diff --git a/.gitignore b/.gitignore --- a/.gitignore +++ b/.gitignore @@ -6,6 +6,9 @@ *_flymake.hs .hsenv .stack-work/ +/*.html TAGS /.idea/ /.dir-locals.el +*.refactored.hs +/*.html diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -18,7 +18,7 @@ install: - stack -j 2 setup --no-terminal --resolver nightly - - stack -j 2 build --only-snapshot --no-terminal script: - - stack -j 2 test --no-terminal + - stack test --flag isobmff-builder:-complextests --flag isobmff-builder:-fullbenchmarks --fast --no-terminal + - stack bench --flag isobmff-builder:-complextests --flag isobmff-builder:-fullbenchmarks --fast --no-terminal diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Sven Heyll (c) 2016 +Copyright Sven Heyll and Lindenbaum GmbH (c) 2016 All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,5 @@ [![Build Status](https://travis-ci.org/sheyll/isobmff-builder.svg?branch=master)](https://travis-ci.org/sheyll/isobmff-builder) -[![Hackage](https://img.shields.io/badge/hackage-isobmff-green.svg?style=flat)](http://hackage.haskell.org/package/isobmff-builder) +[![Hackage](https://img.shields.io/badge/hackage-isobmffbuilder-green.svg?style=flat)](http://hackage.haskell.org/package/isobmff-builder) # ISO-14496-12 Base Media File Format Builder 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/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/examples/734397657.m4s b/examples/734397657.m4s deleted file mode 100644 Binary files a/examples/734397657.m4s and /dev/null differ diff --git a/examples/audio.mpd b/examples/audio.mpd deleted file mode 100644 --- a/examples/audio.mpd +++ /dev/null @@ -1,16 +0,0 @@ - - - - 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 deleted file mode 100644 Binary files a/examples/init.mp4 and /dev/null differ diff --git a/isobmff-builder.cabal b/isobmff-builder.cabal --- a/isobmff-builder.cabal +++ b/isobmff-builder.cabal @@ -1,13 +1,13 @@ name: isobmff-builder -version: 0.10.5.0 +version: 0.11.2.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 license: BSD3 license-file: LICENSE author: Sven Heyll -maintainer: sven.heyll@gmail.com -copyright: 2016 Sven Heyll +maintainer: sven.heyll@lindenbaum.eu +copyright: 2016 Sven Heyll, Lindenbaum GmbH category: Codec build-type: Simple extra-source-files: README.md @@ -15,24 +15,34 @@ , .travis.yml , doc/basic-structure.svg , doc/data_reference_box.svg - , examples/734397657.m4s - , examples/init.mp4 - , examples/audio.mpd + , 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.Boxes + exposed-modules: Data.ByteString.IsoBaseFileFormat.Box + , Data.ByteString.IsoBaseFileFormat.Boxes , Data.ByteString.IsoBaseFileFormat.Boxes.AudioSampleEntry - , Data.ByteString.IsoBaseFileFormat.Boxes.Box - , Data.ByteString.IsoBaseFileFormat.Boxes.BoxFields + , 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.FullBox , Data.ByteString.IsoBaseFileFormat.Boxes.Handler , Data.ByteString.IsoBaseFileFormat.Boxes.HintMediaHeader , Data.ByteString.IsoBaseFileFormat.Boxes.HintSampleEntry @@ -42,46 +52,90 @@ , 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.Time , 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.Versioned + , Data.ByteString.IsoBaseFileFormat.Boxes.TrackRun , Data.ByteString.IsoBaseFileFormat.Boxes.VideoMediaHeader , Data.ByteString.IsoBaseFileFormat.Boxes.VisualSampleEntry , Data.ByteString.IsoBaseFileFormat.Brands.Dash - , Data.ByteString.IsoBaseFileFormat.Brands.Types + , 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.BitRecords + , 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.Kind.Extra + , Data.Type.BitRecords + , Data.Type.BitRecords.Arithmetic + , Data.Type.BitRecords.Assert + , Data.Type.BitRecords.Builder.BitBuffer + , Data.Type.BitRecords.Builder.Holey + , 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.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 + , vector >= 0.11 && < 0.12 , singletons >= 2.2 && < 3 , tagged >= 0.8 && < 1 , time >= 1.6.0.1 && < 2 , text >= 1.2.2.1 && < 2 - , type-spec >= 0.1 + , type-spec >= 0.3 + , mtl >= 2.2 && < 3 + , pretty-types >= 0.2.3 && < 0.3 + , template-haskell >= 2.11 && < 3 default-language: Haskell2010 - ghc-options: -Wall -funbox-strict-fields -fno-warn-unused-do-bind - default-extensions: ConstraintKinds + ghc-options: -O2 -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 @@ -97,32 +151,44 @@ , 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: BoxFieldsSpec + other-modules: BitRecordsSpec + , BoxFieldsSpec , BoxSpec - , BrandTypeSpec , DataReferenceSpec - , DashSpec + , ElementaryStreamDescriptorSpec + , EnumSpec + , ExpandableSpec + , Mp4AudioSampleEntry + , MediaFileSpec + , Mp4AudioFileSpec + , Mp4AudioSegmentSpec , TypeLayoutSpec build-depends: base >= 4.9 && < 5 , bytestring >= 0.10.8.1 - , hspec + , hspec >= 2.2 && < 3 , isobmff-builder , binary , text >= 1.2.2.1 && < 2 - , type-spec >= 0.1 + , type-spec >= 0.3 + , mtl >= 2.2 && < 3 + , QuickCheck + , tagged >= 0.8 && < 1 + , pretty-types >= 0.2.1 && < 0.3 default-language: Haskell2010 - default-extensions: ConstraintKinds + default-extensions: BangPatterns + , ConstraintKinds , CPP , DataKinds , DefaultSignatures @@ -144,12 +210,68 @@ , StandaloneDeriving , TemplateHaskell , TupleSections + , TypeApplications , TypeFamilies , TypeInType , TypeOperators , TypeSynonymInstances + , UnicodeSyntax ghc-options: -Wall -O0 -j +RTS -A256m -n2m -RTS - -fwarn-unused-binds -fno-warn-unused-do-bind -fno-warn-missing-signatures + -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 + default-language: Haskell2010 + build-depends: base >= 4.9 && < 5 + , isobmff-builder + , binary + , bytestring >= 0.10.8.1 && < 0.11 + , criterion >= 1.1 && < 2 + , tagged >= 0.8 && < 1 + , type-spec >= 0.3 + default-language: Haskell2010 + default-extensions: BangPatterns + , ConstraintKinds + , CPP + , DataKinds + , DefaultSignatures + , DeriveDataTypeable + , DeriveFunctor + , DeriveGeneric + , FlexibleInstances + , FlexibleContexts + , FunctionalDependencies + , GADTs + , GeneralizedNewtypeDeriving + , KindSignatures + , MultiParamTypeClasses + , OverloadedStrings + , QuasiQuotes + , RecordWildCards + , RankNTypes + , ScopedTypeVariables + , StandaloneDeriving + , TemplateHaskell + , TupleSections + , TypeApplications + , TypeFamilies + , TypeInType + , TypeOperators + , TypeSynonymInstances + , UnicodeSyntax + ghc-options: -O2 -j +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 diff --git a/spec/BitRecordsSpec.hs b/spec/BitRecordsSpec.hs new file mode 100644 --- /dev/null +++ b/spec/BitRecordsSpec.hs @@ -0,0 +1,470 @@ +{-# 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 = 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` "sized-field\n size: U16 := hex: 000e (dec: 14)\n utf-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 '[ Rem 0 3 `ShouldBe` 0 + , Rem 1 3 `ShouldBe` 1 + , Rem 2 3 `ShouldBe` 2 + , Rem 3 3 `ShouldBe` 0 + , Rem 4 3 `ShouldBe` 1 + , Rem 5 3 `ShouldBe` 2 + , Rem 6 3 `ShouldBe` 0 + ] +testRem = Valid + +testRemPow2 + :: + "RemPow2" + ######### + + "Remainder of '1'" + ~~~~~~~~~~~~~~~~~~ + + It "1 `RemPow2` 1 is 1" (Is 1 (RemPow2 1 1)) + -* It "1 `RemPow2` 8 is 1" (Is 1 (RemPow2 1 8)) + + -/- + + "Remainder of '3916441'" + ~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + It " `RemPow2` 1 is 1" (Is 1 (RemPow2 3916441 1)) + -* It " `RemPow2` 4 is 9" (Is 9 (RemPow2 3916441 4)) + -* It " `RemPow2` 8 is 153" (Is 153 (RemPow2 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 --- a/spec/BoxFieldsSpec.hs +++ b/spec/BoxFieldsSpec.hs @@ -2,6 +2,9 @@ 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) diff --git a/spec/BoxSpec.hs b/spec/BoxSpec.hs --- a/spec/BoxSpec.hs +++ b/spec/BoxSpec.hs @@ -1,7 +1,8 @@ module BoxSpec (spec) where import Test.Hspec -import Data.ByteString.IsoBaseFileFormat.Boxes +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 diff --git a/spec/BrandTypeSpec.hs b/spec/BrandTypeSpec.hs deleted file mode 100644 --- a/spec/BrandTypeSpec.hs +++ /dev/null @@ -1,70 +0,0 @@ -module BrandTypeSpec - (spec) - where - -import Test.Hspec -import Data.ByteString.IsoBaseFileFormat.Boxes -import Data.ByteString.IsoBaseFileFormat.Brands.Types -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 printBuilder test - describe "Single Box BoxLayout" $ - it "accepts valid box content types" $ - let test = - mediaBuilder (Proxy :: Proxy TestBrandSingle) - (singletonBox testBox1) - in printBuilder test - describe "Multiple nested Boxes BoxLayout" $ - it "accepts valid box content types" $ - let test = - mediaBuilder (Proxy :: Proxy TestBrandNested) - (singletonBox (testParentBox1 $: testBox1)) - in printBuilder test - -printBuilder :: Builder -> IO () -printBuilder 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/DashSpec.hs b/spec/DashSpec.hs deleted file mode 100644 --- a/spec/DashSpec.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module DashSpec (spec) where -- TODO rename to mp4 audio init spec - -import Test.Hspec -import Data.ByteString.IsoBaseFileFormat.Brands.Dash -import qualified Data.ByteString.Lazy as BL -import Data.Text () - -spec :: Spec -spec = - do describe "SingleAudioTrackInit version 0" $ - do it "renders some output at all" $ - do createionTime <- mp4CurrentTime - let ct :: Word32 - ct = fromScalar createionTime - 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 createionTime - doc = mkSingleTrackInit args - rendered = BL.unpack $ toLazyByteString $ doc - expected = - [ - -- 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 - -- moov box - ,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 - ,1 ,95 ,144 ,0 ,1 ,95 ,144 ,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 - ,255 ,255 ,255 ,255 - -- trak box - ,0 ,0 ,1,64 - ,116 ,114 ,97 ,107 - -- tkhd box - ,0 ,0 ,0 ,92 - ,116 ,107 ,104 ,100 - ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 ,0 - ,0 ,1 ,0 ,0 ,0 ,0 ,0 ,1 ,95 ,144 ,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,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,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,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,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 - -exampleSingleTrackInit :: U32 "creation_time" -> SingleAudioTrackInit -exampleSingleTrackInit creationTime = - SingleAudioTrackInit - (MovieHeader $ - V0 (creationTime :+ 0 :+ Template :+ durationFromSeconds Template 1) :+ - def) - (TrackHeader $ - V0 (0 :+ 0 :+ 1 :+ Constant :+ durationFromSeconds Template 1) :+ - def) - (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,5 +1,6 @@ module DataReferenceSpec (spec) where +import Data.ByteString.IsoBaseFileFormat.Box import Data.ByteString.IsoBaseFileFormat.Boxes import Test.Hspec 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,195 @@ +{-# 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 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` "base-descriptor: 03\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 >>" + it "can be pretty printed" $ + showRecord (Proxy @(BitRecordOfDescriptor $~ Eval Mp4HeAacEsDescriptor)) + `shouldStartWith` "base-descriptor: 03\n" + 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 = buildAacMp4StreamInit args + rendered = BL.unpack $ toLazyByteString $ 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,56 + ,115,107,105,112 + ,76,105,110,100,101,110,98,97,117,109,32,71,109,98,72,32,105 + ,115,111,98,109,102,102,45,98,117,105,108,100,101,114,44,32 + ,83,118,101,110,32,72,101,121,108,108,32,50,48,49,54 + -- 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" -> AacMp4StreamConfig +exampleSingleTrackInit creationTime = + AacMp4StreamConfig creationTime "Hello world" True SF48000 SingleChannel +#endif diff --git a/spec/Mp4AudioSampleEntry.hs b/spec/Mp4AudioSampleEntry.hs new file mode 100644 --- /dev/null +++ b/spec/Mp4AudioSampleEntry.hs @@ -0,0 +1,27 @@ +module Mp4AudioSampleEntry ( spec ) where + +import Data.ByteString.Builder +import Data.ByteString.IsoBaseFileFormat.ReExports +import qualified Data.ByteString.Lazy as B +import Data.ByteString.Mp4.Boxes.Mp4AudioSampleEntry +import Data.Type.BitRecords +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 (ToBitRecord (AudioObjectType 30)) -/- + + "Big Audio Object Types" + ~~~~~~~~~~~~~~~~~~~~~~~~ + 11 `ShouldBe` BitRecordSize (ToBitRecord (AudioObjectType 31)) 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/TypeLayoutSpec.hs b/spec/TypeLayoutSpec.hs --- a/spec/TypeLayoutSpec.hs +++ b/spec/TypeLayoutSpec.hs @@ -5,7 +5,7 @@ import Test.Hspec import GHC.TypeLits () import Data.ByteString.IsoBaseFileFormat.Util.TypeLayout -import Data.ByteString.IsoBaseFileFormat.Boxes.Box +import Data.ByteString.IsoBaseFileFormat.Box spec :: Spec spec = @@ -25,6 +25,7 @@ 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` () @@ -34,6 +35,7 @@ test7a `shouldBe` () test7b `shouldBe` () test7c `shouldBe` () +#endif ---- data Foo @@ -84,7 +86,10 @@ type TestType5b = Box (ContainerBox Foo '[Bar, Bar]) test5b :: (IsRuleConform TestType5b TestRule5 ~ 'True) => () test5b = () + + ---- +#ifdef COMPLEXTESTS type TestRule6 = (ContainerBox Foo '[ OnceOptionalX (MatchSymbol "baz ") @@ -106,6 +111,8 @@ type TestType6d = Box (ContainerBox Foo '[Bar,Foo]) test6d :: (IsRuleConform TestType6d TestRule6 ~ 'True) => () test6d = () + + ---- type TestRule7 = TopLevel (ContainerBox Foo @@ -142,3 +149,4 @@ ]) 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 ((:++), + 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 --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes.hs @@ -4,14 +4,12 @@ where 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.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.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 @@ -22,24 +20,29 @@ 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.Time 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.Versioned 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 - -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 --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/AudioSampleEntry.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/AudioSampleEntry.hs @@ -1,40 +1,30 @@ -- | 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.Box +import Data.ByteString.IsoBaseFileFormat.Util.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 +import Data.ByteString.IsoBaseFileFormat.ReExports --- | Fields if audio sample entries -newtype instance SampleEntry 'AudioTrack (AudioCoding c) where +-- | 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 - -> SampleEntry 'AudioTrack (AudioCoding c) - deriving (IsBoxContent, Default) - -type DefaultSoundSamplerate = 48000 + :+ Template (U32 "samplerate") + (DefaultSoundSamplerate * 65536) -- TODO implement fix point integer + :+ b + -> AudioSampleEntry b + deriving (Default, IsBoxContent) --- | A coproduct of audio codec types -data family AudioCoding (c :: Symbol) +instance Functor AudioSampleEntry where + fmap fun (AudioSampleEntry (a :+ b :+ c :+ d :+ e :+ f :+ x)) = + AudioSampleEntry (a :+ b :+ c :+ d :+ e :+ f :+ fun x) --- | The MPEG-4 AAC Audio codec -data instance AudioCoding "mp4a" = Mpeg4Aac +type DefaultSoundSamplerate = 48000 -type instance BoxTypeSymbol (AudioCoding c) = c +type instance GetHandlerType (AudioSampleEntry b) = 'AudioTrack +type instance BoxTypeSymbol (AudioSampleEntry b) = BoxTypeSymbol b diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Box.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Box.hs deleted file mode 100644 --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Box.hs +++ /dev/null @@ -1,360 +0,0 @@ -{-# 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.Boxes.Box - (module Data.ByteString.IsoBaseFileFormat.Boxes.Box, module X) - 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.Kind -import GHC.TypeLits as X -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 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) - -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 - -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 - 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 - -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 - --- | 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/BoxFields.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/BoxFields.hs deleted file mode 100644 --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/BoxFields.hs +++ /dev/null @@ -1,298 +0,0 @@ --- | Mini EDSL for labelled box fields. The boxfields can be 'Scalar' or --- 'ScalarArray's. -module Data.ByteString.IsoBaseFileFormat.Boxes.BoxFields - where - -import Data.ByteString.IsoBaseFileFormat.Boxes.Box -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 - -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 n o -> ScalarArray label n o - deriving (Show,Eq) - -instance (Default o,KnownNat (len :: Nat)) => Default (ScalarArray label len o) where - def = ScalarArray $ Vec.replicate def - -instance (Num o,IsBoxContent (Scalar o label),KnownNat (len :: Nat)) => 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 $ - case Vec.fromList l of - Nothing -> - 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)) - Just v -> v - --- * 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 - 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 (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 :: [Integer] - vs = fromSing s - vs' :: [o] - vs' = fromIntegral <$> vs - in ScalarArray (fromJust (Vec.fromList vs')) - -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/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 --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/DataEntryUrl.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/DataEntryUrl.hs @@ -6,9 +6,10 @@ ) where -import Data.ByteString.IsoBaseFileFormat.Boxes.Box -import Data.ByteString.IsoBaseFileFormat.Boxes.FullBox +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 = diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/DataEntryUrn.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/DataEntryUrn.hs --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/DataEntryUrn.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/DataEntryUrn.hs @@ -5,8 +5,8 @@ ) where -import Data.ByteString.IsoBaseFileFormat.Boxes.Box -import Data.ByteString.IsoBaseFileFormat.Boxes.FullBox +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 diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/DataInformation.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/DataInformation.hs --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/DataInformation.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/DataInformation.hs @@ -2,7 +2,7 @@ -- 'Track' the actual location are stored in 'DataReference's. module Data.ByteString.IsoBaseFileFormat.Boxes.DataInformation where -import Data.ByteString.IsoBaseFileFormat.Boxes.Box +import Data.ByteString.IsoBaseFileFormat.Box -- | Data information box phantom type. data DataInformation 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 @@ -9,11 +9,12 @@ ) where -import Data.ByteString.IsoBaseFileFormat.Boxes.Box -import Data.ByteString.IsoBaseFileFormat.Boxes.FullBox +import Data.ByteString.IsoBaseFileFormat.Box +import Data.ByteString.IsoBaseFileFormat.Util.FullBox import Data.ByteString.IsoBaseFileFormat.Boxes.DataEntryUrl -import Data.ByteString.IsoBaseFileFormat.Boxes.BoxFields +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 = diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/FileType.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/FileType.hs --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/FileType.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/FileType.hs @@ -1,6 +1,7 @@ module Data.ByteString.IsoBaseFileFormat.Boxes.FileType where -import Data.ByteString.IsoBaseFileFormat.Boxes.Box +import Data.ByteString.IsoBaseFileFormat.Box +import Data.ByteString.IsoBaseFileFormat.ReExports -- | File Type Box instance IsBox FileType where @@ -14,9 +15,9 @@ -- | Contents of a 'ftyp' box are some 'FourCc' /brands/ and a version. data FileType = - FileType {majorBrand :: FourCc - ,minorVersion :: Word32 - ,compatibleBrands :: [FourCc]} + 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) diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/FullBox.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/FullBox.hs deleted file mode 100644 --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/FullBox.hs +++ /dev/null @@ -1,92 +0,0 @@ --- | Full Boxes -module Data.ByteString.IsoBaseFileFormat.Boxes.FullBox - (FullBox(..), fullBox, BoxFlags(..)) - where - -import Data.ByteString.IsoBaseFileFormat.Boxes.Box - --- | 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/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 @@ -15,13 +15,15 @@ ,auxilliaryVideoTrackHandler ,namedAuxilliaryVideoTrackHandler ,HandlerType(..) + ,GetHandlerType ,HandlerTypeCode) where -import Data.ByteString.IsoBaseFileFormat.Boxes.Box -import Data.ByteString.IsoBaseFileFormat.Boxes.BoxFields -import Data.ByteString.IsoBaseFileFormat.Boxes.FullBox +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 @@ -43,6 +45,9 @@ | HintTrack | TimedMetaDataTrack | AuxilliaryVideoTrack + +-- | Return 'HandlerType' for 'BoxLayout' checking. +type family GetHandlerType t :: HandlerType type family HandlerTypeCode (handlertype :: HandlerType) :: Symbol where HandlerTypeCode 'VideoTrack = "vide" diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/HintMediaHeader.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/HintMediaHeader.hs --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/HintMediaHeader.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/HintMediaHeader.hs @@ -1,11 +1,12 @@ -- | 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.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 diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/HintSampleEntry.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/HintSampleEntry.hs --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/HintSampleEntry.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/HintSampleEntry.hs @@ -2,16 +2,14 @@ -- | 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.SampleEntry () import Data.ByteString.IsoBaseFileFormat.Boxes.Handler -import Data.ByteString.IsoBaseFileFormat.Boxes.Box +import Data.ByteString.IsoBaseFileFormat.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 +newtype HintSampleEntry protocol where + HintSampleEntry :: protocol -> HintSampleEntry protocol --- | Family of protocol specific contents for 'HintTrack's. -type family HintFields (protocol :: Symbol) +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 --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Language.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Language.hs @@ -1,22 +1,23 @@ -- | Boxfield indicating an ISO 639-2 alpha-3 language code. module Data.ByteString.IsoBaseFileFormat.Boxes.Language (Language, mkLanguage) where -import Data.ByteString.IsoBaseFileFormat.Boxes.Box +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). -data Language = Language Word16 +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 && + c0 > toEnum 0x60 && c0 < toEnum 0x7b && c1 > toEnum 0x60 && c1 < toEnum 0x7b && - c2 > toEnum 0x60 && c2 < toEnum 0x7b) = + c2 > toEnum 0x60 && c2 < toEnum 0x7b = let s :: Char -> Word16 s c = fromIntegral (fromEnum c) - 0x60 @@ -31,7 +32,7 @@ fromString = mkLanguage instance Default Language where - def = mkLanguage "deu" + def = mkLanguage "und" instance IsBoxContent Language where boxSize _ = 2 diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Media.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Media.hs --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Media.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Media.hs @@ -1,7 +1,7 @@ -- | Track specific media information container box. module Data.ByteString.IsoBaseFileFormat.Boxes.Media where -import Data.ByteString.IsoBaseFileFormat.Boxes.Box +import Data.ByteString.IsoBaseFileFormat.Box -- | Media data box data Media diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/MediaData.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/MediaData.hs --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/MediaData.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/MediaData.hs @@ -1,7 +1,7 @@ -- | Media data box module Data.ByteString.IsoBaseFileFormat.Boxes.MediaData where -import Data.ByteString.IsoBaseFileFormat.Boxes.Box +import Data.ByteString.IsoBaseFileFormat.Box import qualified Data.ByteString as B -- | Media data box phantom type diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/MediaHeader.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/MediaHeader.hs --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/MediaHeader.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/MediaHeader.hs @@ -1,17 +1,17 @@ -- | Media-independent properties of a tracks media content. module Data.ByteString.IsoBaseFileFormat.Boxes.MediaHeader where -import Data.ByteString.IsoBaseFileFormat.Boxes.Box -import Data.ByteString.IsoBaseFileFormat.Boxes.BoxFields -import Data.ByteString.IsoBaseFileFormat.Boxes.FullBox +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.Boxes.Time +import Data.ByteString.IsoBaseFileFormat.Util.Time +import Data.ByteString.IsoBaseFileFormat.ReExports -- | Media header data box. -data MediaHeader (v :: Nat) where +newtype MediaHeader (v :: Nat) where MediaHeader - :: KnownNat v - => Timing v :+ Language :+ Constant (I16 "pre_defined") 0 + :: Timing v :+ Language :+ Constant (I16 "pre_defined") 0 -> MediaHeader v -- | Create a 'MediaHeader' box. diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/MediaInformation.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/MediaInformation.hs --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/MediaInformation.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/MediaInformation.hs @@ -2,7 +2,7 @@ -- technicalities of the media data associated with a 'Track'. module Data.ByteString.IsoBaseFileFormat.Boxes.MediaInformation where -import Data.ByteString.IsoBaseFileFormat.Boxes.Box +import Data.ByteString.IsoBaseFileFormat.Box -- | Media information box type. data MediaInformation diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/MetaDataSampleEntry.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/MetaDataSampleEntry.hs --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/MetaDataSampleEntry.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/MetaDataSampleEntry.hs @@ -1,26 +1,18 @@ 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.Box +import Data.ByteString.IsoBaseFileFormat.Util.BoxFields +import Data.ByteString.IsoBaseFileFormat.Util.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 () +import Data.ByteString.IsoBaseFileFormat.ReExports -- * 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 GetHandlerType (MetaDataCoding c) = 'TimedMetaDataTrack type instance BoxTypeSymbol (MetaDataCoding c) = c -- | A coproduct of meta data codings (XML, Text, ...) diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Movie.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Movie.hs --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Movie.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Movie.hs @@ -1,7 +1,7 @@ -- | Meta data for a presentation of a /movie/. module Data.ByteString.IsoBaseFileFormat.Boxes.Movie where -import Data.ByteString.IsoBaseFileFormat.Boxes.Box +import Data.ByteString.IsoBaseFileFormat.Box -- | Compose a set of boxes into a 'Movie' movie :: Boxes ts -> Box (ContainerBox Movie ts) 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 --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/MovieHeader.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/MovieHeader.hs @@ -1,10 +1,11 @@ -- | Meta data for a presentation of a /movie/. module Data.ByteString.IsoBaseFileFormat.Boxes.MovieHeader where -import Data.ByteString.IsoBaseFileFormat.Boxes.Box -import Data.ByteString.IsoBaseFileFormat.Boxes.BoxFields -import Data.ByteString.IsoBaseFileFormat.Boxes.FullBox -import Data.ByteString.IsoBaseFileFormat.Boxes.Time +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 @@ -23,9 +24,8 @@ -- 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. -data MovieHeader (version :: Nat) where +newtype MovieHeader (version :: Nat) where MovieHeader :: - KnownNat version => Timing version :+ Template (I32 "rate") 0x00010000 :+ Template (I16 "volume") 0x0100 @@ -36,12 +36,17 @@ :+ 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) +type MovieHeaderTimesV0 = MovieHeaderTimes + (Scalar Word32) + (Template (U32 "duration") 0xffffffff) -- | Time and timing information about a movie (64bit version). -type MovieHeaderTimesV1 = MovieHeaderTimes (Scalar Word64) +type MovieHeaderTimesV1 = MovieHeaderTimes + (Scalar Word64) + (Template (U64 "duration") 0xffffffffffffffff) -- | Time and timing information about a movie. -- @@ -50,16 +55,11 @@ -- 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 = +type MovieHeaderTimes uint dur = uint "creation_time" :+ uint "modification_time" :+ TimeScale - :+ uint "duration" - - -instance IsBoxContent (MovieHeader version) where - boxSize (MovieHeader c) = boxSize c - boxBuilder (MovieHeader c) = boxBuilder c + :+ dur instance IsBox (MovieHeader version) diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/NullMediaHeader.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/NullMediaHeader.hs --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/NullMediaHeader.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/NullMediaHeader.hs @@ -1,8 +1,9 @@ -- | 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 +import Data.ByteString.IsoBaseFileFormat.Box +import Data.ByteString.IsoBaseFileFormat.Util.FullBox +import Data.ByteString.IsoBaseFileFormat.ReExports -- | Null header data box. data NullMediaHeader = NullMediaHeader diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/ProgressiveDownloadInformation.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/ProgressiveDownloadInformation.hs --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/ProgressiveDownloadInformation.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/ProgressiveDownloadInformation.hs @@ -1,9 +1,9 @@ module Data.ByteString.IsoBaseFileFormat.Boxes.ProgressiveDownloadInformation where -import Data.ByteString.IsoBaseFileFormat.Boxes.Box -import Data.ByteString.IsoBaseFileFormat.Boxes.BoxFields -import Data.ByteString.IsoBaseFileFormat.Boxes.FullBox +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 @@ -19,5 +19,6 @@ -- | Construct a @pdin@ box. pdinBox - :: ProgressiveDownloadContent -> Box (FullBox ProgressiveDownload 0) + :: 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 --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/SampleDescription.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/SampleDescription.hs @@ -3,13 +3,14 @@ -- 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.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 handlerType = +newtype SampleDescription = SampleDescription (U32 "entry_count") deriving (Default,IsBoxContent) @@ -17,11 +18,11 @@ sampleDescription :: (KnownNat (Length ts)) => Boxes ts - -> Box (ContainerBox (FullBox (SampleDescription h) 0) ts) + -> Box (ContainerBox (FullBox SampleDescription 0) ts) sampleDescription bs = containerBox (FullBox 0 $ SampleDescription (typeListLength bs)) bs -instance IsBox (SampleDescription h) +instance IsBox SampleDescription -type instance BoxTypeSymbol (SampleDescription h) = "stsd" +type instance BoxTypeSymbol SampleDescription = "stsd" diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/SampleEntry.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/SampleEntry.hs --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/SampleEntry.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/SampleEntry.hs @@ -3,50 +3,50 @@ -- reference entry table. module Data.ByteString.IsoBaseFileFormat.Boxes.SampleEntry where -import Data.ByteString.IsoBaseFileFormat.Boxes.Box +import Data.ByteString.IsoBaseFileFormat.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) +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 - :: forall (handlertype :: HandlerType) (format :: k) - . U16 "data_reference_index" - -> SampleEntry handlertype format - -> Box (SampleEntry handlertype format) -sampleEntry i c = Box (SampleEntryFields (Constant :+ i :+ c)) + :: 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 @SampleEntryFields (SampleEntry h f)@. -newtype SampleEntryFields a where - SampleEntryFields +-- 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" - :+ a - -> SampleEntryFields a -deriving instance IsBoxContent a => IsBoxContent (SampleEntryFields a) -deriving instance Default a => Default (SampleEntryFields a) + :+ 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). -data MatchSampleEntry (handlerType :: HandlerType) +-- 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 g' f)) (MatchSampleEntry g) = - HandlerTypeCode g' == HandlerTypeCode g + 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 handlertype format) = BoxTypeSymbol format + BoxTypeSymbol (SampleEntry handlerSpecific) = BoxTypeSymbol handlerSpecific -instance (IsBoxContent (SampleEntry handlertype format) - ,KnownSymbol (BoxTypeSymbol (SampleEntry handlertype format))) - => IsBox (SampleEntry handlertype format) where - type BoxContent (SampleEntry handlertype format) = - SampleEntryFields (SampleEntry handlertype format) +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 --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/SampleTable.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/SampleTable.hs @@ -5,7 +5,7 @@ -- block of audio samples. module Data.ByteString.IsoBaseFileFormat.Boxes.SampleTable where -import Data.ByteString.IsoBaseFileFormat.Boxes.Box +import Data.ByteString.IsoBaseFileFormat.Box -- | A sample table contains no fieds. data SampleTable = SampleTable 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 --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Skip.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Skip.hs @@ -1,10 +1,12 @@ -- | A filler box with a specific size. module Data.ByteString.IsoBaseFileFormat.Boxes.Skip where -import Data.ByteString.IsoBaseFileFormat.Boxes.Box +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 Int +newtype Skip = Skip B.ByteString instance IsBox Skip where type BoxContent Skip = Skip @@ -16,5 +18,5 @@ skipBox = Box instance IsBoxContent Skip where - boxSize (Skip bs) = fromIntegral bs - boxBuilder (Skip bs) = mconcat (replicate bs (word8 0)) + 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 --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/SoundMediaHeader.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/SoundMediaHeader.hs @@ -1,11 +1,12 @@ -- | 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.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 diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Time.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Time.hs deleted file mode 100644 --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Time.hs +++ /dev/null @@ -1,72 +0,0 @@ --- | Time and timing utilities. -module Data.ByteString.IsoBaseFileFormat.Boxes.Time - (referenceTime, utcToMp4, mp4CurrentTime, durationFromSeconds, - TimeScale, Timing) - where - -import Data.Time.Clock -import Data.Time.Calendar -import Data.Ratio -import Data.ByteString.IsoBaseFileFormat.Boxes.Box -import Data.ByteString.IsoBaseFileFormat.Boxes.BoxFields -import Data.ByteString.IsoBaseFileFormat.Boxes.Versioned - --- * 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 - --- | 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. -type TimeScale = Template (U32 "timescale") 90000 - --- | 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 $ fromScalar $ templateValue timeScale - in timeScaleI * fromInteger seconds - --- | 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 TimingV0 = TimingImpl (Scalar Word32) - -type TimingV1 = TimingImpl (Scalar Word64) - -type TimingImpl uint = - uint "creation_time" - :+ uint "modification_time" - :+ TimeScale - :+ uint "duration" diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/TimeToSample.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/TimeToSample.hs --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/TimeToSample.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/TimeToSample.hs @@ -2,9 +2,10 @@ -- 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 +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 diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Track.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Track.hs --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Track.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Track.hs @@ -1,7 +1,7 @@ -- | Meta data for a presentation of a /movie/. module Data.ByteString.IsoBaseFileFormat.Boxes.Track where -import Data.ByteString.IsoBaseFileFormat.Boxes.Box +import Data.ByteString.IsoBaseFileFormat.Box -- * @trak@ Box -- | Compose a 'Track' box from the given boxes. 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) + +-- | Defaults for movie fragments - the type alias +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 --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/TrackHeader.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/TrackHeader.hs @@ -1,20 +1,39 @@ -- | Track header box -module Data.ByteString.IsoBaseFileFormat.Boxes.TrackHeader where +module Data.ByteString.IsoBaseFileFormat.Boxes.TrackHeader + (trackHeader, TrackHeader(..), TrackHeaderFlags(..) + , type TrackHeaderTimes , type TrackHeaderTimesV0 , type TrackHeaderTimesV1 ) where -import Data.ByteString.IsoBaseFileFormat.Boxes.Box -import Data.ByteString.IsoBaseFileFormat.Boxes.BoxFields -import Data.ByteString.IsoBaseFileFormat.Boxes.FullBox -import Data.ByteString.IsoBaseFileFormat.Boxes.Versioned +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 - :: KnownNat version - => TrackHeader version -> Box (FullBox (TrackHeader version) version) -trackHeader = fullBox 0 + :: 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. -data TrackHeader (version :: Nat) where +newtype TrackHeader (version :: Nat) where TrackHeader :: Versioned TrackHeaderTimesV0 TrackHeaderTimesV1 version :+ Constant (I32Arr "reserved" 2) '[0, 0] @@ -27,25 +46,26 @@ :+ I32 "width" :+ I32 "height" -> TrackHeader version + deriving (IsBoxContent) -- | Time and timing information about a track (32bit version). -type TrackHeaderTimesV0 = TrackHeaderTimes (Scalar Word32) +type TrackHeaderTimesV0 = TrackHeaderTimes + (Scalar Word32) + (TS32 "duration") -- | Time and timing information about a track (64bit version). -type TrackHeaderTimesV1 = TrackHeaderTimes (Scalar Word64) +type TrackHeaderTimesV1 = TrackHeaderTimes + (Scalar Word64) + (TS64 "duration") -- | Time and timing information about a track. -type TrackHeaderTimes uint = +type TrackHeaderTimes uint dur = uint "creation_time" :+ uint "modification_time" :+ U32 "track_ID" :+ Constant (U32 "reserved") 0 - :+ uint "duration" - -instance IsBoxContent (TrackHeader version) where - boxSize (TrackHeader c) = boxSize c - boxBuilder (TrackHeader c) = boxBuilder c + :+ dur -instance IsBox (TrackHeader version) +instance IsBox (TrackHeader v) -type instance BoxTypeSymbol (TrackHeader version) = "tkhd" +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/Versioned.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/Versioned.hs deleted file mode 100644 --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/Versioned.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} --- | A binary version 0/1 field with seperate content for each version. -module Data.ByteString.IsoBaseFileFormat.Boxes.Versioned - (Versioned(..)) - where - -import Data.ByteString.IsoBaseFileFormat.Boxes.Box - --- 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/IsoBaseFileFormat/Boxes/VideoMediaHeader.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/VideoMediaHeader.hs --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/VideoMediaHeader.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/VideoMediaHeader.hs @@ -1,11 +1,12 @@ -- | 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.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 diff --git a/src/Data/ByteString/IsoBaseFileFormat/Boxes/VisualSampleEntry.hs b/src/Data/ByteString/IsoBaseFileFormat/Boxes/VisualSampleEntry.hs --- a/src/Data/ByteString/IsoBaseFileFormat/Boxes/VisualSampleEntry.hs +++ b/src/Data/ByteString/IsoBaseFileFormat/Boxes/VisualSampleEntry.hs @@ -2,27 +2,17 @@ -- | 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.Box +import Data.ByteString.IsoBaseFileFormat.Util.BoxFields import Data.ByteString.IsoBaseFileFormat.Boxes.Handler -import Data.ByteString.IsoBaseFileFormat.Boxes.SampleEntry +import Data.ByteString.IsoBaseFileFormat.ReExports 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 +newtype VideoSampleEntry c where VideoSampleEntry :: U16 "pre_defined" :+ Constant (U16 "reserved") 0 @@ -38,21 +28,17 @@ :+ Maybe (Box CleanAperture) :+ Maybe (Box PixelAspectRatio) :+ [Box SomeColourInformation] - -> SampleEntry 'VideoTrack (VideoCoding c) + :+ 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 --- | 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' @@ -124,7 +110,7 @@ SomeColourInformation :: forall (profile :: ColourTypeProfile) . IsBoxContent (ColourInformation profile) - => ColourInformation profile + => !(ColourInformation profile) -> SomeColourInformation instance IsBoxContent SomeColourInformation where boxSize (SomeColourInformation c) = boxSize c 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,13 +4,15 @@ -- 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) + (Dash, dash) where +import Data.ByteString.IsoBaseFileFormat.Box +import Data.ByteString.IsoBaseFileFormat.MediaFile +import Data.ByteString.IsoBaseFileFormat.Boxes +import Data.ByteString.IsoBaseFileFormat.ReExports -import Data.ByteString.IsoBaseFileFormat.Brands.Types -import Data.ByteString.IsoBaseFileFormat.Boxes as X hiding (All) -import Data.Kind (Type, Constraint) +-- 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) @@ -20,11 +22,16 @@ dash = Proxy -- | A 'BoxLayout' which contains the stuff needed for the 'dash' brand. --- TODO incomplete +-- 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 @@ -33,8 +40,10 @@ , TrackLayout v 'HintTrack , TrackLayout v 'TimedMetaDataTrack , TrackLayout v 'AuxilliaryVideoTrack]) + , OO MovieExtends + '[ OO_ (MovieExtendsHeader v) + , OM_ TrackExtends ] ] - , SO_ Skip ] type TrackLayout version handlerType = @@ -52,58 +61,27 @@ (OneOf '[ OM_ DataEntryUrl , OM_ DataEntryUrn])]] , OM SampleTable - '[ OM (SampleDescription handlerType) + '[ OM SampleDescription '[ SomeMandatoryX (MatchSampleEntry handlerType) ] , OM_ TimeToSample - -- , OM_ (SampleToChunk version) - -- , OO_ (SampleSizes version) - -- , OM_ (SampleChunkOffset version) + , OM_ SampleToChunk + , OM_ SampleSize + , OneOf '[ OM_ ChunkOffset32 + , OM_ ChunkOffset64 ] ] ] ] ]) - --- Missing Boxes --- stts --- stsc --- stsz --- stco --- esds --- mvex --- trex --- For media --- styp --- moof --- mfhd --- traf --- tfhd --- 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 '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 (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 [] ))))) +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/Brands/Types.hs b/src/Data/ByteString/IsoBaseFileFormat/Brands/Types.hs deleted file mode 100644 --- a/src/Data/ByteString/IsoBaseFileFormat/Brands/Types.hs +++ /dev/null @@ -1,17 +0,0 @@ --- | Brand/Box-validation -module Data.ByteString.IsoBaseFileFormat.Brands.Types - where - -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 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/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/BitRecords.hs b/src/Data/ByteString/IsoBaseFileFormat/Util/BitRecords.hs deleted file mode 100644 --- a/src/Data/ByteString/IsoBaseFileFormat/Util/BitRecords.hs +++ /dev/null @@ -1,214 +0,0 @@ -{-# 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/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,304 @@ +{-# 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 + + +-- * 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 :: [Integer] + !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,93 @@ +-- | 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/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/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,292 @@ +-- | A single-track AAC audio streaming utility wrapping 'AudioFile' for +-- streaming via e.g. DASH. +module Data.ByteString.Mp4.AudioStreaming + ( Segment(..) + , InitSegment(..) + , StreamingContext, AacMp4StreamConfig(..) + , AacMp4TrackFragment(..) + , numberOfChannels + , buildAacMp4TrackFragment + , buildAacMp4StreamInit + , 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.IsoBaseFileFormat.Util.Versioned +import Data.ByteString.Mp4.Boxes.AudioSpecificConfig as X +import Data.ByteString.Mp4.Boxes.Mp4AudioSampleEntry as X +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE + +-- | 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. + +-- | Contains the configuration and state for the creation of a DASH audio +-- stream. +data StreamingContext = + StreamingContext { acConfig :: !AacMp4StreamConfig + , acSegmentDuration :: !Word64 -- (in ticks) + , acSequence :: !Word32 + , acBaseTime :: !Word64 + , acSegments :: ![(Word32, BS.ByteString)] + } + +-- | Initialisation segment parameters of an aac audio stream mp4 file. +data AacMp4StreamConfig = + AacMp4StreamConfig { creationTime :: !(TS32 "creation_time") + , trackName :: !String + , useHeAac :: !Bool + , sampleRate :: !SamplingFreqTable + , channelConfig :: !ChannelConfigTable} + +data Segment = + Segment + { segmentSequence :: !Word32 + , segmentTime :: !Word64 + , segmentData :: !BS.ByteString + } + +newtype InitSegment = + InitSegment + { fromInitSegment :: 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 'AacMp4StreamConfig' from an 'StreamingContext' +getStreamConfig :: StreamingContext -> AacMp4StreamConfig +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 :: AacMp4StreamConfig -> Word32 -> Word64 +sampleCountDuration (AacMp4StreamConfig _ _ _ _ _c) r = + fromIntegral r -- `div` channelConfigToNumber c TODO clean this whole mess up and remove all Word32/Word64 + +getAacMp4StreamConfigTimeScale :: AacMp4StreamConfig -> TimeScale +getAacMp4StreamConfigTimeScale AacMp4StreamConfig{..} = + 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 (InitSegment, StreamingContext) +streamInitINTERNAL_TESTING !trackTitle !segmentDuration !sbr !rate !channels = do + t <- mp4CurrentTime + let !cfg = AacMp4StreamConfig t trackTitle sbr rate channels + !dur = diffTimeToTicks segmentDuration timeScale + !timeScale = getAacMp4StreamConfigTimeScale cfg + return (InitSegment + (BL.toStrict (toLazyByteString (buildAacMp4StreamInit cfg))) + , StreamingContext cfg dur 0 0 []) + +instance Show InitSegment where + show (InitSegment !d) = + printf "INIT SEGMENT - size: %14d" (BS.length d) + +-- | 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 + -> (InitSegment, StreamingContext) +streamInitUtc !trackTitle !availabilityStartTime !refTime !segmentDuration !sbr !rate !channels = + let !cfg = AacMp4StreamConfig t0 trackTitle sbr rate channels + !t0 = utcToMp4 availabilityStartTime + !secondsSinceRef = diffUTCTime availabilityStartTime refTime + !dur = diffTimeToTicks segmentDuration timeScale + !timeScale = getAacMp4StreamConfigTimeScale cfg + in (InitSegment + (BL.toStrict (toLazyByteString (buildAacMp4StreamInit 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 'AacMp4StreamConfig' record to a generic 'Boxes' collection. +buildAacMp4StreamInit + :: AacMp4StreamConfig -> Builder +buildAacMp4StreamInit AacMp4StreamConfig{..} = + 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-builder, Sven Heyll 2016"))) + :| 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)) + +-- | 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,310 @@ +{-# 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 + ("SBR audio object type" <:> PutHex8 (FromEnum AudioObjectTypeId aoId) + #+: BitRecordOfEnum extFreq + :+: AudioObjectTypeRec aoId + :+: BitRecordOfAudioSubConfig subCfg))) + +-- | Common header for audio specific config +type AudioConfigCommon aoId samplingFrequencyIndex channels rest = + ("audio-specific-config" <:> PutHex8 (FromEnum AudioObjectTypeId aoId)) + #+$ (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 = + (If ((FromEnum AudioObjectTypeId n) <=? 30) + "AudioObjectType" + "ExtAudioObjectType") <:> PutHex8 (FromEnum AudioObjectTypeId 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,72 @@ +{-# 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)) = + ("base-descriptor" <:> PutHex8 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,55 @@ +{-# 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.Type.Pretty +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 = + PutStr "decoder-config-descriptor" + #+$ (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,112 @@ +{-# LANGUAGE UndecidableInstances #-} +module Data.ByteString.Mp4.Boxes.DecoderSpecificInfo where + +import Data.ByteString.Mp4.Boxes.BaseDescriptor +import Data.Type.BitRecords +import Data.Type.Pretty +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 (PutStr "decoder-specific-info" #+$ 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,80 @@ +{-# 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 = + runHoley + . esdBoxHoley + +esdBoxHoley :: forall (record :: IsA (Descriptor 'ES_Descr)) r (rendered :: BitRecord) . + ( BitStringBuilderHoley (Proxy rendered) r + , rendered ~ (RenderEsDescr record) + ) + => Proxy record -> Holey EsdBox r (ToBitStringBuilder (Proxy rendered) r) +esdBoxHoley _p = + hoistM (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 + (PutStr "elementary-stream-descriptor" + #+$ "esId" @: FieldU16 :~ esId + .+: "depEsIdFlag" @: FlagJust depEsId + .+: "urlFlag" @: FlagJust url + .+: "ocrEsIdFlag" @: FlagJust ocrEsId + .+: "streamPriority" @: Field 5 :~ streamPrio + .+: ("depEsId" @: FieldU16 :+? depEsId) + :+: (PutStr "url" #+: (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,73 @@ +{-# 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) = + (("expandable-content-size" <:> + PutHex32 (ShiftR StaticExpandableContentMaxBits (BitRecordSize record) 3) + #+$ 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,18 @@ +{-# 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 + (PutStr "mp4-sync-layer-descriptor" + #+$ ('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,156 @@ +{-# 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) + +-- * Symbolic Types and Type Functions + +-- | A /symbolic/ type, i.e. a wrapper around a (poly kinded) type to be +-- produced by 'Eval' instances. +-- +-- All data types, e.g. @data Point2 x y :: Type@ can be made into /symbolic +-- representations/ of other types, by adding a /symbolic/ type parameter: +-- @data Point2 x y :: A Vec2 -> Type@. +-- +-- Complete 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,21 @@ +module Data.Type.BitRecords ( + module Data.Type.BitRecords.Arithmetic + , module Data.Type.BitRecords.Assert + , module Data.Type.BitRecords.Builder.BitBuffer + , module Data.Type.BitRecords.Builder.Holey + , 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.Type.BitRecords.Builder.Holey +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,118 @@ +{-# LANGUAGE UndecidableInstances #-} +module Data.Type.BitRecords.Arithmetic where + +import Data.Type.Bool +import GHC.TypeLits + +-- | 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 family Rem (x :: Nat) (y :: Nat) :: Nat where + Rem x 1 = 0 + Rem x 0 = TypeError ('Text "divide by zero: " ':<>: 'ShowType x ':<>: 'Text " `Rem` 0") + Rem x y = 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) + +-- | Efficient 'Rem' operation for power of 2 values. Note that x must be +-- representable by 'RemPow2Bits' bits. +type RemPow2 x p = + FromBits (TakeLastN p (ToBits x RemPow2Bits)) + +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 'RemPow2' may occupy. +type RemPow2Bits = 32 + +-- | Integer division of x and y: @Div x y ==> x / y@, +-- NOTE This only works for small numbers currently +type Div (x :: Nat) (y :: Nat) = DivImpl (x - (x `Rem` y)) y 0 +type family + DivImpl (x :: Nat) (y :: nat) (acc :: Nat) :: Nat where + DivImpl 0 y acc = acc + DivImpl x y acc = If (x + 1 <=? y) acc (DivImpl (x - y) y (acc + 1)) + +-- * 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,163 @@ +{-# 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.Type.BitRecords.Arithmetic +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 `RemPow2` 6 + +-- | 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.: +-- +-- @ +-- runHoley $ 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/Holey.hs b/src/Data/Type/BitRecords/Builder/Holey.hs new file mode 100644 --- /dev/null +++ b/src/Data/Type/BitRecords/Builder/Holey.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE Strict #-} +module Data.Type.BitRecords.Builder.Holey where + +import Control.Category +import Data.Monoid +import Prelude hiding (id, (.)) +import Data.Tagged + +newtype Holey m r a = HM {runHM :: (m -> r) -> a } + +instance Monoid m => Category (Holey m) where + (.) (HM f) (HM g) = HM (\k -> (f (\m1 -> g (\m2 -> k (m1 <> m2))))) + id = HM ($ mempty) + +instance Monoid m => Monoid (Holey m r r) where + mappend = (.) + mempty = id + +hoistM :: (m -> n) -> Holey m a b -> Holey n a b +hoistM into (HM f) = HM (\k -> f (k . into)) + +hoistR :: (s -> r) -> Holey m r a -> Holey m s a +hoistR outof (HM f) = HM (\k -> f (outof . k)) + +immediate :: m -> Holey m r r +immediate m = + HM { runHM = ($ m) } + +indirect :: (a -> m) -> Holey m r (a -> r) +indirect f = + HM { runHM = (. f) } + +bind :: Holey m b c + -> (m -> Holey n a b) + -> Holey n a c +bind mbc fm = HM $ \ kna -> runHM mbc (($ kna) . runHM . fm) + +applyHoley :: Holey m r (a -> b) -> a -> Holey m r b +applyHoley (HM !f) x = HM $ \k -> f k x + +taggedHoley :: forall tag m r a x . Holey m r (a -> x) -> Holey m r (Tagged tag a -> x) +taggedHoley = mapHoley (\f -> f . untag) + +-- TODO prove Functor law, make functor +mapHoley :: (a -> b) -> Holey m r a -> Holey m r b +mapHoley f (HM !h) = HM $ \k -> f (h k) + +runHoley :: Holey m m a -> a +runHoley = ($ id) . runHM 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,322 @@ +{-# 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.Type.BitRecords.Builder.Holey +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 Data.ByteString.Builder +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 -> !Builder -> BuilderBox + +instance Monoid BuilderBox where + mempty = MkBuilderBox 0 mempty + mappend (MkBuilderBox !ls !lb) (MkBuilderBox !rs !rb) = + MkBuilderBox (ls + rs) (lb <> rb) + +-- | Create a '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 = runHoley . bitBuilderBoxHoley + +-- | Like 'bitBuilderBox', but 'runHoley' the result and accept as an additional +-- parameter a wrapper function to wrap the final result (the 'BuilderBox') and +-- 'runHoley' the whole machiner. +wrapBitBuilderBox :: + forall (record :: BitRecord) wrapped . + BitStringBuilderHoley (Proxy record) wrapped + => (BuilderBox -> wrapped) + -> Proxy record + -> ToBitStringBuilder (Proxy record) wrapped +wrapBitBuilderBox !f !p = runHoley (hoistM f (bitBuilderBoxHoley p)) + +-- | Create a 'Builder' from a 'BitRecord' and store it in a 'BuilderBox'; +-- return a 'Holey' monoid that does that on 'runHoley' +bitBuilderBoxHoley :: + forall (record :: BitRecord) r . + BitStringBuilderHoley (Proxy record) r + => Proxy record + -> Holey 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 hoistM fromBitStringBuilder (bitStringBuilderHoley p) + +-- * Low-level interface to building 'BitRecord's and other things + +newtype BitStringBuilder = + BitStringBuilder {unBitStringBuilder :: Dual (Endo BitStringBuilderState)} + deriving (Monoid) + +runBitStringBuilder + :: BitStringBuilder -> 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 :: + !Builder -> !BitStringBuilderChunk -> !Word64 -> BitStringBuilderState + +getBitStringBuilderStateBuilder + :: BitStringBuilderState -> 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' <> + 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 <> + 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 + :: Holey BitStringBuilder Builder a -> a +runBitStringBuilderHoley (HM !x) = x runBitStringBuilder + +-- * 'BitString' construction from 'BitRecord's + +class BitStringBuilderHoley a r where + type ToBitStringBuilder a r + type ToBitStringBuilder a r = r + bitStringBuilderHoley :: a -> Holey 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 _ = + indirect (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 _ = indirect (appendBitString . bitStringProxyLength (Proxy @s) . unB) + +-- **** Naturals + +instance forall a . + BitStringBuilderHoley (Proxy (MkField 'MkFieldU64)) a where + type ToBitStringBuilder (Proxy (MkField 'MkFieldU64)) a = Word64 -> a + bitStringBuilderHoley _ = indirect (appendBitString . bitString 64) + +instance forall a . + BitStringBuilderHoley (Proxy (MkField 'MkFieldU32)) a where + type ToBitStringBuilder (Proxy (MkField 'MkFieldU32)) a = Word32 -> a + bitStringBuilderHoley _ = indirect (appendBitString . bitString 32 . fromIntegral) + +instance forall a . + BitStringBuilderHoley (Proxy (MkField 'MkFieldU16)) a where + type ToBitStringBuilder (Proxy (MkField 'MkFieldU16)) a = Word16 -> a + bitStringBuilderHoley _ = indirect (appendBitString . bitString 16 . fromIntegral) + +instance forall a . + BitStringBuilderHoley (Proxy (MkField 'MkFieldU8)) a where + type ToBitStringBuilder (Proxy (MkField 'MkFieldU8)) a = Word8 -> a + bitStringBuilderHoley _ = indirect (appendBitString . bitString 8 . fromIntegral) + +-- **** Signed + +instance forall a . + BitStringBuilderHoley (Proxy (MkField 'MkFieldI64)) a where + type ToBitStringBuilder (Proxy (MkField 'MkFieldI64)) a = Int64 -> a + bitStringBuilderHoley _ = indirect (appendBitString . bitString 64 . fromIntegral @Int64 @Word64) + +instance forall a . + BitStringBuilderHoley (Proxy (MkField 'MkFieldI32)) a where + type ToBitStringBuilder (Proxy (MkField 'MkFieldI32)) a = Int32 -> a + bitStringBuilderHoley _ = indirect (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 _ = indirect (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 _ = indirect (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 _ = applyHoley (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 _ = applyHoley (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 _ = applyHoley (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 forall d r a . BitStringBuilderHoley (Proxy r) a => + BitStringBuilderHoley (Proxy ('BitRecordDocNested d r)) a where + type ToBitStringBuilder (Proxy ('BitRecordDocNested d r)) a = + ToBitStringBuilder (Proxy r) a + bitStringBuilderHoley _ = bitStringBuilderHoley (Proxy @r) + +instance BitStringBuilderHoley (Proxy ('BitRecordDoc d)) a where + bitStringBuilderHoley _ = id + +instance BitStringBuilderHoley (Proxy 'EmptyBitRecord) a where + bitStringBuilderHoley _ = id + +-- ** Tracing/Debug Printing + +-- | Print a 'Builder' to a space seperated series of hexa-decimal bytes. +printBuilder :: Builder -> String +printBuilder b = + ("<< " ++) $ + (++ " >>") $ unwords $ printf "%0.2x" <$> B.unpack (toLazyByteString b) + +bitStringPrinter + :: BitStringBuilderHoley a String + => a -> ToBitStringBuilder a String +bitStringPrinter = + runHoley . hoistM (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,379 @@ +{-# 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 + BitRecordDoc :: PrettyType -> BitRecord + BitRecordMember :: IsA (BitRecordField t) -> BitRecord + BitRecordDocNested :: PrettyType -> BitRecord -> 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 + +-- | Eval the size in as a number of bits from a 'BitRecord' +type family BitRecordSize (x :: BitRecord) :: Nat where + BitRecordSize 'EmptyBitRecord = 0 + BitRecordSize ('BitRecordDoc d) = 0 + BitRecordSize ('BitRecordMember f) = BitRecordFieldSize f + BitRecordSize ('BitRecordDocNested d r) = BitRecordSize r + BitRecordSize ('BitRecordAppend l r) = BitRecordSize l + BitRecordSize r + +-- | The total number of members in a record. +type family BitRecordMemberCount (b :: BitRecord) :: Nat where + BitRecordMemberCount 'EmptyBitRecord = 0 + BitRecordMemberCount ('BitRecordDoc r) = 0 + BitRecordMemberCount ('BitRecordMember f) = 1 + BitRecordMemberCount ('BitRecordDocNested d r) = BitRecordMemberCount r + BitRecordMemberCount ('BitRecordAppend l r) = BitRecordMemberCount l + BitRecordMemberCount r + +-- | Return 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) + +-- TODO remove?? + +-- ** Record PrettyPrinting + +-- | Augment the pretty printed output of a 'BitRecord' +data (prettyTitle :: PrettyType) #: (r :: IsA BitRecord) :: IsA BitRecord +infixr 4 #: +type instance Eval (prettyTitle #: r) = Append ('BitRecordDoc prettyTitle) (Eval r) + +-- | Augment the pretty printed output of a 'BitRecord' +type (prettyTitle :: PrettyType) #+: (r :: BitRecord) = + Append ('BitRecordDoc prettyTitle) r +infixr 4 #+: + +-- | Augment the pretty printed output of a 'BitRecord' +data (prettyTitle :: PrettyType) #$ (r :: IsA BitRecord) :: IsA BitRecord +infixr 2 #$ +type instance Eval (prettyTitle #$ r) = 'BitRecordDocNested prettyTitle (Eval r) + +-- | Augment the pretty printed output of a 'BitRecord' +type (prettyTitle :: PrettyType) #+$ (r :: BitRecord) + = 'BitRecordDocNested prettyTitle r +infixr 2 #+$ + +-- ** 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)) = + Append ('BitRecordDoc (PutStr "Just")) ('BitRecordMember fld) +type instance Eval (MaybeField 'Nothing) = + 'BitRecordDoc (PutStr "Nothing") + +-- | 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 + PrettyRecord ('BitRecordDoc p) = p + PrettyRecord ('BitRecordDocNested p r) = p <$$--> 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,141 @@ +{-# LANGUAGE UndecidableInstances #-} +module Data.Type.BitRecords.Enum where + +import Data.Type.BitRecords.Core +import Data.Type.BitRecords.Builder.BitBuffer +import Data.Type.BitRecords.Builder.Holey +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 _ = + indirect (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) = + PutStr "sized-record" #+$ ("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) = + PutStr "sized-field" #+$ "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.Type.BitRecords.Builder.Holey +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 --- a/stack.yaml +++ b/stack.yaml @@ -1,70 +1,12 @@ -# 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 +resolver: lts-7.5 -# 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 +- pretty-types-0.2.3.1 +- type-spec-0.3.0.1 -# 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