audacity 0.0 → 0.0.1

raw patch · 13 files changed

+1196/−63 lines, 13 filesdep +bytestringdep +directorydep +explicit-exceptiondep ~basedep ~non-emptydep ~storablevectornew-component:exe:audacity-combinenew-component:exe:audacity-concatPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: bytestring, directory, explicit-exception, optparse-applicative, storable-record, tagchup, transformers, xml-basic

Dependency ranges changed: base, non-empty, storablevector, utility-ht

API changes (from Hackage documentation)

Files

• audacity.cabal +88/−9
• example/Bundle.hs +88/−0
• example/Combine.hs +81/−0
• example/Common.hs +96/−0
• example/Concatenate.hs +5/−50
• src/Sound/Audacity/LabelTrack.hs +32/−4
• src/Sound/Audacity/Project.hs +73/−0
• src/Sound/Audacity/Project/Track/Label.hs +117/−0
• src/Sound/Audacity/Project/Track/Wave.hs +325/−0
• src/Sound/Audacity/Project/Track/Wave/Summary.hs +141/−0
• src/Sound/Audacity/XML.hs +45/−0
• src/Sound/Audacity/XML/Attribute.hs +25/−0
• src/Sound/Audacity/XML/Parser.hs +80/−0

@@ -1,11 +1,29 @@ Name:                audacity-Version:             0.0+Version:             0.0.1 Synopsis:            Interchange with the Audacity sound signal editor Description:   This package provides functions   for interchange with the Audacity sound signal editor.   Currently we support import and export of label tracks.-Homepage:            http://code.haskell.org/~thielema/audacity+  .+  It provides two examples:+  .+  * @sox-concat@:+    Concatenate a sequence of sound files with matching+    sampling rates and numbers of channels using SoX+    and generate an Audacity label track file+    that shows the origins of the parts.+  .+  * @audacity-concat@:+    Create an Audacity project file+    containing a virtual concatenation of the input sound files+    and a label track showing the origins of the sound files.+  .+  * @audacity-combine@:+    Put several audio and label files into tracks of a new Audacity project.+    Opening one or even multiple such projects is much easier+    than loading individual tracks into Audacity.+Homepage:            http://hub.darcs.net/thielema/audacity License:             BSD3 License-File:        LICENSE Author:              Henning Thielemann@@ -15,13 +33,13 @@ Cabal-Version:       >=1.10  Source-Repository this-  Tag:         0.0+  Tag:         0.0.1   Type:        darcs-  Location:    http://code.haskell.org/~thielema/audacity+  Location:    http://hub.darcs.net/thielema/audacity  Source-Repository head   Type:        darcs-  Location:    http://code.haskell.org/~thielema/audacity+  Location:    http://hub.darcs.net/thielema/audacity  Flag buildExamples   description: Build example executables@@ -30,16 +48,35 @@ Library   Exposed-Modules:     Sound.Audacity.LabelTrack+    Sound.Audacity.Project+    Sound.Audacity.Project.Track.Label+    Sound.Audacity.Project.Track.Wave+    Sound.Audacity.Project.Track.Wave.Summary+  Other-Modules:+    Sound.Audacity.XML+    Sound.Audacity.XML.Parser+    Sound.Audacity.XML.Attribute   Build-Depends:+    storablevector >=0.2.9 && <0.3,+    storable-record >=0.0 && <0.1,+    bytestring >=0.9 && <0.11,+    directory >=1.1 && <1.4,+    filepath >=1.3 && <1.5,+    tagchup >=0.4 && <0.5,+    xml-basic >=0.1.1 && <0.2,+    non-empty >=0.2.1 && <0.4,     utility-ht >=0.0.10 && <0.1,+    explicit-exception >=0.1.7 && <0.2,+    transformers >=0.3 && <0.6,     deepseq >=1.3 && <1.5,-    base >=4.5 && <4.9+    base >=4.5 && <5   Hs-Source-Dirs:      src   Default-Language:    Haskell2010   GHC-Options:         -Wall  Executable sox-concat   Main-Is:             Concatenate.hs+  Other-Modules:       Common   Hs-Source-Dirs:      example   Default-Language:    Haskell2010   GHC-Options:         -Wall@@ -47,10 +84,52 @@     Build-Depends:       audacity,       soxlib >=0.0 && <0.1,-      storablevector >=0.2.9 && <0.3,+      storablevector,+      directory,+      optparse-applicative >=0.11 && <0.13,       filepath >=1.3 && <1.5,-      non-empty >=0.1.3 && <0.3,-      utility-ht >=0.0.10 && <0.1,+      non-empty,+      utility-ht,+      base+  Else+    Buildable: False++Executable audacity-concat+  Main-Is:             Bundle.hs+  Other-Modules:       Common+  Hs-Source-Dirs:      example+  Default-Language:    Haskell2010+  GHC-Options:         -Wall+  If flag(buildExamples)+    Build-Depends:+      audacity,+      soxlib >=0.0 && <0.1,+      storablevector,+      directory,+      optparse-applicative >=0.11 && <0.13,+      filepath >=1.3 && <1.5,+      non-empty,+      utility-ht,+      base+  Else+    Buildable: False++Executable audacity-combine+  Main-Is:             Combine.hs+  Other-Modules:       Common+  Hs-Source-Dirs:      example+  Default-Language:    Haskell2010+  GHC-Options:         -Wall+  If flag(buildExamples)+    Build-Depends:+      audacity,+      soxlib >=0.0 && <0.1,+      storablevector,+      directory,+      optparse-applicative >=0.11 && <0.13,+      filepath >=1.3 && <1.5,+      non-empty,+      utility-ht,       base   Else     Buildable: False

@@ -0,0 +1,88 @@+module Main where++import Common+         (defaultSampleRate, multiArgs, withSound, summaryName, waveSummary, )++import qualified Sound.Audacity.Project.Track.Label as ProjectLabelTrack+import qualified Sound.Audacity.Project.Track.Wave.Summary as ProjectWaveSummary+import qualified Sound.Audacity.Project.Track.Wave as ProjectWaveTrack+import qualified Sound.Audacity.Project as Audacity+import qualified Sound.Audacity.LabelTrack as LabelTrack+import qualified Sound.SoxLib as SoxLib++import Control.Monad (when, liftM2, )++import qualified Data.NonEmpty as NonEmpty+import qualified Data.List as List+import Data.Traversable (forM, )++import qualified System.FilePath as FilePath+import Text.Printf (printf, )++++projectLabelTrack :: String -> LabelTrack.T Double String -> Audacity.Track+projectLabelTrack name labels =+   Audacity.LabelTrack+      (ProjectLabelTrack.deflt {+         ProjectLabelTrack.name_ = name,+         ProjectLabelTrack.track_ = labels+      })++run :: NonEmpty.T [] FilePath -> FilePath -> IO ()+run neInputs@(NonEmpty.Cons input0 inputs) output = do+   let outputSummary = summaryName output+   let defltRate maybeRate = maybe defaultSampleRate id maybeRate+   let write sh maybeRate numChan input sig = do+         sequs <- waveSummary sh numChan input sig+         dur <-+            return $!+               fromIntegral+                  (maximum $ map ProjectWaveTrack.numSamples_ sequs)+                     / defltRate maybeRate+         return (sequs, dur)+   (maybeRate, sequLengths) <-+      ProjectWaveSummary.withHandle outputSummary $ \sh ->+      withSound input0 $ \ _fmt rate0 numChan0 sig0 ->+      fmap ((,) rate0) $+      liftM2 (:) (write sh rate0 numChan0 input0 sig0) $+         forM inputs $ \input ->+         withSound input $ \ _fmt rate numChan sig -> do+            let showRate = maybe "<no rate>" show+            when (rate0 /= rate) $+               ioError $ userError $+                  printf "%s: rate %s differs from initial rate %s"+                     input (showRate rate) (showRate rate0)+            when (numChan0 /= numChan) $+               ioError $ userError $+                  printf "%s: number channels (%d) differs from initial input (%d)"+                     input numChan numChan0+            write sh rate numChan input sig+   let (sequss, lengths) = unzip sequLengths+       originTrack =+         LabelTrack.fromAdjacentChunks $+         zip lengths $ map FilePath.takeBaseName $ NonEmpty.flatten neInputs+       sequenceTracks =+         flip map (List.transpose sequss) $ \sequs ->+         Audacity.WaveTrack $+         ProjectWaveTrack.deflt {+            ProjectWaveTrack.name_ = "bundle",+            ProjectWaveTrack.rate_ = round $ defltRate maybeRate,+            ProjectWaveTrack.clips_ =+               zipWith ProjectWaveTrack.Clip (scanl (+) 0 lengths) sequs+         }++   writeFile output $+      flip Audacity.format "" $+      Audacity.deflt {+         Audacity.zoom_ = 850 / sum lengths,+         Audacity.name_ = FilePath.takeBaseName outputSummary,+         Audacity.tracks_ =+            sequenceTracks ++ [projectLabelTrack "origin" originTrack]+      }+++main :: IO ()+main =+   SoxLib.formatWith $+   uncurry run =<< multiArgs "Create Audacity track from multiple clips"

@@ -0,0 +1,81 @@+module Main where++import Common+         (defaultSampleRate, multiArgs, withSound, summaryName, waveSummary, )++import qualified Sound.Audacity.Project.Track.Label as ProjectLabelTrack+import qualified Sound.Audacity.Project.Track.Wave.Summary as ProjectWaveSummary+import qualified Sound.Audacity.Project.Track.Wave as ProjectWaveTrack+import qualified Sound.Audacity.Project as Audacity+import qualified Sound.Audacity.LabelTrack as LabelTrack+import qualified Sound.SoxLib as SoxLib++import qualified Control.Functor.HT as FuncHT+import Control.Monad (join, )++import qualified Data.NonEmpty as NonEmpty+import Data.Traversable (forM, )+import Data.NonEmpty ((!:), )++import qualified System.FilePath as FilePath+import Text.Printf (printf, )++++projectLabelTrack :: String -> LabelTrack.T Double String -> Audacity.Track+projectLabelTrack name labels =+   Audacity.LabelTrack+      (ProjectLabelTrack.deflt {+         ProjectLabelTrack.name_ = name,+         ProjectLabelTrack.track_ = labels+      })++run :: NonEmpty.T [] FilePath -> FilePath -> IO ()+run inputs output = do+   let outputSummary = summaryName output+   let defltRate maybeRate = maybe defaultSampleRate id maybeRate+   let write sh maybeRate numChan input sig = do+         let chanExc =+               ioError $ userError $+                  printf "%s: number channels (%d) is too small" input numChan+         sequs <-+            (maybe chanExc return . NonEmpty.fetch =<<) $+            waveSummary sh numChan input sig+         return $ flip fmap sequs $ \sequ ->+            (Audacity.WaveTrack $+             ProjectWaveTrack.deflt {+               ProjectWaveTrack.name_ = FilePath.takeBaseName input,+               ProjectWaveTrack.rate_ = round $ defltRate maybeRate,+               ProjectWaveTrack.clips_ = [ProjectWaveTrack.Clip 0 sequ]+             },+             fromIntegral (ProjectWaveTrack.numSamples_ sequ)+               / defltRate maybeRate)++   trackLengths <-+      ProjectWaveSummary.withHandle outputSummary $ \sh ->+      forM inputs $ \input ->+      if FilePath.takeExtensions input == ".txt"+         then do+            labels <- LabelTrack.readFile input+            return $ NonEmpty.singleton $+               (projectLabelTrack (FilePath.takeBaseName input) labels,+                NonEmpty.maximum $ (0!:) $+                map (snd.fst) $ LabelTrack.decons labels)+         else+            withSound input $ \ _fmt rate numChan sig ->+               write sh rate numChan input sig+   let (tracks, lengths) = FuncHT.unzip $ join trackLengths++   writeFile output $+      flip Audacity.format "" $+      Audacity.deflt {+         Audacity.zoom_ = 850 / NonEmpty.maximum lengths,+         Audacity.name_ = FilePath.takeBaseName outputSummary,+         Audacity.tracks_ = NonEmpty.flatten tracks+      }+++main :: IO ()+main =+   SoxLib.formatWith $+   uncurry run =<< multiArgs "Create Audacity project from multiple tracks"

@@ -0,0 +1,96 @@+module Common where++import qualified Sound.Audacity.Project.Track.Wave.Summary as ProjectWaveSummary+import qualified Sound.Audacity.Project.Track.Wave as ProjectWaveTrack+import qualified Sound.SoxLib as SoxLib++import qualified Data.StorableVector.Lazy as SVL+import Foreign.Storable (peek, )++import qualified Options.Applicative.Types as OPInt+import qualified Options.Applicative as OP+import Control.Applicative ((<*>), )++import qualified System.FilePath as FilePath+import qualified System.Directory as Dir+import qualified System.Exit as Exit+import qualified System.IO as IO+import System.FilePath ((</>))++import qualified Data.NonEmpty as NonEmpty+import Data.NonEmpty ((!:), )+import Data.Maybe (fromMaybe, )+import Data.Monoid ((<>), )++import Data.Int (Int32, )+++summaryName :: FilePath -> String+summaryName path = FilePath.dropExtension path ++ "_data"++waveSummary ::+   ProjectWaveSummary.Handle ->+   Int -> FilePath -> SVL.Vector Int32 ->+   IO [ProjectWaveTrack.Sequence]+waveSummary sh numChan input sig = do+   cwd <- Dir.getCurrentDirectory+   ProjectWaveSummary.usingHandle sh .+      ProjectWaveTrack.pcmAliasSequencesFromStorableVectorChannels+         ProjectWaveTrack.Interleaved 262144 (cwd </> input) .+      SVL.deinterleave numChan .+      SVL.map (\x -> fromIntegral x / 2^(31::Int))+         $ sig+++defaultSampleRate :: SoxLib.Rate+defaultSampleRate = 44100+++withSound ::+   FilePath ->+   (SoxLib.Format SoxLib.ReadMode ->+    Maybe SoxLib.Rate -> Int -> SVL.Vector Int32 -> IO a) ->+   IO a+withSound path act =+   SoxLib.withRead SoxLib.defaultReaderInfo path $ \fmtPtr -> do+      fmt <- peek fmtPtr+      let sigInfo = SoxLib.signalInfo fmt+          numChan = fromMaybe 1 $ SoxLib.channels sigInfo+          rate = SoxLib.rate sigInfo+      act fmt rate numChan =<<+         SoxLib.readStorableVectorLazy fmtPtr+            (case SVL.defaultChunkSize of+               SVL.ChunkSize size -> SVL.ChunkSize $ numChan * size)+++writerInfoFromFormat ::+   SoxLib.Format mode -> SoxLib.WriterInfo+writerInfoFromFormat fmtIn =+   SoxLib.defaultWriterInfo {+      SoxLib.writerSignalInfo = Just $ SoxLib.signalInfo fmtIn+   }+++exitFailureMsg :: String -> IO a+exitFailureMsg msg = do+   IO.hPutStrLn IO.stderr msg+   Exit.exitFailure+++some :: OP.Parser a -> OP.Parser (NonEmpty.T [] a)+some p = OPInt.fromM $ OP.liftA2 (!:) (OPInt.oneM p) (OPInt.manyM p)++parseArgs :: OP.Parser (NonEmpty.T [] String, String)+parseArgs =+   OP.liftA2 (,)+      (some (OP.strArgument (OP.metavar "SRC")))+      (OP.strOption (OP.long "output" <> OP.metavar "DST"))++info :: String -> OP.Parser a -> OP.ParserInfo a+info desc parser =+   OP.info+      (OP.helper <*> parser)+      (OP.fullDesc <> OP.progDesc desc)++multiArgs :: String -> IO (NonEmpty.T [] String, String)+multiArgs desc = OP.execParser $ info desc parseArgs

@@ -1,64 +1,25 @@ module Main where +import Common (defaultSampleRate, multiArgs, withSound, writerInfoFromFormat, )+ import qualified Sound.Audacity.LabelTrack as LabelTrack import qualified Sound.SoxLib as SoxLib  import qualified Data.StorableVector.Lazy as SVL-import Foreign.Storable (peek, )  import Control.Monad (when, liftM2, )  import qualified Data.NonEmpty.Class as NonEmptyC import qualified Data.NonEmpty as NonEmpty import Data.Traversable (forM, )-import Data.NonEmpty ((!:), ) import Data.Maybe (fromMaybe, )  import qualified System.FilePath as FilePath-import qualified System.Exit as Exit-import qualified System.IO as IO-import System.Environment (getArgs, ) import System.FilePath ((<.>), ) import Text.Printf (printf, ) -import Data.Int (Int32, )  --exitFailureMsg :: String -> IO a-exitFailureMsg msg = do-   IO.hPutStrLn IO.stderr msg-   Exit.exitFailure---defaultSampleRate :: SoxLib.Rate-defaultSampleRate = 44100--withSound ::-   FilePath ->-   (SoxLib.Format SoxLib.ReadMode ->-    Maybe SoxLib.Rate -> Int -> SVL.Vector Int32 -> IO a) ->-   IO a-withSound path act =-   SoxLib.withRead SoxLib.defaultReaderInfo path $ \fmtPtr -> do-      fmt <- peek fmtPtr-      let sigInfo = SoxLib.signalInfo fmt-          numChan = fromMaybe 1 $ SoxLib.channels sigInfo-          rate = SoxLib.rate sigInfo-      act fmt rate numChan =<<-         SoxLib.readStorableVectorLazy fmtPtr-            (case SVL.defaultChunkSize of-               SVL.ChunkSize size -> SVL.ChunkSize $ numChan * size)---writerInfoFromFormat ::-   SoxLib.Format mode -> SoxLib.WriterInfo-writerInfoFromFormat fmtIn =-   SoxLib.defaultWriterInfo {-      SoxLib.writerSignalInfo = Just $ SoxLib.signalInfo fmtIn-   }-- run :: NonEmpty.T [] FilePath -> FilePath -> IO () run neInputs@(NonEmpty.Cons input0 inputs) output = do    let write fmtOut numChan sig = do@@ -91,12 +52,6 @@   main :: IO ()-main = do-   args <- getArgs--   case args of-      arg0 : arg1 : remArgs ->-         case NonEmpty.viewR $ arg0 !: arg1 !: remArgs of-            (inputs, output) -> SoxLib.formatWith $ run inputs output-      [_] -> exitFailureMsg "output file missing"-      [] -> exitFailureMsg "input and output files missing"+main =+   SoxLib.formatWith $+   uncurry run =<< multiArgs "Concatenate audio files and track origins"

@@ -13,16 +13,21 @@ import Data.Tuple.HT (mapFst, mapSnd, mapPair)  import qualified Prelude as P-import Prelude hiding (readFile, writeFile)+import Prelude hiding (readFile, writeFile, null)   newtype T time label = Cons {decons :: [Interval time label]} +instance (Show time, Show label) => Show (T time label) where+   showsPrec p (Cons xs) =+      showParen (p>10) $ showString "LabelTrack.Cons " . shows xs++ type Interval time label = ((time, time), label)   instance Functor (T time) where-   fmap f = Cons . map (mapSnd f) . decons+   fmap f = lift $ map (mapSnd f)  instance Fold.Foldable (T time) where    foldMap f = Fold.foldMap (f . snd) . decons@@ -43,6 +48,9 @@ empty :: T time label empty = Cons [] +null :: T time label -> Bool+null = P.null . decons+ singleton :: (time,time) -> label -> T time label singleton bnds label = Cons [(bnds, label)] @@ -68,6 +76,10 @@ Format the times using a comma, which is certainly only correct in German locale. -}+{-+ToDo: find out, how Audacity formats the labels.+In the project XML file format, the numbers are formatted with decimal points.+-} formatTime :: (RealFrac time) => time -> String formatTime t =    let million = 10^(6::Int)@@ -79,13 +91,29 @@ This is not checked. -} mapTime :: (time0 -> time1) -> T time0 label -> T time1 label-mapTime f  =  Cons . map (mapFst $ mapPair (f, f)) . decons+mapTime f  =  lift $ map (mapFst $ mapPair (f, f)) +mapWithTime ::+   ((time, time) -> label0 -> label1) -> T time label0 -> T time label1+mapWithTime f  =  lift $ map (\(bnd, lab) -> (bnd, f bnd lab))+ realTimes ::    (Fractional time) =>-   time -> T Int String -> T time String+   time -> T Int label -> T time label realTimes sampleRate =    mapTime (\t -> fromIntegral t / sampleRate)++mask :: (Ord time) => (time, time) -> T time label -> T time label+mask (from,to) =+   lift $+      filter (uncurry (<) . fst) .+      map (mapFst (mapPair (max from, min to)))+++zipWithList ::+   (label0 -> label1 -> label2) -> [label0] -> T time label1 -> T time label2+zipWithList f xs = lift $ zipWith (\x (bnd, y) -> (bnd, f x y)) xs+  writeFile :: (RealFrac time) => FilePath -> T time String -> IO () writeFile path intervals =

@@ -0,0 +1,73 @@+module Sound.Audacity.Project where++import qualified Sound.Audacity.Project.Track.Label as LabelTrack+import qualified Sound.Audacity.Project.Track.Wave as WaveTrack+import qualified Sound.Audacity.XML.Attribute as Attr+import qualified Sound.Audacity.XML as XML++import qualified Text.HTML.Tagchup.Format as Format+import qualified Text.HTML.Tagchup.Tag as Tag+import qualified Text.XML.Basic.ProcessingInstruction as PI+import qualified Text.XML.Basic.Name.MixedCase as Name+import qualified Text.XML.Basic.Tag as XmlTag+++data T =+   Cons {+      name_ :: String,+      selectionStart_, selectionEnd_ :: Double,+      vpos_ :: Int,+      h_ :: Double,+      zoom_ :: Double,+      rate_ :: Double,+      tracks_ :: [Track]+   }++deflt :: T+deflt =+   Cons {+      name_ = "",+      selectionStart_ = 0, selectionEnd_ = 0,+      vpos_ = 0,+      h_ = 0,+      zoom_ = 1,+      rate_ = 44100,+      tracks_ = []+   }+++data Track =+     WaveTrack WaveTrack.T+   | LabelTrack LabelTrack.T+++format :: T -> ShowS+format x =+   Format.xmlCondensed (XML.unlines $ toXML x)++toXML :: T -> [[Tag.T Name.T String]]+toXML x =+   [Tag.processing XmlTag.xmlName $ PI.Known $+      XML.attr "version" "1.0" :+      XML.attr "standalone" "no" :+      []] :+   [Tag.special XmlTag.doctypeName $+      "project PUBLIC \"-//audacityproject-1.3.0//DTD//EN\" " +++      "\"http://audacity.sourceforge.net/xml/audacityproject-1.3.0.dtd\""] :+   XML.tag "project" x+     (Attr.string "xmlns" (const "http://audacity.sourceforge.net/xml/") :+      Attr.string "projname" name_ :+      Attr.string "version" (const "1.3.0") :+      Attr.string "audacityversion" (const "2.0.0") :+      Attr.double "sel0" selectionStart_ :+      Attr.double "sel1" selectionEnd_ :+      Attr.int "vpos" vpos_ :+      Attr.double "h" h_ :+      Attr.double "zoom" zoom_ :+      Attr.double "rate" rate_ :+      [])+     (concatMap trackToXML (tracks_ x))++trackToXML :: Track -> [[Tag.T Name.T String]]+trackToXML (LabelTrack x) = LabelTrack.toXML x+trackToXML (WaveTrack x) = WaveTrack.toXML x

@@ -0,0 +1,117 @@+module Sound.Audacity.Project.Track.Label where++import qualified Sound.Audacity.LabelTrack as LabelTrack+import qualified Sound.Audacity.XML.Attribute as Attr+import qualified Sound.Audacity.XML.Parser as Parser+import qualified Sound.Audacity.XML as XML++import qualified Text.HTML.Tagchup.Tag as Tag+import qualified Text.HTML.Tagchup.Tag.Match as TagMatch+import qualified Text.XML.Basic.Name.MixedCase as Name++import Text.Printf (printf)++import qualified Control.Monad.Trans.State as MS+import qualified Control.Monad.Trans.Maybe as MM+import qualified Control.Monad.Exception.Synchronous as ME+import Control.Applicative (many, (<*))++import qualified Data.NonEmpty.Mixed as NonEmptyM+import qualified Data.NonEmpty as NonEmpty+import Data.Maybe (mapMaybe)+++data T =+   Cons {+      name_ :: String,+      height_ :: Int,+      minimized_ :: Bool,+      track_ :: LabelTrack.T Double String+   }+   deriving (Show)++deflt :: T+deflt =+   Cons {+      name_ = "",+      height_ = 100,+      minimized_ = False,+      track_ = LabelTrack.empty+   }+++toXML :: T -> [[Tag.T Name.T String]]+toXML x =+   XML.tag "labeltrack" x+      (Attr.string "name" name_ :+       Attr.int "numlabels" (length . LabelTrack.decons . track_) :+       Attr.int "height" height_ :+       Attr.bool "minimized" minimized_ :+       [])+      $+      map intervalToXML (LabelTrack.decons $ track_ x)++{-+nanosecond precision as in ALSA+-}+intervalToXML :: LabelTrack.Interval Double String -> [Tag.T Name.T String]+intervalToXML ((from,to), title) =+   (Tag.open labelName $+      XML.attr "t"  (printf "%.9f" from) :+      XML.attr "t1" (printf "%.9f" to) :+      XML.attr "title" title :+      []) :+   Tag.close labelName :+   []+++maybeExc ::+   MM.MaybeT (ME.Exceptional Parser.Message) a ->+   Maybe (ME.Exceptional Parser.Message a)+maybeExc (MM.MaybeT act) =+   case act of+      ME.Exception msg -> Just $ ME.Exception msg+      ME.Success ma -> fmap ME.Success ma++tracksFromXML :: [Tag.T Name.T String] -> ME.Exceptional Parser.Message [T]+tracksFromXML =+   sequence . mapMaybe (maybeExc . MS.evalStateT parse . NonEmpty.flatten) .+   snd . NonEmptyM.segmentBefore (TagMatch.open (labeltrackName==) (const True))++{- |+Currently we ignore the 'numlabels' attribute.+Alternatively we could check whether that value matches+the number of read intervals.+-}+parse :: Parser.T T+parse = do+   attrs <- Parser.tagOpen labeltrackName+   name <- Parser.lookupAttr "name" attrs+   height <- Parser.lookupAttrRead "height" attrs+   minimized <- Parser.lookupAttrBool "minimized" attrs+   Parser.skipSpaces+   intervals <- many (parseInterval <* Parser.skipSpaces)+   Parser.tagClose labeltrackName+   return $+      Cons {+         name_ = name,+         height_ = height,+         minimized_ = minimized,+         track_ = LabelTrack.Cons intervals+      }++parseInterval :: Parser.T (LabelTrack.Interval Double String)+parseInterval = do+   attrs <- Parser.tagOpen labelName+   from <- Parser.lookupAttrRead "t" attrs+   to <- Parser.lookupAttrRead "t1" attrs+   title <- Parser.lookupAttr "title" attrs+   Parser.tagClose labelName+   return ((from, to), title)+++labelName :: Tag.Name Name.T+labelName = Tag.Name $ Name.Cons "label"++labeltrackName :: Tag.Name Name.T+labeltrackName = Tag.Name $ Name.Cons "labeltrack"

@@ -0,0 +1,325 @@+module Sound.Audacity.Project.Track.Wave where++import qualified Sound.Audacity.Project.Track.Wave.Summary as Summary++import qualified Sound.Audacity.XML.Attribute as Attr+import qualified Sound.Audacity.XML as XML++import qualified Text.HTML.Tagchup.Tag as Tag+import qualified Text.XML.Basic.Name.MixedCase as Name++import qualified Data.ByteString.Char8 as BS+import Text.Printf (printf)++import qualified System.IO as IO+import System.Directory (createDirectoryIfMissing)+import System.FilePath ((</>))++import qualified Data.StorableVector.Lazy as SVL++import qualified Data.NonEmpty as NonEmpty+import qualified Data.List as List+import Data.NonEmpty ((!:))+import Data.Tuple.HT (mapSnd)++import qualified Control.Monad.Trans.Reader as MR+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad (liftM)+++import Prelude hiding (sequence_)+++data T =+   Cons {+      name_ :: String,+      channel_ :: Channel,+      linked_, mute_, solo_, minimized_ :: Bool,+      height_ :: Int,+      rate_ :: Int,+      gain_, pan_ :: Double,+      clips_ :: [Clip]+   }+   deriving Show++deflt :: T+deflt =+   Cons {+      name_ = "",+      channel_ = Mono,+      linked_ = False, mute_ = False, solo_ = False,+      minimized_ = False,+      height_ = 150,+      rate_ = 44100,+      gain_ = 1.0,+      pan_ = 0.0,+      clips_ = []+   }++data Channel = Left | Right | Mono+   deriving (Eq, Ord, Enum, Show)+++data Clip =+   Clip {+      offset_ :: Double,+      sequence_ :: Sequence+      -- envelope_ :: Envelope+   }+   deriving Show+++data Sequence =+   Sequence {+      maxSamples_ :: Int,+      -- the sampleformat attribute seems to have no effect+      sampleFormat_ :: SampleFormat,+      numSamples_ :: Int,+      blocks_ :: [Block]+   }+   deriving Show++-- cf. audacity:SampleFormat.h+data SampleFormat = Int16Sample | Int24Sample | FloatSample+   deriving (Eq, Ord, Enum, Bounded, Show)++intFromSampleFormat :: SampleFormat -> Int+intFromSampleFormat fmt =+   case fmt of+      Int16Sample -> 0x00020001+      Int24Sample -> 0x00040001+      FloatSample -> 0x0004000F+++data Block =+   Block {+      blockStart_, blockLength_ :: Int,+      blockFile_ :: BlockFile+   }+   deriving Show++data BlockFile =+   PCMAliasBlockFile {+      summaryFile_, aliasFile_ :: FilePath,+      aliasStart_ :: Int,+      -- aliasLength_ :: Int,   replaced by blockLength+      aliasChannel_ :: Int,+      limits_ :: Summary.Limits+   }+   deriving Show+++toXML :: T -> [[Tag.T Name.T String]]+toXML x =+   XML.tag "wavetrack" x+      (Attr.string "name" name_ :+       Attr.enum "channel" channel_ :+       Attr.bool "linked" linked_ :+       Attr.bool "mute" mute_ :+       Attr.bool "solo" solo_ :+       Attr.int "height" height_ :+       Attr.bool "minimized" minimized_ :+       Attr.int "rate" rate_ :+       Attr.double "gain" gain_ :+       Attr.double "pan" pan_ :+       [])+      (concatMap clipToXML (clips_ x))++clipToXML :: Clip -> [[Tag.T Name.T String]]+clipToXML x =+   XML.tag "waveclip" x+      (Attr.string "offset" (printf "%.8f" . offset_) :+       [])+      (sequenceToXML (sequence_ x))++sequenceToXML :: Sequence -> [[Tag.T Name.T String]]+sequenceToXML x =+   XML.tag "sequence" x+      (Attr.int "maxsamples" maxSamples_ :+       Attr.int "numsamples" numSamples_ :+       Attr.int "sampleformat" (intFromSampleFormat . sampleFormat_) :+       [])+      (concatMap blockToXML (blocks_ x))++blockToXML :: Block -> [[Tag.T Name.T String]]+blockToXML x =+   XML.tag "waveblock" x+      (Attr.int "start" blockStart_ :+       [])+   $+   XML.tag "pcmaliasblockfile" x+      (Attr.string "summaryfile" (summaryFile_ . blockFile_) :+       Attr.string "aliasfile" (aliasFile_ . blockFile_) :+       Attr.int "aliasstart" (aliasStart_ . blockFile_) :+       Attr.int "aliaslen" blockLength_ :+       Attr.int "aliaschannel" (aliasChannel_ . blockFile_) :+       Attr.float "min" (Summary.min_ . limits_ . blockFile_) :+       Attr.float "max" (Summary.max_ . limits_ . blockFile_) :+       Attr.float "rms" (Summary.rms_ . limits_ . blockFile_) :+       [])+      []+++{- |+@maxSamples_@ must be at least 1024,+otherwise you get an error about clip values+if you load the project to Audacity.+However, 1024 is not necessarily a good value.+Audacity uses 524288 by default.+-}+{-+Alternatively we could omit the @maxsamples@ attribute+when writing the XML file.+The DTD says that the @maxsamples@ attribute is required,+but Audacity accepts when it is missing.+-}+pcmAliasSequence ::+   (Monad m) =>+   SampleFormat -> Int -> Int -> FilePath -> Int -> Summary.Monad m Sequence+pcmAliasSequence fmt blockSize totalSize path channel =+   liftM+      (\bs ->+         Sequence {+            maxSamples_ = blockSize,+            numSamples_ = totalSize,+            sampleFormat_ = fmt,+            blocks_ = bs+         }) $+   mapM+      (\start -> do+         (Summary.State n) <- Summary.reserve+         return $+            Block {+               blockStart_ = start,+               blockLength_ = min totalSize (start+blockSize) - start,+               blockFile_ =+                  PCMAliasBlockFile {+                     summaryFile_ = printf "e%05x.auf" n,+                     aliasFile_ = path,+                     aliasStart_ = start,+                     aliasChannel_ = channel,+                     limits_ = Summary.defltLimits+                  }+            }) $+   takeWhile (<totalSize) $+   iterate (blockSize+) 0++pcmAliasSequenceFromStorableVector ::+   (MonadIO m) =>+   Int -> FilePath -> Int -> SVL.Vector Float -> Summary.Monad m Sequence+pcmAliasSequenceFromStorableVector blockSize aliasFile channel =+   liftM (sequenceFromBlocksSize blockSize) .+   mapM (uncurry $ storeSummary aliasFile channel) .+   Summary.attachStarts .+   Summary.sequenceFromStorableVector blockSize++pcmAliasSequenceFromSummary ::+   (MonadIO m) =>+   FilePath -> Int -> [Summary.T] -> Summary.Monad m Sequence+pcmAliasSequenceFromSummary aliasFile channel =+   liftM sequenceFromBlocks .+   mapM (uncurry $ storeSummary aliasFile channel) .+   Summary.attachStarts+++{- |+This type lets you specify how to order blocks of multi-channel sounds.+Both orders always work but Haskell's garbage collector works best,+if the order matches the order of the data production.+-}+data BlockOrder =+     Serial+       {- ^ All blocks of a channel are stored adjacently. -}+   | Interleaved+       {- ^ Blocks of channels are interleaved. -}+   deriving (Eq, Ord, Show, Enum, Bounded)+++{- |+It is an unchecked error if StorableVectors have different lengths.+-}+pcmAliasSequencesFromStorableVectorChannels ::+   (MonadIO m) =>+   BlockOrder ->+   Int -> FilePath -> [SVL.Vector Float] -> Summary.Monad m [Sequence]+pcmAliasSequencesFromStorableVectorChannels order blockSize aliasFile =+   liftM (map (sequenceFromBlocksSize blockSize)) .+   blocksFromChannelSummaries order aliasFile .+   map (Summary.sequenceFromStorableVector blockSize)+++pcmAliasSequencesFromChannelSummaries ::+   (MonadIO m) =>+   BlockOrder -> FilePath -> [[Summary.T]] -> Summary.Monad m [Sequence]+pcmAliasSequencesFromChannelSummaries order aliasFile =+   liftM (map sequenceFromBlocks) .+   blocksFromChannelSummaries order aliasFile++blocksFromChannelSummaries ::+   (MonadIO m) =>+   BlockOrder -> FilePath -> [[Summary.T]] -> Summary.Monad m [[Block]]+blocksFromChannelSummaries order aliasFile =+   let applyOrder f =+         case order of+            Serial -> f+            Interleaved -> liftM List.transpose . f . List.transpose+   in  applyOrder+         (mapM+            (mapM+               (\(channel, startBlock) ->+                  uncurry (storeSummary aliasFile channel) startBlock))) .+       zipWith (\channel -> map ((,) channel)) (iterate (1+) 0) .+       map Summary.attachStarts+++sequenceFromBlocks :: [Block] -> Sequence+sequenceFromBlocks bs =+   let lens = map blockLength_ bs+   in  Sequence {+          maxSamples_ = NonEmpty.maximum $ 1024 !: lens,+          numSamples_ = sum lens,+          sampleFormat_ = FloatSample,+          blocks_ = bs+       }++sequenceFromBlocksSize :: Int -> [Block] -> Sequence+sequenceFromBlocksSize blockSize bs =+   Sequence {+      maxSamples_ = blockSize,+      numSamples_ = sum $ map blockLength_ bs,+      sampleFormat_ = FloatSample,+      blocks_ = bs+   }+++storeSummary ::+   MonadIO m =>+   FilePath -> Int -> Int -> Summary.T -> Summary.Monad m Block+storeSummary aliasFile channel start+   (Summary.Cons {+      Summary.length_ = len, Summary.limits_ = limits,+      Summary.content_ = cont}) = do+   (Summary.State n) <- Summary.reserve+   summaryDir <- MR.ask+   let fileName = printf "e%07x.auf" n+   let dirName =+         case mapSnd (take 2) $ splitAt 3 fileName of+            (e, d) -> summaryDir </> e </> 'd':d+   liftIO $ do+      createDirectoryIfMissing True dirName+      IO.withBinaryFile (dirName </> fileName) IO.WriteMode $ \h -> do+         BS.hPut h $ BS.pack "AudacityBlockFile112"+         SVL.hPut h cont+   return $+      Block {+         blockStart_ = start,+         blockLength_ = len,+         blockFile_ =+            PCMAliasBlockFile {+               summaryFile_ = fileName,+               aliasFile_ = aliasFile,+               aliasStart_ = start,+               aliasChannel_ = channel,+               limits_ = limits+            }+      }

@@ -0,0 +1,141 @@+module Sound.Audacity.Project.Track.Wave.Summary where++import qualified Data.StorableVector.Lazy as SVL+import qualified Data.StorableVector as SV+import Foreign.Storable.Record as Store+import Foreign.Storable (Storable (..), )++import qualified Data.List.HT as ListHT+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.Tuple.HT (mapPair)++import qualified Control.Monad.Trans.State as MS+import qualified Control.Monad.Trans.Reader as MR+import qualified Control.Monad.Trans.Class as MT+import qualified Control.Monad as M+import Control.DeepSeq (NFData, rnf, ($!!), )+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Applicative (liftA3, )++import Prelude hiding (Monad, )+++newtype State = State Int+type Monad m = MR.ReaderT FilePath (MS.StateT State m)++eval :: (M.Monad m) => FilePath -> Monad m a -> m a+eval path =+   flip MS.evalStateT (State 0) . flip MR.runReaderT path+++data Handle = Handle FilePath (IORef State)++createHandle :: FilePath -> IO Handle+createHandle path =+   fmap (Handle path) $ newIORef $ State 0++deleteHandle :: Handle -> IO ()+deleteHandle _ = return ()++withHandle :: FilePath -> (Handle -> IO a) -> IO a+withHandle path act =+   createHandle path >>= act++usingHandle :: (MonadIO io) => Handle -> Monad io a -> io a+usingHandle (Handle path stateRef) act = do+   oldState <- liftIO $ readIORef stateRef+   (a, newState) <- flip MS.runStateT oldState $ flip MR.runReaderT path act+   liftIO $ writeIORef stateRef newState+   return a+++data T =+   Cons {+      length_ :: Int,+      limits_ :: Limits,+      content_ :: SVL.Vector Limits+   }+   deriving Show++instance NFData T where+   rnf (Cons len limits dat) = rnf (len, limits, dat)+++fromBlock :: SVL.Vector Float -> T+fromBlock block =+   let sum256 = map accumulate $ SVL.sliceVertical 256 block+       sum65536 = map reduce $ ListHT.sliceVertical 256 sum256+       accumTmp@(_, (_, len)) = reduce sum65536+   in  Cons {+          length_ = len,+          limits_ = limitsFromAccumulators accumTmp,+          content_ =+             SVL.fromChunks $+                (SV.pack $ map limitsFromAccumulators sum256) :+                (SV.pack $ map limitsFromAccumulators sum65536) :+                []+       }+++attachStarts :: [T] -> [(Int, T)]+attachStarts xs =+   zipWith+      (\ start block -> ((,) $!! start) block)+      (scanl (+) 0 $ map length_ xs) xs++sequenceFromStorableVector :: Int -> SVL.Vector Float -> [T]+sequenceFromStorableVector blockSize =+   map fromBlock . SVL.sliceVertical blockSize+++reserve :: (M.Monad m) => Monad m State+reserve = MT.lift $ do+   s@(State n) <- MS.get+   MS.put $ State (n+1)+   return s++++data Limits = Limits {min_, max_, rms_ :: Float}+   deriving Show++instance NFData Limits where+   rnf (Limits ymin ymax yrms) = rnf (ymin, ymax, yrms)++defltLimits :: Limits+defltLimits = Limits {min_ = -1, max_ = 1, rms_ = 0.2}++storeLimits :: Store.Dictionary Limits+storeLimits =+   Store.run $+   liftA3 Limits+      (Store.element min_)+      (Store.element max_)+      (Store.element rms_)++instance Storable Limits where+   sizeOf = Store.sizeOf storeLimits+   alignment = Store.alignment storeLimits+   peek = Store.peek storeLimits+   poke = Store.poke storeLimits++++summary :: Int -> SVL.Vector Float -> SV.Vector Limits+summary chunkSize =+   SV.pack . map (limitsFromAccumulators . accumulate) .+   SVL.sliceVertical chunkSize++reduce :: [((Float, Float), (Float, Int))] -> ((Float, Float), (Float, Int))+reduce xs =+   let ((xmin, xmax), (xsqr, len)) = mapPair (unzip, unzip) $ unzip xs+   in  ((minimum xmin, maximum xmax), (sum xsqr, sum len))++limitsFromAccumulators :: ((Float, Float), (Float, Int)) -> Limits+limitsFromAccumulators ((xmin, xmax), (xsqr, len)) =+   Limits xmin xmax (sqrt (xsqr / fromIntegral len))++accumulate :: SVL.Vector Float -> ((Float, Float), (Float, Int))+accumulate chunk =+   ((SVL.foldl' min 1 chunk, SVL.foldl' max (-1) chunk),+    (SVL.foldl' (+) 0 (SVL.map (^(2::Int)) chunk), SVL.length chunk))

@@ -0,0 +1,45 @@+module Sound.Audacity.XML where++import qualified Text.HTML.Tagchup.Tag as Tag+import qualified Text.XML.Basic.Attribute as Attr+import qualified Text.XML.Basic.Name.MixedCase as Name++import qualified Data.List as List++import Prelude hiding (unlines)+++tag ::+   String -> a ->+   [Attr.T Name.T (a -> String)] ->+   [[Tag.T Name.T String]] ->+   [[Tag.T Name.T String]]+tag name x attrs enclosed =+   let tagName = Tag.Name $ Name.Cons name+   in  [Tag.open tagName $ Attr.mapValues ($x) attrs] :+       enclosed +++       [Tag.close tagName] :+       []++attr :: String -> a -> Attr.T Name.T a+attr name value  =  Attr.cons (Attr.Name $ Name.Cons name) value++unlines :: [[Tag.T Name.T String]] -> [Tag.T Name.T String]+unlines =+   concat . snd .+   List.mapAccumL+      (\oldIndent tags ->+         let newIndent = oldIndent + sum (map tagIndent tags)+         in  (newIndent,+              Tag.text (replicate (min oldIndent newIndent) '\t') :+              tags +++              Tag.text "\n" :+              []))+      0++tagIndent :: Tag.T Name.T String -> Int+tagIndent t =+   case t of+      Tag.Open _ _ -> 1+      Tag.Close _ -> -1+      _ -> 0

@@ -0,0 +1,25 @@+module Sound.Audacity.XML.Attribute where++import qualified Sound.Audacity.XML as XML++import qualified Text.XML.Basic.Attribute as Attr+import qualified Text.XML.Basic.Name.MixedCase as Name+++string :: String -> (a -> String) -> Attr.T Name.T (a -> String)+string  =  XML.attr++bool :: String -> (a -> Bool) -> Attr.T Name.T (a -> String)+bool = enum++enum :: (Enum b) => String -> (a -> b) -> Attr.T Name.T (a -> String)+enum name value  =  XML.attr name (show . fromEnum . value)++int :: String -> (a -> Int) -> Attr.T Name.T (a -> String)+int name value  =  XML.attr name (show . value)++float :: String -> (a -> Float) -> Attr.T Name.T (a -> String)+float name value  =  XML.attr name (show . value)++double :: String -> (a -> Double) -> Attr.T Name.T (a -> String)+double name value  =  XML.attr name (show . value)

@@ -0,0 +1,80 @@+module Sound.Audacity.XML.Parser where++import qualified Text.HTML.Tagchup.Tag as Tag+import qualified Text.XML.Basic.Attribute as Attr+import qualified Text.XML.Basic.Name.MixedCase as Name++import Text.Printf (printf)++import qualified Control.Monad.Trans.State as MS+import qualified Control.Monad.Trans.Maybe as MM+import qualified Control.Monad.Trans.Class as MT+import qualified Control.Monad.Exception.Synchronous as ME+import Control.Monad (MonadPlus, void, when, guard, mzero)+import Control.Applicative (many)++import qualified Data.List.HT as ListHT+import Data.String.HT (trim)+import Data.Char (isSpace)+++type T = MS.StateT [Tag.T Name.T String] (MM.MaybeT (ME.Exceptional Message))+type Message = String+++tag :: T (Tag.T Name.T String)+tag = MS.StateT $ MM.MaybeT . return . ListHT.viewL++fromMaybeGen :: (MonadPlus m) => Maybe a -> m a+fromMaybeGen = maybe mzero return++fromMaybe :: Maybe a -> T a+fromMaybe = MT.lift . MM.MaybeT . return++tagOpen :: Tag.Name Name.T -> T [Attr.T Name.T String]+tagOpen name = do+   x <- tag+   (foundName, attrs) <- fromMaybe $ Tag.maybeOpen x+   guard $ foundName == name+   return attrs++tagClose :: Tag.Name Name.T -> T ()+tagClose name = do+   x <- tag+   foundName <- fromMaybe $ Tag.maybeClose x+   guard $ foundName == name++lookupAttr :: String -> [Attr.T Name.T String] -> T String+lookupAttr name attrs =+   MT.lift $ MT.lift $+      ME.fromMaybe+         (printf "did not find attribute %s in%s"+            name (Attr.formatListBlankHead attrs "")) $+      Attr.lookupLit name attrs++lookupAttrRead :: (Read a) => String -> [Attr.T Name.T String] -> T a+lookupAttrRead name attrs = do+   str <- lookupAttr name attrs+   case reads str of+      [(x, "")] -> return x+      _ ->+         MT.lift $ MT.lift $ ME.throw $+            "could not parse attribute value " ++ str++lookupAttrBool :: String -> [Attr.T Name.T String] -> T Bool+lookupAttrBool name attrs = do+   str <- lookupAttr name attrs+   case str of+      "0" -> return False+      "1" -> return True+      _ -> MT.lift $ MT.lift $ ME.throw $ "not a bool value: " ++ str++skipSpace :: T ()+skipSpace = do+   x <- tag+   text <- fromMaybe $ Tag.maybeText x+   when (not $ all isSpace text) $ MT.lift $ MT.lift $+      ME.throw $ "expected spaces, but found: " ++ show (trim text)++skipSpaces :: T ()+skipSpaces = void $ many skipSpace