1 {-# LANGUAGE TypeSynonymInstances, OverlappingInstances, NoMonomorphismRestriction, ScopedTypeVariables #-}
3 import System
.IO
(readFile
, FilePath
(..))
4 import System
.Directory
(
8 import System
.FilePath
((</>))
9 import System
.Environment
(getArgs
, getProgName
)
11 import Text
.Printf
(printf
)
13 import qualified Text
.XML
.Light
.Cursor
as C
14 import Control
.Monad
(foldM
)
15 import Control
.Exception
(SomeException
(..), handle
, bracket
)
21 , movieTitle :: String
22 , movieYear :: Maybe Int
23 , movieDirectors ::
[String
]
24 , movieActors ::
[String
]
25 , movieCountries ::
[String
]
26 , movieLength :: Maybe Int
27 , movieUserRating :: Maybe Int
28 , moviePressRating :: Maybe Int
29 , movieGenres ::
[String
]
30 , movieSynopsis :: String
31 , movieBudget :: Maybe Int
32 , movieBudgetUnit :: String
33 , movieFiles ::
[FilePath
]
37 emptyMovie
= Movie
0 "no title" Nothing
[] [] []
38 Nothing Nothing Nothing
[] "" Nothing
"" [] ""
40 data Arg
= XML
| MovieDir
deriving (Show
, Eq
)
41 type Args
= [(Arg
, String
)]
45 progName
<- getProgName
46 case checkArgs
$ readArgs args
of
47 Nothing
-> printf usage progName
49 let Just dir
= lookup MovieDir args
50 let Just xmlFile
= lookup XML args
51 paths
<- moviePaths dir
52 movies
<- readXMLFile xmlFile
56 coversDir
= "../img/covers"
57 movieExtenstions
= ["avi", "mkv", "rmvb", "ogm", "divx"]
58 usage
= "Usage : %s -d <Movies dir> -x <XML file>\n"
60 checkArgs :: Maybe Args
-> Maybe Args
61 checkArgs Nothing
= Nothing
62 checkArgs
(Just args
) =
63 case (lookup XML args
, lookup MovieDir args
) of
64 (Just _
, Just _
) -> Just args
67 readArgs ::
[String
] -> Maybe Args
68 readArgs
(name:value:rest
)
69 | name
== "-x" = (XML
, value
) <:
> readArgs rest
70 | name
== "-d" = (MovieDir
, value
) <:
> readArgs rest
73 _
<:
> Nothing
= Nothing
74 arg
<:
> Just args
= Just
$ arg : args
75 readArgs
(_:
[]) = Nothing
76 readArgs
(_
) = Just
[]
78 moviePaths :: FilePath
-> IO
[FilePath
]
80 paths
<- filePaths
(\filename
->
81 any
(`isSuffixOf` filename
) movieExtenstions
) dir
82 -- Keep only the relative path.
83 return
$ map
(drop
$ Data
.List
.length dir
+ 1) paths
85 filePaths ::
(String
-> Bool
) -> FilePath
-> IO
[FilePath
]
86 filePaths predicat baseDir
= do
90 contents
<- getDirectoryContents dir
91 foldM
(\acc entry
-> do
92 let absDir
= dir
</> entry
93 doesDirectoryExist absDir
>>= \exists
->
96 paths
<- processDir absDir
101 return
(absDir : acc
)
105 (contents \\
["..", "."])
107 readXMLFile :: FilePath
-> IO Movies
108 readXMLFile file
= do
109 content
<- readFile file
110 let Just root
= parseXMLDoc content
113 case elementXMLToMovie elem
of
115 Just movie
-> movie : acc
)
120 type ParseState
= C
.Cursor
121 newtype Parse alpha
= Parse
{
122 runParse :: ParseState
-> Either String
(alpha
, ParseState
)
124 identity :: alpha
-> Parse alpha
125 identity a
= Parse
(\s
-> Right
(a
, s
))
127 parseNextSibilingContent :: Parse String
128 parseNextSibilingContent
=
129 getState
==> \initState
->
130 case nextSibilingElement initState
of
132 bail
"no more sibiling slement"
133 Just
(elem
, cursor
) ->
134 putState cursor
==> \_
->
135 identity
(strContent elem
)
137 getState :: Parse ParseState
138 getState
= Parse
(\s
-> Right
(s
, s
))
140 -- Remplace the current state by a new one.
141 putState :: ParseState
-> Parse
()
142 putState s
= Parse
(\_
-> Right
((), s
))
144 -- Construct a parser which return a string error.
145 bail :: String
-> Parse alpha
146 bail err
= Parse
$ \s
->
148 err
++ "\nFail at " ++
150 Elem elem
-> "element '" ++ qName
(elName elem
) ++ "'" ++ showLine
(elLine elem
)
151 Text txt
-> "text '" ++ cdData txt
++ "'" ++ showLine
(cdLine txt
)
152 CRef cref
-> "cref '" ++ cref
156 Just l
-> " (line " ++ show l
++ ")"
159 (==>) :: Parse alpha
-> (alpha
-> Parse beta
) -> Parse beta
160 firstParser
==> secondParser
= Parse chainedParser
162 chainedParser initState
=
163 case runParse firstParser initState
of
166 Right
(firstResult
, newState
) ->
167 runParse
(secondParser firstResult
) newState
169 elementXMLToMovie :: Element
-> Maybe Movie
170 elementXMLToMovie elem
=
171 Just
(emptyMovie
, C
.fromElement elem
) >>?
175 case findAttr
(simpleQName
"id") elem
of
177 Just id
-> Just
(m
{ movieId
= read id :: Int
}, c
)
178 otherwise
-> Nothing
) >>?
180 case firstChildElement c
of
181 Just
(elem
, c'
) -> Just
(m
{ movieTitle
= strContent elem
}, c'
)
182 otherwise
-> Nothing
) >>?
184 case nextSibilingElement c
of
185 Just
(elem
, c'
) -> Just m
{ movieYear
= intElement elem
}
186 otherwise
-> Nothing
)
189 (>>?) :: Maybe alpha
-> (alpha
-> Maybe beta
) -> Maybe beta
190 Nothing
>>? _
= Nothing
193 -- Some XML helper functions
194 simpleQName name
= QName name Nothing Nothing
195 firstChildElement :: C
.Cursor
-> Maybe
(Element
, C
.Cursor
)
196 firstChildElement c
=
197 case C
.firstChild c
of
200 Elem elem
-> Just
(elem
, c'
)
201 otherwise
-> nextSibilingElement c'
204 nextSibilingElement :: C
.Cursor
-> Maybe
(Element
, C
.Cursor
)
205 nextSibilingElement c
=
209 Elem elem
-> Just
(elem
, c'
)
210 otherwise
-> nextSibilingElement c'
213 -- Try to cast an element content to an Int.
214 intElement :: Element
-> Maybe Int
218 else Just
(read content :: Int
)
219 where content
= strContent elem
221 writeXMLFile :: Movies
-> FilePath
-> IO
()
222 writeXMLFile movies file
= undefined
224 filesPath :: FilePath
-> IO
[FilePath
]
225 filesPath basePath
= undefined
227 movieName :: FilePath
-> String
228 movieName
= undefined
230 -- Int is the module id.
231 data SearchResult
= OK
(Int
, Movie
)
232 | Many
[(Int
, String
)] -- String is the name of the movie.
235 data Module
= Module
{
236 search :: String
-> IO SearchResult
237 -- Int is the module id. FilePath is a path to the image like "../img/4353"
238 , downloadImage :: Int
-> FilePath
242 Gets a movie by asking the given module to find a movie.
243 A movie is seeked by its the filename.
244 If there is many possibilities then it will ask the user.
246 searchAMovie :: String
-> Module
-> IO SearchResult
247 searchAMovie filename mod
= undefined