+{-# LANGUAGE TypeSynonymInstances, OverlappingInstances, NoMonomorphismRestriction, ScopedTypeVariables #-}
+
import System.IO (readFile, FilePath(..))
-import System.Environment (getArgs)
+import System.Directory (
+ getDirectoryContents
+ , doesDirectoryExist
+ )
+import System.FilePath ((</>))
+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)
-data Args = Args {
- xml :: String
- , moviesDir :: FilePath
-} deriving (Show)
+emptyMovie = Movie 0 "no title" Nothing [] [] []
+ Nothing Nothing Nothing [] "" Nothing "" [] ""
-test = do
- args <- getArgs
- case readArgs args of
- Left mess -> print mess
- Right args -> do
- paths <- moviePaths $ moviesDir args
- file <- readFile "../xml/test.xml"
- print $ parseXMLDoc file
+data Arg = XML | MovieDir deriving (Show, Eq)
+type Args = [(Arg, String)]
+main = do
+ args <- getArgs
+ progName <- getProgName
+ case checkArgs $ readArgs args of
+ Nothing -> printf usage progName
+ Just args -> do
+ let Just dir = lookup MovieDir args
+ let Just xmlFile = lookup XML args
+ paths <- moviePaths dir
+ movies <- readXMLFile xmlFile
+ print movies
+ --print paths
+
+coversDir = "../img/covers"
movieExtenstions = ["avi", "mkv", "rmvb", "ogm", "divx"]
-
-readArgs :: [String] -> Either String Args
-readArgs plop = undefined
-{--readArgs (name:value:rest) = case name of
- "-x" -> { xml = value }
- "-d" -> { moviesDir = value }--}
+usage = "Usage : %s -d <Movies dir> -x <XML file>\n"
+
+checkArgs :: Maybe Args -> Maybe Args
+checkArgs Nothing = Nothing
+checkArgs (Just args) =
+ case (lookup XML args, lookup MovieDir args) of
+ (Just _, Just _) -> Just args
+ otherwise -> Nothing
+
+readArgs :: [String] -> Maybe Args
+readArgs (name:value:rest)
+ | name == "-x" = (XML, value) <:> readArgs rest
+ | name == "-d" = (MovieDir, value) <:> readArgs rest
+ | otherwise = Nothing
+ where
+ _ <:> Nothing = Nothing
+ arg <:> Just args = Just $ arg : args
+readArgs (_:[]) = Nothing
+readArgs (_) = Just []
moviePaths :: FilePath -> IO [FilePath]
-moviePaths dir = undefined
+moviePaths dir = do
+ paths <- filePaths (\filename ->
+ any (`isSuffixOf` filename) movieExtenstions) dir
+ -- Keep only the relative path.
+ return $ map (drop $ Data.List.length dir + 1) paths
+
+filePaths :: (String -> Bool) -> FilePath -> IO [FilePath]
+filePaths predicat baseDir = do
+ processDir baseDir
+ where
+ processDir dir = do
+ contents <- getDirectoryContents dir
+ foldM (\acc entry -> do
+ let absDir = dir </> entry
+ doesDirectoryExist absDir >>= \exists ->
+ if exists
+ then do
+ paths <- processDir absDir
+ return (paths ++ acc)
+ else
+ if predicat entry
+ then
+ return (absDir : acc)
+ else
+ return acc)
+ []
+ (contents \\ ["..", "."])
readXMLFile :: FilePath -> IO Movies
-readXMLFile file = undefined
-
-
+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
projects / pompage.git / blobdiff