module Sound.Audacity.Project.Track.Label (
   T (Cons, name_, height_, minimized_, track_),
   deflt,
   toXML,
   intervalToXML,
   tracksFromXML,
   parse,
   parseInterval,
   labelName,
   labeltrackName,
   ) 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 {
      T -> String
name_ :: String,
      T -> Int
height_ :: Int,
      T -> Bool
minimized_ :: Bool,
      T -> T Double String
track_ :: LabelTrack.T Double String
   }
   deriving (Int -> T -> ShowS
[T] -> ShowS
T -> String
(Int -> T -> ShowS) -> (T -> String) -> ([T] -> ShowS) -> Show T
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [T] -> ShowS
$cshowList :: [T] -> ShowS
show :: T -> String
$cshow :: T -> String
showsPrec :: Int -> T -> ShowS
$cshowsPrec :: Int -> T -> ShowS
Show)

deflt :: T
deflt :: T
deflt =
   Cons :: String -> Int -> Bool -> T Double String -> T
Cons {
      name_ :: String
name_ = String
"",
      height_ :: Int
height_ = Int
100,
      minimized_ :: Bool
minimized_ = Bool
False,
      track_ :: T Double String
track_ = T Double String
forall time label. T time label
LabelTrack.empty
   }


toXML :: T -> [[Tag.T Name.T String]]
toXML :: T -> [[T T String]]
toXML T
x =
   String
-> T -> [T T (T -> String)] -> [[T T String]] -> [[T T String]]
forall a.
String
-> a -> [T T (a -> String)] -> [[T T String]] -> [[T T String]]
XML.tag String
"labeltrack" T
x
      (String -> (T -> String) -> T T (T -> String)
forall a. String -> (a -> String) -> T T (a -> String)
Attr.string String
"name" T -> String
name_ T T (T -> String) -> [T T (T -> String)] -> [T T (T -> String)]
forall a. a -> [a] -> [a]
:
       String -> (T -> Int) -> T T (T -> String)
forall a. String -> (a -> Int) -> T T (a -> String)
Attr.int String
"numlabels" ([Interval Double String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Interval Double String] -> Int)
-> (T -> [Interval Double String]) -> T -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T Double String -> [Interval Double String]
forall time label. T time label -> [Interval time label]
LabelTrack.decons (T Double String -> [Interval Double String])
-> (T -> T Double String) -> T -> [Interval Double String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T -> T Double String
track_) T T (T -> String) -> [T T (T -> String)] -> [T T (T -> String)]
forall a. a -> [a] -> [a]
:
       String -> (T -> Int) -> T T (T -> String)
forall a. String -> (a -> Int) -> T T (a -> String)
Attr.int String
"height" T -> Int
height_ T T (T -> String) -> [T T (T -> String)] -> [T T (T -> String)]
forall a. a -> [a] -> [a]
:
       String -> (T -> Bool) -> T T (T -> String)
forall a. String -> (a -> Bool) -> T T (a -> String)
Attr.bool String
"minimized" T -> Bool
minimized_ T T (T -> String) -> [T T (T -> String)] -> [T T (T -> String)]
forall a. a -> [a] -> [a]
:
       [])
      ([[T T String]] -> [[T T String]])
-> [[T T String]] -> [[T T String]]
forall a b. (a -> b) -> a -> b
$
      (Interval Double String -> [T T String])
-> [Interval Double String] -> [[T T String]]
forall a b. (a -> b) -> [a] -> [b]
map Interval Double String -> [T T String]
intervalToXML (T Double String -> [Interval Double String]
forall time label. T time label -> [Interval time label]
LabelTrack.decons (T Double String -> [Interval Double String])
-> T Double String -> [Interval Double String]
forall a b. (a -> b) -> a -> b
$ T -> T Double String
track_ T
x)

{-
nanosecond precision as in ALSA
-}
intervalToXML :: LabelTrack.Interval Double String -> [Tag.T Name.T String]
intervalToXML :: Interval Double String -> [T T String]
intervalToXML ((Double
from,Double
to), String
title) =
   (Name T -> [T T String] -> T T String
forall name string. Name name -> [T name string] -> T name string
Tag.open Name T
labelName ([T T String] -> T T String) -> [T T String] -> T T String
forall a b. (a -> b) -> a -> b
$
      String -> String -> T T String
forall a. String -> a -> T T a
XML.attr String
"t"  (String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%.9f" Double
from) T T String -> [T T String] -> [T T String]
forall a. a -> [a] -> [a]
:
      String -> String -> T T String
forall a. String -> a -> T T a
XML.attr String
"t1" (String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%.9f" Double
to) T T String -> [T T String] -> [T T String]
forall a. a -> [a] -> [a]
:
      String -> String -> T T String
forall a. String -> a -> T T a
XML.attr String
"title" String
title T T String -> [T T String] -> [T T String]
forall a. a -> [a] -> [a]
:
      []) T T String -> [T T String] -> [T T String]
forall a. a -> [a] -> [a]
:
   Name T -> T T String
forall name string. Name name -> T name string
Tag.close Name T
labelName T T String -> [T T String] -> [T T String]
forall a. a -> [a] -> [a]
:
   []


maybeExc ::
   MM.MaybeT (ME.Exceptional Parser.Message) a ->
   Maybe (ME.Exceptional Parser.Message a)
maybeExc :: MaybeT (Exceptional String) a -> Maybe (Exceptional String a)
maybeExc (MM.MaybeT Exceptional String (Maybe a)
act) =
   case Exceptional String (Maybe a)
act of
      ME.Exception String
msg -> Exceptional String a -> Maybe (Exceptional String a)
forall a. a -> Maybe a
Just (Exceptional String a -> Maybe (Exceptional String a))
-> Exceptional String a -> Maybe (Exceptional String a)
forall a b. (a -> b) -> a -> b
$ String -> Exceptional String a
forall e a. e -> Exceptional e a
ME.Exception String
msg
      ME.Success Maybe a
ma -> (a -> Exceptional String a)
-> Maybe a -> Maybe (Exceptional String a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Exceptional String a
forall e a. a -> Exceptional e a
ME.Success Maybe a
ma

tracksFromXML :: [Tag.T Name.T String] -> ME.Exceptional Parser.Message [T]
tracksFromXML :: [T T String] -> Exceptional String [T]
tracksFromXML =
   [Exceptional String T] -> Exceptional String [T]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Exceptional String T] -> Exceptional String [T])
-> ([T T String] -> [Exceptional String T])
-> [T T String]
-> Exceptional String [T]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (T [] (T T String) -> Maybe (Exceptional String T))
-> [T [] (T T String)] -> [Exceptional String T]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (MaybeT (Exceptional String) T -> Maybe (Exceptional String T)
forall a.
MaybeT (Exceptional String) a -> Maybe (Exceptional String a)
maybeExc (MaybeT (Exceptional String) T -> Maybe (Exceptional String T))
-> (T [] (T T String) -> MaybeT (Exceptional String) T)
-> T [] (T T String)
-> Maybe (Exceptional String T)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT [T T String] (MaybeT (Exceptional String)) T
-> [T T String] -> MaybeT (Exceptional String) T
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
MS.evalStateT StateT [T T String] (MaybeT (Exceptional String)) T
parse ([T T String] -> MaybeT (Exceptional String) T)
-> (T [] (T T String) -> [T T String])
-> T [] (T T String)
-> MaybeT (Exceptional String) T
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T [] (T T String) -> [T T String]
forall (f :: * -> *) a. Cons f => T f a -> f a
NonEmpty.flatten) ([T [] (T T String)] -> [Exceptional String T])
-> ([T T String] -> [T [] (T T String)])
-> [T T String]
-> [Exceptional String T]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   ([T T String], [T [] (T T String)]) -> [T [] (T T String)]
forall a b. (a, b) -> b
snd (([T T String], [T [] (T T String)]) -> [T [] (T T String)])
-> ([T T String] -> ([T T String], [T [] (T T String)]))
-> [T T String]
-> [T [] (T T String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (T T String -> Bool)
-> [T T String] -> ([T T String], [T [] (T T String)])
forall (f :: * -> *) a.
Foldable f =>
(a -> Bool) -> f a -> ([a], [T [] a])
NonEmptyM.segmentBefore ((Name T -> Bool) -> ([T T String] -> Bool) -> T T String -> Bool
forall name string.
(Name name -> Bool)
-> ([T name string] -> Bool) -> T name string -> Bool
TagMatch.open (Name T
labeltrackNameName T -> Name T -> Bool
forall a. Eq a => a -> a -> Bool
==) (Bool -> [T T String] -> Bool
forall a b. a -> b -> a
const Bool
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 :: StateT [T T String] (MaybeT (Exceptional String)) T
parse = do
   [T T String]
attrs <- Name T -> T [T T String]
Parser.tagOpen Name T
labeltrackName
   String
name <- String -> [T T String] -> T String
Parser.lookupAttr String
"name" [T T String]
attrs
   Int
height <- String -> [T T String] -> T Int
forall a. Read a => String -> [T T String] -> T a
Parser.lookupAttrRead String
"height" [T T String]
attrs
   Bool
minimized <- String -> [T T String] -> T Bool
Parser.lookupAttrBool String
"minimized" [T T String]
attrs
   T ()
Parser.skipSpaces
   [Interval Double String]
intervals <- StateT
  [T T String] (MaybeT (Exceptional String)) (Interval Double String)
-> StateT
     [T T String] (MaybeT (Exceptional String)) [Interval Double String]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (StateT
  [T T String] (MaybeT (Exceptional String)) (Interval Double String)
parseInterval StateT
  [T T String] (MaybeT (Exceptional String)) (Interval Double String)
-> T ()
-> StateT
     [T T String] (MaybeT (Exceptional String)) (Interval Double String)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* T ()
Parser.skipSpaces)
   Name T -> T ()
Parser.tagClose Name T
labeltrackName
   T -> StateT [T T String] (MaybeT (Exceptional String)) T
forall (m :: * -> *) a. Monad m => a -> m a
return (T -> StateT [T T String] (MaybeT (Exceptional String)) T)
-> T -> StateT [T T String] (MaybeT (Exceptional String)) T
forall a b. (a -> b) -> a -> b
$
      Cons :: String -> Int -> Bool -> T Double String -> T
Cons {
         name_ :: String
name_ = String
name,
         height_ :: Int
height_ = Int
height,
         minimized_ :: Bool
minimized_ = Bool
minimized,
         track_ :: T Double String
track_ = [Interval Double String] -> T Double String
forall time label. [Interval time label] -> T time label
LabelTrack.Cons [Interval Double String]
intervals
      }

parseInterval :: Parser.T (LabelTrack.Interval Double String)
parseInterval :: StateT
  [T T String] (MaybeT (Exceptional String)) (Interval Double String)
parseInterval = do
   [T T String]
attrs <- Name T -> T [T T String]
Parser.tagOpen Name T
labelName
   Double
from <- String -> [T T String] -> T Double
forall a. Read a => String -> [T T String] -> T a
Parser.lookupAttrRead String
"t" [T T String]
attrs
   Double
to <- String -> [T T String] -> T Double
forall a. Read a => String -> [T T String] -> T a
Parser.lookupAttrRead String
"t1" [T T String]
attrs
   String
title <- String -> [T T String] -> T String
Parser.lookupAttr String
"title" [T T String]
attrs
   Name T -> T ()
Parser.tagClose Name T
labelName
   Interval Double String
-> StateT
     [T T String] (MaybeT (Exceptional String)) (Interval Double String)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Double
from, Double
to), String
title)


labelName :: Tag.Name Name.T
labelName :: Name T
labelName = T -> Name T
forall ident. ident -> Name ident
Tag.Name (T -> Name T) -> T -> Name T
forall a b. (a -> b) -> a -> b
$ String -> T
Name.Cons String
"label"

labeltrackName :: Tag.Name Name.T
labeltrackName :: Name T
labeltrackName = T -> Name T
forall ident. ident -> Name ident
Tag.Name (T -> Name T) -> T -> Name T
forall a b. (a -> b) -> a -> b
$ String -> T
Name.Cons String
"labeltrack"