Parse.hs

module Darcs.Helpers.Parse where

import Control.Monad.Error
-- import Text.ParserCombinators.Parsec
import Text.XML.HaXml 
import Text.XML.HaXml.Parse 
--import Text.XML.HaXml.Pretty
import Text.XML.HaXml.Posn
-- when a user registers, they get a sample darcs project created in their name 
-- so they can test out repo checkout right away, even before registering their ssh key
import Text.ParserCombinators.Parsec
import qualified Text.ParserCombinators.Parsec.XML as ParseX
import Safe





  
prsPatches = many prsPatch
prsPatch :: ParseX.XMLParser Patch
prsPatch = do
  (attrs,[name]) <- ParseX.namedElementWithAttrs "patch"
  auth <- get1Attr "author" attrs
  date <- get1Attr "date" attrs
  ldate <- get1Attr "local_date" attrs
  boolInverted  <- maybe (fail "prsPatch, boolInverted") return . readMay =<< ( get1Attr "inverted" $ attrs )
  hash <- get1Attr "hash" attrs
  patchDesc <- either (const $ fail "prsPatch, patchname") 
                          return
                             . parse (ParseX.stringElement "name") "patchname" $ [name] 
  let ptch = Patch (PatchAuthor auth) (PatchDate date) (PatchLocalDate ldate) (PatchInverted boolInverted)
                   (PatchHash hash) (PatchContents patchDesc {-"blaarg"-}{- patchMsg -})
  return ptch
  where 
    get1Attr :: Monad m => String -> [(String, AttValue)] -> m String
    get1Attr k attrs = do
      (AttValue [etVal]) <- maybe (fail $ "getPatch, no val for" ++ k) return . lookup k $ attrs  
      case etVal of 
        Left val -> return val
        Right err -> fail $ "getAttr, k: " ++ k

{-
get1ElCont :: Content Posn -> Either String String
get1ElCont cont = do
  return . verbatim $ cont
-}

data Patch = Patch { patchAuthor :: PatchAuthor
                                 , patchDate :: PatchDate
                                 , patchLocalDate :: PatchLocalDate
                                 , patchInverted :: PatchInverted
                                 , patchHash :: PatchHash
                                 , patchMessage :: PatchContents }
  deriving (Read,Show,Eq)
newtype PatchAuthor = PatchAuthor String
  deriving (Read,Show,Eq)
newtype PatchDate = PatchDate String
  deriving (Read,Show,Eq)
newtype PatchLocalDate = PatchLocalDate String
  deriving (Read,Show,Eq)
newtype PatchInverted = PatchInverted Bool
  deriving (Read,Show,Eq)
newtype PatchHash = PatchHash String
  deriving (Read,Show,Eq)
newtype PatchContents = PatchContents String
  deriving (Read,Show,Eq)



xmlParseTidy :: [Char] -> Either String (Document Posn)
xmlParseTidy xmlString = xmlParse' "xmlParseErrors.out" . clean $ xmlString
  where clean xs = filter ( \c -> (c/='\n') && (c/='\t')) xs