ADD Begining of a new XML parser. Inspired by the book 'Real World Haskell' (chap...

[pompage.git] / src / Pompage.hs

diff --git a/src/Pompage.hs b/src/Pompage.hs
index 6cf4349..a60f324 100644 (file)
--- a/src/Pompage.hs
+++ b/src/Pompage.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE TypeSynonymInstances, OverlappingInstances, NoMonomorphismRestriction, ScopedTypeVariables #-}
+
 import System.IO (readFile, FilePath(..))
 import System.Directory (
      getDirectoryContents
@@ -8,28 +10,33 @@ import System.Environment (getArgs, getProgName)
 import Data.List
 import Text.Printf (printf)
 import Text.XML.Light
+import qualified Text.XML.Light.Cursor as C
 import Control.Monad (foldM)
+import Control.Exception (SomeException(..), handle, bracket)
 
 type Movies = [Movie]
 
 data Movie = Movie {
-     files :: [FilePath]
-   , id :: Int
-   , title :: String
-   , year :: Maybe Int
-   , directors :: [String]
-   , actors :: [String]
-   , countries :: [String]
-   , length :: Maybe Int
-   , userRating :: Maybe Int
-   , pressRating :: Maybe Int
-   , genre :: [String]
-   , synopsis :: String
-   , budget :: Int
-   , budgetUnit :: String
-   , url :: String
+     movieId :: Int
+   , movieTitle :: String
+   , movieYear :: Maybe Int
+   , movieDirectors :: [String]
+   , movieActors :: [String]
+   , movieCountries :: [String]
+   , movieLength :: Maybe Int
+   , movieUserRating :: Maybe Int
+   , moviePressRating :: Maybe Int
+   , movieGenres :: [String]
+   , movieSynopsis :: String
+   , movieBudget :: Maybe Int
+   , movieBudgetUnit :: String
+   , movieFiles :: [FilePath]
+   , movieUrl :: String
 } deriving (Show)
 
+emptyMovie = Movie 0 "no title" Nothing [] [] []
+   Nothing Nothing Nothing [] "" Nothing "" [] ""
+
 data Arg = XML | MovieDir deriving (Show, Eq)
 type Args = [(Arg, String)]
 
@@ -44,8 +51,9 @@ main = do
          paths <- moviePaths dir
          movies <- readXMLFile xmlFile
          print movies
-         print paths
+         --print paths
 
+coversDir = "../img/covers"
 movieExtenstions = ["avi", "mkv", "rmvb", "ogm", "divx"]
 usage = "Usage : %s -d <Movies dir> -x <XML file>\n"
 
@@ -96,13 +104,119 @@ filePaths predicat baseDir = do
             []
             (contents \\ ["..", "."])
 
-
 readXMLFile :: FilePath -> IO Movies
-readXMLFile file = undefined
-{-
-   file <- readFile "../xml/test.xml"
-   --print $ parseXMLDoc file
--}
+readXMLFile file = do
+   content <- readFile file
+   let Just root = parseXMLDoc content
+   return $
+      foldl (\acc elem ->
+         case elementXMLToMovie elem of
+            Nothing -> acc
+            Just movie -> movie : acc)
+      []
+      (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) >>?
+   (\(m, c) ->
+      case C.current c of
+         Elem elem ->
+            case findAttr (simpleQName "id") elem of
+            Nothing -> Nothing
+            Just id -> Just (m { movieId = read id :: Int }, c)
+         otherwise -> Nothing) >>?
+   (\(m, c) ->
+      case firstChildElement c of
+         Just (elem, c') -> Just (m { movieTitle = strContent elem }, c')
+         otherwise -> Nothing) >>?
+   (\(m, c) ->
+      case nextSibilingElement c of
+         Just (elem, c') -> Just m { movieYear =  intElement elem }
+         otherwise -> Nothing)
+
+-- A bit naive
+(>>?) :: Maybe alpha -> (alpha -> Maybe beta) -> Maybe beta
+Nothing >>? _ = Nothing
+Just v >>? f = f v
+
+-- Some XML helper functions
+simpleQName name = QName name Nothing Nothing
+firstChildElement :: C.Cursor -> Maybe (Element, C.Cursor)
+firstChildElement c =
+   case C.firstChild c of
+      Just c' ->
+         case C.current c' of
+            Elem elem -> Just (elem, c')
+            otherwise -> nextSibilingElement c'
+      otherwise -> Nothing
+
+nextSibilingElement :: C.Cursor -> Maybe (Element, C.Cursor)
+nextSibilingElement c =
+   case C.right c of
+      Just c' ->
+         case C.current c' of
+            Elem elem -> Just (elem, c')
+            otherwise -> nextSibilingElement c'
+      Nothing -> Nothing
+
+-- Try to cast an element content to an Int.
+intElement :: Element -> Maybe Int
+intElement elem =
+   if content == []
+      then Nothing
+      else Just (read content :: Int)
+   where content = strContent elem
 
 writeXMLFile :: Movies -> FilePath -> IO ()
 writeXMLFile movies file = undefined