Format.hs

-- | Song format parser
module Vimus.Song.Format (
  SongFormat(..)
, parser

-- * exported for testing
, FormatTree(..)
, format
, meta
, alternatives
, parse
) where

import           Control.Applicative (Alternative(..), pure, liftA2)
import           Data.Default (Default(..))
import           Data.Foldable (asum)
import           Data.List (intercalate)
import           Data.Maybe (fromMaybe)
import           Data.Map (Map)
import qualified Data.Map as Map
import           Data.Monoid (Monoid(..))
import           Text.Printf (printf)

import qualified Network.MPD as MPD

import qualified Vimus.Command.Parser as Parser

import Vimus.Song


infixr 4 :+:

-- | AST for formats:
data FormatTree s m a =
    Empty
  | Pure a
  | FormatTree s m a :+: FormatTree s m a
  | Meta (s -> m a)
  | Alt [FormatTree s m a]

-- | Format AST
format
    :: (Alternative m, Monoid a)
    => a -- ^ default value for failed top-level metadata query
    -> s -- ^ container for metadata
    -> FormatTree s m a -> m a
format d n = top where
  top Empty     = empty
  top (Pure a)  = pure a
  top (x :+: y) = top x <#> top y
  top (Alt xs)  = asum $ fmap nested xs
  top (Meta f)  = f n <|> pure d -- if metadata query failed, replace failure with 'd'

  nested (Meta f)  = f n
  nested (x :+: y) = nested x <#> nested y
  nested t         = top t

  (<#>) = liftA2 mappend


newtype SongFormat = SongFormat (MPD.Song -> String)

instance Default SongFormat where
  def = SongFormat $ \song ->
    printf "%s - %s - %s - %s"
      (orNone $ artist song)
      (orNone $ album song)
      (orNone $ track song)
      (orNone $ title song)
   where
    orNone = fromMaybe "(none)"

parser :: Map String (MPD.Song -> Maybe String) -> Parser.Parser SongFormat
parser queries = Parser.Parser $ \str -> do
  tree <- parse queries str
  return (SongFormat (\song -> fromMaybe "(none)" $ format "none" song tree), "")

parse
  :: Map String (MPD.Song -> Maybe String)
  -> String
  -> Either Parser.ParseError (FormatTree MPD.Song Maybe String)
parse queries = go "" where
  go acc ('\\':'(':cs) = go ('(':acc) cs
  go acc ('\\':')':cs) = go (')':acc) cs
  go acc ('\\':'%':cs) = go ('%':acc) cs
  go acc ('(':cs) = do
    (xs, ys) <- alternatives cs
    alts     <- mapM (go "") xs
    rest     <- go "" ys
    return $ Pure (reverse acc) <+> Alt alts <+> rest
  go acc ('%':cs) = do
    (key, ys) <- meta cs
    case Map.lookup key queries of
      Nothing -> Left (Parser.ParseError $ "non-supported meta pattern: %" ++ key ++ "%")
      Just metadata -> do
        rest <- go "" ys
        return $ Pure (reverse acc) <+> Meta metadata <+> rest
  go acc (c:cs) = go (c:acc) cs
  go acc [] = Right (Pure (reverse acc))

  infixr 4 <+>
  Pure "" <+> x = x
  x <+> Pure "" = x
  x <+>       y = x :+: y


data Nat = Z | S Nat

-- | Parse alternatives pattern
alternatives :: String -> Either Parser.ParseError ([String], String)
alternatives = go Z [] "" where
  go n strings acc ('\\':'(':xs) = go n strings ('(':'\\':acc) xs
  go n strings acc ('\\':')':xs) = go n strings (')':'\\':acc) xs
  go n strings acc ('\\':'|':xs) = go n strings ('|':'\\':acc) xs
  go n strings acc ('(':xs)      = go (S n) strings ('(':acc) xs
  go Z strings acc (')':xs)      = Right (reverse (reverse acc : strings), xs)
  go (S n) strings acc (')':xs)  = go n strings (')':acc) xs
  go Z strings acc ('|':xs)      = go Z (reverse acc : strings) [] xs
  go n strings acc (x:xs)        = go n strings (x:acc) xs
  go _ strings acc []            = Left . Parser.ParseError $
    "unterminated alternatives pattern: (" ++ intercalate "|" (reverse acc : strings)

-- | Parse meta pattern
meta :: String -> Either Parser.ParseError (String, String)
meta = go "" where
  go acc ('\\':'%':xs) = go ('%':acc) xs
  go acc ('%':xs)      = Right (reverse acc, xs)
  go acc (x:xs)        = go (x:acc) xs
  go acc []            = Left (Parser.ParseError $ "unterminated meta pattern: %" ++ reverse acc)