ParsePlist.hs

{-# LANGUAGE OverloadedStrings #-}
module ParsePlist ( parseFromPlist
                  ,  plistParser
                  , plistParserWithHeaderAndFooter
                  , defaultHeader
                  , defaultFooter
                  , parseXexpr
                  )where

import Control.Monad
import qualified Data.Text.Lazy as L
import qualified Data.Text      as T
import Text.Parsec         (parse, spaces, (<|>), manyTill, many, noneOf,
                            anyChar, char, eof, try, lookAhead, string)
import Text.Parsec.Text.Lazy  (Parser)

import XExpression -- Xexpr data type

-----------------------------  API

-- TODO: parse errors 
parseFromPlist :: L.Text -> Either String Xexpr
parseFromPlist txt = case parse plistParser "" txt of
  Left  x -> Left (show x)
  Right x -> Right x
  
  

plistParser :: Parser Xexpr
plistParser = defaultHeader *> parseXexpr <* defaultFooter

plistParserWithHeaderAndFooter :: Parser a -> Parser b -> Parser Xexpr
plistParserWithHeaderAndFooter h f = h *> parseXexpr <* f


defaultHeader :: Parser ()
defaultHeader = void $ manyTill anyChar (try (lookAhead (string "<dict>")))

defaultFooter :: Parser ()
defaultFooter = string "</plist>" *> spaces <|> eof

parseXexpr :: Parser Xexpr
parseXexpr = do
  xmark <- parseXmark
  cont  <- parseSubs xmark <|> parseLit xmark
  _ <- eof <|>  spaces
  return $ Xmark (L.toStrict xmark) cont


----------------------------- PRIVATE

parseXmark :: Parser L.Text
parseXmark = (L.strip . L.pack)  <$>
             (char '<' *> spaces
              *> (many $ noneOf ">") <*
             char '>' <* spaces)


parseLit :: L.Text -> Parser Xexpr
parseLit endMark = (Lit . T.strip . T.pack) <$> (spaces *>
                   (manyTill anyChar
                             (try (string ("</" ++ L.unpack endMark ++ ">")))))


parseSubs :: L.Text -> Parser Xexpr
parseSubs endMark = Subs <$>
                    manyTill (parseXexpr <* spaces)
                             (try (string ("</" ++ L.unpack endMark ++ ">")))