packages feed

dahdit-audio (empty) → 0.8.0

raw patch · 12 files changed

+3602/−0 lines, 12 filesdep +aesondep +aeson-casingdep +aeson-pretty

Dependencies added: aeson, aeson-casing, aeson-pretty, aeson-via, base, bytestring, containers, dahdit, dahdit-audio, data-default, data-sword, daytripper, digest, directory, filepath, ghc-typelits-knownnat, microlens, mtl, optparse-applicative, pathwalk, prettyprinter, primitive, regex-tdfa, tasty, tasty-hunit, text, transformers

Files

+ README.md view
@@ -0,0 +1,10 @@+# dahdit-audio++Audio file parsing/printing with dahdit++Supports++* RIFF+* WAVE+* AIFF+* SF2
+ dahdit-audio.cabal view
@@ -0,0 +1,157 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.38.0.+--+-- see: https://github.com/sol/hpack++name:           dahdit-audio+version:        0.8.0+synopsis:       Audio file parsing/printing with dahdit+description:    Please see the README on GitHub at <https://github.com/ejconlon/dahdit#readme>+homepage:       https://github.com/ejconlon/dahdit#readme+bug-reports:    https://github.com/ejconlon/dahdit/issues+author:         Eric Conlon+maintainer:     ejconlon@gmail.com+copyright:      (c) 2023 Eric Conlon+license:        BSD3+build-type:     Simple+tested-with:+    GHC == 9.8.4+extra-source-files:+    README.md++source-repository head+  type: git+  location: https://github.com/ejconlon/dahdit++library+  exposed-modules:+      Dahdit.Audio.Aiff+      Dahdit.Audio.Common+      Dahdit.Audio.Convert+      Dahdit.Audio.Dsp+      Dahdit.Audio.Quiet+      Dahdit.Audio.Riff+      Dahdit.Audio.Sfont+      Dahdit.Audio.Wav+      Dahdit.Audio.Wav.Simple+  other-modules:+      Paths_dahdit_audio+  hs-source-dirs:+      src+  default-extensions:+      BangPatterns+      ConstraintKinds+      DataKinds+      DeriveFunctor+      DeriveFoldable+      DeriveGeneric+      DeriveTraversable+      DerivingStrategies+      DerivingVia+      FlexibleContexts+      FlexibleInstances+      FunctionalDependencies+      GADTs+      GeneralizedNewtypeDeriving+      LambdaCase+      KindSignatures+      MultiParamTypeClasses+      MultiWayIf+      Rank2Types+      ScopedTypeVariables+      StandaloneDeriving+      TupleSections+      TypeApplications+      TypeOperators+      TypeFamilies+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -fno-warn-unused-top-binds+  build-depends:+      aeson ==2.2.*+    , aeson-casing ==0.2.*+    , aeson-pretty ==0.8.*+    , aeson-via ==0.2.*+    , base >=4.12 && <5+    , bytestring ==0.12.*+    , containers ==0.6.*+    , dahdit ==0.8.*+    , data-default ==0.7.*+    , data-sword ==0.2.*+    , digest >=0.0.1 && <0.0.3+    , directory ==1.3.*+    , filepath ==1.4.*+    , ghc-typelits-knownnat ==0.7.*+    , microlens ==0.4.*+    , mtl >=2.2 && <2.4+    , optparse-applicative >=0.16 && <0.19+    , pathwalk ==0.3.*+    , prettyprinter ==1.7.*+    , primitive ==0.9.*+    , regex-tdfa ==1.3.*+    , text ==2.1.*+    , transformers >=0.5 && <0.7+  default-language: GHC2021++test-suite dahdit-audio-test+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Paths_dahdit_audio+  hs-source-dirs:+      test+  default-extensions:+      BangPatterns+      ConstraintKinds+      DataKinds+      DeriveFunctor+      DeriveFoldable+      DeriveGeneric+      DeriveTraversable+      DerivingStrategies+      DerivingVia+      FlexibleContexts+      FlexibleInstances+      FunctionalDependencies+      GADTs+      GeneralizedNewtypeDeriving+      LambdaCase+      KindSignatures+      MultiParamTypeClasses+      MultiWayIf+      Rank2Types+      ScopedTypeVariables+      StandaloneDeriving+      TupleSections+      TypeApplications+      TypeOperators+      TypeFamilies+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -fno-warn-unused-top-binds -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      aeson ==2.2.*+    , aeson-casing ==0.2.*+    , aeson-pretty ==0.8.*+    , aeson-via ==0.2.*+    , base >=4.12 && <5+    , bytestring ==0.12.*+    , containers ==0.6.*+    , dahdit ==0.8.*+    , dahdit-audio+    , data-default ==0.7.*+    , data-sword ==0.2.*+    , daytripper+    , digest >=0.0.1 && <0.0.3+    , directory ==1.3.*+    , filepath ==1.4.*+    , ghc-typelits-knownnat ==0.7.*+    , microlens ==0.4.*+    , mtl >=2.2 && <2.4+    , optparse-applicative >=0.16 && <0.19+    , pathwalk ==0.3.*+    , prettyprinter ==1.7.*+    , primitive ==0.9.*+    , regex-tdfa ==1.3.*+    , tasty ==1.5.*+    , tasty-hunit ==0.10.*+    , text ==2.1.*+    , transformers >=0.5 && <0.7+  default-language: GHC2021
+ src/Dahdit/Audio/Aiff.hs view
@@ -0,0 +1,473 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoStarIsType #-}+{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}++module Dahdit.Audio.Aiff+  ( PascalString (..)+  , Chunk (..)+  , KnownChunk (..)+  , Variant (..)+  , AiffCommonBody (..)+  , AiffCommonChunk+  , AiffDataBody (..)+  , AiffDataChunk+  , AiffChunk (..)+  , Aiff (..)+  , lookupAiffChunk+  , lookupAiffCommonChunk+  , lookupAiffDataChunk+  , aiffToPcmContainer+  , aiffGatherMarkers+  )+where++import Control.Monad (unless)+import Dahdit+  ( Binary (..)+  , ByteArray+  , ByteCount (..)+  , Get+  , Put+  , ShortByteString+  , StaticByteSized (..)+  , StaticBytes (..)+  , ViaGeneric (..)+  , ViaStaticGeneric (..)+  , Word16BE+  , Word32BE (..)+  , byteSizeFoldable+  , getByteString+  , getExact+  , getLookAhead+  , getRemainingByteArray+  , getRemainingSeq+  , getSeq+  , getSkip+  , getWord16BE+  , getWord8+  , putByteArray+  , putByteString+  , putSeq+  , putWord16BE+  , putWord8+  )+import Dahdit.Audio.Common+  ( ChunkHeaderSize+  , ConvertErr+  , CountSize+  , KnownLabel (..)+  , Label+  , LabelSize+  , PadCount+  , SimpleMarker (..)+  , UnparsedBody+  , chunkHeaderSize+  , countSize+  , dedupeSimpleMarkers+  , getChunkSizeBE+  , getExpectLabel+  , guardChunk+  , labelSize+  , padCount+  , putChunkSizeBE+  )+import Dahdit.Audio.Dsp (PcmContainer (PcmContainer), PcmMeta (PcmMeta))+import Data.ByteString.Char8 qualified as BSC+import Data.ByteString.Short qualified as BSS+import Data.Default (Default (..))+import Data.Foldable (toList)+import Data.Maybe (fromMaybe)+import Data.Primitive.ByteArray (byteArrayFromListN, indexByteArray, sizeofByteArray)+import Data.Proxy (Proxy (..))+import Data.Sequence (Seq (..))+import Data.Sequence qualified as Seq+import Data.Word (Word8)+import GHC.Generics (Generic)+import GHC.TypeLits (type (*), type (+))++-- AIFF-C file parsing according to+-- http://www-mmsp.ece.mcgill.ca/Documents/AudioFormats/AIFF/AIFF.html+-- We only bother to support "sowt" compression (little endian samples)++-- AIFF shares a similar 4-byte label + size + payload structure with RIFF+-- We could use a lot of the same structures to read the file... If they were+-- big-endian.++labelForm, labelAifc, labelAiff, labelComm, labelSsnd, labelFver, labelAnno, labelMark, labelSowt :: Label+labelForm = "FORM"+labelAifc = "AIFC"+labelAiff = "AIFF"+labelComm = "COMM"+labelSsnd = "SSND"+labelFver = "FVER"+labelAnno = "ANNO"+labelMark = "MARK"+labelSowt = "sowt"++data Chunk a = Chunk+  { chunkLabel :: !Label+  , chunkBody :: !a+  }+  deriving stock (Eq, Show)++chunkUnpaddedByteSize :: (Binary a) => Chunk a -> ByteCount+chunkUnpaddedByteSize (Chunk _ body) = byteSize body++instance (StaticByteSized a) => StaticByteSized (Chunk a) where+  type StaticSize (Chunk a) = PadCount (ChunkHeaderSize + StaticSize a)++instance (Binary a) => Binary (Chunk a) where+  byteSize c = padCount (chunkHeaderSize + chunkUnpaddedByteSize c)+  get = do+    lab <- get+    usz <- getChunkSizeBE+    body <- getExact usz get+    unless (even usz) (getSkip 1)+    pure $! Chunk lab body+  put c@(Chunk lab body) = do+    put lab+    let !usz = chunkUnpaddedByteSize c+    putChunkSizeBE usz+    put body+    unless (even usz) (putWord8 0)++newtype KnownChunk a = KnownChunk+  { knownChunkBody :: a+  }+  deriving stock (Show)+  deriving newtype (Eq, Default)++knownChunkUnpaddedByteSize :: (Binary a) => KnownChunk a -> ByteCount+knownChunkUnpaddedByteSize (KnownChunk body) = byteSize body++instance (StaticByteSized a) => StaticByteSized (KnownChunk a) where+  type StaticSize (KnownChunk a) = PadCount (ChunkHeaderSize + StaticSize a)++instance (Binary a, KnownLabel a) => Binary (KnownChunk a) where+  byteSize kc = padCount (chunkHeaderSize + knownChunkUnpaddedByteSize kc)+  get = do+    getExpectLabel (knownLabel (Proxy :: Proxy a))+    usz <- getChunkSizeBE+    body <- getExact usz get+    unless (even usz) (getSkip 1)+    pure $! KnownChunk body+  put kc@(KnownChunk body) = do+    put (knownLabel (Proxy :: Proxy a))+    let !usz = knownChunkUnpaddedByteSize kc+    putChunkSizeBE usz+    put body+    unless (even usz) (putWord8 0)++-- | A "Pascal-style string" with a leading byte count and optional+-- trailing padding byte to make total length even.+newtype PascalString = PascalString {unPascalString :: ShortByteString}+  deriving stock (Show)+  deriving newtype (Eq)++instance Default PascalString where+  def = PascalString BSS.empty++instance Binary PascalString where+  byteSize (PascalString sbs) = padCount (ByteCount (BSS.length sbs + 1))+  get = do+    usz <- fmap fromIntegral getWord8+    sbs <- getByteString usz+    unless (odd usz) (getSkip 1)+    pure $! PascalString sbs+  put (PascalString sbs) = do+    let !usz = fromIntegral (BSS.length sbs)+    putWord8 usz+    putByteString sbs+    unless (odd usz) (putWord8 0)++notCompressed :: PascalString+notCompressed = PascalString (BSS.toShort (BSC.pack "not compressed"))++-- | "80 bit IEEE Standard 754 floating point number"+newtype ExtendedFloat = ExtendedFloat {unExtendedFloat :: StaticBytes 10}+  deriving stock (Show)+  deriving newtype (Eq, Default, StaticByteSized, Binary)++data AiffCommonBody = AiffCommonBody+  { aceNumChannels :: !Word16BE+  , aceNumSampleFrames :: !Word32BE+  , aceSampleSize :: !Word16BE+  , aceSampleRate :: !ExtendedFloat+  , aceCompressionType :: !Label+  , aceCompressionName :: !PascalString+  }+  deriving stock (Eq, Show, Generic)+  deriving (Binary) via (ViaGeneric AiffCommonBody)++instance KnownLabel AiffCommonBody where+  knownLabel _ = labelComm++type AiffCommonChunk = KnownChunk AiffCommonBody++data AiffCommonBodyOld = AiffCommonBodyOld+  { aceoNumChannels :: !Word16BE+  , aceoNumSampleFrames :: !Word32BE+  , aceoSampleSize :: !Word16BE+  , aceoSampleRate :: !ExtendedFloat+  }+  deriving stock (Eq, Show, Generic)+  deriving (Binary) via (ViaStaticGeneric AiffCommonBodyOld)++instance KnownLabel AiffCommonBodyOld where+  knownLabel _ = labelComm++type AiffCommonChunkOld = KnownChunk AiffCommonBodyOld++oldToNewCommonChunk :: KnownChunk AiffCommonBodyOld -> KnownChunk AiffCommonBody+oldToNewCommonChunk (KnownChunk (AiffCommonBodyOld x y z w)) = KnownChunk (AiffCommonBody x y z w labelSowt notCompressed)++newToOldCommonChunk :: KnownChunk AiffCommonBody -> KnownChunk AiffCommonBodyOld+newToOldCommonChunk (KnownChunk (AiffCommonBody x y z w _ _)) = KnownChunk (AiffCommonBodyOld x y z w)++getCommonChunk :: Variant -> Get AiffCommonChunk+getCommonChunk = \case+  VariantAiff -> fmap oldToNewCommonChunk get+  VariantAifc -> get++putCommonChunk :: Variant -> AiffCommonChunk -> Put+putCommonChunk = \case+  VariantAiff -> put . newToOldCommonChunk+  VariantAifc -> put++data AiffDataBody = AiffDataBody+  { adbOffset :: !Word32BE+  , adbBlockSize :: !Word32BE+  , adbSoundData :: !ByteArray+  }+  deriving stock (Eq, Show, Generic)++instance Binary AiffDataBody where+  byteSize (AiffDataBody _ _ arr) = 8 + fromIntegral (sizeofByteArray arr)+  get = do+    adbOffset <- get+    unless (adbOffset == 0) (fail "need zero offset")+    adbBlockSize <- get+    adbSoundData <- getRemainingByteArray+    pure $! AiffDataBody {..}+  put (AiffDataBody {..}) = do+    put adbOffset+    put adbBlockSize+    putByteArray adbSoundData++instance KnownLabel AiffDataBody where+  knownLabel _ = labelSsnd++type AiffDataChunk = KnownChunk AiffDataBody++type AiffVersionChunk = Chunk UnparsedBody++type AiffAnnoChunk = Chunk UnparsedBody++data AiffMark = AiffMark+  { amId :: !Word16BE+  , amPosition :: !Word32BE+  , amName :: !PascalString+  }+  deriving stock (Eq, Show, Generic)+  deriving (Binary) via (ViaGeneric AiffMark)++newtype AiffMarkBody = AiffMarkBody+  { ambMarkers :: Seq AiffMark+  }+  deriving stock (Show)+  deriving newtype (Eq)++instance Binary AiffMarkBody where+  byteSize (AiffMarkBody marks) = 2 + byteSizeFoldable marks+  get = do+    ec <- fmap fromIntegral getWord16BE+    marks <- getSeq ec get+    pure $! AiffMarkBody marks+  put (AiffMarkBody marks) = do+    putWord16BE (fromIntegral (Seq.length marks))+    putSeq put marks++instance KnownLabel AiffMarkBody where+  knownLabel _ = labelMark++type AiffMarkChunk = KnownChunk AiffMarkBody++type AiffUnparsedChunk = Chunk UnparsedBody++data AiffChunk+  = AiffChunkCommon !AiffCommonChunk+  | AiffChunkData !AiffDataChunk+  | AiffChunkVersion !AiffVersionChunk+  | AiffChunkAnno !AiffAnnoChunk+  | AiffChunkMark !AiffMarkChunk+  | AiffChunkUnparsed !AiffUnparsedChunk+  deriving stock (Eq, Show, Generic)++getChunk :: Variant -> Get AiffChunk+getChunk variant = do+  label <- getLookAhead get+  if+    | label == labelComm -> fmap AiffChunkCommon (getCommonChunk variant)+    | label == labelSsnd -> fmap AiffChunkData get+    | label == labelFver -> fmap AiffChunkVersion get+    | label == labelAnno -> fmap AiffChunkAnno get+    | label == labelMark -> fmap AiffChunkMark get+    | otherwise -> fmap AiffChunkUnparsed get++putChunk :: Variant -> AiffChunk -> Put+putChunk variant = \case+  AiffChunkCommon x -> putCommonChunk variant x+  AiffChunkData x -> put x+  AiffChunkVersion x -> put x+  AiffChunkAnno x -> put x+  AiffChunkMark x -> put x+  AiffChunkUnparsed x -> put x++instance Binary AiffChunk where+  byteSize = \case+    AiffChunkCommon x -> byteSize x+    AiffChunkData x -> byteSize x+    AiffChunkVersion x -> byteSize x+    AiffChunkAnno x -> byteSize x+    AiffChunkMark x -> byteSize x+    AiffChunkUnparsed x -> byteSize x+  get = getChunk VariantAifc+  put = putChunk VariantAifc++data Variant = VariantAiff | VariantAifc+  deriving stock (Eq, Show)++data AiffHeader = AiffHeader+  { ahVariant :: !Variant+  , ahRemainingSize :: ByteCount+  }+  deriving stock (Eq, Show, Generic)++type AiffHeaderSize = 2 * LabelSize + CountSize++aiffHeaderSize :: ByteCount+aiffHeaderSize = 2 * labelSize + countSize++instance StaticByteSized AiffHeader where+  type StaticSize AiffHeader = AiffHeaderSize+  staticByteSize _ = aiffHeaderSize++instance Binary AiffHeader where+  get = do+    getExpectLabel labelForm+    sz <- getChunkSizeBE+    label <- get @Label+    variant <-+      if+        | label == labelAiff -> pure VariantAiff+        | label == labelAifc -> pure VariantAifc+        | otherwise -> fail ("Expected label AIFC or AIFF in header but got: " ++ show (unStaticBytes label))+    pure $! AiffHeader variant (sz - labelSize)+  put (AiffHeader variant remSz) = do+    put labelForm+    putChunkSizeBE (remSz + labelSize)+    put $ case variant of+      VariantAiff -> labelAiff+      VariantAifc -> labelAifc++data Aiff = Aiff+  { aiffVariant :: !Variant+  , aiffChunks :: !(Seq AiffChunk)+  }+  deriving stock (Eq, Show)++instance Binary Aiff where+  byteSize (Aiff _ chunks) = aiffHeaderSize + byteSizeFoldable chunks+  get = do+    AiffHeader variant remSz <- get+    chunks <- getExact remSz (getRemainingSeq (getChunk variant))+    let !chunks' = swapDataEndian variant chunks+    pure $! Aiff variant chunks'+  put (Aiff variant chunks) = do+    let !chunks' = swapDataEndian variant chunks+    let !remSz = byteSizeFoldable chunks'+    put (AiffHeader variant remSz)+    putSeq (putChunk variant) chunks'++swapDataEndian :: Variant -> Seq AiffChunk -> Seq AiffChunk+swapDataEndian variant chunks =+  case variant of+    VariantAifc -> chunks+    VariantAiff -> fromMaybe chunks $ do+      let aiff = Aiff variant chunks+      KnownChunk comBody <- lookupAiffCommonChunk aiff+      KnownChunk (AiffDataBody x y arr) <- lookupAiffDataChunk aiff+      let arr' = swapArrayEndian (fromIntegral (aceSampleSize comBody)) arr+      let datChunk' = KnownChunk (AiffDataBody x y arr')+      Just $! flip fmap chunks $ \c ->+        case c of+          AiffChunkData _ -> AiffChunkData datChunk'+          _ -> c++swappedByteArray2 :: ByteArray -> [Word8]+swappedByteArray2 arr = go 0 Empty+ where+  sz = sizeofByteArray arr+  go !i !acc =+    if i == sz+      then toList acc+      else go (i + 2) (acc :|> indexByteArray arr (i + 1) :|> indexByteArray arr i)++swappedByteArray3 :: ByteArray -> [Word8]+swappedByteArray3 arr = go 0 Empty+ where+  sz = sizeofByteArray arr+  go !i !acc =+    if i == sz+      then toList acc+      else go (i + 3) (acc :|> indexByteArray arr (i + 2) :|> indexByteArray arr (i + 1) :|> indexByteArray arr i)++swapArrayEndian :: Int -> ByteArray -> ByteArray+swapArrayEndian bitDepth arr =+  if+    | bitDepth == 8 -> arr+    | bitDepth == 16 -> byteArrayFromListN (sizeofByteArray arr) (swappedByteArray2 arr)+    | bitDepth == 24 -> byteArrayFromListN (sizeofByteArray arr) (swappedByteArray3 arr)+    | otherwise -> error ("Unsupported endian swap depth: " ++ show bitDepth)++lookupAiffChunk :: (AiffChunk -> Bool) -> Aiff -> Maybe AiffChunk+lookupAiffChunk p (Aiff _ chunks) = fmap (Seq.index chunks) (Seq.findIndexL p chunks)++lookupAiffCommonChunk :: Aiff -> Maybe AiffCommonChunk+lookupAiffCommonChunk w =+  case lookupAiffChunk (\case AiffChunkCommon _ -> True; _ -> False) w of+    Just (AiffChunkCommon x) -> Just x+    _ -> Nothing++lookupAiffDataChunk :: Aiff -> Maybe AiffDataChunk+lookupAiffDataChunk w =+  case lookupAiffChunk (\case AiffChunkData _ -> True; _ -> False) w of+    Just (AiffChunkData x) -> Just x+    _ -> Nothing++lookupAiffMarkChunk :: Aiff -> Maybe AiffMarkChunk+lookupAiffMarkChunk w =+  case lookupAiffChunk (\case AiffChunkMark _ -> True; _ -> False) w of+    Just (AiffChunkMark x) -> Just x+    _ -> Nothing++-- NOTE: Taking sr as a param here so we don't have to interpret extended fp+aiffToPcmContainer :: Int -> Aiff -> Either ConvertErr PcmContainer+aiffToPcmContainer sr aiff = do+  KnownChunk commBody <- guardChunk "common" (lookupAiffCommonChunk aiff)+  KnownChunk dataBody <- guardChunk "data" (lookupAiffDataChunk aiff)+  let !nc = fromIntegral (aceNumChannels commBody)+      !ns = fromIntegral (aceNumSampleFrames commBody)+      !bps = fromIntegral (aceSampleSize commBody)+      !meta = PcmMeta nc ns bps sr+      !arr = adbSoundData dataBody+  pure $! PcmContainer meta arr++aiffGatherMarkers :: Aiff -> Seq SimpleMarker+aiffGatherMarkers aiff =+  case lookupAiffMarkChunk aiff of+    Nothing -> Empty+    Just (KnownChunk (AiffMarkBody marks)) ->+      dedupeSimpleMarkers (fmap (\am -> SimpleMarker (unPascalString (amName am)) (unWord32BE (amPosition am))) marks)
+ src/Dahdit/Audio/Common.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE OverloadedStrings #-}++module Dahdit.Audio.Common+  ( rethrow+  , LabelSize+  , CountSize+  , Label+  , labelSize+  , countSize+  , getExpectLabel+  , getChunkSizeLE+  , expectChunkSizeLE+  , putChunkSizeLE+  , getChunkSizeBE+  , expectChunkSizeBE+  , putChunkSizeBE+  , ChunkHeaderSize+  , chunkHeaderSize+  , KnownLabel (..)+  , UnparsedBody (..)+  , PadCount+  , padCount+  , SimpleMarker (..)+  , dedupeSimpleMarkers+  , ConvertErr (..)+  , guardBps+  , guardChunk+  , LoopMarks (..)+  , LoopMarkNames+  , LoopMarkPoints+  , defaultLoopMarkNames+  , defineLoopMarks+  , findMark+  , findLoopMarks+  , recallLoopMarkNames+  , defaultNoteNumber+  , adjustMarker+  , adjustLoopPoints+  )+where++import Control.Exception (Exception, throwIO)+import Control.Monad (unless)+import Dahdit+  ( Binary (..)+  , ByteCount+  , Get+  , Put+  , StaticBytes+  , Word32BE+  , Word32LE+  , getExpect+  , getRemainingString+  , putByteString+  )+import Dahdit.Audio.Dsp (DspErr)+import Data.ByteString.Short (ShortByteString)+import Data.ByteString.Short qualified as BSS+import Data.Proxy (Proxy (..))+import Data.Sequence (Seq (..))+import Data.Sequence qualified as Seq+import Data.Set qualified as Set+import Data.Word (Word32)+import GHC.TypeLits (Mod, Nat, type (+))++rethrow :: (Exception e) => Either e a -> IO a+rethrow = either throwIO pure++type LabelSize = 4 :: Nat++type CountSize = 4 :: Nat++type Label = StaticBytes LabelSize++labelSize, countSize :: ByteCount+labelSize = 4+countSize = 4++getExpectLabel :: Label -> Get ()+getExpectLabel = getExpect "label" get++getChunkSizeLE :: Get ByteCount+getChunkSizeLE = fmap fromIntegral (get @Word32LE)++expectChunkSizeLE :: ByteCount -> Get ()+expectChunkSizeLE = getExpect "chunk size" getChunkSizeLE++putChunkSizeLE :: ByteCount -> Put+putChunkSizeLE = put @Word32LE . fromIntegral++getChunkSizeBE :: Get ByteCount+getChunkSizeBE = fmap fromIntegral (get @Word32BE)++expectChunkSizeBE :: ByteCount -> Get ()+expectChunkSizeBE = getExpect "chunk size" getChunkSizeBE++putChunkSizeBE :: ByteCount -> Put+putChunkSizeBE = put @Word32BE . fromIntegral++type ChunkHeaderSize = 8 :: Nat++chunkHeaderSize :: ByteCount+chunkHeaderSize = 8++class KnownLabel a where+  knownLabel :: Proxy a -> Label++newtype UnparsedBody = UnparsedBody+  { ubContents :: ShortByteString+  }+  deriving stock (Show)+  deriving newtype (Eq)++instance Binary UnparsedBody where+  byteSize (UnparsedBody bs) = fromIntegral (BSS.length bs)+  get = fmap UnparsedBody getRemainingString+  put (UnparsedBody bs) = putByteString bs++type PadCount (n :: Nat) = n + Mod n 2++padCount :: ByteCount -> ByteCount+padCount bc = if even bc then bc else bc + 1++data SimpleMarker = SimpleMarker+  { smName :: !ShortByteString+  -- ^ name of the cue point+  , smPosition :: !Word32+  -- ^ position in SAMPLES not bytes or elements+  }+  deriving stock (Eq, Show)++ordNubBy :: (Ord b) => (a -> b) -> Seq a -> Seq a+ordNubBy f = go Set.empty Seq.empty+ where+  go !accSet !accSeq = \case+    Empty -> accSeq+    x :<| xs ->+      let !y = f x+      in  if Set.member y accSet+            then go accSet accSeq xs+            else go (Set.insert y accSet) (accSeq :|> x) xs++-- | Sort, keeping the first of any given name+dedupeSimpleMarkers :: Seq SimpleMarker -> Seq SimpleMarker+dedupeSimpleMarkers = ordNubBy smName . Seq.sortOn smPosition++data ConvertErr+  = ConvertErrMissingChunk !String+  | ConvertErrDsp !DspErr+  | ConvertErrBadBps !Int+  | ConvertErrMissingMark !ShortByteString+  | ConvertErrNoLoopMarks+  deriving stock (Eq, Show)++instance Exception ConvertErr++guardBps :: Int -> Int -> Either ConvertErr ()+guardBps needBps haveBps = unless (needBps == haveBps) (Left (ConvertErrBadBps haveBps))++guardChunk :: String -> Maybe c -> Either ConvertErr c+guardChunk name = maybe (Left (ConvertErrMissingChunk name)) Right++data LoopMarks a = LoopMarks+  { lmStart :: !a+  , lmLoopStart :: !a+  , lmLoopEnd :: !a+  , lmEnd :: !a+  }+  deriving stock (Eq, Show, Functor, Foldable, Traversable)++type LoopMarkNames = LoopMarks ShortByteString++type LoopMarkPoints = LoopMarks (Int, SimpleMarker)++type LoopMarkOffsets = LoopMarks Int++defaultLoopMarkNames :: LoopMarkNames+defaultLoopMarkNames = LoopMarks "Start" "LoopStart" "LoopEnd" "End"++defineLoopMarks :: (Integral a) => LoopMarkNames -> LoopMarks a -> LoopMarkPoints+defineLoopMarks (LoopMarks nw nx ny nz) (LoopMarks pw px py pz) =+  LoopMarks+    (0, SimpleMarker nw (fromIntegral pw))+    (1, SimpleMarker nx (fromIntegral px))+    (2, SimpleMarker ny (fromIntegral py))+    (3, SimpleMarker nz (fromIntegral pz))++findMark :: ShortByteString -> Seq SimpleMarker -> Either ConvertErr (Int, SimpleMarker)+findMark name marks =+  case Seq.findIndexL (\sm -> smName sm == name) marks of+    Nothing -> Left (ConvertErrMissingMark name)+    Just ix -> Right (ix, Seq.index marks ix)++findLoopMarks :: LoopMarkNames -> Seq SimpleMarker -> Either ConvertErr LoopMarkPoints+findLoopMarks names marks = traverse (`findMark` marks) names++recallLoopMarkNames :: LoopMarkPoints -> LoopMarkNames+recallLoopMarkNames = fmap (smName . snd)++-- | Midi note C5 is default note+defaultNoteNumber :: Int+defaultNoteNumber = 72++adjustMarker :: Word32 -> SimpleMarker -> SimpleMarker+adjustMarker amt (SimpleMarker name pos) = SimpleMarker name (amt + pos)++adjustLoopPoints :: Word32 -> LoopMarkPoints -> LoopMarkPoints+adjustLoopPoints = fmap . fmap . adjustMarker
+ src/Dahdit/Audio/Convert.hs view
@@ -0,0 +1,186 @@+{-# LANGUAGE RecordWildCards #-}++module Dahdit.Audio.Convert+  ( convertMod+  , convertModGeneric+  , loadAiff+  , loadWav+  , Neutral (..)+  , aiffToNeutral+  , wavToNeutral+  , loadNeutral+  , neutralToWav+  , neutralMono+  , neutralCrossFade+  , neutralCropLoop+  , neutralToSampleWav+  , neutralToMonoWav+  )+where++import Control.Monad (unless, (>=>))+import Dahdit (Int16LE, Int24LE, Int32LE, Seq (..), StaticByteSized, decodeFile)+import Dahdit.Audio.Aiff (Aiff, aiffGatherMarkers, aiffToPcmContainer)+import Dahdit.Audio.Common+  ( ConvertErr (..)+  , LoopMarkNames+  , LoopMarkPoints+  , LoopMarks (..)+  , SimpleMarker (..)+  , adjustMarker+  , findLoopMarks+  , recallLoopMarkNames+  , rethrow+  )+import Dahdit.Audio.Dsp+  ( Mod+  , PcmContainer (..)+  , PcmMeta (..)+  , SampleCount+  , applyMod+  , applyModGeneric+  , changeBitDepth+  , crop+  , ensureMonoFromLeft+  , linearCrossFade+  )+import Dahdit.Audio.Wav+  ( Wav+  , WavChunk (..)+  , wavAddChunks+  , wavFromPcmContainer+  , wavGatherMarkers+  , wavToPcmContainer+  , wavUseLoopPoints+  , wavUseMarkers+  )+import Data.Maybe (isJust)+import Data.Primitive (Prim)+import Data.Sequence qualified as Seq+import System.FilePath (splitExtension)++convertMod+  :: (StaticByteSized a, Prim b, StaticByteSized b) => Mod a b -> PcmContainer -> Either ConvertErr PcmContainer+convertMod modx con = either (Left . ConvertErrDsp) Right (applyMod modx con)++convertModGeneric+  :: (forall a. (Prim a, StaticByteSized a, Integral a) => Mod a a) -> PcmContainer -> Either ConvertErr PcmContainer+convertModGeneric modx con = either (Left . ConvertErrDsp) Right (applyModGeneric modx con)++loadAiff :: FilePath -> IO Aiff+loadAiff = decodeFile >=> rethrow . fst++loadWav :: FilePath -> IO Wav+loadWav = decodeFile >=> rethrow . fst++data Neutral = Neutral+  { neCon :: !PcmContainer+  , neMarks :: !(Seq SimpleMarker)+  , neLoopMarks :: !(Maybe LoopMarkPoints)+  }+  deriving stock (Eq, Show)++guardSr :: Int -> Neutral -> IO ()+guardSr expectedSr ne = do+  let actualSr = pmSampleRate (pcMeta (neCon ne))+  unless (expectedSr == actualSr) (fail ("Expected SR: " ++ show expectedSr ++ " but got " ++ show actualSr))++-- NOTE: Taking sr as a param here so we don't have to interpret extended fp+aiffToNeutral :: Int -> Aiff -> Maybe LoopMarkNames -> Either ConvertErr Neutral+aiffToNeutral sr aiff mayNames = do+  neCon <- aiffToPcmContainer sr aiff+  let !neMarks = aiffGatherMarkers aiff+  neLoopMarks <- maybe (pure Nothing) (fmap Just . (`findLoopMarks` neMarks)) mayNames+  pure $! Neutral {..}++wavToNeutral :: Wav -> Maybe LoopMarkNames -> Either ConvertErr Neutral+wavToNeutral wav mayNames = do+  neCon <- wavToPcmContainer wav+  let !neMarks = wavGatherMarkers wav+  neLoopMarks <- maybe (pure Nothing) (fmap Just . (`findLoopMarks` neMarks)) mayNames+  pure $! Neutral {..}++loadNeutral :: Int -> Maybe LoopMarkNames -> FilePath -> IO Neutral+loadNeutral sr mayNames fp = do+  let (_, ext) = splitExtension fp+  ne <-+    if+      | ext == ".wav" -> do+          wav <- loadWav fp+          rethrow (wavToNeutral wav mayNames)+      | ext == ".aif" || ext == ".aifc" || ext == ".aiff" -> do+          aiff <- loadAiff fp+          rethrow (aiffToNeutral sr aiff mayNames)+      | otherwise -> fail ("Could not load with unknown extension: " ++ fp)+  guardSr sr ne+  pure ne++neutralToWav :: Int -> Neutral -> Wav+neutralToWav note (Neutral {..}) =+  let !sr = pmSampleRate (pcMeta neCon)+      !maySampleChunk = fmap (WavChunkSample . wavUseLoopPoints sr note) neLoopMarks+      !markChunks = if Seq.null neMarks then [] else let (!wcc, !wac) = wavUseMarkers neMarks in [WavChunkCue wcc, WavChunkAdtl wac]+      !chunks = Seq.fromList (markChunks ++ maybe [] pure maySampleChunk)+      !wav = wavFromPcmContainer neCon+  in  wavAddChunks chunks wav++neutralMono :: Neutral -> Either ConvertErr Neutral+neutralMono ne@(Neutral {..}) = do+  con' <- convertModGeneric ensureMonoFromLeft neCon+  pure $! ne {neCon = con'}++neutralReduceDepth :: Neutral -> Either ConvertErr Neutral+neutralReduceDepth ne@(Neutral {..}) = do+  case pmBitsPerSample (pcMeta neCon) of+    16 -> pure ne+    24 -> do+      con' <- convertMod (changeBitDepth @Int24LE @Int16LE 24 16) neCon+      pure $! ne {neCon = con'}+    32 -> do+      con' <- convertMod (changeBitDepth @Int32LE @Int16LE 32 16) neCon+      pure $! ne {neCon = con'}+    y -> Left (ConvertErrBadBps y)++neutralCrossFade :: SampleCount -> Neutral -> Either ConvertErr Neutral+neutralCrossFade width ne@(Neutral {..}) = do+  LoopMarks _ (_, !loopStart) (_, !loopEnd) _ <- maybe (Left ConvertErrNoLoopMarks) Right neLoopMarks+  let !loopStartPos = smPosition loopStart+      !loopEndPos = smPosition loopEnd+  con' <- convertModGeneric (linearCrossFade width (fromIntegral loopStartPos) (fromIntegral loopEndPos)) neCon+  pure $! ne {neCon = con'}++neutralCropLoop :: Neutral -> Either ConvertErr Neutral+neutralCropLoop (Neutral {..}) = do+  initLoopMarks <- maybe (Left ConvertErrNoLoopMarks) Right neLoopMarks+  let !names = recallLoopMarkNames initLoopMarks+      LoopMarks (_, !start) _ (_, !loopEnd) (_, !end) = initLoopMarks+      !startPos = smPosition start+      !loopEndPos = smPosition loopEnd+      !endPos = smPosition end+      !filteredMarks = Seq.filter (\sm -> let p = smPosition sm in p >= startPos && p <= loopEndPos) neMarks+      !withEndMarks = if endPos <= loopEndPos then filteredMarks else filteredMarks :|> end {smPosition = loopEndPos}+      !finalMarks = fmap (adjustMarker (-startPos)) withEndMarks+  !finalLoopMarks <- findLoopMarks names finalMarks+  con' <- convertModGeneric (crop (fromIntegral startPos) (fromIntegral loopEndPos)) neCon+  pure $! Neutral {neCon = con', neLoopMarks = Just finalLoopMarks, neMarks = finalMarks}++neutralIfHasMarks :: (Neutral -> Either e Neutral) -> Neutral -> Either e Neutral+neutralIfHasMarks f ne = do+  if isJust (neLoopMarks ne)+    then f ne+    else Right ne++-- | Example converting to instrument sample representing a particular note (with loop marks)+neutralToSampleWav :: SampleCount -> Int -> Neutral -> Either ConvertErr Wav+neutralToSampleWav width note ne =+  fmap+    (neutralToWav note)+    ( neutralMono ne+        >>= neutralReduceDepth+        >>= neutralIfHasMarks (neutralCrossFade width)+        >>= neutralIfHasMarks neutralCropLoop+    )++-- | Example simply converting to mono 16-bit+neutralToMonoWav :: Neutral -> Either ConvertErr Wav+neutralToMonoWav ne = fmap (wavFromPcmContainer . neCon) (neutralMono ne >>= neutralReduceDepth)
+ src/Dahdit/Audio/Dsp.hs view
@@ -0,0 +1,285 @@+{-# LANGUAGE RecordWildCards #-}++module Dahdit.Audio.Dsp+  ( SampleCount (..)+  , DspErr (..)+  , monoFromLeft+  , monoFromRight+  , monoFromAvg+  , ensureMonoFromLeft+  , changeBitDepth+  , stereoFromMono+  , linearCrossFade+  , crop+  , ModMeta (..)+  , Mod (..)+  , modId+  , modAndThen+  , PcmMeta (..)+  , PcmContainer (..)+  , applyMod+  , applyModGeneric+  )+where++import Control.Exception (Exception)+import Control.Monad (unless)+import Dahdit+  ( ByteCount (..)+  , ElemCount (..)+  , Int16LE+  , Int24LE+  , Int32LE+  , Int8+  , StaticByteSized+  , proxyForF+  , staticByteSize+  )+import Data.Bits (Bits (..))+import Data.Coerce (coerce)+import Data.Primitive (Prim)+import Data.Primitive.ByteArray (ByteArray (..), sizeofByteArray)+import Data.Primitive.PrimArray (PrimArray (..), clonePrimArray, generatePrimArray, indexPrimArray, sizeofPrimArray)+import Data.Proxy (Proxy (..))+import Data.Word (Word64)++newtype SampleCount = SampleCount {unSampleCount :: Int}+  deriving stock (Show)+  deriving newtype (Eq, Ord, Num, Enum, Real, Integral)++data Sampled f where+  Sampled :: (Prim a, StaticByteSized a, Integral a) => !(f a) -> Sampled f++getSampled :: Int -> Maybe (Sampled Proxy)+getSampled = \case+  8 -> Just (Sampled (Proxy :: Proxy Int8))+  16 -> Just (Sampled (Proxy :: Proxy Int16LE))+  24 -> Just (Sampled (Proxy :: Proxy Int24LE))+  32 -> Just (Sampled (Proxy :: Proxy Int32LE))+  _ -> Nothing++data DspErr+  = DspErrOddSamples+  | DspErrBadElemSize+  | DspErrBadBitWidth+  | DspErrNotStereo+  | DspErrNotMono+  | DspErrBadFade+  | DspErrBadCrop+  deriving stock (Eq, Show)++instance Exception DspErr++newtype Sel a = Sel {runSel :: PrimArray a -> ElemCount -> a}++selMonoLeft, selMonoRight :: (Prim a) => Sel a+selMonoLeft = Sel $ \arr i -> indexPrimArray arr (unElemCount i * 2)+selMonoRight = Sel $ \arr i -> indexPrimArray arr (unElemCount i * 2 + 1)++selMonoAvg :: (Prim a, Integral a, Bits a) => Sel a+selMonoAvg = Sel $ \arr i ->+  let !ix = i * 2+      !lval = indexPrimArray arr (unElemCount ix)+      !rval = indexPrimArray arr (unElemCount ix + 1)+      !halfLval = div lval 2+      !halfRval = div rval 2+      !extra = lval .&. rval .&. 1+  in  halfLval + halfRval + extra++data ModMeta = ModMeta+  { mmNumChannels :: !Int+  , mmBitsPerSample :: !Int+  , mmSampleRate :: !Int+  }+  deriving stock (Eq, Show)++-- Array layout: samples are interspersed: [chan1 samp1, chan2 samp1, chan1 samp2, chan2 samp2, chan1 samp3, ...]+-- numChannels -> array -> (newNumChannels, newArray)+newtype Mod a b = Mod {runMod :: ModMeta -> PrimArray a -> Either DspErr (ModMeta, PrimArray b)}++modId :: Mod a a+modId = Mod (curry Right)++modAndThen :: Mod a b -> Mod b c -> Mod a c+modAndThen modAB modBC = Mod $ \nc src -> do+  (nc', src') <- runMod modAB nc src+  runMod modBC nc' src'++monoFromSel :: (Prim a) => Sel a -> Mod a a+monoFromSel sel = Mod $ \mm src -> do+  unless (mmNumChannels mm == 2) (Left DspErrNotStereo)+  let !srcLen = sizeofPrimArray src+  unless (even srcLen) (Left DspErrOddSamples)+  let !destLen = div srcLen 2+      !dest = generatePrimArray destLen (runSel sel src . ElemCount)+  Right (mm {mmNumChannels = 1}, dest)++monoFromLeft, monoFromRight :: (Prim a) => Mod a a+monoFromLeft = monoFromSel selMonoLeft+monoFromRight = monoFromSel selMonoRight++monoFromAvg :: (Prim a, Integral a, Bits a) => Mod a a+monoFromAvg = monoFromSel selMonoAvg++ensureMonoFromSel :: (Prim a) => Sel a -> Mod a a+ensureMonoFromSel sel = Mod $ \mm src -> do+  if mmNumChannels mm == 1+    then pure (mm, src)+    else runMod (monoFromSel sel) mm src++ensureMonoFromLeft :: (Prim a) => Mod a a+ensureMonoFromLeft = ensureMonoFromSel selMonoLeft++changeBitDepth :: (Prim a, Integral a, Prim b, Num b) => Int -> Int -> Mod a b+changeBitDepth srcBitDepth destBitDepth = Mod $ \mm0 src ->+  let bitShift = destBitDepth - srcBitDepth+  in  pure $+        let mm1 = mm0 {mmBitsPerSample = destBitDepth}+            dest = generatePrimArray (sizeofPrimArray src) $ \i ->+              let x = indexPrimArray src i+                  y = shift (fromIntegral @_ @Word64 x) bitShift+              in  fromIntegral y+        in  (mm1, dest)++stereoFromMono :: (Prim a) => Mod a a+stereoFromMono = Mod $ \mm src -> do+  unless (mmNumChannels mm == 1) (Left DspErrNotMono)+  let !srcLen = sizeofPrimArray src+      !destLen = srcLen * 2+      !dest = generatePrimArray destLen (\i -> indexPrimArray src (div i 2))+  Right (mm {mmNumChannels = 2}, dest)++guardFade :: SampleCount -> SampleCount -> SampleCount -> Either DspErr ()+guardFade width loopStart loopEnd = do+  if width <= 0+    || loopEnd <= loopStart+    || loopStart <= loopStart - width+    || loopStart + width <= loopStart+    || loopEnd <= loopEnd - width+    || loopEnd + width <= loopEnd+    then Left DspErrBadFade+    else Right ()++combine :: (Integral a) => Int -> Int -> a -> a -> a+combine intDistTot intDist1 one two =+  let dist1 = fromIntegral intDist1+      dist2 = fromIntegral (intDistTot - intDist1)+      distTot = fromIntegral intDistTot+  in  fromInteger (div (dist1 * fromIntegral one + dist2 * fromIntegral two) distTot)++-- Cross fade:  | --------- PreStart Start PostStart PreEnd End PostEnd ---- |+-- Guarded to ensure inequalities are strict+-- Width here is one-sided+-- Width is number of samples to fade over+linearCrossFade :: (Prim a, Integral a) => SampleCount -> SampleCount -> SampleCount -> Mod a a+linearCrossFade width loopStart loopEnd = Mod $ \mm src -> do+  guardFade width loopStart loopEnd+  let !nc = mmNumChannels mm+      !sampWidth = nc * unSampleCount width+      !sampTotDist = 2 * sampWidth+      !sampBetween = nc * unSampleCount (loopEnd - loopStart)+      !sampPreStart = nc * unSampleCount (loopStart - width)+      !sampStart = nc * unSampleCount loopStart+      !sampPostStart = nc * unSampleCount (loopStart + width)+      !sampPreEnd = nc * unSampleCount (loopEnd - width)+      !sampEnd = nc * unSampleCount loopStart+      !sampPostEnd = nc * unSampleCount (loopEnd + width)+      !sz = sizeofPrimArray src+      !sampLast = sz - sampBetween+      genElem i =+        let !v = indexPrimArray src i+        in  if+              | i >= sampPreStart && i <= sampPostStart ->+                  if i >= sampLast+                    then v+                    else+                      let !w = indexPrimArray src (i + sampBetween)+                          f = combine sampTotDist (coerce (sampPostStart - i))+                      in  if i < sampStart then f v w else f w v+              | i >= sampPreEnd && i <= sampPostEnd ->+                  if i < sampBetween+                    then v+                    else+                      let !w = indexPrimArray src (i - sampBetween)+                          f = combine sampTotDist (coerce (sampPostEnd - i))+                      in  if i < sampEnd then f v w else f w v+              | otherwise -> v+      !dest = generatePrimArray sz genElem+  Right (mm, dest)++guardCrop :: SampleCount -> SampleCount -> Either DspErr ()+guardCrop start end = do+  if end <= start+    then Left DspErrBadCrop+    else Right ()++crop :: (Prim a) => SampleCount -> SampleCount -> Mod a a+crop start end = Mod $ \mm src -> do+  guardCrop start end+  let !nc = mmNumChannels mm+      !sampStart = nc * unSampleCount start+      !sampEnd = nc * unSampleCount end+      !dest = clonePrimArray src sampStart (sampEnd - sampStart)+  Right (mm, dest)++data PcmMeta = PcmMeta+  { pmNumChannels :: !Int+  , pmNumSamples :: !SampleCount+  , pmBitsPerSample :: !Int+  , pmSampleRate :: !Int+  }+  deriving stock (Eq, Show)++data PcmContainer = PcmContainer+  { pcMeta :: !PcmMeta+  , pcData :: !ByteArray+  }+  deriving stock (Eq, Show)++pmToMm :: PcmMeta -> ModMeta+pmToMm (PcmMeta {..}) = ModMeta {mmNumChannels = pmNumChannels, mmBitsPerSample = pmBitsPerSample, mmSampleRate = pmSampleRate}++toLifted :: (StaticByteSized a) => Proxy a -> PcmContainer -> Either DspErr (ModMeta, PrimArray a)+toLifted prox (PcmContainer pm arr@(ByteArray ba)) = do+  let !elemSize = staticByteSize prox+  let !actualNs = div (sizeofByteArray arr) (unByteCount elemSize * pmNumChannels pm)+  unless+    (unByteCount elemSize * 8 == pmBitsPerSample pm && actualNs == unSampleCount (pmNumSamples pm))+    (Left DspErrBadElemSize)+  let !mm = pmToMm pm+  Right (mm, PrimArray ba)++fromLifted :: (Prim b, StaticByteSized b) => ModMeta -> PrimArray b -> Either DspErr PcmContainer+fromLifted mm arr@(PrimArray ba) = do+  let !elemSize = staticByteSize (proxyForF arr)+      !nc = mmNumChannels mm+      !ns = div (sizeofPrimArray arr) nc+      !bps = unByteCount elemSize * 8+      !sr = mmSampleRate mm+      !extraElems = rem (sizeofPrimArray arr) nc+  unless (extraElems == 0) (Left DspErrBadElemSize)+  let !pm = PcmMeta nc (SampleCount ns) bps sr+  Right $! PcmContainer pm (ByteArray ba)++proxyFromFirst :: m a b -> Proxy a+proxyFromFirst _ = Proxy++applyMod :: (StaticByteSized a, Prim b, StaticByteSized b) => Mod a b -> PcmContainer -> Either DspErr PcmContainer+applyMod modx con = do+  (mm, src) <- toLifted (proxyFromFirst modx) con+  (mm', dest) <- runMod modx mm src+  fromLifted mm' dest++proxMod+  :: (Prim a, StaticByteSized a, Integral a)+  => Proxy a+  -> (forall x. (Prim x, StaticByteSized x, Integral x) => Mod x x)+  -> Mod a a+proxMod _ allMod = allMod++applyModGeneric+  :: (forall a. (Prim a, StaticByteSized a, Integral a) => Mod a a) -> PcmContainer -> Either DspErr PcmContainer+applyModGeneric allMod con =+  case getSampled (pmBitsPerSample (pcMeta con)) of+    Nothing -> Left DspErrBadBitWidth+    Just (Sampled prox) -> applyMod (proxMod prox allMod) con
+ src/Dahdit/Audio/Quiet.hs view
@@ -0,0 +1,28 @@+module Dahdit.Audio.Quiet+  ( QuietByteArray (..)+  , QuietPrimArray (..)+  )+where++import Data.Default (Default (..))+import Data.Primitive (Prim)+import Data.Primitive.ByteArray (ByteArray, emptyByteArray, sizeofByteArray)+import Data.Primitive.PrimArray (PrimArray, emptyPrimArray, sizeofPrimArray)++newtype QuietByteArray = QuietByteArray {unQuietByteArray :: ByteArray}+  deriving newtype (Eq, Ord)++instance Show QuietByteArray where+  show (QuietByteArray arr) = "QuietByteArray{" ++ show (sizeofByteArray arr) ++ "}"++instance Default QuietByteArray where+  def = QuietByteArray emptyByteArray++newtype QuietPrimArray a = QuietPrimArray {unQuietPrimArray :: PrimArray a}+  deriving newtype (Eq, Ord)++instance (Prim a) => Show (QuietPrimArray a) where+  show (QuietPrimArray arr) = "QuietPrimArray{" ++ show (sizeofPrimArray arr) ++ "}"++instance Default (QuietPrimArray a) where+  def = QuietPrimArray emptyPrimArray
+ src/Dahdit/Audio/Riff.hs view
@@ -0,0 +1,200 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}++module Dahdit.Audio.Riff+  ( labelRiff+  , labelList+  , listChunkHeaderSize+  , Chunk (..)+  , KnownChunk (..)+  , ListChunkBody (..)+  , ListChunk (..)+  , KnownListChunk (..)+  , KnownOptChunk (..)+  , ChunkLabel (..)+  , peekChunkLabel+  )+where++import Control.Monad (unless)+import Dahdit+  ( Binary (..)+  , ByteCount+  , Get+  , StaticByteSized (..)+  , byteSizeFoldable+  , getExact+  , getLookAhead+  , getRemainingSeq+  , getSkip+  , putSeq+  , putWord8+  )+import Dahdit.Audio.Common+  ( ChunkHeaderSize+  , KnownLabel (..)+  , Label+  , LabelSize+  , PadCount+  , chunkHeaderSize+  , countSize+  , getChunkSizeLE+  , getExpectLabel+  , labelSize+  , padCount+  , putChunkSizeLE+  )+import Data.Default (Default)+import Data.Proxy (Proxy (..))+import Data.Sequence (Seq)+import GHC.TypeLits (Nat, type (+))++labelRiff, labelList :: Label+labelRiff = "RIFF"+labelList = "LIST"++type ListChunkHeaderSize = (ChunkHeaderSize + LabelSize) :: Nat++listChunkHeaderSize :: ByteCount+listChunkHeaderSize = chunkHeaderSize + labelSize++data Chunk a = Chunk+  { chunkLabel :: !Label+  , chunkBody :: !a+  }+  deriving stock (Eq, Show)++chunkUnpaddedByteSize :: (Binary a) => Chunk a -> ByteCount+chunkUnpaddedByteSize (Chunk _ body) = byteSize body++instance (StaticByteSized a) => StaticByteSized (Chunk a) where+  type StaticSize (Chunk a) = PadCount (ChunkHeaderSize + StaticSize a)++instance (Binary a) => Binary (Chunk a) where+  byteSize c = padCount (chunkHeaderSize + chunkUnpaddedByteSize c)+  get = do+    lab <- get+    usz <- getChunkSizeLE+    body <- getExact usz get+    unless (even usz) (getSkip 1)+    pure $! Chunk lab body+  put c@(Chunk lab body) = do+    put lab+    let !usz = chunkUnpaddedByteSize c+    putChunkSizeLE usz+    put body+    unless (even usz) (putWord8 0)++newtype KnownChunk a = KnownChunk+  { knownChunkBody :: a+  }+  deriving stock (Show)+  deriving newtype (Eq, Default)++knownChunkUnpaddedByteSize :: (Binary a) => KnownChunk a -> ByteCount+knownChunkUnpaddedByteSize (KnownChunk body) = byteSize body++instance (StaticByteSized a) => StaticByteSized (KnownChunk a) where+  type StaticSize (KnownChunk a) = PadCount (ChunkHeaderSize + StaticSize a)++instance (Binary a, KnownLabel a) => Binary (KnownChunk a) where+  byteSize c = padCount (chunkHeaderSize + knownChunkUnpaddedByteSize c)+  get = do+    getExpectLabel (knownLabel (Proxy :: Proxy a))+    usz <- getChunkSizeLE+    body <- getExact usz get+    unless (even usz) (getSkip 1)+    pure $! KnownChunk body+  put kc@(KnownChunk body) = do+    put (knownLabel (Proxy :: Proxy a))+    let !usz = knownChunkUnpaddedByteSize kc+    putChunkSizeLE usz+    put body+    unless (even usz) (putWord8 0)++data ListChunkBody a = ListChunkBody+  { lcbLabel :: !Label+  , lcbItems :: !(Seq a)+  }+  deriving stock (Eq, Show)++instance (Binary a) => Binary (ListChunkBody a) where+  byteSize (ListChunkBody _ items) = labelSize + byteSizeFoldable items+  get = do+    label <- get+    items <- getRemainingSeq get+    pure $! ListChunkBody label items+  put (ListChunkBody label items) = do+    put label+    putSeq put items++instance KnownLabel (ListChunkBody a) where+  knownLabel _ = labelList++newtype ListChunk a = ListChunk {unListChunk :: KnownChunk (ListChunkBody a)}+  deriving stock (Show)+  deriving newtype (Eq, Binary)++newtype KnownListChunk a = KnownListChunk+  { klcItems :: Seq a+  }+  deriving stock (Show)+  deriving newtype (Eq, Default)++instance (Binary a, KnownLabel a) => Binary (KnownListChunk a) where+  byteSize (KnownListChunk body) = padCount (listChunkHeaderSize + byteSizeFoldable body)+  get = do+    getExpectLabel labelList+    usz <- getChunkSizeLE+    items <- getExact usz $ do+      getExpectLabel (knownLabel (Proxy :: Proxy a))+      getRemainingSeq get+    unless (even usz) (getSkip 1)+    pure $! KnownListChunk items+  put (KnownListChunk items) = do+    put labelList+    let !usz = labelSize + byteSizeFoldable items+    putChunkSizeLE usz+    put (knownLabel (Proxy :: Proxy a))+    putSeq put items+    unless (even usz) (putWord8 0)++newtype KnownOptChunk a = KnownOptChunk+  { kocItem :: Maybe a+  }+  deriving stock (Show)+  deriving newtype (Eq, Default)++instance (Binary a, KnownLabel a) => Binary (KnownOptChunk a) where+  byteSize (KnownOptChunk item) = padCount (listChunkHeaderSize + byteSizeFoldable item)+  get = do+    getExpectLabel labelList+    usz <- getChunkSizeLE+    item <- getExact usz $ do+      let !label = knownLabel (Proxy :: Proxy a)+      getExpectLabel label+      if usz == labelSize+        then pure Nothing+        else fmap Just get+    unless (even usz) (getSkip 1)+    pure $! KnownOptChunk item+  put (KnownOptChunk item) = do+    put labelList+    let !usz = labelSize + byteSizeFoldable item+    putChunkSizeLE usz+    put (knownLabel (Proxy :: Proxy a))+    maybe (pure ()) put item+    unless (even usz) (putWord8 0)++data ChunkLabel+  = ChunkLabelSingle !Label+  | ChunkLabelList !Label+  deriving stock (Eq, Show)++peekChunkLabel :: Get ChunkLabel+peekChunkLabel = getLookAhead $ do+  label <- get+  if label == labelList+    then getSkip countSize *> fmap ChunkLabelList get+    else pure (ChunkLabelSingle label)
+ src/Dahdit/Audio/Sfont.hs view
@@ -0,0 +1,844 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances #-}++module Dahdit.Audio.Sfont+  ( Sfont (..)+  , InfoChunk (..)+  , PdtaChunk (..)+  , SdtaChunk (..)+  , Info (..)+  , Sdta (..)+  , PdtaCat (..)+  , PdtaBlock (..)+  , Pdta (..)+  , Phdr (..)+  , Bag (..)+  , Mod (..)+  , Gen (..)+  , GenPair (..)+  , GenTag (..)+  , defGenVal+  , lookupGenVal+  , Inst (..)+  , Shdr (..)+  , buildPdta+  , labelSfbk+  )+where++import Control.Monad (unless)+import Dahdit+  ( Binary (..)+  , ByteCount (..)+  , Get+  , Int16LE (..)+  , Put+  , ShortByteString+  , StaticByteSized (..)+  , StaticBytes+  , TermBytes16+  , ViaStaticGeneric (..)+  , Word16LE+  , Word32LE+  , byteSizeViaStatic+  , getExact+  , getPrimArray+  , getRemainingSeq+  , getRemainingSize+  , getRemainingStaticSeq+  , getRemainingString+  , getSkip+  , putByteString+  , putPrimArray+  , putSeq+  )+import Dahdit.Audio.Common+  ( KnownLabel (..)+  , Label+  , chunkHeaderSize+  , getChunkSizeLE+  , getExpectLabel+  , labelSize+  , putChunkSizeLE+  )+import Dahdit.Audio.Riff (KnownListChunk, KnownOptChunk, labelRiff)+import Data.ByteString.Short qualified as BSS+import Data.Foldable (foldl')+import Data.Int (Int8)+import Data.Primitive.ByteArray (ByteArray (..), sizeofByteArray)+import Data.Primitive.PrimArray (PrimArray (..))+import Data.Proxy (Proxy (..))+import Data.Sequence (Seq (..))+import Data.Sequence qualified as Seq+import Data.Type.Equality (testEquality)+import Data.Word (Word8)+import GHC.Generics (Generic)+import Type.Reflection (TypeRep, Typeable, typeRep, (:~:) (..))++labelSfbk+  , labelInfo+  , labelIfil+  , labelIver+  , labelIsng+  , labelInam+  , labelIrom+  , labelIcrd+  , labelIeng+  , labelIprd+  , labelIcop+  , labelIcmt+  , labelIsft+  , labelSdta+  , labelSmpl+  , labelSm24+  , labelPdta+  , labelPhdr+  , labelPbag+  , labelPmod+  , labelPgen+  , labelInst+  , labelIbag+  , labelImod+  , labelIgen+  , labelShdr+    :: Label+labelSfbk = "sfbk"+labelInfo = "INFO"+labelIfil = "ifil"+labelIver = "iver"+labelIsng = "isng"+labelInam = "INAM"+labelIrom = "irom"+labelIcrd = "ICRD"+labelIeng = "IENG"+labelIprd = "IPRD"+labelIcop = "ICOP"+labelIcmt = "ICMT"+labelIsft = "ISFT"+labelSdta = "sdta"+labelSmpl = "smpl"+labelSm24 = "sm24"+labelPdta = "pdta"+labelPhdr = "phdr"+labelPbag = "pbag"+labelPmod = "pmod"+labelPgen = "pgen"+labelInst = "inst"+labelIbag = "ibag"+labelImod = "imod"+labelIgen = "igen"+labelShdr = "shdr"++newtype SampleCount = SampleCount {unSampleCount :: Word32LE}+  deriving stock (Show)+  deriving newtype (Eq, Ord, Num, Enum, Real, Integral, StaticByteSized, Binary)++type ShortText = StaticBytes 20++data Sfont = Sfont+  { sfontInfo :: !InfoChunk+  , sfontSdta :: !SdtaChunk+  , sfontPdta :: !PdtaChunk+  }+  deriving stock (Eq, Show)++instance Binary Sfont where+  byteSize (Sfont info sdta pdta) = chunkHeaderSize + labelSize + byteSize info + byteSize sdta + byteSize pdta+  get = do+    getExpectLabel labelRiff+    chunkSize <- getChunkSizeLE+    getExact chunkSize $ do+      getExpectLabel labelSfbk+      info <- get+      sdta <- get+      pdta <- get+      pure $! Sfont info sdta pdta+  put sfont@(Sfont info sdta pdta) = do+    put labelRiff+    let !chunkSize = byteSize sfont - chunkHeaderSize+    putChunkSizeLE chunkSize+    put labelSfbk+    put info+    put sdta+    put pdta++newtype InfoChunk = InfoChunk {unInfoChunk :: KnownListChunk Info}+  deriving stock (Show)+  deriving newtype (Eq, Binary)++newtype PdtaChunk = PdtaChunk {unPdtaChunk :: KnownListChunk PdtaBlock}+  deriving stock (Show)+  deriving newtype (Eq, Binary)++data Info+  = InfoVersion !Word16LE !Word16LE+  | InfoTargetSoundEngine !TermBytes16+  | InfoBankName !TermBytes16+  | InfoRomName !TermBytes16+  | InfoRomVersion !Word16LE !Word16LE+  | InfoCreationDate !TermBytes16+  | InfoAuthors !TermBytes16+  | InfoIntendedProduct !TermBytes16+  | InfoCopyrightMessage !TermBytes16+  | InfoComments !TermBytes16+  | InfoUsedTools !TermBytes16+  | InfoReserved !Label !ShortByteString+  deriving stock (Eq, Show)++instance KnownLabel Info where+  knownLabel _ = labelInfo++whichLabelInfo :: Info -> Label+whichLabelInfo = \case+  InfoVersion _ _ -> labelIfil+  InfoRomVersion _ _ -> labelIver+  InfoTargetSoundEngine _ -> labelIsng+  InfoBankName _ -> labelInam+  InfoRomName _ -> labelIrom+  InfoCreationDate _ -> labelIcrd+  InfoAuthors _ -> labelIeng+  InfoIntendedProduct _ -> labelIprd+  InfoCopyrightMessage _ -> labelIcop+  InfoComments _ -> labelIcmt+  InfoUsedTools _ -> labelIsft+  InfoReserved l _ -> l++instance Binary Info where+  byteSize info =+    chunkHeaderSize + case info of+      InfoVersion _ _ -> 4+      InfoTargetSoundEngine z -> byteSize z+      InfoBankName z -> byteSize z+      InfoRomName z -> byteSize z+      InfoRomVersion _ _ -> 4+      InfoCreationDate z -> byteSize z+      InfoAuthors z -> byteSize z+      InfoIntendedProduct z -> byteSize z+      InfoCopyrightMessage z -> byteSize z+      InfoComments z -> byteSize z+      InfoUsedTools z -> byteSize z+      InfoReserved _ bs -> ByteCount (BSS.length bs)+  get = do+    label <- get+    chunkSize <- getChunkSizeLE+    getExact chunkSize $+      if+        | label == labelIfil -> do+            unless (chunkSize == 4) (fail "Bad ifil chunk size")+            w1 <- get+            w2 <- get+            pure $! InfoVersion w1 w2+        | label == labelIver -> do+            unless (chunkSize == 4) (fail "Bad iver chunk size")+            w1 <- get+            w2 <- get+            pure $! InfoRomVersion w1 w2+        | label == labelIsng -> fmap InfoTargetSoundEngine get+        | label == labelInam -> fmap InfoBankName get+        | label == labelIrom -> fmap InfoRomName get+        | label == labelIcrd -> fmap InfoCreationDate get+        | label == labelIeng -> fmap InfoAuthors get+        | label == labelIprd -> fmap InfoIntendedProduct get+        | label == labelIcop -> fmap InfoCopyrightMessage get+        | label == labelIcmt -> fmap InfoComments get+        | label == labelIsft -> fmap InfoUsedTools get+        | otherwise -> do+            bs <- getRemainingString+            pure $! InfoReserved label bs+  put info = do+    let !label = whichLabelInfo info+    put label+    let !chunkSize = byteSize info - chunkHeaderSize+    putChunkSizeLE chunkSize+    case info of+      InfoVersion w1 w2 -> put w1 *> put w2+      InfoTargetSoundEngine z -> put z+      InfoBankName z -> put z+      InfoRomName z -> put z+      InfoRomVersion w1 w2 -> put w1 *> put w2+      InfoCreationDate z -> put z+      InfoAuthors z -> put z+      InfoIntendedProduct z -> put z+      InfoCopyrightMessage z -> put z+      InfoComments z -> put z+      InfoUsedTools z -> put z+      InfoReserved _ bs -> putByteString bs++data Sdta = Sdta+  { sdtaHighBits :: !(PrimArray Int16LE)+  , sdtaLowBits :: !(Maybe (PrimArray Word8))+  }+  deriving stock (Eq, Show)++instance KnownLabel Sdta where+  knownLabel _ = labelSdta++getHighBits :: SampleCount -> Get (PrimArray Int16LE)+getHighBits numSamples = getPrimArray (Proxy :: Proxy Int16LE) (fromIntegral numSamples)++getLowBits :: SampleCount -> Get (PrimArray Word8)+getLowBits numSamples = getPrimArray (Proxy :: Proxy Word8) (fromIntegral numSamples)++instance Binary Sdta where+  byteSize (Sdta (PrimArray hba) mlow) = sizeHigh + sizeLow+   where+    sizeHigh = chunkHeaderSize + ByteCount (sizeofByteArray (ByteArray hba))+    sizeLow = maybe 0 (\(PrimArray lba) -> chunkHeaderSize + ByteCount (sizeofByteArray (ByteArray lba))) mlow++  get = do+    chunkSize <- getRemainingSize+    getExpectLabel labelSmpl+    highSize <- getChunkSizeLE+    let !numSamples = div (fromIntegral highSize) 2+    highBits <- getHighBits numSamples+    let !numExtra = chunkSize - highSize - chunkHeaderSize+    if+      | numExtra > 0 -> do+          getExpectLabel labelSm24+          lowSize <- getChunkSizeLE+          let !expectedSize = if even numSamples then numSamples else numSamples + 1+          unless (fromIntegral lowSize == expectedSize) (fail "invalid low sample size")+          lowBits <- getLowBits numSamples+          unless (even numSamples) (getSkip 1)+          pure $! Sdta highBits (Just lowBits)+      | numExtra == 0 -> pure $! Sdta highBits Nothing+      | otherwise -> fail "invalid sdata chunk/sample sizes"+  put (Sdta high@(PrimArray hba) mlow) = do+    put labelSmpl+    putChunkSizeLE (ByteCount (sizeofByteArray (ByteArray hba)))+    putPrimArray high+    case mlow of+      Nothing -> pure ()+      Just low@(PrimArray lba) -> do+        put labelSm24+        putChunkSizeLE (ByteCount (sizeofByteArray (ByteArray lba)))+        putPrimArray low++newtype SdtaChunk = SdtaChunk {unSdtaChunk :: KnownOptChunk Sdta}+  deriving stock (Show)+  deriving newtype (Eq, Binary)++data PdtaCat+  = PdtaCatPreset+  | PdtaCatInst+  deriving stock (Eq, Show)++data PdtaBlock+  = PdtaBlockPhdr !(Seq Phdr)+  | PdtaBlockBag !PdtaCat !(Seq Bag)+  | PdtaBlockMod !PdtaCat !(Seq Mod)+  | PdtaBlockGen !PdtaCat !(Seq Gen)+  | PdtaBlockInst !(Seq Inst)+  | PdtaBlockShdr !(Seq Shdr)+  deriving stock (Eq, Show)++instance KnownLabel PdtaBlock where+  knownLabel _ = labelPdta++whichLabelPdtaBlock :: PdtaBlock -> Label+whichLabelPdtaBlock = \case+  PdtaBlockPhdr _ -> labelPhdr+  PdtaBlockBag pc _ -> case pc of+    PdtaCatPreset -> labelPbag+    PdtaCatInst -> labelIbag+  PdtaBlockMod pc _ -> case pc of+    PdtaCatPreset -> labelPmod+    PdtaCatInst -> labelImod+  PdtaBlockGen pc _ -> case pc of+    PdtaCatPreset -> labelPgen+    PdtaCatInst -> labelIgen+  PdtaBlockInst _ -> labelInst+  PdtaBlockShdr _ -> labelShdr++instance Binary PdtaBlock where+  byteSize block = res+   where+    res =+      chunkHeaderSize + case block of+        PdtaBlockPhdr phdrs -> fromIntegral (Seq.length phdrs) * sizePhdr+        PdtaBlockBag _ bags -> fromIntegral (Seq.length bags) * sizeBag+        PdtaBlockMod _ mods -> fromIntegral (Seq.length mods) * sizeMod+        PdtaBlockGen _ gens -> fromIntegral (Seq.length gens) * sizeGen+        PdtaBlockInst insts -> fromIntegral (Seq.length insts) * sizeInst+        PdtaBlockShdr shdrs -> fromIntegral (Seq.length shdrs) * sizeShdr+    sizePhdr = staticByteSize (Proxy :: Proxy Phdr)+    sizeBag = staticByteSize (Proxy :: Proxy Bag)+    sizeMod = staticByteSize (Proxy :: Proxy Mod)+    sizeGen = staticByteSize (Proxy :: Proxy Gen)+    sizeInst = staticByteSize (Proxy :: Proxy Inst)+    sizeShdr = staticByteSize (Proxy :: Proxy Shdr)++  get = do+    label <- get+    chunkSize <- getChunkSizeLE+    getExact chunkSize $+      if+        | label == labelPhdr ->+            fmap PdtaBlockPhdr (getRemainingStaticSeq get)+        | label == labelPbag ->+            fmap (PdtaBlockBag PdtaCatPreset) (getRemainingStaticSeq get)+        | label == labelPmod ->+            fmap (PdtaBlockMod PdtaCatPreset) (getRemainingStaticSeq get)+        | label == labelPgen ->+            fmap (PdtaBlockGen PdtaCatPreset) (getRemainingStaticSeq get)+        | label == labelInst ->+            fmap PdtaBlockInst (getRemainingSeq get)+        | label == labelIbag ->+            fmap (PdtaBlockBag PdtaCatInst) (getRemainingStaticSeq get)+        | label == labelImod ->+            fmap (PdtaBlockMod PdtaCatInst) (getRemainingStaticSeq get)+        | label == labelIgen ->+            fmap (PdtaBlockGen PdtaCatInst) (getRemainingStaticSeq get)+        | label == labelShdr ->+            fmap PdtaBlockShdr (getRemainingStaticSeq get)+        | otherwise ->+            fail ("unrecognized pdta elem: " ++ show label)+  put block = do+    let !label = whichLabelPdtaBlock block+    put label+    let !chunkSize = byteSize block - chunkHeaderSize+    putChunkSizeLE chunkSize+    case block of+      PdtaBlockPhdr phdrs -> putSeq put phdrs+      PdtaBlockBag _ bags -> putSeq put bags+      PdtaBlockMod _ mods -> putSeq put mods+      PdtaBlockGen _ gens -> putSeq put gens+      PdtaBlockInst insts -> putSeq put insts+      PdtaBlockShdr shdrs -> putSeq put shdrs++-- | Preset header+data Phdr = Phdr+  { phdrPresetName :: !ShortText+  , phdrPreset :: !Word16LE+  , phdrBank :: !Word16LE+  , phdrPresetBagIndex :: !Word16LE+  , phdrLibrary :: !Word32LE+  , phdrGenre :: !Word32LE+  , phdrMorphology :: !Word32LE+  }+  deriving stock (Eq, Show, Generic)+  deriving (StaticByteSized, Binary) via (ViaStaticGeneric Phdr)++data Bag = Bag+  { bagGenIndex :: !Word16LE+  , bagModIndex :: !Word16LE+  }+  deriving stock (Eq, Show, Generic)+  deriving (StaticByteSized, Binary) via (ViaStaticGeneric Bag)++-- | Modulator+data Mod = Mod+  { modSrcOper :: !Word16LE+  , modDestOper :: !Word16LE+  , modAmount :: !Int16LE+  , modAmtSrcOper :: !Word16LE+  , modTransOper :: !Word16LE+  }+  deriving stock (Eq, Show, Generic)+  deriving (StaticByteSized, Binary) via (ViaStaticGeneric Mod)++data SampleMode+  = SampleModeNoLoop !Int16LE+  | SampleModeContLoop+  | SampleModePressLoop+  deriving stock (Eq, Ord, Show)++instance StaticByteSized SampleMode where+  type StaticSize SampleMode = 2+  staticByteSize _ = 2++instance Binary SampleMode where+  byteSize = byteSizeViaStatic+  get = do+    c <- get+    pure $! case c of+      1 -> SampleModeContLoop+      3 -> SampleModePressLoop+      _ -> SampleModeNoLoop c+  put sm =+    put $! case sm of+      SampleModeContLoop -> 1+      SampleModePressLoop -> 3+      SampleModeNoLoop c -> c++data Range = Range+  { rangeLo :: !Word8+  , rangeHi :: !Word8+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving (StaticByteSized, Binary) via (ViaStaticGeneric Range)++data ReservedGen = ReservedGen+  { reservedGenTag :: !Word16LE+  , reservedGetVal :: !Int16LE+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving (StaticByteSized, Binary) via (ViaStaticGeneric ReservedGen)++-- | Instrument+data Inst = Inst+  { instName :: !ShortText+  , instBagIndex :: !Word16LE+  }+  deriving stock (Eq, Show, Generic)+  deriving (StaticByteSized, Binary) via (ViaStaticGeneric Inst)++-- | Sample header+data Shdr = Shdr+  { shdrSampleName :: !ShortText+  , shdrStart :: !Word32LE+  , shdrEnd :: !Word32LE+  , shdrStartLoop :: !Word32LE+  , shdrEndLoop :: !Word32LE+  , shdrSampleRate :: !Word32LE+  , shdrOriginalPitch :: !Word8+  , shdrPitchCorrection :: !Int8+  , shdrSampleLink :: !Word16LE+  , shdrSampleType :: !Word16LE+  }+  deriving stock (Eq, Show, Generic)+  deriving (StaticByteSized, Binary) via (ViaStaticGeneric Shdr)++data Pdta = Pdta+  { pdtaPhdrs :: !(Seq Phdr)+  -- ^ Preset headers+  , pdtaPbags :: !(Seq Bag)+  -- ^ Preset bags+  , pdtaPmods :: !(Seq Mod)+  -- ^ Preset modulators+  , pdtaPgens :: !(Seq Gen)+  -- ^ Preset generators+  , pdtaInsts :: !(Seq Inst)+  -- ^ Instrument names+  , pdtaIbags :: !(Seq Bag)+  -- ^ Instrument bags+  , pdtaImods :: !(Seq Mod)+  -- ^ Instrument modulators+  , pdtaIgens :: !(Seq Gen)+  -- ^ Instrument generators+  , pdtaShdrs :: !(Seq Shdr)+  -- ^ Sample headers+  }+  deriving stock (Eq, Show)++emptyPdta :: Pdta+emptyPdta = Pdta Empty Empty Empty Empty Empty Empty Empty Empty Empty++buildPdta :: Seq PdtaBlock -> Pdta+buildPdta = foldl' go emptyPdta+ where+  go p = \case+    PdtaBlockPhdr phdrs -> p {pdtaPhdrs = pdtaPhdrs p <> phdrs}+    PdtaBlockBag cat bags -> case cat of+      PdtaCatPreset -> p {pdtaPbags = pdtaPbags p <> bags}+      PdtaCatInst -> p {pdtaIbags = pdtaIbags p <> bags}+    PdtaBlockMod cat mods -> case cat of+      PdtaCatPreset -> p {pdtaPmods = pdtaPmods p <> mods}+      PdtaCatInst -> p {pdtaImods = pdtaImods p <> mods}+    PdtaBlockGen cat gens -> case cat of+      PdtaCatPreset -> p {pdtaPgens = pdtaPgens p <> gens}+      PdtaCatInst -> p {pdtaIgens = pdtaIgens p <> gens}+    PdtaBlockInst insts -> p {pdtaInsts = pdtaInsts p <> insts}+    PdtaBlockShdr shdrs -> p {pdtaShdrs = pdtaShdrs p <> shdrs}++-- | Tags for generators+data GenTag a where+  GenTagStartAddressOffset :: GenTag Int16LE+  GenTagEndAddressOffset :: GenTag Int16LE+  GenTagLoopStartAddressOffset :: GenTag Int16LE+  GenTagLoopEndAddressOffset :: GenTag Int16LE+  GenTagStartAddressCoarseOffset :: GenTag Int16LE+  GenTagModLfoToPitch :: GenTag Int16LE+  GenTagVibLfoToPitch :: GenTag Int16LE+  GenTagModEnvToPitch :: GenTag Int16LE+  GenTagInitFc :: GenTag Int16LE+  GenTagInitQ :: GenTag Int16LE+  GenTagModLfoToFc :: GenTag Int16LE+  GenTagModEnvToFc :: GenTag Int16LE+  GenTagEndAddressCoarseOffset :: GenTag Int16LE+  GenTagModLfoToVol :: GenTag Int16LE+  GenTagChorus :: GenTag Int16LE+  GenTagReverb :: GenTag Int16LE+  GenTagPan :: GenTag Int16LE+  GenTagDelayModLfo :: GenTag Int16LE+  GenTagFreqModLfo :: GenTag Int16LE+  GenTagDelayVibLfo :: GenTag Int16LE+  GenTagFreqVibLfo :: GenTag Int16LE+  GenTagDelayModEnv :: GenTag Int16LE+  GenTagAttackModEnv :: GenTag Int16LE+  GenTagHoldModEnv :: GenTag Int16LE+  GenTagDecayModEnv :: GenTag Int16LE+  GenTagSustainModEnv :: GenTag Int16LE+  GenTagReleaseModEnv :: GenTag Int16LE+  GenTagKeyToModEnvHold :: GenTag Int16LE+  GenTagKeyToModEnvDecay :: GenTag Int16LE+  GenTagDelayVolEnv :: GenTag Int16LE+  GenTagAttackVolEnv :: GenTag Int16LE+  GenTagHoldVolEnv :: GenTag Int16LE+  GenTagDecayVolEnv :: GenTag Int16LE+  GenTagSustainVolEnv :: GenTag Int16LE+  GenTagReleaseVolEnv :: GenTag Int16LE+  GenTagKeyToVolEnvHold :: GenTag Int16LE+  GenTagKeyToVolEnvDecay :: GenTag Int16LE+  GenTagInstIndex :: GenTag Word16LE+  GenTagKeyRange :: GenTag Range+  GenTagVelRange :: GenTag Range+  GenTagLoopStartAddressCoarseOffset :: GenTag Int16LE+  GenTagKey :: GenTag Word16LE+  GenTagVel :: GenTag Word16LE+  GenTagInitAtten :: GenTag Int16LE+  GenTagLoopEndAddressCoarseOffset :: GenTag Int16LE+  GenTagCoarseTune :: GenTag Int16LE+  GenTagFineTune :: GenTag Int16LE+  GenTagSampleIndex :: GenTag Word16LE+  GenTagSampleMode :: GenTag SampleMode+  GenTagScaleTuning :: GenTag Int16LE+  GenTagExclusiveClass :: GenTag Int16LE+  GenTagRootKey :: GenTag Word16LE+  GenTagReserved :: Word16LE -> GenTag Int16LE++deriving instance Eq (GenTag a)++deriving instance Ord (GenTag a)++deriving instance Show (GenTag a)++genTagRep :: GenTag a -> Word16LE+genTagRep = \case+  GenTagStartAddressOffset -> 0+  GenTagEndAddressOffset -> 1+  GenTagLoopStartAddressOffset -> 2+  GenTagLoopEndAddressOffset -> 3+  GenTagStartAddressCoarseOffset -> 4+  GenTagModLfoToPitch -> 5+  GenTagVibLfoToPitch -> 6+  GenTagModEnvToPitch -> 7+  GenTagInitFc -> 8+  GenTagInitQ -> 9+  GenTagModLfoToFc -> 10+  GenTagModEnvToFc -> 11+  GenTagEndAddressCoarseOffset -> 12+  GenTagModLfoToVol -> 13+  GenTagChorus -> 15+  GenTagReverb -> 16+  GenTagPan -> 17+  GenTagDelayModLfo -> 21+  GenTagFreqModLfo -> 22+  GenTagDelayVibLfo -> 23+  GenTagFreqVibLfo -> 24+  GenTagDelayModEnv -> 25+  GenTagAttackModEnv -> 26+  GenTagHoldModEnv -> 27+  GenTagDecayModEnv -> 28+  GenTagSustainModEnv -> 29+  GenTagReleaseModEnv -> 30+  GenTagKeyToModEnvHold -> 31+  GenTagKeyToModEnvDecay -> 32+  GenTagDelayVolEnv -> 33+  GenTagAttackVolEnv -> 34+  GenTagHoldVolEnv -> 35+  GenTagDecayVolEnv -> 36+  GenTagSustainVolEnv -> 37+  GenTagReleaseVolEnv -> 38+  GenTagKeyToVolEnvHold -> 39+  GenTagKeyToVolEnvDecay -> 40+  GenTagInstIndex -> 41+  GenTagKeyRange -> 43+  GenTagVelRange -> 44+  GenTagLoopStartAddressCoarseOffset -> 45+  GenTagKey -> 46+  GenTagVel -> 47+  GenTagInitAtten -> 48+  GenTagLoopEndAddressCoarseOffset -> 50+  GenTagCoarseTune -> 51+  GenTagFineTune -> 52+  GenTagSampleIndex -> 53+  GenTagSampleMode -> 54+  GenTagScaleTuning -> 56+  GenTagExclusiveClass -> 57+  GenTagRootKey -> 58+  GenTagReserved t -> t++data GenPair a = GenPair+  { genPairTag :: !(GenTag a)+  , genPairVal :: !a+  }+  deriving stock (Eq, Ord, Show)++putGenPair :: (Binary a) => GenPair a -> Put+putGenPair (GenPair tag val) = put (genTagRep tag) *> put val++data Gen+  = GenInt !(GenPair Int16LE)+  | GenWord !(GenPair Word16LE)+  | GenRange !(GenPair Range)+  | GenSampleMode !(GenPair SampleMode)+  deriving stock (Eq, Ord, Show)++getGenInt :: GenTag Int16LE -> Get Gen+getGenInt tag = fmap (GenInt . GenPair tag) get++getGenWord :: GenTag Word16LE -> Get Gen+getGenWord tag = fmap (GenWord . GenPair tag) get++getGenRange :: GenTag Range -> Get Gen+getGenRange tag = fmap (GenRange . GenPair tag) get++getGenSampleMode :: GenTag SampleMode -> Get Gen+getGenSampleMode tag = fmap (GenSampleMode . GenPair tag) get++instance StaticByteSized Gen where+  type StaticSize Gen = 4+  staticByteSize _ = 4++instance Binary Gen where+  byteSize = byteSizeViaStatic+  get = do+    tag <- get+    case tag of+      0 -> getGenInt GenTagStartAddressOffset+      1 -> getGenInt GenTagEndAddressOffset+      2 -> getGenInt GenTagLoopStartAddressOffset+      3 -> getGenInt GenTagLoopEndAddressOffset+      4 -> getGenInt GenTagStartAddressCoarseOffset+      5 -> getGenInt GenTagModLfoToPitch+      6 -> getGenInt GenTagVibLfoToPitch+      7 -> getGenInt GenTagModEnvToPitch+      8 -> getGenInt GenTagInitFc+      9 -> getGenInt GenTagInitQ+      10 -> getGenInt GenTagModLfoToFc+      11 -> getGenInt GenTagModEnvToFc+      12 -> getGenInt GenTagEndAddressCoarseOffset+      13 -> getGenInt GenTagModLfoToVol+      15 -> getGenInt GenTagChorus+      16 -> getGenInt GenTagReverb+      17 -> getGenInt GenTagPan+      21 -> getGenInt GenTagDelayModLfo+      22 -> getGenInt GenTagFreqModLfo+      23 -> getGenInt GenTagDelayVibLfo+      24 -> getGenInt GenTagFreqVibLfo+      25 -> getGenInt GenTagDelayModEnv+      26 -> getGenInt GenTagAttackModEnv+      27 -> getGenInt GenTagHoldModEnv+      28 -> getGenInt GenTagDecayModEnv+      29 -> getGenInt GenTagSustainModEnv+      30 -> getGenInt GenTagReleaseModEnv+      31 -> getGenInt GenTagKeyToModEnvHold+      32 -> getGenInt GenTagKeyToModEnvDecay+      33 -> getGenInt GenTagDelayVolEnv+      34 -> getGenInt GenTagAttackVolEnv+      35 -> getGenInt GenTagHoldVolEnv+      36 -> getGenInt GenTagDecayVolEnv+      37 -> getGenInt GenTagSustainVolEnv+      38 -> getGenInt GenTagReleaseVolEnv+      39 -> getGenInt GenTagKeyToVolEnvHold+      40 -> getGenInt GenTagKeyToVolEnvDecay+      41 -> getGenWord GenTagInstIndex+      43 -> getGenRange GenTagKeyRange+      44 -> getGenRange GenTagVelRange+      45 -> getGenInt GenTagLoopStartAddressCoarseOffset+      46 -> getGenWord GenTagKey+      47 -> getGenWord GenTagVel+      48 -> getGenInt GenTagInitAtten+      50 -> getGenInt GenTagLoopEndAddressCoarseOffset+      51 -> getGenInt GenTagCoarseTune+      52 -> getGenInt GenTagFineTune+      53 -> getGenWord GenTagSampleIndex+      54 -> getGenSampleMode GenTagSampleMode+      56 -> getGenInt GenTagScaleTuning+      57 -> getGenInt GenTagExclusiveClass+      58 -> getGenWord GenTagRootKey+      _ -> getGenInt (GenTagReserved tag)+  put = \case+    GenInt gp -> putGenPair gp+    GenWord gp -> putGenPair gp+    GenRange gp -> putGenPair gp+    GenSampleMode gp -> putGenPair gp++defGenVal :: GenTag a -> a+defGenVal = \case+  GenTagStartAddressOffset -> 0+  GenTagEndAddressOffset -> 0+  GenTagLoopStartAddressOffset -> 0+  GenTagLoopEndAddressOffset -> 0+  GenTagStartAddressCoarseOffset -> 0+  GenTagModLfoToPitch -> 0+  GenTagVibLfoToPitch -> 0+  GenTagModEnvToPitch -> 0+  GenTagInitFc -> 13500+  GenTagInitQ -> 0+  GenTagModLfoToFc -> 0+  GenTagModEnvToFc -> 0+  GenTagEndAddressCoarseOffset -> 0+  GenTagModLfoToVol -> 0+  GenTagChorus -> 0+  GenTagReverb -> 0+  GenTagPan -> 0+  GenTagDelayModLfo -> -12000+  GenTagFreqModLfo -> 0+  GenTagDelayVibLfo -> -12000+  GenTagFreqVibLfo -> 0+  GenTagDelayModEnv -> -12000+  GenTagAttackModEnv -> -12000+  GenTagHoldModEnv -> -12000+  GenTagDecayModEnv -> -12000+  GenTagSustainModEnv -> 0+  GenTagReleaseModEnv -> -12000+  GenTagKeyToModEnvHold -> 0+  GenTagKeyToModEnvDecay -> 0+  GenTagDelayVolEnv -> -12000+  GenTagAttackVolEnv -> -12000+  GenTagHoldVolEnv -> -12000+  GenTagDecayVolEnv -> -12000+  GenTagSustainVolEnv -> 0+  GenTagReleaseVolEnv -> -12000+  GenTagKeyToVolEnvHold -> 0+  GenTagKeyToVolEnvDecay -> 0+  GenTagInstIndex -> 0+  GenTagKeyRange -> Range 0 127+  GenTagVelRange -> Range 0 127+  GenTagLoopStartAddressCoarseOffset -> 0+  GenTagKey -> -1+  GenTagVel -> -1+  GenTagInitAtten -> 0+  GenTagLoopEndAddressCoarseOffset -> 0+  GenTagCoarseTune -> 0+  GenTagFineTune -> 0+  GenTagSampleIndex -> 0+  GenTagSampleMode -> SampleModeNoLoop 0+  GenTagScaleTuning -> 100+  GenTagExclusiveClass -> 0+  GenTagRootKey -> -1+  GenTagReserved _ -> 0++genTagTyRep :: (Typeable a) => GenTag a -> TypeRep a+genTagTyRep _ = typeRep++genTagTest :: (Typeable a, Typeable b) => GenTag a -> GenTag b -> Maybe (a :~: b)+genTagTest t s = case testEquality (genTagTyRep t) (genTagTyRep s) of+  Nothing -> Nothing+  Just Refl -> if t == s then Just Refl else Nothing++lookupGenVal :: (Typeable a) => GenTag a -> Seq Gen -> Maybe a+lookupGenVal t = go+ where+  go = \case+    Empty -> Nothing+    gp :<| rest ->+      case gp of+        GenInt (GenPair s v) ->+          case genTagTest t s of+            Just Refl -> Just v+            Nothing -> go rest+        GenWord (GenPair s v) ->+          case genTagTest t s of+            Just Refl -> Just v+            Nothing -> go rest+        GenRange (GenPair s v) ->+          case genTagTest t s of+            Just Refl -> Just v+            Nothing -> go rest+        GenSampleMode (GenPair s v) ->+          case genTagTest t s of+            Just Refl -> Just v+            Nothing -> go rest
+ src/Dahdit/Audio/Wav.hs view
@@ -0,0 +1,572 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoStarIsType #-}++module Dahdit.Audio.Wav+  ( PaddedString (..)+  , WavFormatBody (..)+  , WavFormatChunk+  , WavHeader (..)+  , WavDataBody (..)+  , WavDataChunk+  , WavUnparsedChunk+  , WavInfoElem (..)+  , WavInfoChunk+  , WavAdtlData (..)+  , WavAdtlElem (..)+  , WavAdtlChunk+  , WavCuePoint (..)+  , WavCueBody (..)+  , WavCueChunk+  , WavSampleLoop (..)+  , WavSampleBody (..)+  , WavSampleChunk+  , WavChunk (..)+  , Wav (..)+  , lookupWavChunk+  , lookupWavFormatChunk+  , lookupWavDataChunk+  , wavToPcmContainer+  , wavFromPcmContainer+  , wavUseMarkers+  , wavUseLoopPoints+  , wavAddChunks+  , wavGatherMarkers+  )+where++import Control.Monad (unless)+import Dahdit+  ( Binary (..)+  , ByteCount (..)+  , ShortByteString+  , StaticByteSized (..)+  , ViaStaticGeneric (..)+  , Word16LE+  , Word32LE (..)+  , byteSizeFoldable+  , getExact+  , getRemainingByteArray+  , getRemainingSeq+  , getRemainingString+  , getSeq+  , putByteArray+  , putByteString+  , putSeq+  , putWord8+  )+import Dahdit.Audio.Common+  ( ConvertErr+  , CountSize+  , KnownLabel (..)+  , Label+  , LabelSize+  , LoopMarkPoints+  , LoopMarks (..)+  , SimpleMarker (..)+  , UnparsedBody (..)+  , countSize+  , dedupeSimpleMarkers+  , getChunkSizeLE+  , getExpectLabel+  , guardChunk+  , labelSize+  , padCount+  , putChunkSizeLE+  )+import Dahdit.Audio.Dsp (PcmContainer (..), PcmMeta (..), SampleCount (..))+import Dahdit.Audio.Riff (Chunk (..), ChunkLabel (..), KnownChunk (..), KnownListChunk (..), labelRiff, peekChunkLabel)+import Data.ByteString.Short qualified as BSS+import Data.Default (Default (..))+import Data.Foldable (toList)+import Data.Maybe (fromMaybe)+import Data.Primitive (sizeofByteArray)+import Data.Primitive.ByteArray (ByteArray)+import Data.Sequence (Seq (..))+import Data.Sequence qualified as Seq+import Data.String (IsString)+import GHC.Generics (Generic)+import GHC.TypeLits (Nat, type (*), type (+))++labelWave, labelFmt, labelData, labelInfo, labelAdtl, labelCue, labelNote, labelLabl, labelLtxt, labelSmpl :: Label+labelWave = "WAVE"+labelFmt = "fmt "+labelData = "data"+labelInfo = "INFO"+labelAdtl = "adtl"+labelCue = "cue "+labelNote = "note"+labelLabl = "labl"+labelLtxt = "ltxt"+labelSmpl = "smpl"++-- | A string NUL-padded to align to short width+newtype PaddedString = PaddedString {unPaddedString :: ShortByteString}+  deriving stock (Show)+  deriving newtype (Eq, IsString)++instance Default PaddedString where+  def = PaddedString BSS.empty++mkPaddedString :: ShortByteString -> PaddedString+mkPaddedString sbs =+  PaddedString $+    if not (BSS.null sbs) && BSS.last sbs == 0+      then BSS.init sbs+      else sbs++instance Binary PaddedString where+  byteSize (PaddedString sbs) = padCount (ByteCount (BSS.length sbs))+  get = do+    sbs <- getRemainingString+    pure $! mkPaddedString sbs+  put (PaddedString sbs) = do+    putByteString sbs+    let !usz = BSS.length sbs+    unless (even usz) (putWord8 0)++data WavFormatBody = WavFormatBody+  { wfbFormatType :: !Word16LE+  , wfbNumChannels :: !Word16LE+  , wfbSampleRate :: !Word32LE+  , wfbBitsPerSample :: !Word16LE+  , wfbExtra :: !ShortByteString+  }+  deriving stock (Eq, Show)++instance Default WavFormatBody where+  def = WavFormatBody 1 1 44100 16 mempty++isSupportedBPS :: Word16LE -> Bool+isSupportedBPS w = mod w 8 == 0 && w <= 64++isSupportedFmtExtraSize :: ByteCount -> Bool+isSupportedFmtExtraSize x = x == 0 || x == 2 || x == 24++instance Binary WavFormatBody where+  byteSize wf = 16 + ByteCount (BSS.length (wfbExtra wf))+  get = do+    formatType <- get+    numChannels <- get+    sampleRate <- get+    bpsAvg <- get+    bpsSlice <- get+    bps <- get+    unless (isSupportedBPS bps) (fail ("Bad bps: " ++ show bps))+    unless (bpsSlice == div bps 8 * numChannels) (fail ("Bad bps slice: " ++ show bpsSlice))+    unless (bpsAvg == sampleRate * fromIntegral bpsSlice) (fail ("Bad average bps: " ++ show bpsAvg))+    extra <- getRemainingString+    let !extraLen = ByteCount (BSS.length extra)+    unless (isSupportedFmtExtraSize extraLen) (fail ("Bad extra length: " ++ show extraLen))+    pure $! WavFormatBody formatType numChannels sampleRate bps extra+  put (WavFormatBody fty nchan sr bps extra) = do+    let !bpsSlice = div bps 8 * nchan+    let !bpsAvg = sr * fromIntegral bpsSlice+    put fty+    put nchan+    put sr+    put bpsAvg+    put bpsSlice+    put bps+    putByteString extra++instance KnownLabel WavFormatBody where+  knownLabel _ = labelFmt++type WavFormatChunk = KnownChunk WavFormatBody++newtype WavDataBody = WavDataBody {unWavDataBody :: ByteArray}+  deriving stock (Show)+  deriving newtype (Eq)++instance KnownLabel WavDataBody where+  knownLabel _ = labelData++instance Binary WavDataBody where+  byteSize (WavDataBody arr) = fromIntegral (sizeofByteArray arr)+  get = fmap WavDataBody getRemainingByteArray+  put (WavDataBody arr) = putByteArray arr++type WavDataChunk = KnownChunk WavDataBody++data WavInfoElem = WavInfoElem+  { wieKey :: !Label+  , wieVal :: !PaddedString+  }+  deriving stock (Eq, Show)++instance Binary WavInfoElem where+  byteSize (WavInfoElem _ val) = labelSize + countSize + byteSize val+  get = do+    key <- get+    sz <- getChunkSizeLE+    val <- getExact sz get+    pure $! WavInfoElem key val+  put (WavInfoElem key val) = do+    put key+    putChunkSizeLE (byteSize val)+    put val++instance KnownLabel WavInfoElem where+  knownLabel _ = labelInfo++type WavInfoChunk = KnownListChunk WavInfoElem++-- NOTE: these are all the same for now, but ltxt has additional+-- structure that could be parsed out later+data WavAdtlData+  = WavAdtlDataLabl !PaddedString+  | WavAdtlDataNote !PaddedString+  | WavAdtlDataLtxt !PaddedString+  deriving stock (Eq, Show)++byteSizeWavAdtlData :: WavAdtlData -> ByteCount+byteSizeWavAdtlData = \case+  WavAdtlDataLabl bs -> byteSize bs+  WavAdtlDataNote bs -> byteSize bs+  WavAdtlDataLtxt bs -> byteSize bs++wadString :: WavAdtlData -> ShortByteString+wadString = \case+  WavAdtlDataLabl (PaddedString bs) -> bs+  WavAdtlDataNote (PaddedString bs) -> bs+  WavAdtlDataLtxt (PaddedString bs) -> bs++data WavAdtlElem = WavAdtlElem+  { waeCueId :: !Word32LE+  , waeData :: !WavAdtlData+  }+  deriving stock (Eq, Show)++instance Binary WavAdtlElem where+  byteSize (WavAdtlElem _ dat) = 12 + byteSizeWavAdtlData dat+  get = do+    lab <- get+    sz <- getChunkSizeLE+    (cueId, bs) <- getExact sz $ do+      cueId <- get+      bs <- get+      pure (cueId, bs)+    dat <-+      if+        | lab == labelNote -> pure $! WavAdtlDataNote bs+        | lab == labelLabl -> pure $! WavAdtlDataLabl bs+        | lab == labelLtxt -> pure $! WavAdtlDataLtxt bs+        | otherwise -> fail ("Unknown adtl sub-chunk: " ++ show lab)+    pure $! WavAdtlElem cueId dat+  put (WavAdtlElem cueId dat) = do+    put $! case dat of+      WavAdtlDataLabl _ -> labelLabl+      WavAdtlDataNote _ -> labelNote+      WavAdtlDataLtxt _ -> labelLtxt+    putChunkSizeLE (4 + byteSizeWavAdtlData dat)+    put cueId+    case dat of+      WavAdtlDataLabl bs -> put bs+      WavAdtlDataNote bs -> put bs+      WavAdtlDataLtxt bs -> put bs++instance KnownLabel WavAdtlElem where+  knownLabel _ = labelAdtl++type WavAdtlChunk = KnownListChunk WavAdtlElem++data WavCuePoint = WavCuePoint+  { wcpPointId :: !Word32LE+  , wcpPosition :: !Word32LE+  , wcpChunkId :: !Word32LE+  , wcpChunkStart :: !Word32LE+  , wcpBlockStart :: !Word32LE+  , wcpSampleStart :: !Word32LE+  }+  deriving stock (Eq, Show)++type CuePointSize = 24 :: Nat++cuePointSize :: ByteCount+cuePointSize = 24++instance StaticByteSized WavCuePoint where+  type StaticSize WavCuePoint = CuePointSize+  staticByteSize _ = cuePointSize++instance Binary WavCuePoint where+  byteSize _ = cuePointSize+  get = do+    wcpPointId <- get+    wcpPosition <- get+    wcpChunkId <- get+    wcpChunkStart <- get+    wcpBlockStart <- get+    wcpSampleStart <- get+    pure $! WavCuePoint {..}+  put (WavCuePoint {..}) = do+    put wcpPointId+    put wcpPosition+    put wcpChunkId+    put wcpChunkStart+    put wcpBlockStart+    put wcpSampleStart++newtype WavCueBody = WavCueBody+  { wcbPoints :: Seq WavCuePoint+  }+  deriving stock (Eq, Show)++instance Binary WavCueBody where+  byteSize (WavCueBody points) = countSize + fromIntegral (Seq.length points) * cuePointSize+  get = do+    count <- get @Word32LE+    points <- getSeq (fromIntegral count) get+    pure $! WavCueBody points+  put (WavCueBody points) = do+    put (fromIntegral (Seq.length points) :: Word32LE)+    putSeq put points++instance KnownLabel WavCueBody where+  knownLabel _ = labelCue++type WavCueChunk = KnownChunk WavCueBody++data WavSampleLoop = WavSampleLoop+  { wslId :: !Word32LE+  , wslType :: !Word32LE+  , wslStart :: !Word32LE+  , wslEnd :: !Word32LE+  , wslFraction :: !Word32LE+  , wslNumPlays :: !Word32LE+  }+  deriving stock (Eq, Show, Generic)+  deriving (StaticByteSized, Binary) via (ViaStaticGeneric WavSampleLoop)++-- See https://www.recordingblogs.com/wiki/sample-chunk-of-a-wave-file+-- for explanation of sample period - for 44100 sr it's 0x00005893+data WavSampleBody = WavSampleBody+  { wsbManufacturer :: !Word32LE+  , wsbProduct :: !Word32LE+  , wsbSamplePeriod :: !Word32LE+  , wsbMidiUnityNote :: !Word32LE+  , wsbMidiPitchFrac :: !Word32LE+  , wsbSmtpeFormat :: !Word32LE+  , wsbSmtpeOffset :: !Word32LE+  , wsbSampleLoops :: !(Seq WavSampleLoop)+  }+  deriving stock (Eq, Show)++instance Binary WavSampleBody where+  byteSize wsb = 32 + byteSizeFoldable (wsbSampleLoops wsb)+  get = do+    wsbManufacturer <- get+    wsbProduct <- get+    wsbSamplePeriod <- get+    wsbMidiUnityNote <- get+    wsbMidiPitchFrac <- get+    wsbSmtpeFormat <- get+    wsbSmtpeOffset <- get+    numLoops <- get @Word32LE+    wsbSampleLoops <- getSeq (fromIntegral numLoops) get+    pure $! WavSampleBody {..}+  put (WavSampleBody {..}) = do+    put wsbManufacturer+    put wsbProduct+    put wsbSamplePeriod+    put wsbMidiUnityNote+    put wsbMidiPitchFrac+    put wsbSmtpeFormat+    put wsbSmtpeOffset+    put @Word32LE (fromIntegral (Seq.length wsbSampleLoops))+    putSeq put wsbSampleLoops++instance KnownLabel WavSampleBody where+  knownLabel _ = labelSmpl++type WavSampleChunk = KnownChunk WavSampleBody++type WavUnparsedChunk = Chunk UnparsedBody++data WavChunk+  = WavChunkFormat !WavFormatChunk+  | WavChunkData !WavDataChunk+  | WavChunkInfo !WavInfoChunk+  | WavChunkAdtl !WavAdtlChunk+  | WavChunkCue !WavCueChunk+  | WavChunkSample !WavSampleChunk+  | WavChunkUnparsed !WavUnparsedChunk+  deriving stock (Eq, Show)++instance Binary WavChunk where+  byteSize = \case+    WavChunkFormat x -> byteSize x+    WavChunkData x -> byteSize x+    WavChunkInfo x -> byteSize x+    WavChunkAdtl x -> byteSize x+    WavChunkCue x -> byteSize x+    WavChunkSample x -> byteSize x+    WavChunkUnparsed x -> byteSize x++  get = do+    chunkLabel <- peekChunkLabel+    case chunkLabel of+      ChunkLabelSingle label | label == labelFmt -> fmap WavChunkFormat get+      ChunkLabelSingle label | label == labelData -> fmap WavChunkData get+      ChunkLabelList label | label == labelInfo -> fmap WavChunkInfo get+      ChunkLabelList label | label == labelAdtl -> fmap WavChunkAdtl get+      ChunkLabelSingle label | label == labelCue -> fmap WavChunkCue get+      ChunkLabelSingle label | label == labelSmpl -> fmap WavChunkSample get+      _ -> fmap WavChunkUnparsed get+  put = \case+    WavChunkFormat x -> put x+    WavChunkData x -> put x+    WavChunkInfo x -> put x+    WavChunkAdtl x -> put x+    WavChunkCue x -> put x+    WavChunkSample x -> put x+    WavChunkUnparsed x -> put x++newtype WavHeader = WavHeader+  { wavHeaderRemainingSize :: ByteCount+  }+  deriving stock (Show)+  deriving newtype (Eq)++type WavHeaderSize = 2 * LabelSize + CountSize++wavHeaderSize :: ByteCount+wavHeaderSize = 2 * labelSize + countSize++instance StaticByteSized WavHeader where+  type StaticSize WavHeader = WavHeaderSize+  staticByteSize _ = wavHeaderSize++instance Binary WavHeader where+  get = do+    getExpectLabel labelRiff+    sz <- getChunkSizeLE+    getExpectLabel labelWave+    pure $! WavHeader (sz - labelSize)+  put (WavHeader remSz) = do+    put labelRiff+    putChunkSizeLE (remSz + labelSize)+    put labelWave++newtype Wav = Wav+  { wavChunks :: Seq WavChunk+  }+  deriving stock (Eq, Show)++instance Binary Wav where+  byteSize (Wav chunks) = wavHeaderSize + byteSizeFoldable chunks+  get = do+    WavHeader remSz <- get+    chunks <- getExact remSz (getRemainingSeq get)+    pure $! Wav chunks+  put (Wav chunks) = do+    let !remSz = byteSizeFoldable chunks+    put (WavHeader remSz)+    putSeq put chunks++lookupWavChunk :: (WavChunk -> Bool) -> Wav -> Maybe WavChunk+lookupWavChunk p (Wav chunks) = fmap (Seq.index chunks) (Seq.findIndexL p chunks)++bindWavChunk :: (WavChunk -> Seq WavChunk) -> Wav -> Wav+bindWavChunk f (Wav chunks) = Wav (chunks >>= f)++lookupWavFormatChunk :: Wav -> Maybe WavFormatChunk+lookupWavFormatChunk w =+  case lookupWavChunk (\case WavChunkFormat _ -> True; _ -> False) w of+    Just (WavChunkFormat x) -> Just x+    _ -> Nothing++lookupWavDataChunk :: Wav -> Maybe WavDataChunk+lookupWavDataChunk w =+  case lookupWavChunk (\case WavChunkData _ -> True; _ -> False) w of+    Just (WavChunkData x) -> Just x+    _ -> Nothing++lookupWavCueChunk :: Wav -> Maybe WavCueChunk+lookupWavCueChunk w =+  case lookupWavChunk (\case WavChunkCue _ -> True; _ -> False) w of+    Just (WavChunkCue x) -> Just x+    _ -> Nothing++lookupWavAdtlChunk :: Wav -> Maybe WavAdtlChunk+lookupWavAdtlChunk w =+  case lookupWavChunk (\case WavChunkAdtl _ -> True; _ -> False) w of+    Just (WavChunkAdtl x) -> Just x+    _ -> Nothing++wavToPcmContainer :: Wav -> Either ConvertErr PcmContainer+wavToPcmContainer wav = do+  KnownChunk fmtBody <- guardChunk "format" (lookupWavFormatChunk wav)+  KnownChunk (WavDataBody arr) <- guardChunk "data" (lookupWavDataChunk wav)+  let !nc = fromIntegral (wfbNumChannels fmtBody)+      !bps = fromIntegral (wfbBitsPerSample fmtBody)+      !sr = fromIntegral (wfbSampleRate fmtBody)+      !ns = SampleCount (div (sizeofByteArray arr) (nc * div bps 8))+      !meta = PcmMeta nc ns bps sr+  pure $! PcmContainer meta arr++wavFromPcmContainer :: PcmContainer -> Wav+wavFromPcmContainer (PcmContainer (PcmMeta {..}) arr) =+  let fmtBody =+        WavFormatBody+          { wfbFormatType = 1+          , wfbNumChannels = fromIntegral pmNumChannels+          , wfbSampleRate = fromIntegral pmSampleRate+          , wfbBitsPerSample = fromIntegral pmBitsPerSample+          , wfbExtra = mempty+          }+      fmtChunk = WavChunkFormat (KnownChunk fmtBody)+      dataChunk = WavChunkData (KnownChunk (WavDataBody arr))+  in  Wav (Seq.fromList [fmtChunk, dataChunk])++wcpFromMarker :: Int -> SimpleMarker -> WavCuePoint+wcpFromMarker ix sm = WavCuePoint (fromIntegral ix) (fromIntegral (smPosition sm)) 0 0 0 (fromIntegral (smPosition sm))++waeFromMarker :: Int -> SimpleMarker -> WavAdtlElem+waeFromMarker ix sm = WavAdtlElem (fromIntegral ix) (WavAdtlDataLabl (mkPaddedString (smName sm)))++wavUseMarkers :: Seq SimpleMarker -> (WavCueChunk, WavAdtlChunk)+wavUseMarkers marks =+  let wcps = Seq.mapWithIndex wcpFromMarker marks+      wcc = KnownChunk (WavCueBody wcps)+      waes = Seq.mapWithIndex waeFromMarker marks+      wac = KnownListChunk waes+  in  (wcc, wac)++wavUseLoopPoints :: Int -> Int -> LoopMarkPoints -> WavSampleChunk+wavUseLoopPoints sr note (LoopMarks _ (startId, loopStart) (_, loopEnd) _) =+  let wsbManufacturer = 0+      wsbProduct = 0+      wsbSamplePeriod = fromIntegral (div 1000000000 sr)+      wsbMidiUnityNote = fromIntegral note+      wsbMidiPitchFrac = 0+      wsbSmtpeFormat = 0+      wsbSmtpeOffset = 0+      wslId = fromIntegral startId+      wslType = 0+      wslStart = fromIntegral (smPosition loopStart)+      wslEnd = fromIntegral (smPosition loopEnd)+      wslFraction = 0+      wslNumPlays = 0+      wsl = WavSampleLoop {..}+      wsbSampleLoops = Seq.singleton wsl+      wsb = WavSampleBody {..}+  in  KnownChunk wsb++wavAddChunks :: Seq WavChunk -> Wav -> Wav+wavAddChunks chunks wav = wav {wavChunks = wavChunks wav <> chunks}++wavGatherMarkers :: Wav -> Seq SimpleMarker+wavGatherMarkers wav = fromMaybe Seq.empty $ do+  KnownChunk cueBody <- lookupWavCueChunk wav+  KnownListChunk adtlElems <- lookupWavAdtlChunk wav+  let !cues = fmap (\wcp -> (wcpPointId wcp, wcpSampleStart wcp)) (toList (wcbPoints cueBody))+      !names = fmap (\wae -> (waeCueId wae, wadString (waeData wae))) (toList adtlElems)+      !marks = Seq.fromList $ do+        (pid, ss) <- cues+        case lookup pid names of+          Nothing -> []+          Just nm -> [SimpleMarker nm (unWord32LE ss)]+  pure $! dedupeSimpleMarkers marks
+ src/Dahdit/Audio/Wav/Simple.hs view
@@ -0,0 +1,116 @@+-- | Interface semi-compatible with the WAVE library (but more efficient)+module Dahdit.Audio.Wav.Simple+  ( WAVE (..)+  , WAVEHeader (..)+  , WAVESample+  , WAVESamples (..)+  , toPcmContainer+  , toComplex+  , fromComplex+  , getWAVEFile+  , putWAVEFile+  )+where++import Control.Exception (throwIO)+import Control.Monad (unless, (>=>))+import Dahdit.Audio.Common (ConvertErr (..), guardChunk, rethrow)+import Dahdit.Audio.Convert (convertMod)+import Dahdit.Audio.Dsp (DspErr (..), PcmContainer (..), PcmMeta (..), SampleCount (..), changeBitDepth)+import Dahdit.Audio.Riff (KnownChunk (..))+import Dahdit.Audio.Wav+  ( Wav (..)+  , WavChunk (..)+  , WavDataBody (..)+  , WavFormatBody (..)+  , lookupWavFormatChunk+  , wavToPcmContainer+  )+import Dahdit.Iface (decodeFileEnd, encodeFile)+import Dahdit.Nums (Int16LE, Int24LE)+import Dahdit.Proxy (proxyForF)+import Dahdit.Sizes (ByteCount (..), staticByteSize)+import Data.Int (Int32)+import Data.Primitive.ByteArray (ByteArray (..), sizeofByteArray)+import Data.Primitive.PrimArray (PrimArray (..), sizeofPrimArray)+import Data.Sequence (Seq (..))++data WAVEHeader = WAVEHeader+  { waveNumChannels :: Int+  , waveFrameRate :: Int+  , waveBitsPerSample :: Int+  , waveFrames :: Maybe Int+  }+  deriving stock (Eq, Show)++type WAVESample = Int32++newtype WAVESamples = WAVESamples {unWAVESamples :: PrimArray Int32}+  deriving stock (Eq, Show)++data WAVE = WAVE+  { waveHeader :: WAVEHeader+  , waveSamples :: WAVESamples+  }+  deriving stock (Eq, Show)++toPcmContainer :: WAVE -> Either ConvertErr PcmContainer+toPcmContainer (WAVE hdr (WAVESamples arr@(PrimArray ba))) = do+  let elemSize = staticByteSize (proxyForF arr)+      nc = waveNumChannels hdr+      ns = div (sizeofPrimArray arr) nc+      bps = unByteCount elemSize * 8+      sr = waveFrameRate hdr+      extraElems = rem (sizeofPrimArray arr) nc+      pm = PcmMeta nc (SampleCount ns) bps sr+  unless (extraElems == 0) (Left (ConvertErrDsp DspErrBadElemSize))+  pure (PcmContainer pm (ByteArray ba))++toComplex :: WAVE -> Either ConvertErr Wav+toComplex wave0@(WAVE hdr _) = do+  pc0 <- toPcmContainer wave0+  let bps = waveBitsPerSample hdr+  pc1 <- case bps of+    16 -> convertMod (changeBitDepth @Int32 @Int16LE 32 16) pc0+    24 -> convertMod (changeBitDepth @Int32 @Int24LE 32 24) pc0+    32 -> pure pc0+    y -> Left (ConvertErrBadBps y)+  let samps1 = pcData pc1+      wfb =+        WavFormatBody+          { wfbFormatType = 1+          , wfbNumChannels = fromIntegral (waveNumChannels hdr)+          , wfbSampleRate = fromIntegral (waveFrameRate hdr)+          , wfbBitsPerSample = fromIntegral bps+          , wfbExtra = mempty+          }+      headerChunk = WavChunkFormat (KnownChunk wfb)+      dataChunk = WavChunkData (KnownChunk (WavDataBody samps1))+  pure (Wav (headerChunk :<| dataChunk :<| Empty))++fromComplex :: Wav -> Either ConvertErr WAVE+fromComplex wav0 = do+  pc0 <- wavToPcmContainer wav0+  let bps = pmBitsPerSample (pcMeta pc0)+  pc1 <- case bps of+    16 -> convertMod (changeBitDepth @Int16LE @Int32 16 32) pc0+    24 -> convertMod (changeBitDepth @Int24LE @Int32 24 32) pc0+    32 -> pure pc0+    y -> Left (ConvertErrBadBps y)+  KnownChunk wfb <- guardChunk "format" (lookupWavFormatChunk wav0)+  let !samps@(ByteArray ba) = pcData pc1+      hdr =+        WAVEHeader+          { waveNumChannels = fromIntegral (wfbNumChannels wfb)+          , waveFrameRate = fromIntegral (wfbSampleRate wfb)+          , waveBitsPerSample = bps+          , waveFrames = Just (div (sizeofByteArray samps) 4)+          }++  pure (WAVE hdr (WAVESamples (PrimArray ba)))++getWAVEFile :: FilePath -> IO WAVE+getWAVEFile = decodeFileEnd >=> rethrow . fst >=> rethrow . fromComplex++putWAVEFile :: FilePath -> WAVE -> IO ()+putWAVEFile fp wave = either throwIO (`encodeFile` fp) (toComplex wave)
+ test/Main.hs view
@@ -0,0 +1,523 @@+{-# LANGUAGE OverloadedStrings #-}++module Main (main) where++import Control.Exception (Exception, throwIO)+import Control.Monad ((>=>))+import Dahdit+  ( Binary (..)+  , ByteCount+  , ElemCount (..)+  , Get+  , Int16LE (..)+  , ShortByteString+  , StaticByteSized (..)+  , Word8+  , byteSize+  , decode+  , decodeFile+  , decodeFileEnd+  , encode+  , encodeFile+  , getExact+  , getSkip+  , getTarget+  )+import Dahdit.Audio.Aiff (Aiff (..), AiffDataBody (..), lookupAiffDataChunk)+import Dahdit.Audio.Aiff qualified as Aiff+import Dahdit.Audio.Common+  ( LoopMarks (..)+  , UnparsedBody (..)+  , chunkHeaderSize+  , defaultLoopMarkNames+  , defaultNoteNumber+  , defineLoopMarks+  , getChunkSizeLE+  , getExpectLabel+  , guardChunk+  , rethrow+  )+import Dahdit.Audio.Convert+  ( Neutral (..)+  , aiffToNeutral+  , neutralMono+  , neutralToSampleWav+  , neutralToWav+  , wavToNeutral+  )+import Dahdit.Audio.Dsp (ModMeta (..), PcmContainer (..), linearCrossFade, monoFromLeft, runMod)+import Dahdit.Audio.Riff (Chunk (..), KnownChunk (..), KnownListChunk (..), KnownOptChunk (..), labelRiff)+import Dahdit.Audio.Sfont+  ( Bag+  , Gen+  , InfoChunk (..)+  , Inst+  , Mod+  , PdtaChunk (..)+  , Phdr+  , Sdta (..)+  , SdtaChunk (..)+  , Sfont (..)+  , Shdr+  , labelSfbk+  )+import Dahdit.Audio.Wav+  ( Wav (..)+  , WavAdtlChunk+  , WavAdtlData (..)+  , WavAdtlElem (..)+  , WavChunk (..)+  , WavDataBody (..)+  , WavFormatBody (..)+  , WavFormatChunk+  , WavHeader (..)+  , WavInfoElem (..)+  , lookupWavDataChunk+  , lookupWavFormatChunk+  , wavToPcmContainer+  )+import Dahdit.Audio.Wav.Simple qualified as DAWS+import Data.ByteString.Lazy qualified as BSL+import Data.ByteString.Short qualified as BSS+import Data.Foldable (for_, toList)+import Data.Int (Int8)+import Data.Maybe (fromMaybe)+import Data.Primitive.ByteArray (indexByteArray, sizeofByteArray)+import Data.Primitive.PrimArray (primArrayFromList, sizeofPrimArray)+import Data.Proxy (Proxy (..))+import Data.Sequence qualified as Seq+import Test.Daytripper (daytripperMain)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))++drumFmtOffset :: ByteCount+drumFmtOffset = 12++drumDataOffset :: ByteCount+drumDataOffset = 36++drumPostDataOffset :: ByteCount+drumPostDataOffset = 497816++drumFmtChunk :: WavFormatChunk+drumFmtChunk = KnownChunk (WavFormatBody 1 2 44100 16 mempty)++drumFileSize :: ByteCount+drumFileSize = 497896++drumEndOffset :: ByteCount+drumEndOffset = drumFileSize + 8++drumHeader :: WavHeader+drumHeader = WavHeader (drumFileSize - 4)++drumDataLen :: ElemCount+drumDataLen = 248886++readShort :: FilePath -> IO ShortByteString+readShort = fmap (BSS.toShort . BSL.toStrict) . BSL.readFile++throwFirst :: (Exception e) => (Either e a, b) -> IO (a, b)+throwFirst (ea, b) =+  case ea of+    Left e -> throwIO e+    Right a -> pure (a, b)++decodeThrow :: (Binary a) => ShortByteString -> IO (a, ByteCount)+decodeThrow = decode >=> throwFirst++getTargetThrow :: Get a -> ShortByteString -> IO (a, ByteCount)+getTargetThrow g z = getTarget g z >>= throwFirst++decodeFileThrow :: (Binary a) => FilePath -> IO (a, ByteCount)+decodeFileThrow = decodeFile >=> throwFirst++testWavSerde :: TestTree+testWavSerde = testCase "serde" $ do+  -- KnownChunk+  byteSize drumFmtChunk @?= 24+  fmtBs <- encode drumFmtChunk+  (fmt, fmtSz) <- decodeThrow fmtBs+  byteSize fmt @?= fmtSz+  fmt @?= drumFmtChunk+  -- Odd and even unparsed chunks+  let unpSz = 10+      unpOdd = Chunk "FOOB" (UnparsedBody "A")+      unpEven = Chunk "FOOB" (UnparsedBody "AB")+  byteSize unpOdd @?= unpSz+  byteSize unpEven @?= unpSz+  unpOddBs <- encode unpOdd+  (unpOdd', unpOddSz) <- decodeThrow unpOddBs+  byteSize unpOdd' @?= unpOddSz+  unpOdd' @?= unpOdd+  unpEvenBs <- encode unpEven+  (unpEven', unpEvenSz) <- decodeThrow unpEvenBs+  byteSize unpEven' @?= unpEvenSz+  unpEven' @?= unpEven+  -- Adtl chunks+  let adtlChunkEven = KnownListChunk (Seq.singleton (WavAdtlElem 42 (WavAdtlDataNote "hi")))+  assertReparses @WavAdtlChunk adtlChunkEven+  let adtlChunkOdd = KnownListChunk (Seq.singleton (WavAdtlElem 42 (WavAdtlDataNote "h")))+  assertReparses @WavAdtlChunk adtlChunkOdd++testWavHeader :: TestTree+testWavHeader = testCase "header" $ do+  bs <- readShort "testdata/drums.wav"+  (header, bc) <- decodeThrow bs+  header @?= drumHeader+  bc @?= drumFmtOffset++testWavData :: TestTree+testWavData = testCase "data" $ do+  bs <- readShort "testdata/drums.wav"+  (arr, _) <- flip getTargetThrow bs $ do+    getSkip drumDataOffset+    chunk <- get+    case chunk of+      WavChunkData (KnownChunk (WavDataBody arr)) -> pure arr+      _ -> fail "expected data"+  fromIntegral (sizeofByteArray arr) @?= drumDataLen * 2 -- x2 for 2-byte samples++testWavInfo :: TestTree+testWavInfo = testCase "info" $ do+  bs <- readShort "testdata/drums.wav"+  (info, _) <- flip getTargetThrow bs $ do+    getSkip drumPostDataOffset+    chunk <- get+    case chunk of+      WavChunkInfo (KnownListChunk info) -> pure info+      _ -> fail "expected info"+  info @?= Seq.fromList [WavInfoElem "IART" "freewavesamples.com"]++testWavWhole :: TestTree+testWavWhole = testCase "whole" $ do+  bs <- readShort "testdata/drums.wav"+  (wav, _) <- decodeThrow bs+  fmtChunk <- rethrow (guardChunk "format" (lookupWavFormatChunk wav))+  fmtChunk @?= drumFmtChunk+  KnownChunk (WavDataBody arr) <- rethrow (guardChunk "data" (lookupWavDataChunk wav))+  fromIntegral (sizeofByteArray arr) @?= drumDataLen * 2 -- x2 for 2-byte samples+  Seq.length (wavChunks wav) @?= 4++testWavWrite :: TestTree+testWavWrite = testCase "write" $ do+  bs <- readShort "testdata/drums.wav"+  (wav, bc) <- decodeThrow bs+  byteSize wav @?= bc+  for_ (wavChunks wav) assertReparses+  bs' <- encode wav+  bs' @?= bs++testWavWrite2 :: TestTree+testWavWrite2 = testCase "write 2" $ do+  bs <- readShort "testdata/DX-EPiano1-C1.wav"+  (wav, bc) <- decodeThrow bs+  byteSize wav @?= bc+  for_ (wavChunks wav) assertReparses+  bs' <- encode wav+  bs' @?= bs++testWav :: TestTree+testWav = testGroup "wav" [testWavSerde, testWavHeader, testWavData, testWavInfo, testWavWhole, testWavWrite, testWavWrite2]++testAiff :: TestTree+testAiff = testCase "aiff" $ do+  bs <- readShort "testdata/M1F1-int16s-AFsp.aif"+  (aiff, bc) <- decodeThrow bs+  byteSize aiff @?= bc+  bc @?= fromIntegral (BSS.length bs)+  for_ (aiffChunks aiff) assertReparses+  bs' <- encode aiff+  fromIntegral (BSS.length bs') @?= bc+  bs' @?= bs++testAiff2 :: TestTree+testAiff2 = testCase "aiff2" $ do+  bs <- readShort "testdata/DX-EPiano1-C1.aif"+  (aiff :: Aiff, _) <- decodeThrow bs+  bs' <- encode aiff+  bs' @?= bs++testSfontWhole :: TestTree+testSfontWhole = testCase "whole" $ do+  bs <- readShort "testdata/timpani.sf2"+  ( Sfont (InfoChunk (KnownListChunk infos)) (SdtaChunk (KnownOptChunk maySdta)) (PdtaChunk (KnownListChunk pdtaBlocks))+    , _+    ) <-+    decodeThrow bs+  Seq.length infos @?= 5+  case maySdta of+    Nothing -> fail "Missing sdta"+    Just sdta -> do+      sizeofPrimArray (sdtaHighBits sdta) @?= 1365026+      sdtaLowBits sdta @?= Nothing+  Seq.length pdtaBlocks @?= 9++testSfontWrite :: TestTree+testSfontWrite = testCase "write" $ do+  bs <- readShort "testdata/timpani.sf2"+  (sfont, _) <- decodeThrow @Sfont bs+  bs' <- encode sfont+  bs' @?= bs++testSfontManual :: TestTree+testSfontManual = testCase "manual" $ do+  bs <- readShort "testdata/timpani.sf2"+  ((info, sdta, pdta), _) <- flip getTargetThrow bs $ do+    getExpectLabel labelRiff+    chunkSize <- getChunkSizeLE+    getExact chunkSize $ do+      getExpectLabel labelSfbk+      info <- get @InfoChunk+      sdta <- get @SdtaChunk+      pdta <- get @PdtaChunk+      pure (info, sdta, pdta)+  let expecInfoSize = 124 + chunkHeaderSize+      expecSdtaSize = 2730064 + chunkHeaderSize+      expecPdtaSize = 3010 + chunkHeaderSize+  byteSize info @?= expecInfoSize+  byteSize sdta @?= expecSdtaSize+  byteSize pdta @?= expecPdtaSize+  infoBs <- encode info+  BSS.length infoBs @?= fromIntegral expecInfoSize+  sdtaBs <- encode sdta+  BSS.length sdtaBs @?= fromIntegral expecSdtaSize+  pdtaBs <- encode pdta+  BSS.length pdtaBs @?= fromIntegral expecPdtaSize++testSfontSizes :: TestTree+testSfontSizes = testCase "sizes" $ do+  staticByteSize (Proxy :: Proxy Phdr) @?= 38+  staticByteSize (Proxy :: Proxy Bag) @?= 4+  staticByteSize (Proxy :: Proxy Mod) @?= 10+  staticByteSize (Proxy :: Proxy Gen) @?= 4+  staticByteSize (Proxy :: Proxy Inst) @?= 22+  staticByteSize (Proxy :: Proxy Shdr) @?= 46++testSfont :: TestTree+testSfont = testGroup "sfont" [testSfontSizes, testSfontWhole, testSfontWrite, testSfontManual]++assertReparses :: (Binary a, Eq a, Show a) => a -> IO ()+assertReparses a = do+  bs <- encode a+  (a', bc) <- decodeThrow bs+  byteSize a' @?= bc+  a' @?= a++testConvertDx :: TestTree+testConvertDx = testCase "DX" $ do+  bs <- readShort "testdata/DX-EPiano1-C1.aif"+  (aif, _) <- decodeThrow bs+  ne <- rethrow (aiffToNeutral 44100 aif (Just defaultLoopMarkNames))+  -- Test that a standard translation of the wav works+  let !wav = neutralToWav defaultNoteNumber ne+  pc <- rethrow (wavToPcmContainer wav)+  pc @?= neCon ne+  assertReparses wav+  xne <- rethrow (wavToNeutral wav (Just defaultLoopMarkNames))+  xne @?= ne+  -- Test that the sample wav works+  let !width = 2500 -- double this is 0.1s of total fade+  swav <- rethrow (neutralToSampleWav width defaultNoteNumber ne)+  assertReparses swav+  pure ()++aifSamples :: Aiff -> [Word8]+aifSamples aif =+  let Aiff.KnownChunk (AiffDataBody _ _ wavData) = fromMaybe (error "no data") (lookupAiffDataChunk aif)+      !sz = sizeofByteArray wavData+  in  fmap (indexByteArray wavData) [0 .. sz - 1]++wavSamples :: Wav -> [Word8]+wavSamples wav =+  let KnownChunk (WavDataBody wavData) = fromMaybe (error "no data") (lookupWavDataChunk wav)+      !sz = sizeofByteArray wavData+  in  fmap (indexByteArray wavData) [0 .. sz - 1]++neutralSamples :: Neutral -> [Word8]+neutralSamples ne =+  let !wavData = pcData (neCon ne)+      !sz = sizeofByteArray wavData+  in  fmap (indexByteArray wavData) [0 .. sz - 1]++wavFmt :: Wav -> WavFormatBody+wavFmt wav = fmtBody+ where+  KnownChunk fmtBody = fromMaybe (error "no format") (lookupWavFormatChunk wav)++takeN :: Int -> [Word8] -> [Word8]+takeN n xs = let f = take n in f xs ++ reverse (f (reverse xs))++evenShorts :: [Word8] -> [Word8]+evenShorts (x : y : zs) = x : y : oddShorts zs+evenShorts _ = []++oddShorts :: [Word8] -> [Word8]+oddShorts (_ : _ : zs) = evenShorts zs+oddShorts _ = []++takeSome :: [Word8] -> [Word8]+takeSome = takeN 10++takeSomeEvens :: [Word8] -> [Word8]+takeSomeEvens = evenShorts . takeN 20++tryAifToWav :: Int -> String -> IO ()+tryAifToWav channels variant = do+  (aif, _) <- decodeFileThrow ("testdata/sin_" ++ variant ++ ".aifc")+  (wav, _) <- decodeFileThrow ("testdata/sin_" ++ variant ++ ".wav")+  ne <- rethrow (aiffToNeutral 44100 aif Nothing)+  let !conv = neutralToWav defaultNoteNumber ne+  let !aifPart = takeSome (aifSamples aif)+  let !wavPart = takeSome (wavSamples wav)+  wavPart @?= aifPart+  let !convPart = takeSome (wavSamples conv)+  convPart @?= aifPart+  -- conv and wav will be different bc of addl chunks like cue+  -- but their formats will be the same+  let !convFx = wavFmt conv+  wfbNumChannels convFx @?= fromIntegral channels+  let !wavFx = wavFmt wav+  convFx @?= wavFx++tryWavMono :: IO ()+tryWavMono = do+  -- Read stereo + mono versions of same wav, assert their samples are correct+  (wavStereo, _) <- decodeFileThrow "testdata/sin_stereo.wav"+  (wavMono, _) <- decodeFileThrow "testdata/sin_mono.wav"+  let !leftStereoPart = takeSomeEvens (wavSamples wavStereo)+  let !monoPart = takeSome (wavSamples wavMono)+  monoPart @?= leftStereoPart+  -- Now make the stereo wav mono and assert the same+  neExtract <- rethrow (wavToNeutral wavStereo Nothing >>= neutralMono)+  let !extractPart = takeSome (neutralSamples neExtract)+  extractPart @?= monoPart++testConvertSin :: TestTree+testConvertSin = testCase "sin" $ do+  tryAifToWav 1 "mono"+  tryAifToWav 2 "stereo"+  tryWavMono++testConvertLoop :: TestTree+testConvertLoop = testCase "loop" $ do+  (wav, _) <- decodeFileThrow "testdata/sin_mono.wav"+  con <- rethrow (wavToPcmContainer wav)+  let mkLoopMarks = defineLoopMarks @Int defaultLoopMarkNames . fmap (* 6000)+      !loopMarks = mkLoopMarks (LoopMarks 1 2 3 4)+      !marks = Seq.fromList (fmap snd (toList loopMarks))+  let !ne = Neutral {neCon = con, neLoopMarks = Just loopMarks, neMarks = marks}+  -- Convert and write out for inspection+  let !fullWav = neutralToWav defaultNoteNumber ne+  encodeFile fullWav "testoutput/sin_mono_full.wav"+  sampleWav <- rethrow (neutralToSampleWav 2500 defaultNoteNumber ne)+  encodeFile sampleWav "testoutput/sin_mono_sample.wav"+  -- Test full wav marks+  fullNe <- rethrow (wavToNeutral fullWav (Just defaultLoopMarkNames))+  let !actualFullLoopMarks = neLoopMarks fullNe+  actualFullLoopMarks @?= Just loopMarks+  -- Test sample wav marks+  let !expectedSampleLoopMarks = mkLoopMarks (LoopMarks 0 1 2 2)+  sampleNe <- rethrow (wavToNeutral sampleWav (Just defaultLoopMarkNames))+  let !actualSampleLoopMarks = neLoopMarks sampleNe+  actualSampleLoopMarks @?= Just expectedSampleLoopMarks++testConvertFade :: TestTree+testConvertFade = testCase "fade" $ do+  (wav, _) <- decodeFileThrow "testdata/fadeout_post.wav"+  con <- rethrow (wavToPcmContainer wav)+  let mkLoopMarks = defineLoopMarks @Int defaultLoopMarkNames . fmap (* 4410)+      !loopMarks = mkLoopMarks (LoopMarks 0 3 6 10)+      !marks = Seq.fromList (fmap snd (toList loopMarks))+  let !ne = Neutral {neCon = con, neLoopMarks = Just loopMarks, neMarks = marks}+  -- Convert and write out for inspection+  let !fullWav = neutralToWav defaultNoteNumber ne+  encodeFile fullWav "testoutput/fadeout_full.wav"+  sampleWav <- rethrow (neutralToSampleWav 1000 defaultNoteNumber ne)+  encodeFile sampleWav "testoutput/fadeout_sample.wav"++testConvertDxFade :: TestTree+testConvertDxFade = testCase "dx fade" $ do+  (wav, _) <- decodeFileThrow "testdata/DX-EPiano1-C1.wav"+  ne <- rethrow (wavToNeutral wav (Just defaultLoopMarkNames))+  neMon <- rethrow (neutralMono ne)+  -- Convert and write out for inspection+  let !fullWav = neutralToWav defaultNoteNumber neMon+  encodeFile fullWav "testoutput/dx_full.wav"+  sampleWav <- rethrow (neutralToSampleWav 2500 defaultNoteNumber neMon)+  encodeFile sampleWav "testoutput/dx_sample.wav"++testConvert :: TestTree+testConvert = testGroup "convert" [testConvertDx, testConvertSin, testConvertLoop, testConvertFade, testConvertDxFade]++testDspMono :: TestTree+testDspMono = testCase "mono" $ do+  let !larr1 = primArrayFromList @Int16LE [0, 1, 2, 3, 4, 5]+      !larr2 = primArrayFromList @Int16LE [0, 2, 4]+      !mm1 = ModMeta {mmNumChannels = 2, mmBitsPerSample = 16, mmSampleRate = 44100}+      !mm2 = mm1 {mmNumChannels = 1}+  (!mmx, !larrx) <- rethrow (runMod monoFromLeft mm1 larr1)+  mmx @?= mm2+  larrx @?= larr2++testDspFadeOne :: TestTree+testDspFadeOne = testCase "fade one" $ do+  let !larr1 = primArrayFromList @Int8 [5, 5, 5, 5, 5, 5, 5, 5, 5, 1, 1, 1, 1, 1, 1, 1, 1]+      --                                                               ^                       ^+      !width = 1+      !loopStart = 7+      !loopEnd = 15+      !larr2 = primArrayFromList @Int8 [5, 5, 5, 5, 5, 5, 5, 3, 5, 1, 1, 1, 1, 1, 5, 3, 1]+      --                                                               ^                       ^+      !mm = ModMeta {mmNumChannels = 1, mmBitsPerSample = 8, mmSampleRate = 44100}+  (!mmx, !larrx) <- rethrow (runMod (linearCrossFade width loopStart loopEnd) mm larr1)+  mmx @?= mm+  larrx @?= larr2++testDspFadeSome :: TestTree+testDspFadeSome = testCase "fade some" $ do+  let !larr1 = primArrayFromList @Int8 [5, 5, 5, 5, 5, 5, 5, 5, 5, 1, 1, 1, 1, 1, 1, 1, 1]+      !width = 3+      !loopStart = 7+      !loopEnd = 15+      !larr2 = primArrayFromList @Int8 [5, 5, 5, 5, 5, 4, 3, 3, 3, 1, 1, 1, 5, 4, 3, 3, 2]+      !mm = ModMeta {mmNumChannels = 1, mmBitsPerSample = 8, mmSampleRate = 44100}+  (!mmx, !larrx) <- rethrow (runMod (linearCrossFade width loopStart loopEnd) mm larr1)+  mmx @?= mm+  larrx @?= larr2++testDspFadeWider :: TestTree+testDspFadeWider = testCase "fade wider" $ do+  let !larr1 = primArrayFromList @Int16LE [5, 5, 5, 5, 5, 5, 5, 5, 5, 1, 1, 1, 1, 1, 1, 1, 1]+      !width = 3+      !loopStart = 7+      !loopEnd = 15+      !larr2 = primArrayFromList @Int16LE [5, 5, 5, 5, 5, 4, 3, 3, 3, 1, 1, 1, 5, 4, 3, 3, 2]+      !mm = ModMeta {mmNumChannels = 1, mmBitsPerSample = 16, mmSampleRate = 44100}+  (!mmx, !larrx) <- rethrow (runMod (linearCrossFade width loopStart loopEnd) mm larr1)+  mmx @?= mm+  larrx @?= larr2++testDsp :: TestTree+testDsp = testGroup "dsp" [testDspMono, testDspFadeOne, testDspFadeSome, testDspFadeWider]++testWavSimple :: TestTree+testWavSimple = testCase "wav simple" $ do+  wav <- rethrow . fst =<< decodeFileEnd "testdata/drums.wav"+  pcBefore <- rethrow (wavToPcmContainer wav)+  simple <- rethrow (DAWS.fromComplex wav)+  complex <- rethrow (DAWS.toComplex simple)+  pcAfter <- rethrow (wavToPcmContainer complex)+  -- There is more to check, but a good approximation is that+  -- the wavs are equal as PCM containers before and after converting to+  -- the simplified representation.+  pcAfter @?= pcBefore++testDahditAudio :: TestTree+testDahditAudio =+  testGroup+    "dahdit-audio"+    [testWav, testAiff, testAiff2, testSfont, testConvert, testDsp, testWavSimple]++main :: IO ()+main = daytripperMain (const testDahditAudio)