diff --git a/.gitignore b/.gitignore
new file mode 100644
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,11 @@
+*.hi
+*.o
+*.swp
+*.tag
+*~
+*_flymake.hs
+.hsenv
+.stack-work/
+TAGS
+/.idea/
+/.dir-locals.el
diff --git a/.travis.yml b/.travis.yml
new file mode 100644
--- /dev/null
+++ b/.travis.yml
@@ -0,0 +1,24 @@
+language: c
+
+sudo: false
+cache:
+ directories:
+ - $HOME/.stack/
+
+matrix:
+ include:
+ - env: CABALVER=1.22 GHCVER=8.0.1
+ addons: {apt: {packages: [cabal-install-1.22,ghc-8.0.1],sources: [hvr-ghc]}}
+
+before_install:
+ - mkdir -p ~/.local/bin
+ - export PATH=~/.local/bin:$PATH
+ - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar -xzO --wildcards '*/stack' > ~/.local/bin/stack
+ - chmod a+x ~/.local/bin/stack
+
+install:
+ - stack -j 2 setup --no-terminal --resolver nightly
+ - stack -j 2 build --only-snapshot --no-terminal
+
+script:
+ - stack -j 2 test --no-terminal
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-builder)
+[](http://hackage.haskell.org/package/isobmff-builder)
+
+# ISO-14496-12 Base Media File Format Builder
+
+This project contains a bytestring-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/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/examples/734397657.m4s b/examples/734397657.m4s
new file mode 100644
Binary files /dev/null and b/examples/734397657.m4s differ
diff --git a/examples/audio.mpd b/examples/audio.mpd
new file mode 100644
--- /dev/null
+++ b/examples/audio.mpd
@@ -0,0 +1,16 @@
+
+
+
+ Media Presentation Description for audio only from DASH-IF live simulator
+
+ http://vm2.dashif.org/livesim/testpic_2s/
+
+
+
+
+
+
+
+
+
+
diff --git a/examples/init.mp4 b/examples/init.mp4
new file mode 100644
Binary files /dev/null and b/examples/init.mp4 differ
diff --git a/isobmff-builder.cabal b/isobmff-builder.cabal
--- a/isobmff-builder.cabal
+++ b/isobmff-builder.cabal
@@ -1,5 +1,5 @@
name: isobmff-builder
-version: 0.10.0.0
+version: 0.10.5.0
synopsis: A (bytestring-) builder for the ISO-14496-12 base media file format
description: Please see README.md
homepage: https://github.com/sheyll/isobmff-builder#readme
@@ -10,45 +10,69 @@
copyright: 2016 Sven Heyll
category: Codec
build-type: Simple
--- extra-source-files:
+extra-source-files: README.md
+ , stack.yaml
+ , .travis.yml
+ , doc/basic-structure.svg
+ , doc/data_reference_box.svg
+ , examples/734397657.m4s
+ , examples/init.mp4
+ , examples/audio.mpd
+ , .gitignore
cabal-version: >=1.10
library
hs-source-dirs: src
exposed-modules: Data.ByteString.IsoBaseFileFormat.Boxes
+ , Data.ByteString.IsoBaseFileFormat.Boxes.AudioSampleEntry
, Data.ByteString.IsoBaseFileFormat.Boxes.Box
, Data.ByteString.IsoBaseFileFormat.Boxes.BoxFields
+ , 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.FullBox
, 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.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.SampleTable
, Data.ByteString.IsoBaseFileFormat.Boxes.Skip
+ , Data.ByteString.IsoBaseFileFormat.Boxes.SoundMediaHeader
, Data.ByteString.IsoBaseFileFormat.Boxes.SpecificMediaHeader
, Data.ByteString.IsoBaseFileFormat.Boxes.Time
+ , Data.ByteString.IsoBaseFileFormat.Boxes.TimeToSample
, Data.ByteString.IsoBaseFileFormat.Boxes.Track
, Data.ByteString.IsoBaseFileFormat.Boxes.TrackHeader
, Data.ByteString.IsoBaseFileFormat.Boxes.Versioned
+ , Data.ByteString.IsoBaseFileFormat.Boxes.VideoMediaHeader
+ , Data.ByteString.IsoBaseFileFormat.Boxes.VisualSampleEntry
, Data.ByteString.IsoBaseFileFormat.Brands.Dash
, Data.ByteString.IsoBaseFileFormat.Brands.Types
, Data.ByteString.IsoBaseFileFormat.Util.TypeLayout
+ , Data.ByteString.IsoBaseFileFormat.Util.BitRecords
build-depends: base >= 4.9 && < 5
, bytestring >= 0.10.8.1 && < 0.11
, type-list >= 0.5.0.0 && < 0.6
, data-default >= 0.7.1.1 && < 0.8
, vector-sized >= 0.3.2.0 && < 0.4
, singletons >= 2.2 && < 3
- , lens >= 4.14 && < 5
+ , tagged >= 0.8 && < 1
, time >= 1.6.0.1 && < 2
, text >= 1.2.2.1 && < 2
+ , type-spec >= 0.1
default-language: Haskell2010
ghc-options: -Wall -funbox-strict-fields -fno-warn-unused-do-bind
default-extensions: ConstraintKinds
@@ -96,6 +120,7 @@
, isobmff-builder
, binary
, text >= 1.2.2.1 && < 2
+ , type-spec >= 0.1
default-language: Haskell2010
default-extensions: ConstraintKinds
, CPP
diff --git a/spec/BoxFieldsSpec.hs b/spec/BoxFieldsSpec.hs
--- a/spec/BoxFieldsSpec.hs
+++ b/spec/BoxFieldsSpec.hs
@@ -2,11 +2,8 @@
import Test.Hspec
import Data.ByteString.IsoBaseFileFormat.Boxes
--- import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Lazy as BL
--- import qualified Data.Binary.Get as Binary
import Control.Exception (evaluate)
-import qualified Data.Text as T
-- import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Lazy as BL import
-- qualified Data.Binary.Get as Binary
@@ -40,7 +37,7 @@
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
+ BL.pack [0 ,0 ,0 ,0
,0 ,0 ,0 ,0
,0 ,65 ,0 ,66
,1 ,0 ,0 ,0
@@ -54,27 +51,43 @@
,0 ,0 ,0 ,74
,0 ,0 ,0 ,75
,0 ,0 ,0 ,76
- ,0 ,0 ,0 ,77])
+ ,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 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
+type ExampleContentShort =
+ U8 "bla"
+ :+ Constant (U8 "blub") 123
+ :+ Template (I64Arr "foos" 3) '[1, 2, 3]
+ :+ U64Arr "baz" 7
example1 :: ExampleContent
-example1 = Scalar 100 :+ Constant :+ Default :+ u64Arr [1,2,3]
+example1 = Scalar 100 :+ Constant :+ Template :+ u64Arr [1,2,3,4,5,6,7]
example1' :: ExampleContentShort
-example1' = example1
+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"
+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 :+ Default :+ Constant :+
+ Constant :+ Custom 65 :+ Custom 66 :+ Template :+ Constant :+
Custom (i32Arr [67 .. 75]) :+
i32 76 :+
i32 77
diff --git a/spec/BrandTypeSpec.hs b/spec/BrandTypeSpec.hs
--- a/spec/BrandTypeSpec.hs
+++ b/spec/BrandTypeSpec.hs
@@ -56,15 +56,15 @@
data TestBrandEmpty
-instance IsBrand TestBrandEmpty where
+instance IsMediaFileFormat TestBrandEmpty where
type BoxLayout TestBrandEmpty = Boxes '[]
data TestBrandSingle
-instance IsBrand TestBrandSingle where
+instance IsMediaFileFormat TestBrandSingle where
type BoxLayout TestBrandSingle = Boxes '[OM_ TestBox1]
data TestBrandNested
-instance IsBrand TestBrandNested where
+instance IsMediaFileFormat TestBrandNested where
type BoxLayout TestBrandNested = Boxes '[OM TestParentBox1 '[OM_ TestBox1]]
diff --git a/spec/DashSpec.hs b/spec/DashSpec.hs
--- a/spec/DashSpec.hs
+++ b/spec/DashSpec.hs
@@ -1,5 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
-module DashSpec (spec) where
+module DashSpec (spec) where -- TODO rename to mp4 audio init spec
import Test.Hspec
import Data.ByteString.IsoBaseFileFormat.Brands.Dash
@@ -26,9 +26,9 @@
[
-- ftyp box
0,0,0,28,102,116,121,112,100,97,115,104,0,0,0,0
- ,105,115,111,109,105,115,111,53,109,112,52,50,0,0
+ ,105,115,111,109,105,115,111,53,109,112,52,50
-- moov box
- ,1 ,105 ,109 ,111 ,111 ,118
+ ,0,0,1,180,109 ,111 ,111 ,118
-- mvhd box
,0 ,0 ,0 ,108 ,109 ,118 ,104 ,100 ,0 ,0 ,0 ,0]
++ cts ++ [0 ,0 ,0 ,0 ,0
@@ -39,7 +39,7 @@
,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0
,255 ,255 ,255 ,255
-- trak box
- ,0 ,0 ,0 ,245
+ ,0 ,0 ,1,64
,116 ,114 ,97 ,107
-- tkhd box
,0 ,0 ,0 ,92
@@ -51,28 +51,43 @@
,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,0,145
+ ,0,0,0,220
,109,100,105,97
,0,0,0,32,109,100,104,100,0,0,0,0
,0,0,0,0,0,0,0,0,0,1,95,144,0,0,0,0,16,181,0,0
-- hdlr box
- ,0,0,0,45
+ ,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,33,0
- ,0,0,0,60
+ ,72,101,108,108,111,32,119,111,114,108,100,0
+ -- minf box
+ ,0,0,0,136
,109,105,110,102
,0,0,0,16
,115,109,104,100,0,0,0,0,0,0,0,0
+ -- dinf box
,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,110,32
- ,0,0,0,1]
- -- BL.writeFile "/tmp/xxx.mp4" (BL.pack rendered)
+ ,117,114,108,32
+ ,0,0,0,1
+ -- stbl
+ ,0,0,0,76,115,116,98,108
+ -- stsd
+ ,0,0,0,52,115,116,115,100
+ ,0,0,0,0,0,0,0,1
+ -- mp4a
+ ,0,0,0,36,109,112,52,97
+ ,0,0,0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,2,0,16,0,0,0,0
+ ,187,128,0,0
+ -- stts
+ ,0,0,0,16,115,116,116,115,0,0,0,0,0,0,0,0]
+ BL.writeFile "/tmp/isobmff-test-case-dash-spec.mp4" (BL.pack rendered)
rendered `shouldBe`
expected
@@ -80,11 +95,11 @@
exampleSingleTrackInit creationTime =
SingleAudioTrackInit
(MovieHeader $
- V0 (creationTime :+ 0 :+ Default :+ durationFromSeconds Default 1) :+
+ V0 (creationTime :+ 0 :+ Template :+ durationFromSeconds Template 1) :+
def)
(TrackHeader $
- V0 (0 :+ 0 :+ 1 :+ Constant :+ durationFromSeconds Default 1) :+
+ V0 (0 :+ 0 :+ 1 :+ Constant :+ durationFromSeconds Template 1) :+
def)
- (MediaHeader $ def)
- (Handler $ def :+ AudioTrack :+ def :+ (Custom "Hello world!"))
+ (MediaHeader def)
+ (namedAudioTrackHandler "Hello world")
(SoundMediaHeader def)
diff --git a/spec/DataReferenceSpec.hs b/spec/DataReferenceSpec.hs
--- a/spec/DataReferenceSpec.hs
+++ b/spec/DataReferenceSpec.hs
@@ -1,25 +1,19 @@
module DataReferenceSpec (spec) where
-import Test.Hspec
-import Data.ByteString.IsoBaseFileFormat.Boxes
-
-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
+import Data.ByteString.IsoBaseFileFormat.Boxes
+import Test.Hspec
spec :: Spec
-spec = return ()
--- describe "IsBoxContent" $ do
--- describe "LocalMediaEntry" $ do
--- describe "boxSize" $ do
--- it "returns 0" $
--- let actual = boxSize (localMediaDataReference :: DRef)
--- -- dref: size+fourcc+fullbox+entries -> 4 * 4bytes
--- expected = 4 + 4 + 4 + 4 + (4 + 4 + boxSize ("xxxx" :+ FullBox Default 0 () :: DEntryLocal))
--- in actual `shouldBe` expected
---
--- -- type DRef = Box (Dash 0) DataReference
--- type DEntryLocal = FourCc :+ FullBox 0 ()
--- type DEntryUrl = FourCc :+ FullBox 0 (T.Text)
--- type DEntryUrn = FourCc :+ FullBox 0 (T.Text :+ T.Text)
+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/src/Data/ByteString/IsoBaseFileFormat/Boxes.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes.hs
--- a/src/Data/ByteString/IsoBaseFileFormat/Boxes.hs
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes.hs
@@ -3,32 +3,43 @@
( module X)
where
-import Data.ByteString.IsoBaseFileFormat.Boxes.Box as X
-import Data.ByteString.IsoBaseFileFormat.Boxes.BoxFields 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.FullBox as X
-import Data.ByteString.IsoBaseFileFormat.Boxes.Handler 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.Movie as X
-import Data.ByteString.IsoBaseFileFormat.Boxes.MovieHeader as X
-import Data.ByteString.IsoBaseFileFormat.Boxes.ProgressiveDownloadInformation as X
-import Data.ByteString.IsoBaseFileFormat.Boxes.Language as X
-import Data.ByteString.IsoBaseFileFormat.Boxes.Skip as X
-import Data.ByteString.IsoBaseFileFormat.Boxes.SpecificMediaHeader as X
-import Data.ByteString.IsoBaseFileFormat.Boxes.Time as X
-import Data.ByteString.IsoBaseFileFormat.Boxes.Track as X
-import Data.ByteString.IsoBaseFileFormat.Boxes.TrackHeader as X
-import Data.ByteString.IsoBaseFileFormat.Boxes.Versioned as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.AudioSampleEntry as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.Box as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.BoxFields 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.FullBox 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.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.SampleTable 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.Time as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.TimeToSample as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.Track as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.TrackHeader as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.Versioned as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.VideoMediaHeader as X
+import Data.ByteString.IsoBaseFileFormat.Boxes.VisualSampleEntry as X
-import Data.Int as X
-import Data.Kind as X (Type, Constraint)
-import Data.Maybe as X
-import Data.Type.Bool as X
-import Data.Type.Equality as X
-import Text.Printf as X
-import Data.Default as X
+import Data.Kind as X
+ (Constraint,
+ Type)
+import Text.Printf 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,40 @@
+-- | Detailed audio sample description.
+module Data.ByteString.IsoBaseFileFormat.Boxes.AudioSampleEntry where
+
+import Data.ByteString.IsoBaseFileFormat.Boxes.Box
+import Data.ByteString.IsoBaseFileFormat.Boxes.BoxFields
+import Data.ByteString.IsoBaseFileFormat.Boxes.Handler
+import Data.ByteString.IsoBaseFileFormat.Boxes.SampleEntry
+
+-- | Construct an audio sample entry box.
+audioSampleEntry ::
+ (KnownSymbol
+ (BoxTypeSymbol (SampleEntry 'AudioTrack (AudioCoding c))))
+ => AudioCoding c
+ -> U16 "data_reference_index"
+ -> SampleEntry 'AudioTrack (AudioCoding c)
+ -> Box (SampleEntry 'AudioTrack (AudioCoding c))
+audioSampleEntry _ = sampleEntry
+
+-- | Fields if audio sample entries
+newtype instance SampleEntry 'AudioTrack (AudioCoding c) 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
+ -> SampleEntry 'AudioTrack (AudioCoding c)
+ deriving (IsBoxContent, Default)
+
+type DefaultSoundSamplerate = 48000
+
+-- | A coproduct of audio codec types
+data family AudioCoding (c :: Symbol)
+
+-- | The MPEG-4 AAC Audio codec
+data instance AudioCoding "mp4a" = Mpeg4Aac
+
+type instance BoxTypeSymbol (AudioCoding c) = c
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Box.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Box.hs
--- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Box.hs
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Box.hs
@@ -13,26 +13,29 @@
where
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.Maybe as X
+import Data.Tagged as X
+import Data.Proxy as X
+import Data.Word as X
import Data.Bits as X
import Data.ByteString.Builder as X
import Data.Monoid as X
-import Data.Proxy as X
-import Data.Word as X
import Data.Kind
import GHC.TypeLits as X
-import Data.String
-import Data.Default
-import Data.Singletons.Prelude.List (Length)
-import Data.Type.Equality
-import Data.Type.Bool
+import Data.String as X
+import Data.Singletons.Prelude.List (Length, (:++))
+import Data.Type.Equality as X
+import Data.Type.Bool as X
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
-import Data.Singletons.Prelude.List ((:++))
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 where
+class (KnownSymbol (BoxTypeSymbol t), IsBoxContent (BoxContent t)) => IsBox (t :: Type) where
type BoxContent t
type BoxContent t = t
toBoxType :: proxy t -> BoxType
@@ -42,7 +45,7 @@
-- 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 :: Symbol
+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
@@ -51,14 +54,13 @@
boxSize :: a -> BoxSize
boxBuilder :: a -> Builder
--- * Data types
-
+-- * 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 ::
- (IsBox b) =>
- BoxContent b -> Box b
+ !(BoxContent b) -> Box b
instance IsBox b => IsBox (Box b) where
type BoxContent (Box b) = BoxContent b
@@ -66,7 +68,7 @@
type instance BoxTypeSymbol (Box b) = BoxTypeSymbol b
-instance IsBoxContent (Box cnt) where
+instance IsBox cnt => IsBoxContent (Box cnt) where
boxBuilder b@(Box cnt) = sB <> tB <> sExtB <> tExtB <> cntB
where s = boxSize b
t = toBoxType b
@@ -81,10 +83,13 @@
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
+ ContainerBox :: IsBox b => !(BoxContent b) -> !(Boxes bs) -> ContainerBox b bs
instance (IsBox b) => IsBox (ContainerBox b bs)
@@ -97,10 +102,10 @@
-- | A heterogenous collection of boxes.
data Boxes (boxTypes :: [Type]) where
NoBoxes :: Boxes '[]
- (:.) :: Box l -> Boxes r -> Boxes (Box l ': r)
+ (:.) :: 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)
- (:|) :: Box l -> Box r -> Boxes '[Box l, Box r]
+ (:<>) :: !(Boxes l) -> !(Boxes r) -> Boxes (l :++ r)
+ (:|) :: (IsBox l, IsBox r) => !(Box l) -> !(Box r) -> Boxes '[Box l, Box r]
infixr 1 :<>
infixr 2 :.
@@ -108,11 +113,11 @@
infixr 3 $:
-- | Apply a function to a 'Boxes' collection containing only a single 'Box'.
-($:) :: (Boxes '[Box l] -> r) -> Box l -> r
+($:) :: IsBox l => (Boxes '[Box l] -> r) -> Box l -> r
($:) f = f . singletonBox
-- | Create a 'Boxes' collection with a single 'Box'.
-singletonBox :: Box l -> Boxes '[Box l]
+singletonBox :: IsBox l => Box l -> Boxes '[Box l]
singletonBox b = b :. NoBoxes
-- | Get the elements in a type level array
@@ -142,7 +147,7 @@
-- the end of the file.
data BoxSize
= UnlimitedSize
- | BoxSize Word64
+ | BoxSize !Word64
deriving (Show,Eq)
instance IsBoxContent BoxSize where
@@ -172,7 +177,7 @@
-- | The 'BoxSize' can be > 2^32 in which case an 'BoxSizeExtension' must be
-- added after the type field.
-data BoxSizeExtension =
+newtype BoxSizeExtension =
BoxSizeExtension BoxSize
instance IsBoxContent BoxSizeExtension where
@@ -193,10 +198,10 @@
=
-- | `FourCc` can be used as @boxType@ in `Box`, standard four letter character
-- code, e.g. @ftyp@
- StdType FourCc
+ StdType !FourCc
|
-- | CustomBoxType defines custom @boxType@s in `Box`es.
- CustomBoxType String
+ CustomBoxType !String
deriving (Show,Eq)
-- | Create a box type from a 'Symbol'. Parse the symbol value, if it's a four
@@ -205,7 +210,7 @@
parseBoxType :: KnownSymbol t => proxy t -> BoxType
parseBoxType px = StdType (fromString (symbolVal px))
--- | A type containin a printable four letter character code.
+-- | A type containin a printable four letter character code. TODO replace impl with U32Text
newtype FourCc =
FourCc (Char,Char,Char,Char)
deriving (Show,Eq)
@@ -234,7 +239,7 @@
-- | 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.
-data BoxTypeExtension =
+newtype BoxTypeExtension =
BoxTypeExtension BoxType
instance IsBoxContent BoxTypeExtension where
@@ -260,12 +265,19 @@
-- boxSize = foldr' (\e acc -> acc + boxSize e) 0
-- boxBuilder = foldMap boxBuilder
+instance Default B.ByteString where
+ def = mempty
+
-- | 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
+instance Default T.Text where
+ def = ""
+
+
-- | This instance writes zero bytes for 'Nothing' and delegates on 'Just'.
instance IsBoxContent a => IsBoxContent (Maybe a) where
boxSize = maybe 0 boxSize
@@ -274,16 +286,43 @@
-- * Box concatenation
-- | Box content composition
-data a :+ b = a :+ b
+data a :+ b = !a :+ !b
infixr 3 :+
instance (IsBoxContent p,IsBoxContent c) => IsBoxContent (p :+ c) where
- boxSize (p :+ c) = boxSize p + boxSize c
+ 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
+
+instance Default c => Default (Tagged s c) where
+ def = Tagged def
+
+-- * 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 []
-- * Type Layout Rule Matchers
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/BoxFields.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/BoxFields.hs
--- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/BoxFields.hs
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/BoxFields.hs
@@ -4,16 +4,15 @@
where
import Data.ByteString.IsoBaseFileFormat.Boxes.Box
-import Data.ByteString.IsoBaseFileFormat.Boxes.Versioned
-import Data.Default
-import Data.Int
-import Data.Maybe
import Text.Printf
import Data.Singletons
import Data.Singletons.Prelude.List
import qualified Data.Vector.Sized as Vec
import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import qualified Data.ByteString as B
+
-- * Scalar box fields
type U64 label = Scalar Word64 label
@@ -27,7 +26,6 @@
i64 = Scalar
type U32 label = Scalar Word32 label
-
type I32 label = Scalar Int32 label
u32 :: Word32 -> U32 label
@@ -214,15 +212,15 @@
-- 'ScalarArray', with a type level default value. The wrapped content must
-- implement 'FromTypeLit'.
data Template o v where
- Default :: Template o v
+ Template :: Template o v
Custom :: o -> Template o v
instance Default (Template o v) where
- def = Default
+ def = Template
-- | Get a value from a 'Template'.
templateValue :: FromTypeLit o v => Template o v -> o
-templateValue d@Default = fromTypeLit d
+templateValue d@Template = fromTypeLit d
templateValue (Custom v) = v
instance (IsBoxContent o,FromTypeLit o v) => IsBoxContent (Template o v) where
@@ -247,9 +245,54 @@
instance KnownSymbol str => FromTypeLit T.Text (str :: Symbol) where
fromTypeLit = T.pack . symbolVal
--- * Versioned support
+-- * String/Text field types
--- | A utility for 'Versioned' to apply a type constructor to either a
--- @('Scalar' Word32)@ or a @('Scalar' Word64)@ depending on the type level
--- version. This uses 'SelectByVersion'.
-type U32U64 c = SelectByVersion c (Scalar Word32) (Scalar Word64)
+-- | 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/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,32 @@
+-- | A data references URL.
+module Data.ByteString.IsoBaseFileFormat.Boxes.DataEntryUrl
+ (DataEntryUrl()
+ ,localMediaDataEntryUrl
+ ,dataEntryUrl
+ )
+ where
+
+import Data.ByteString.IsoBaseFileFormat.Boxes.Box
+import Data.ByteString.IsoBaseFileFormat.Boxes.FullBox
+import qualified Data.Text as T
+
+-- | 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.Boxes.Box
+import Data.ByteString.IsoBaseFileFormat.Boxes.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/DataReference.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/DataReference.hs
--- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/DataReference.hs
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/DataReference.hs
@@ -4,39 +4,22 @@
-- same file as the.
module Data.ByteString.IsoBaseFileFormat.Boxes.DataReference
(DataReference()
- ,DataEntryUrl()
- ,DataEntryUrn()
,dataReference
,localMediaDataReference
- ,localMediaDataEntryUrl
- ,dataEntryUrl
- ,dataEntryUrn
)
where
import Data.ByteString.IsoBaseFileFormat.Boxes.Box
import Data.ByteString.IsoBaseFileFormat.Boxes.FullBox
+import Data.ByteString.IsoBaseFileFormat.Boxes.DataEntryUrl
import Data.ByteString.IsoBaseFileFormat.Boxes.BoxFields
- hiding (Default)
-import qualified Data.Text as T
import Data.Singletons.Prelude.List (Length)
-import Data.Default
-- | A container for 'DataEntryUrl's and 'DataEntryUrn's
newtype DataReference =
DataReference (U32 "entry_count")
deriving (Default,IsBoxContent)
--- | A container for a URL
-newtype DataEntryUrl =
- DataEntryUrl (Maybe T.Text)
- deriving (Default,IsBoxContent)
-
--- | A container for a URN and optionally a URL
-newtype DataEntryUrn =
- DataEntryUrn (T.Text :+ T.Text)
- deriving (IsBoxContent)
-
-- | Create a 'DataReference' box.
dataReference
:: KnownNat (Length ts)
@@ -50,30 +33,5 @@
:: Box (ContainerBox (FullBox DataReference 0) '[Box (FullBox DataEntryUrl 0)])
localMediaDataReference = dataReference (singletonBox localMediaDataEntryUrl)
--- | 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)
-
--- | 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 DataReference
type instance BoxTypeSymbol DataReference = "dref"
-
-instance IsBox DataEntryUrn
-type instance BoxTypeSymbol DataEntryUrn = "urn "
-
-instance IsBox DataEntryUrl
-type instance BoxTypeSymbol DataEntryUrl = "urn "
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/FullBox.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/FullBox.hs
--- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/FullBox.hs
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/FullBox.hs
@@ -15,6 +15,10 @@
-> 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
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Handler.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Handler.hs
--- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Handler.hs
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Handler.hs
@@ -1,48 +1,108 @@
+{-# 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 where
+module Data.ByteString.IsoBaseFileFormat.Boxes.Handler
+ (Handler()
+ ,handler
+ ,audioTrackHandler
+ ,namedAudioTrackHandler
+ ,videoTrackHandler
+ ,namedVideoTrackHandler
+ ,hintTrackHandler
+ ,namedHintTrackHandler
+ ,timedMetadataTrackHandler
+ ,namedTimedMetadataTrackHandler
+ ,auxilliaryVideoTrackHandler
+ ,namedAuxilliaryVideoTrackHandler
+ ,HandlerType(..)
+ ,HandlerTypeCode)
+ where
import Data.ByteString.IsoBaseFileFormat.Boxes.Box
import Data.ByteString.IsoBaseFileFormat.Boxes.BoxFields
import Data.ByteString.IsoBaseFileFormat.Boxes.FullBox
-import Data.Default
import qualified Data.Text as T
-- | Handler box fields. A handler box may also contain a null terminated
--- description text in UTF-8.
-newtype Handler where
- Handler :: Constant (U32 "pre_defined") 0
- :+ HandlerType
- :+ Constant (U32Arr "reserved" 3) '[0,0,0]
- :+ Template T.Text ""
- -> Handler
- deriving (IsBoxContent, Default)
+-- 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
+data HandlerType
+ = VideoTrack
| AudioTrack
| HintTrack
- | TimedMetadataTrack
+ | TimedMetaDataTrack
| AuxilliaryVideoTrack
+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
- :: Handler -> Box (FullBox Handler 0)
+ :: (KnownSymbol (HandlerTypeCode t))
+ => Handler t -> Box (FullBox (Handler t) 0)
handler = fullBox 0
-instance IsBox Handler where
- type BoxContent Handler = Handler
+-- | Create 'Handler' fields for 'AudioTrack's with @"Audio Track"@ as @name@.
+audioTrackHandler :: Handler 'AudioTrack
+audioTrackHandler = namedAudioTrackHandler "Audio Track"
-type instance BoxTypeSymbol Handler = "hdlr"
+-- | Create 'Handler' fields for 'AudioTrack's, with the given name.
+namedAudioTrackHandler :: T.Text -> Handler 'AudioTrack
+namedAudioTrackHandler txt = Handler (def :+ def :+ def :+ Custom txt)
-instance Default HandlerType where
- def = AudioTrack
+-- | Create 'Handler' fields for 'VideoTrack's with @"Video Track"@ as @name@.
+videoTrackHandler :: Handler 'VideoTrack
+videoTrackHandler = namedVideoTrackHandler "Video Track"
-instance IsBoxContent HandlerType where
- boxSize _ = 4
- boxBuilder VideoTrack = boxBuilder (FourCc ('v','i','d','e'))
- boxBuilder AudioTrack = boxBuilder (FourCc ('s','o','u','n'))
- boxBuilder HintTrack = boxBuilder (FourCc ('h','i','n','t'))
- boxBuilder TimedMetadataTrack = boxBuilder (FourCc ('m','e','t','a'))
- boxBuilder AuxilliaryVideoTrack = boxBuilder (FourCc ('a','u','x','v'))
+-- | 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,28 @@
+-- | Media-independent properties of a hint tracks media content.
+module Data.ByteString.IsoBaseFileFormat.Boxes.HintMediaHeader where
+
+import Data.ByteString.IsoBaseFileFormat.Boxes.Box
+import Data.ByteString.IsoBaseFileFormat.Boxes.BoxFields
+import Data.ByteString.IsoBaseFileFormat.Boxes.FullBox
+import Data.ByteString.IsoBaseFileFormat.Boxes.Handler
+import Data.ByteString.IsoBaseFileFormat.Boxes.SpecificMediaHeader
+
+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,17 @@
+{-# 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.Boxes.Box
+
+-- | Protocol specific data. To create 'HintSampleEntry's a protocol specific
+-- 'HintFields' instance must be provided
+data instance SampleEntry 'HintTrack protocol where
+ HintSampleEntry
+ :: (IsBoxContent (HintFields protocol), Default (HintFields protocol))
+ => HintFields protocol -> SampleEntry 'HintTrack protocol
+
+-- | Family of protocol specific contents for 'HintTrack's.
+type family HintFields (protocol :: Symbol)
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Language.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Language.hs
--- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Language.hs
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Language.hs
@@ -2,8 +2,6 @@
module Data.ByteString.IsoBaseFileFormat.Boxes.Language (Language, mkLanguage) where
import Data.ByteString.IsoBaseFileFormat.Boxes.Box
-import Data.Default
-import Data.String
-- | 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
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,110 @@
+module Data.ByteString.IsoBaseFileFormat.Boxes.MetaDataSampleEntry where
+
+import Data.ByteString.IsoBaseFileFormat.Boxes.Box
+import Data.ByteString.IsoBaseFileFormat.Boxes.BoxFields
+import Data.ByteString.IsoBaseFileFormat.Boxes.FullBox
+import Data.ByteString.IsoBaseFileFormat.Boxes.Handler
+import Data.ByteString.IsoBaseFileFormat.Boxes.SampleEntry
+import qualified Data.Text as T
+import qualified Data.ByteString as B
+import Data.Tagged ()
+import Data.Default ()
+
+-- * Generat meta data sample entry
+
+-- | Construct a meta data sample entry box. For every 'MetaDataCoding'
+-- a 'SampleEntry' instances must be provided.
+metaDataSampleEntry ::
+ MetaDataCoding c
+ -> U16 "data_reference_index"
+ -> SampleEntry 'TimedMetaDataTrack (MetaDataCoding c)
+ -> Box (SampleEntry 'TimedMetaDataTrack (MetaDataCoding c))
+metaDataSampleEntry _ = sampleEntry
+
+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/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,21 @@
+-- | Indicate that a tracks media content is /null/ or /dummy/ media.
+module Data.ByteString.IsoBaseFileFormat.Boxes.NullMediaHeader where
+
+import Data.ByteString.IsoBaseFileFormat.Boxes.Box
+import Data.ByteString.IsoBaseFileFormat.Boxes.FullBox
+
+-- | 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/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,27 @@
+-- | 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.Boxes.Box
+import Data.ByteString.IsoBaseFileFormat.Boxes.FullBox
+import Data.ByteString.IsoBaseFileFormat.Boxes.BoxFields
+import Data.Singletons.Prelude.List (Length)
+
+-- | A sample table contains no fieds.
+newtype SampleDescription handlerType =
+ SampleDescription (U32 "entry_count")
+ deriving (Default,IsBoxContent)
+
+-- | Create a hint media header data box.
+sampleDescription
+ :: (KnownNat (Length ts))
+ => Boxes ts
+ -> Box (ContainerBox (FullBox (SampleDescription h) 0) ts)
+sampleDescription bs =
+ containerBox (FullBox 0 $ SampleDescription (typeListLength bs))
+ bs
+
+instance IsBox (SampleDescription h)
+
+type instance BoxTypeSymbol (SampleDescription h) = "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.Boxes.Box
+import Data.ByteString.IsoBaseFileFormat.Boxes.Handler
+import Data.ByteString.IsoBaseFileFormat.Boxes.BoxFields
+
+-- | Specific sample entries must provide an instance for this data family.
+-- The @format@ parameter will be used as 'BoxTypeSymbol'.
+data family SampleEntry (handlertype :: HandlerType) (format :: k)
+
+-- | Create a 'SampleEntry' 'Box' from the data reference index and the
+-- 'HandlerType' specific 'SampleEntry' instance.
+sampleEntry
+ :: forall (handlertype :: HandlerType) (format :: k)
+ . U16 "data_reference_index"
+ -> SampleEntry handlertype format
+ -> Box (SampleEntry handlertype format)
+sampleEntry i c = Box (SampleEntryFields (Constant :+ i :+ c))
+
+-- | A common header for all specific sample entries, the 'BoxContent' of the
+-- abstract 'SampleEntry' is @SampleEntryFields (SampleEntry h f)@.
+newtype SampleEntryFields a where
+ SampleEntryFields
+ :: Constant (U8Arr "reserved" 6) '[0,0,0,0,0,0]
+ :+ U16 "data_reference_index"
+ :+ a
+ -> SampleEntryFields a
+deriving instance IsBoxContent a => IsBoxContent (SampleEntryFields a)
+deriving instance Default a => Default (SampleEntryFields a)
+
+-- | 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).
+data MatchSampleEntry (handlerType :: HandlerType)
+
+type instance
+ IsRuleConform (Box (SampleEntry g' f)) (MatchSampleEntry g) =
+ HandlerTypeCode g' == HandlerTypeCode g
+
+-- | The 'BoxTypeSymbol' of sample entry is exactly the @format@ type index of
+-- the 'SampleEntry' family.
+type instance
+ BoxTypeSymbol (SampleEntry handlertype format) = BoxTypeSymbol format
+
+instance (IsBoxContent (SampleEntry handlertype format)
+ ,KnownSymbol (BoxTypeSymbol (SampleEntry handlertype format)))
+ => IsBox (SampleEntry handlertype format) where
+ type BoxContent (SampleEntry handlertype format) =
+ SampleEntryFields (SampleEntry handlertype format)
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.Boxes.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/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,25 @@
+-- | Media-independent properties of a tracks sound content.
+module Data.ByteString.IsoBaseFileFormat.Boxes.SoundMediaHeader where
+
+import Data.ByteString.IsoBaseFileFormat.Boxes.Box
+import Data.ByteString.IsoBaseFileFormat.Boxes.BoxFields
+import Data.ByteString.IsoBaseFileFormat.Boxes.FullBox
+import Data.ByteString.IsoBaseFileFormat.Boxes.Handler
+import Data.ByteString.IsoBaseFileFormat.Boxes.SpecificMediaHeader
+
+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
--- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/SpecificMediaHeader.hs
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/SpecificMediaHeader.hs
@@ -1,79 +1,11 @@
--- | Media-independent properties of a tracks media content.
+-- | Select the specific media header from the 'HandlerType'
module Data.ByteString.IsoBaseFileFormat.Boxes.SpecificMediaHeader where
-import Data.ByteString.IsoBaseFileFormat.Boxes.Box
-import Data.ByteString.IsoBaseFileFormat.Boxes.BoxFields
-import Data.ByteString.IsoBaseFileFormat.Boxes.FullBox
-import Data.Default
-
--- * Videos
-
--- | 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"
-
--- * Sounds
-
--- | 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"
-
--- * Hints
-
--- | 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"
-
--- * Dummy/Null media
-
--- | 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"
+--
+-- import Data.ByteString.IsoBaseFileFormat.Boxes.VideoMediaHeader
+import Data.ByteString.IsoBaseFileFormat.Boxes.Handler
+--
-instance Default NullMediaHeader where
- def = NullMediaHeader
-instance IsBoxContent NullMediaHeader where
- boxSize _ = 0
- boxBuilder _ = mempty
+-- | 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,27 @@
+-- | 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.Boxes.Box
+import Data.ByteString.IsoBaseFileFormat.Boxes.FullBox
+import Data.ByteString.IsoBaseFileFormat.Boxes.BoxFields
+
+-- | 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/Versioned.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Versioned.hs
--- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Versioned.hs
+++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Versioned.hs
@@ -1,14 +1,13 @@
{-# LANGUAGE UndecidableInstances #-}
-- | A binary version 0/1 field with seperate content for each version.
module Data.ByteString.IsoBaseFileFormat.Boxes.Versioned
- (Versioned(..), ApplyVersioned(..), SelectByVersion)
+ (Versioned(..))
where
import Data.ByteString.IsoBaseFileFormat.Boxes.Box
-import Data.Default
-import Data.Kind
-import Data.Singletons
+-- 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
@@ -23,39 +22,3 @@
boxSize (V1 c) = boxSize c
boxBuilder (V0 c) = boxBuilder c
boxBuilder (V1 c) = boxBuilder c
-
-data VersionedBox c where
- BoxV0 :: forall (v :: Nat -> Type). IsBoxContent (v 0) => v 0 -> VersionedBox v
- BoxV1 :: forall (v :: Nat -> Type). IsBoxContent (v 1) => v 1 -> VersionedBox v
-
-instance (IsBoxContent (b 0), Default (b 0)) => Default (VersionedBox b) where
- def = BoxV0 def
-
-instance IsBoxContent (VersionedBox c) where
- boxSize (BoxV0 c) = boxSize c
- boxSize (BoxV1 c) = boxSize c
- boxBuilder (BoxV0 c) = boxBuilder c
- boxBuilder (BoxV1 c) = boxBuilder c
-
--- * Versions based on type level arrows
-
--- | Two alternative representations based on a /version/ index.
--- Use this for box content that can be either 32 or 64 bit.
-data ApplyVersioned (v' :: Nat ~> Type) where
- OnV0 :: forall (v :: Nat ~> Type). IsBoxContent (v @@ 0) => v @@ 0 -> ApplyVersioned v
- OnV1 :: forall (v :: Nat ~> Type). IsBoxContent (v @@ 1) => v @@ 1 -> ApplyVersioned v
-
-instance (IsBoxContent (b @@ 0), Default (b @@ 0)) => Default (ApplyVersioned b) where
- def = OnV0 def
-
-instance IsBoxContent (ApplyVersioned c) where
- boxSize (OnV0 c) = boxSize c
- boxSize (OnV1 c) = boxSize c
- boxBuilder (OnV0 c) = boxBuilder c
- boxBuilder (OnV1 c) = boxBuilder c
-
--- | A type level arrow that applys the type constructor to one of the two
--- versions depending on the /version/ parameter.
-data SelectByVersion :: (a -> Type) -> a -> a -> Nat ~> Type
-type instance Apply (SelectByVersion f v0 v1) 0 = f v0
-type instance Apply (SelectByVersion f v0 v1) 1 = f v1
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,25 @@
+-- | Media-independent properties of a tracks video content.
+module Data.ByteString.IsoBaseFileFormat.Boxes.VideoMediaHeader where
+
+import Data.ByteString.IsoBaseFileFormat.Boxes.Box
+import Data.ByteString.IsoBaseFileFormat.Boxes.BoxFields
+import Data.ByteString.IsoBaseFileFormat.Boxes.FullBox
+import Data.ByteString.IsoBaseFileFormat.Boxes.Handler
+import Data.ByteString.IsoBaseFileFormat.Boxes.SpecificMediaHeader
+
+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,184 @@
+{-# LANGUAGE UndecidableInstances #-}
+-- | Detailed visual sample description.
+module Data.ByteString.IsoBaseFileFormat.Boxes.VisualSampleEntry where
+
+import Data.ByteString.IsoBaseFileFormat.Boxes.Box
+import Data.ByteString.IsoBaseFileFormat.Boxes.BoxFields
+import Data.ByteString.IsoBaseFileFormat.Boxes.Handler
+import Data.ByteString.IsoBaseFileFormat.Boxes.SampleEntry
+import qualified Data.Text as T
+
+-- | Construct a visual sample entry box
+visualSampleEntry ::
+ (KnownSymbol
+ (BoxTypeSymbol (SampleEntry 'VideoTrack (VideoCoding codec))))
+ => VideoCoding codec
+ -> U16 "data_reference_index"
+ -> SampleEntry 'VideoTrack (VideoCoding codec)
+ -> Box (SampleEntry 'VideoTrack (VideoCoding codec))
+visualSampleEntry _ = sampleEntry
+
+-- | 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 instance SampleEntry 'VideoTrack (VideoCoding 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]
+ -> SampleEntry 'VideoTrack (VideoCoding c)
+ deriving (IsBoxContent, Default)
+
+instance IsBoxContent [Box SomeColourInformation] where
+ boxSize = sum . fmap boxSize
+ boxBuilder = fold . fmap boxBuilder
+
+-- | A coproduct of video codec types
+data family VideoCoding (c :: Symbol)
+
+-- | Simple default MPEG-4 video
+data instance VideoCoding "mp4v" = Mpeg4Avc
+
+type instance BoxTypeSymbol (VideoCoding c) = c
+
+-- * 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
--- a/src/Data/ByteString/IsoBaseFileFormat/Brands/Dash.hs
+++ b/src/Data/ByteString/IsoBaseFileFormat/Brands/Dash.hs
@@ -4,14 +4,12 @@
-- educational, current need.
-- This is a convenient way of building documents of that kind.
module Data.ByteString.IsoBaseFileFormat.Brands.Dash
- (Dash, SingleAudioTrackInit(..), mkSingleTrackInit, module X) where
+ (Dash, SingleAudioTrackInit(..), mkSingleTrackInit, module X)
+ where
import Data.ByteString.IsoBaseFileFormat.Brands.Types
import Data.ByteString.IsoBaseFileFormat.Boxes as X hiding (All)
import Data.Kind (Type, Constraint)
-import Control.Lens
-import Data.Promotion.Prelude.List
-import Data.Singletons
-- | 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.
@@ -23,61 +21,54 @@
-- | A 'BoxLayout' which contains the stuff needed for the 'dash' brand.
-- TODO incomplete
-instance IsBrand (Dash v) where
+instance IsMediaFileFormat (Dash v) where
type BoxLayout (Dash v) =
Boxes
- '[ OM_ FileType
+ '[ OM_ FileType
, OM Movie
'[ OM_ (MovieHeader v)
- , SM Track
- '[ OM_ (TrackHeader v)
- , OM Media
- '[ OM_ (MediaHeader v)
- , OM_ Handler
- , OM MediaInformation
- '[ OneOf '[ OM_ VideoMediaHeader
- , OM_ SoundMediaHeader
- , OM_ HintMediaHeader
- , OM_ NullMediaHeader]
- , OM DataInformation
- '[ OM DataReference
- '[ OneOf '[ OM_ DataEntryUrl
- , OM_ DataEntryUrn]
- , SomeOptionalX
- (OneOf '[ OM_ DataEntryUrl
- , OM_ DataEntryUrn])]]
- -- , OM (SampleTable v) -- TODO
- -- '[ OM_ (SampleDescriptions v)
- -- , OM_ (TimeToSample v)
- -- , OM_ (SampleToChunk v)
- -- , OO_ (SampleSizes v)
- -- , OM_ (SampleChunkOffset v)
- -- ]
- ]
- ]
- ]
+ , SomeMandatoryX
+ (OneOf '[ TrackLayout v 'VideoTrack
+ , TrackLayout v 'AudioTrack
+ , TrackLayout v 'HintTrack
+ , TrackLayout v 'TimedMetaDataTrack
+ , TrackLayout v 'AuxilliaryVideoTrack])
]
, SO_ Skip
]
+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 handlerType)
+ '[ SomeMandatoryX (MatchSampleEntry handlerType) ]
+ , OM_ TimeToSample
+ -- , OM_ (SampleToChunk version)
+ -- , OO_ (SampleSizes version)
+ -- , OM_ (SampleChunkOffset version)
+ ]
+ ]
+ ]
+ ])
+
+
-- Missing Boxes
--- START 17:47:
--- mdia
--- mdhd
--- hdlr
--- minf
--- smhd
--- dinf
--- dref
--- ??url
--- stbl
--- stsd
-- stts
-- stsc
-- stsz
-- stco
--- soun
--- mp4a
-- esds
-- mvex
-- trex
@@ -90,23 +81,29 @@
-- trun
-- | A record which contains the stuff needed for a single track initialization
-- document according to the 'Dash' brand. TODO incomplete
+-- TODO take this out into its own module, make a new package for specific file formats
data SingleAudioTrackInit =
- SingleAudioTrackInit {_mvhd :: MovieHeader 0
- ,_tkhd :: TrackHeader 0
- ,_mdhd :: MediaHeader 0
- ,_hdlr :: Handler
- ,_smhd :: SoundMediaHeader}
-
-makeLenses ''SingleAudioTrackInit
+ SingleAudioTrackInit {mvhd :: MovieHeader 0
+ ,tkhd :: TrackHeader 0
+ ,mdhd :: MediaHeader 0
+ ,hdlr :: Handler 'AudioTrack
+ ,smhd :: SoundMediaHeader}
-- | Convert a 'SingleAudioTrackInit' record to a generic 'Boxes' collection.
mkSingleTrackInit
:: SingleAudioTrackInit -> Builder
mkSingleTrackInit doc = mediaBuilder dash $
- fileTypeBox (FileType "dash" 0 ["isom","iso5","mp42"])
- :|
- movie (movieHeader (doc ^. mvhd) :|
- track (trackHeader (doc ^. tkhd) :|
- media (mediaHeader (doc ^. mdhd) :. handler (doc ^. hdlr) :|
- mediaInformation
- (soundMediaHeader (doc ^. smhd) :| dataInformation $: localMediaDataReference ))))
+ fileTypeBox (FileType "dash" 0 ["isom","iso5","mp42"])
+ :| movie
+ ( movieHeader (mvhd doc)
+ :| track
+ ( trackHeader (tkhd doc)
+ :| media
+ ( mediaHeader (mdhd doc)
+ :. handler (hdlr doc)
+ :| mediaInformation
+ ( soundMediaHeader (smhd doc)
+ :. (dataInformation $: localMediaDataReference)
+ :| sampleTable
+ ((sampleDescription $: audioSampleEntry Mpeg4Aac 1 def)
+ :| timeToSample [] )))))
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Brands/Types.hs b/src/Data/ByteString/IsoBaseFileFormat/Brands/Types.hs
--- a/src/Data/ByteString/IsoBaseFileFormat/Brands/Types.hs
+++ b/src/Data/ByteString/IsoBaseFileFormat/Brands/Types.hs
@@ -5,9 +5,10 @@
import Data.ByteString.IsoBaseFileFormat.Boxes.Box
import Data.ByteString.IsoBaseFileFormat.Util.TypeLayout ()
+-- 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 IsBrand brand where
+class IsMediaFileFormat brand where
-- | The layout that an IsBoxContent instance has to have, before 'packMedia' accepts it
type BoxLayout brand
mediaBuilder
diff --git a/src/Data/ByteString/IsoBaseFileFormat/Util/BitRecords.hs b/src/Data/ByteString/IsoBaseFileFormat/Util/BitRecords.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/ByteString/IsoBaseFileFormat/Util/BitRecords.hs
@@ -0,0 +1,214 @@
+{-# LANGUAGE UndecidableInstances #-}
+module Data.ByteString.IsoBaseFileFormat.Util.BitRecords where
+
+import Data.Kind
+import Data.Word
+import Data.Type.Bool
+import GHC.TypeLits
+import Data.Bits
+import Data.Proxy
+import Test.TypeSpecCrazy
+
+data Field :: Nat -> Type
+data (:=>) :: k -> Type -> Type
+data (:*:) :: Type -> Type -> Type
+type FieldPosition = (Nat, Nat)
+
+type Flag = Field 1
+
+infixr 6 :=>
+infixl 5 :*:
+
+-- nested fields
+data (:/) :: Symbol -> k -> Type
+infixr 7 :/
+
+
+type family
+ GetFieldSize (f :: l) :: Nat where
+ GetFieldSize (label :=> f) = GetFieldSize f
+ GetFieldSize (Field n ) = n
+ GetFieldSize (l :*: r) = GetFieldSize l + GetFieldSize r
+
+type family
+ HasField (f :: fk) (l :: lk) :: Bool where
+ HasField (l :=> f) l = 'True
+ HasField (l :=> f) (l :/ p) = HasField f p
+ HasField (f1 :*: f2) l = HasField f1 l || HasField f2 l
+ HasField f l = 'False
+
+type family
+ HasFieldConstraint (label :: lk) (field :: fk) :: Constraint where
+ HasFieldConstraint l f =
+ If (HasField f l)
+ (HasField f l ~ 'True)
+ (TypeError ('Text "Label not found: '"
+ ':<>: 'ShowType l
+ ':<>: 'Text "' in:"
+ ':$$: 'ShowType f ))
+
+type family
+ FocusOn (l :: lk) (f :: fk) :: Result fk where
+ FocusOn l f =
+ If (HasField f l)
+ ('Right (FocusOnUnsafe l f))
+ ('Left ('Text "Label not found. Cannot focus '"
+ ':<>: 'ShowType l
+ ':<>: 'Text "' in:"
+ ':$$: 'ShowType f ))
+
+type family
+ FocusOnUnsafe (l :: lk) (f :: fk) :: fk where
+ FocusOnUnsafe l (l :=> f) = f
+ FocusOnUnsafe (l :/ p) (l :=> f) = FocusOnUnsafe p f
+ FocusOnUnsafe l (f :*: f') = FocusOnUnsafe l (If (HasField f l) f f')
+
+-- field location and access
+
+type family
+ GetFieldPosition (f :: field) (l :: label) :: Result FieldPosition where
+ GetFieldPosition f l =
+ If (HasField f l)
+ ('Right (GetFieldPositionUnsafe f l))
+ ('Left ('Text "Label not found. Cannot get bit range for '"
+ ':<>: 'ShowType l
+ ':<>: 'Text "' in:"
+ ':$$: 'ShowType f ))
+
+type family
+ GetFieldPositionUnsafe (f :: field) (l :: label) :: FieldPosition where
+ GetFieldPositionUnsafe (l :=> f) l = '(0, GetFieldSize f - 1)
+ GetFieldPositionUnsafe (l :=> f) (l :/ p) = GetFieldPositionUnsafe f p
+ GetFieldPositionUnsafe (f :*: f') l =
+ If (HasField f l)
+ (GetFieldPositionUnsafe f l)
+ (AddToFieldPosition (GetFieldSize f) (GetFieldPositionUnsafe f' l))
+
+type family
+ AddToFieldPosition (v :: Nat) (e :: (Nat, Nat)) :: (Nat, Nat) where
+ AddToFieldPosition v '(a,b) = '(a + v, b + v)
+
+type family
+ IsFieldPostition (pos :: FieldPosition) :: Constraint where
+ IsFieldPostition '(a, b) =
+ If (a <=? b)
+ (a <= b, KnownNat a, KnownNat b)
+ (TypeError
+ ('Text "Bad field position: " ':<>: 'ShowType '(a,b)
+ ':$$: 'Text "First index greater than last: "
+ ':<>: 'ShowType a
+ ':<>: 'Text " > "
+ ':<>: 'ShowType b ))
+
+type family
+ FieldPostitionToList (pos :: FieldPosition) :: [Nat] where
+ FieldPostitionToList '(a, a) = '[a]
+ FieldPostitionToList '(a, b) = (a ': (FieldPostitionToList '(a+1, b)))
+
+type family
+ AlignField (a :: Nat) (f :: field) :: Result field where
+ AlignField 0 f = 'Left ('Text "Invalid alignment of 0")
+ AlignField a f = 'Right (AddPadding ((a - (GetFieldSize f `Rem` a)) `Rem` a) f)
+
+type family
+ AddPadding (n :: Nat) (f :: field) :: field where
+ AddPadding 0 f = f
+ AddPadding n f = f :*: Field n
+
+-- | Get the remainder of the integer division of x and y, such that @forall x
+-- y. exists k. (Rem x y) == x - y * k@ The algorithm is: count down x
+-- until zero, incrementing the accumulator at each step. Whenever the
+-- accumulator is equal to y set it to zero.
+--
+-- If the accumulator has reached y reset it. It is important to do this
+-- BEFORE checking if x == y and then returning the accumulator, for the case
+-- where x = k * y with k > 0. For example:
+--
+-- @
+-- 6 `Rem` 3 = RemImpl 6 3 0
+-- RemImpl 6 3 0 = RemImpl (6-1) 3 (0+1) -- RemImpl Clause 4
+-- RemImpl 5 3 1 = RemImpl (5-1) 3 (1+1) -- RemImpl Clause 4
+-- RemImpl 4 3 2 = RemImpl (4-1) 3 (2+1) -- RemImpl Clause 4
+-- RemImpl 3 3 3 = RemImpl 3 3 0 -- RemImpl Clause 2 !!!
+-- RemImpl 3 3 0 = 0 -- RemImpl Clause 3 !!!
+-- @
+--
+type Rem (x :: Nat) (y :: Nat) = RemImpl x y 0
+type family
+ RemImpl (x :: Nat) (y :: nat) (acc :: Nat) :: Nat where
+ -- finished if x was < y:
+ RemImpl 0 y acc = acc
+ RemImpl x y y = RemImpl x y 0
+ -- finished if x was >= y:
+ RemImpl y y acc = acc
+ -- the base case
+ RemImpl x y acc = RemImpl (x - 1) y (acc + 1)
+
+getFlag
+ :: forall a (path :: k) (first :: Nat) field p1 p2
+ . ( IsFieldC path field first first
+ , Bits a )
+ => p1 path -> p2 field -> a -> Bool
+getFlag _ _ a = testBit a pos
+ where pos = fromIntegral $ natVal (Proxy :: Proxy first)
+
+setFlag
+ :: forall a (path :: k) (first :: Nat) field p1 p2
+ . ( IsFieldC path field first first
+ , Bits a )
+ => p1 path -> p2 field -> Bool -> a -> a
+setFlag _ _ v a = modifyBit a pos
+ where pos = fromIntegral $ natVal (Proxy :: Proxy first)
+ modifyBit = if v then setBit else clearBit
+
+getField
+ :: forall a b (path :: k) (first :: Nat) (last :: Nat) field pxy1 pxy2
+ . ( IsFieldC path field first last
+ , Integral a
+ , Bits a
+ , Num b)
+ => pxy1 path -> pxy2 field -> a -> b
+getField _ _ a = fromIntegral ((a `shiftR` posFirst) .&. bitMask)
+ where
+ bitMask =
+ let bitCount = 1 + posLast - posFirst
+ in (2 ^ bitCount) - 1
+ posFirst = fromIntegral $ natVal (Proxy :: Proxy first)
+ posLast = fromIntegral $ natVal (Proxy :: Proxy last)
+
+setField
+ :: forall a b (path :: k) (first :: Nat) (last :: Nat) field pxy1 pxy2
+ . ( IsFieldC path field first last
+ , Num a
+ , Bits a
+ , Integral b)
+ => pxy1 path -> pxy2 field -> b -> a -> a
+setField _ _ v x = (x .&. bitMaskField) .|. (v' `shiftL` posFirst)
+ where
+ v' = bitMaskValue .&. fromIntegral v
+ bitMaskField = complement (bitMaskValue `shiftL` posFirst)
+ bitMaskValue =
+ let bitCount = 1 + posLast - posFirst
+ in (2 ^ bitCount) - 1
+ posFirst = fromIntegral $ natVal (Proxy :: Proxy first)
+ posLast = fromIntegral $ natVal (Proxy :: Proxy last)
+
+
+
+type Foo =
+ "foo" :=> Flag
+ :*: Field 4
+ :*: "bar" :=> Field 2
+ :*: Field 4
+ :*: "baz" :=> Field 17
+
+type IsFieldC name field first last =
+ ( name `HasFieldConstraint` field
+ , KnownNat first
+ , KnownNat last
+ , 'Right '(first, last) ~ (GetFieldPosition field name)
+ )
+
+getFooField :: IsFieldC name Foo first last
+ => proxy name -> Word64 -> Word64
+getFooField px = getField px (Proxy :: Proxy Foo)
diff --git a/stack.yaml b/stack.yaml
new file mode 100644
--- /dev/null
+++ b/stack.yaml
@@ -0,0 +1,70 @@
+# This file was automatically generated by 'stack init'
+#
+# Some commonly used options have been documented as comments in this file.
+# For advanced use and comprehensive documentation of the format, please see:
+# http://docs.haskellstack.org/en/stable/yaml_configuration/
+
+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
+# A snapshot resolver dictates the compiler version and the set of packages
+# to be used for project dependencies. For example:
+#
+# resolver: lts-3.5
+# resolver: nightly-2015-09-21
+# resolver: ghc-7.10.2
+# resolver: ghcjs-0.1.0_ghc-7.10.2
+# resolver:
+# name: custom-snapshot
+# location: "./custom-snapshot.yaml"
+resolver: nightly-2016-07-30
+
+# User packages to be built.
+# Various formats can be used as shown in the example below.
+#
+# packages:
+# - some-directory
+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
+# - location:
+# git: https://github.com/commercialhaskell/stack.git
+# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+# extra-dep: true
+# subdirs:
+# - auto-update
+# - wai
+#
+# A package marked 'extra-dep: true' will only be built if demanded by a
+# non-dependency (i.e. a user package), and its test suites and benchmarks
+# will not be run. This is useful for tweaking upstream packages.
+packages:
+- '.'
+
+# Dependency packages to be pulled from upstream that are not in the resolver
+# (e.g., acme-missiles-0.3)
+extra-deps:
+- vector-sized-0.3.2.0
+- show-type-0.1.1
+- type-spec-0.2.0.0
+
+# Override default flag values for local packages and extra-deps
+flags: {}
+
+# Extra package databases containing global packages
+extra-package-dbs: []
+
+# Control whether we use the GHC we find on the path
+# system-ghc: true
+#
+# Require a specific version of stack, using version ranges
+# require-stack-version: -any # Default
+# require-stack-version: ">=1.1"
+#
+# Override the architecture used by stack, especially useful on Windows
+# arch: i386
+# arch: x86_64
+#
+# Extra directories used by stack for building
+# extra-include-dirs: [/path/to/dir]
+# extra-lib-dirs: [/path/to/dir]
+#
+# Allow a newer minor version of GHC than the snapshot specifies
+# compiler-check: newer-minor