diff --git a/audacity.cabal b/audacity.cabal
--- a/audacity.cabal
+++ b/audacity.cabal
@@ -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
diff --git a/example/Bundle.hs b/example/Bundle.hs
new file mode 100644
--- /dev/null
+++ b/example/Bundle.hs
@@ -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"
diff --git a/example/Combine.hs b/example/Combine.hs
new file mode 100644
--- /dev/null
+++ b/example/Combine.hs
@@ -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"
diff --git a/example/Common.hs b/example/Common.hs
new file mode 100644
--- /dev/null
+++ b/example/Common.hs
@@ -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
diff --git a/example/Concatenate.hs b/example/Concatenate.hs
--- a/example/Concatenate.hs
+++ b/example/Concatenate.hs
@@ -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"
diff --git a/src/Sound/Audacity/LabelTrack.hs b/src/Sound/Audacity/LabelTrack.hs
--- a/src/Sound/Audacity/LabelTrack.hs
+++ b/src/Sound/Audacity/LabelTrack.hs
@@ -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 =
diff --git a/src/Sound/Audacity/Project.hs b/src/Sound/Audacity/Project.hs
new file mode 100644
--- /dev/null
+++ b/src/Sound/Audacity/Project.hs
@@ -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
diff --git a/src/Sound/Audacity/Project/Track/Label.hs b/src/Sound/Audacity/Project/Track/Label.hs
new file mode 100644
--- /dev/null
+++ b/src/Sound/Audacity/Project/Track/Label.hs
@@ -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"
diff --git a/src/Sound/Audacity/Project/Track/Wave.hs b/src/Sound/Audacity/Project/Track/Wave.hs
new file mode 100644
--- /dev/null
+++ b/src/Sound/Audacity/Project/Track/Wave.hs
@@ -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
+            }
+      }
diff --git a/src/Sound/Audacity/Project/Track/Wave/Summary.hs b/src/Sound/Audacity/Project/Track/Wave/Summary.hs
new file mode 100644
--- /dev/null
+++ b/src/Sound/Audacity/Project/Track/Wave/Summary.hs
@@ -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))
diff --git a/src/Sound/Audacity/XML.hs b/src/Sound/Audacity/XML.hs
new file mode 100644
--- /dev/null
+++ b/src/Sound/Audacity/XML.hs
@@ -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
diff --git a/src/Sound/Audacity/XML/Attribute.hs b/src/Sound/Audacity/XML/Attribute.hs
new file mode 100644
--- /dev/null
+++ b/src/Sound/Audacity/XML/Attribute.hs
@@ -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)
diff --git a/src/Sound/Audacity/XML/Parser.hs b/src/Sound/Audacity/XML/Parser.hs
new file mode 100644
--- /dev/null
+++ b/src/Sound/Audacity/XML/Parser.hs
@@ -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