parser for the MPD database

MPDParser.hs

{-# LANGUAGE NoMonomorphismRestriction, TupleSections, MonadComprehensions #-}
module MPDDatabase where

import Data.List
import qualified Database as D
import Control.Monad
import Text.ParserCombinators.Parsec
import Control.Applicative hiding ((<|>), optional)

data Directory = DirTerminal (String, String, [DContents]) deriving (Show)

data DContents = 
    Track (String, [(String, String)]) | 
    Playlist (String,[(String, String)]) | 
    Direc Directory deriving (Show)

-- Directory parsing

directoryBegin = (string "directory: ") *> word

-- Info section parser

nothing = string ""

charsets = ["UTF-8"]        

number = many1 digit
word = many1 (noneOf ['\n', '\r'])

track = do
        n <- number <|> word
        _ <- optional $ (choice [(string "/"), (string "-"), (string "&")]) *> number
        return n

infoTags = choice [(songComposer nothing "" ), (songPerfPlay nothing ""), (artistAlbum nothing "") 
            ,(timeTitleTrack nothing nothing "" nothing), (songMtime nothing "") 
            ,(songGenre nothing ""), (discDate nothing nothing ""), (songName nothing "")]

versionString = (string "mpd_version: ") *> (join <$> (sepBy1 number (string ".")))

fCharsetFormat = 
    snd <$> (parseThen "f" [pTag "s_charset" 
        (choice $ map string charsets) ": ", pTag "ormat" number ": "])

tagString = (string "tag: ") *> (fst <$> infoTags)
infoItems = [fCharsetFormat, tagString, versionString]
infoParse = 
    (string "info_begin\n") *> 
    manyTill (sepEndBy1 (choice infoItems) (string "\n")) (string "info_end\n")

-- Song section parser
parseThen c ps = [(c++t,x) | _ <- string c, (t,x) <- choice ps]

songBegin = do
    _ <- (string "song_begin: ")
    title <- word
    _ <- string "\n"
    return title

songEnd = (string "song_end")

pTag t p c = (string $ t++c) *> ((t,) <$> p)

songName w c = pTag "Name" w c
songComposer w c = pTag "Composer" w c
songPerfPlay w c = parseThen "P" [pTag "erformer" w c, pTag "laylist" w c]
songTime n c = pTag "ime" n c
songGenre w c = pTag "Genre" w c
songMtime n c = pTag "mtime" n c
discDate t w c = parseThen "D" [pTag "isc" t c, pTag "ate" w c]
titleTime w c n = parseThen "i" [pTag "tle" w c, pTag "me" n c]
timeTitleTrack t w c n = parseThen "T" [pTag "rack" t c, titleTime w c n]

-- A stuff

albumArtistSort word c = parseThen "Artist" [pTag "Sort" word c, pTag "" word c]
albumArtist word c = parseThen "lbum" [albumArtistSort word c, pTag "" word c]
artistAlbum word c = parseThen "A" [pTag "rtist" word c, albumArtist word c]

songTags' c = choice [(songComposer word c),(songPerfPlay word c), (artistAlbum word c) 
            ,(timeTitleTrack track word c number), (songMtime number c) 
            ,(songGenre word c), (discDate track word c), (songName word c)]

songTags = songTags' ": "

parseSong = do
    title <- songBegin 
    tags <- (sepEndBy1 songTags (string "\n"))
    _ <- songEnd
    return $ Track (title, tags)

-- Directory section parser
-- A directory is made up of a "directory" directive which has the name of the directory
-- then an mtime directive,
-- then many1 of either song or playlist
-- then "end" and the name of the directory

parseDirectoryBegin = pTag "directory" word ": "
parseMtime = pTag "mtime" number ": "
parseBegin = pTag "begin" word ": "
parseDirectoryEnd = pTag "end" word ": "

parseDirectory = do
    dname <- parseDirectoryBegin
    _ <- string "\n"
    mtime <- parseMtime
    _ <- string "\n"
    _ <- parseBegin
    _ <- string "\n"
    songs <- sepEndBy1 (parseSong <|> parseDirectory <|> playListParse) (string "\n")
    _ <- parseDirectoryEnd
    return $ Direc $ DirTerminal (snd dname, snd mtime, songs)

-- Playlist section parser
playListBegin = pTag "playlist_begin" word ": "
playListEnd = string "playlist_end"
playListParse = do
    pl <- playListBegin 
    _ <- string "\n"
    mt <- parseMtime
    _ <- string "\n"
    _ <- playListEnd
    return $ Playlist (snd pl, [mt])

-- Parse entire file

parseDatabase = do
    _ <- infoParse
    ds <- sepEndBy1 (parseDirectory <|> parseSong <|> playListParse) (string "\n")
    return ds