From 798b376bb1bb5c6c7b4088da5f8397a348e039b9 Mon Sep 17 00:00:00 2001
From: Greg Burri <greg.burri@gmail.com>
Date: Mon, 4 May 2009 22:22:44 +0200
Subject: [PATCH] ADD Begining of a new XML parser. Inspired by the book 'Real
 World Haskell' (chap 10). (Not yet finished)

---
 src/Pompage.hs | 50 ++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 50 insertions(+)

diff --git a/src/Pompage.hs b/src/Pompage.hs
index 2316f3f..a60f324 100644
--- a/src/Pompage.hs
+++ b/src/Pompage.hs
@@ -116,6 +116,56 @@ readXMLFile file = do
       []
       (elChildren root)
 
+
+type ParseState = C.Cursor
+newtype Parse alpha = Parse {
+      runParse :: ParseState -> Either String (alpha, ParseState)
+   }
+identity :: alpha -> Parse alpha
+identity a = Parse (\s -> Right (a, s))
+
+parseNextSibilingContent :: Parse String
+parseNextSibilingContent =
+   getState ==> \initState ->
+      case nextSibilingElement initState of
+         Nothing ->
+            bail "no more sibiling slement"
+         Just (elem, cursor) ->
+            putState cursor ==> \_ ->
+               identity (strContent elem)
+
+getState :: Parse ParseState
+getState = Parse (\s -> Right (s, s))
+
+-- Remplace the current state by a new one.
+putState :: ParseState -> Parse ()
+putState s = Parse (\_ -> Right ((), s))
+
+-- Construct a parser which return a string error.
+bail :: String -> Parse alpha
+bail err = Parse $ \s ->
+   Left $
+      err ++ "\nFail at " ++
+      case C.current s of
+         Elem elem -> "element '" ++ qName (elName elem) ++ "'" ++ showLine (elLine elem)
+         Text txt -> "text '" ++ cdData txt ++ "'" ++ showLine (cdLine txt)
+         CRef cref -> "cref '" ++ cref
+   where
+      showLine line =
+            case line of
+               Just l -> " (line " ++ show l ++ ")"
+               Nothing -> ""
+
+(==>) :: Parse alpha -> (alpha -> Parse beta) -> Parse beta
+firstParser ==> secondParser = Parse chainedParser
+   where
+      chainedParser initState =
+         case runParse firstParser initState of
+            Left errMessage ->
+               Left errMessage
+            Right (firstResult, newState) ->
+               runParse (secondParser firstResult) newState
+
 elementXMLToMovie :: Element -> Maybe Movie
 elementXMLToMovie elem =
    Just (emptyMovie, C.fromElement elem) >>?
-- 
2.43.0