module Main where
import System
import IO
import List (nub,takeWhile,dropWhile)
import Control.Monad
import Text.XML.HaXml (version)
import Text.XML.HaXml.Types (DocTypeDecl(..))
import Text.XML.HaXml.Parse (dtdParse)
import Text.XML.HaXml.DtdToHaskell.TypeDef (TypeDef,ppTypeDef,mangle)
import Text.XML.HaXml.DtdToHaskell.Convert (dtd2TypeDef)
import Text.XML.HaXml.DtdToHaskell.Instance (mkInstance)
import Text.PrettyPrint.HughesPJ (render,vcat)
fix2Args :: IO (String,String)
fix2Args = do
args <- getArgs
when ("--version" `elem` args) $ do
putStrLn $ "part of HaXml-"++version
exitWith ExitSuccess
when ("--help" `elem` args) $ do
putStrLn $ "See http://haskell.org/HaXml"
exitWith ExitSuccess
case length args of
0 -> return ("-", "-")
1 -> return (args!!0, "-")
2 -> return (args!!0, args!!1)
_ -> do prog <- getProgName
putStrLn ("Usage: "++prog++" [xmlfile] [outfile]")
exitFailure
main ::IO ()
main =
fix2Args >>= \(inf,outf)->
( if inf=="-" then getContents
else readFile inf ) >>= \content->
( if outf=="-" then return stdout
else openFile outf WriteMode ) >>= \o->
let (DTD name _ markup) = (getDtd . dtdParse inf) content
decls = (nub . dtd2TypeDef) markup
realname = if outf/="-" then mangle (trim outf)
else if null name then mangle (trim inf)
else mangle name
in
do hPutStrLn o ("module "++realname
++" where\n\nimport Text.XML.HaXml.XmlContent"
++"\nimport Text.XML.HaXml.OneOfN")
hPutStrLn o "\n\n{-Type decls-}\n"
(hPutStrLn o . render . vcat . map ppTypeDef) decls
hPutStrLn o "\n\n{-Instance decls-}\n"
mapM_ (hPutStrLn o . (++"\n") . render . mkInstance) decls
hPutStrLn o "\n\n{-Done-}"
hFlush o
getDtd :: Maybe t -> t
getDtd (Just dtd) = dtd
getDtd (Nothing) = error "No DTD in this document"
trim :: [Char] -> [Char]
trim name | '/' `elem` name = (trim . tail . dropWhile (/='/')) name
| '.' `elem` name = takeWhile (/='.') name
| otherwise = name