hxt-7.1: examples/dtd2haskell/DTDtoHXT.hs
-- |
-- DTDtoHXml - A program for generating access functions for the Haskell XML Toolbox
-- from a DTD
--
-- Author : Uwe Schmidt
--
-- Version : $Id: DTDtoHXT.hs,v 1.2 2005/04/14 12:52:51 hxml Exp $
--
-- this program may be used as example main program for the
-- Haskell XML Toolbox
module Main
where
import Text.XML.HXT.Parser -- import all stuff for parsing, validating, and transforming XML
import System.IO -- import the IO and commandline option stuff
import System.Environment
import System.Console.GetOpt
import System.Exit
import Data.Maybe
import Data.Char
import Data.List
-- ------------------------------------------------------------
-- |
-- the main program
main :: IO ()
main
= do
argv <- getArgs -- get the commandline arguments
al <- cmdlineOpts argv -- and evaluate them, return a key-value list
res <- run' -- build a XML root from the list and start parsing
$ getDocumentAndGenerateHaskellCode al emptyRoot
exitProg (null res) -- set return code and terminate
-- ------------------------------------------------------------
exitProg :: Bool -> IO a
exitProg True = exitWith (ExitFailure (-1))
exitProg False = exitWith ExitSuccess
-- ------------------------------------------------------------
uppercaseInitials, namespaceAware, prefixUnderline :: String
uppercaseInitials = "uppercase-initials"
namespaceAware = "namespace-aware"
prefixUnderline = "prefix-underline"
-- ------------------------------------------------------------
generateHXmlToolboxAccessFuntions :: XmlFilter
generateHXmlToolboxAccessFuntions t
= processChildren (isXDTD `guards` genHaskell) t
where
genHaskell dt
= cat
[ code [ sepl
, "--"
, "-- don't edit this module"
, "-- generated with " ++ progName
, "-- simple access function for Haskell XML Toolbox"
, "-- generated from DTD of document: " ++ show source
, ""
, "module " ++ hsmodul
, "where"
, ""
, "import Text.XML.HXT.DOM.XmlTree (XmlFilter)"
, "import qualified Text.XML.HXT.DOM.XmlTree as X hiding (XmlFilter)"
]
, comm "namespace declarations"
, code (map nsType nsPrefixes)
, comm ""
, code (zipWith nsDef nsPrefixes nsUris)
, comm "element names (tag names)"
, code (map (constNameType maxElemLen "tag") elements)
, comm ""
, code (map (constNameDef maxElemLen "tag") elements)
, comm "isTag test filter"
, code (map isTagType elements)
, comm ""
, code (map isTagDef elements)
, comm "make tag nodes constructor filter"
, code (map mkTagType elements)
, comm ""
, code (map mkTagDef elements)
, comm "attribute names"
, code (map (constNameType maxAttrLen "attr") attributes)
, comm ""
, code (map (constNameDef maxAttrLen "attr") attributes)
, comm "get attribute value access filter"
, code (map getValueType attributes)
, comm ""
, code (map getValueDef attributes)
, comm "has attribute test filter"
, code (map hasAttrType attributes)
, comm ""
, code (map hasAttrDef attributes)
, comm "make attribute nodes constructor filter for computed attribute values"
, code (map mkAttrType attributes)
, comm ""
, code (map mkAttrDef attributes)
, comm "make attribute nodes constructor filter for string attribute values"
, code (map mkSAttrType attributes)
, comm ""
, code (map mkSAttrDef attributes)
, comm ("end of module " ++ hsmodul)
]
$ dt
where
code = txt . concatMap (++ "\n")
comm cm = code [ "", sepl, "--", "-- " ++ cm, ""] -- generate a headline comment
sepl = "-- ----------------------------------------"
nn = trInitial . concatMap nc -- normalize names
nc c
| c `elem` ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_" = [c]
| c == ':' || c == '-' = "_"
| otherwise = ("_" ++) . show . fromEnum $ c
trInitial str
| null str = str
| underLn = '_' : str
| upperCs = toUpper (head str) : tail str
| otherwise = str
modname = reverse
. (\ n -> if '.' `elem` n -- remove extension
then drop 1 . dropWhile (/= '.') $ n
else n
)
. takeWhile (/= '/') -- remove dir path
. reverse
maxLen = maximum . (0 :) . map length
padd n x = take n (x ++ repeat ' ')
tagPrefix = "tag"
attrPrefix = "attr"
nsPrefix = "ns"
tagName n = tagPrefix ++ nn n
attName a = attrPrefix ++ nn a
nspName n = nsPrefix ++ nn n
constNameType ln prefix n
= prefix ++ padd ln (nn n) ++ " :: String"
constNameDef ln prefix n
= prefix ++ padd ln (nn n) ++ " = " ++ show n
isTagType n
= "is" ++ padd maxElemLen (nn n) ++ " :: XmlFilter"
isTagDef n
= "is" ++ padd maxElemLen (nn n) ++ " = " ++
( either
(const ("X.isTag " ++ tagPrefix ++ nn n))
(\ (ns, pr, lp)
-> "X.isNsTag " ++ ( if null pr
then tagName n
else show lp
) ++ " " ++ nspName ns
)
. quName
$ n
)
mkTagType n
= "t" ++ padd maxElemLen (nn n) ++ " :: XmlFilter"
mkTagDef n
= "t" ++ padd maxElemLen (nn n) ++ " = " ++
( either
(const ("X.etag " ++ tagName n))
(\ (ns, _pr, _lp)
-> "X.mkXNsTag " ++ tagName n ++ " " ++ nspName ns ++ " X.none X.none"
)
. quName
$ n
)
hasAttrType n
= "has" ++ padd maxAttrLen (nn n) ++ " :: XmlFilter"
hasAttrDef n
= "has" ++ padd maxAttrLen (nn n) ++ " = " ++
( either
(const ("X.hasAttr " ++ attName n))
(\ (ns, _pr, lp)
-> "X.hasNsAttr " ++ show lp ++ " " ++ nspName ns
)
. quNameAttr
$ n
)
mkAttrType n
= "af" ++ padd maxAttrLen (nn n) ++ " :: XmlFilter -> XmlFilter"
mkAttrDef n
= "af" ++ padd maxAttrLen (nn n) ++ " = " ++
( either
(const ("X.mkXAttr " ++ attName n))
(\ (ns, _pr, _lp)
-> "X.mkXNsAttr " ++ attName n ++ " " ++ nspName ns
)
. quNameAttr
$ n
)
mkSAttrType n
= "a" ++ padd maxAttrLen (nn n) ++ " :: String -> XmlFilter"
mkSAttrDef n
= "a" ++ padd maxAttrLen (nn n) ++ " = \\ v -> " ++
( either
(const ( "X.mkXAttr " ++ attName n ++ " (X.txt v)" ))
(\ (ns, _pr, _lp)
-> "X.mkXNsAttr " ++ attName n ++ " " ++ nspName ns ++ " (X.txt v)"
)
. quNameAttr
$ n
)
getValueType n
= "get" ++ padd maxAttrLen (nn n) ++ " :: XmlFilter"
getValueDef n
= "get" ++ padd maxAttrLen (nn n) ++ " = " ++
( either
(const ("X.getValue " ++ attName n))
(\ (ns, _pr, lp)
-> "X.getNsValue " ++ show lp ++ " " ++ nspName ns
)
. quNameAttr
$ n
)
nsType n
= nsPrefix ++ padd maxNsLen (nn n) ++ " :: String"
nsDef n v
= nsPrefix ++ padd maxNsLen (nn n) ++ " = " ++ show v
source = xshow . getValue a_source $ t
modul = modname . xshow . getValue a_output_file $ t
root = xshow . (isDoctype .> getDTDValue a_name) $ dt
hsmodul
| null modul = "DTD" ++ nn root
| otherwise = modul
upperCs = satisfies (hasAttr uppercaseInitials) $ t
underLn = satisfies (hasAttr prefixUnderline) $ t
nsAware = satisfies (hasAttr namespaceAware) $ t
elements -- select all element names from dtd
= nub
. sort
. map ( xshow . this)
. (deep isElement .> getDTDValue a_name)
$ dt
maxElemLen = maxLen . map nn $ elements
attributes
= nub
. sort
. map ( xshow . this)
. (deep isAttlist .> getDTDValue a_value)
$ dt
maxAttrLen = maxLen . map nn $ attributes
nsName [] = root
nsName n = n
namespaces
= map (\ (n,v) -> (drop 6 n, v))
. map (\ t' -> (xshow . getDTDValue a_value $ t', xshow . getDTDValue a_default $ t'))
. isNSAttr
$ dt
nsPrefixes = map (nsName . fst) namespaces
nsUris = map snd namespaces
maxNsLen = maxLen . map nn $ nsPrefixes
quName :: String -> Either String (String, String, String)
quName n
| not nsAware = Left n
| null lp && isNothing defns = Left n
| null lp = Right (nsName "", "", pr)
| isNothing expns = Left n
| otherwise = Right (nsName pr, pr, tail lp)
where
(pr, lp) = span (/= ':') n
defns = lookup "" namespaces
expns = lookup pr namespaces
quNameAttr :: String -> Either String (String, String, String)
quNameAttr an
| ':' `elem` an = quName an
| otherwise = Left an
isNSAttr :: XmlFilter
isNSAttr
= deep isAttlist
.>
( ( getDTDValue a_value
.>
isOfText (\ s' -> s' == "xmlns" || "xmlns:" `isPrefixOf` s')
)
`guards`
( isFixedAttrKind `guards` this)
)
-- ------------------------------------------------------------
-- |
-- the /real/ main program
--
-- get wellformed document, validates document, propagates and check namespaces
-- and controls output
getDocumentAndGenerateHaskellCode :: Attributes -> XmlStateFilter state
getDocumentAndGenerateHaskellCode al
= parseDocument ( al
++
[ (a_parse_html, v_0)
, (a_canonicalize, v_0)
, (a_remove_whitespace, v_0)
]
)
.>>
traceMsg 1 "start processing"
.>>
liftMf generateHXmlToolboxAccessFuntions
.>>
traceMsg 1 "processing finished"
.>>
traceSource
.>>
traceTree
.>>
writeDocument [ (a_output_xml, v_0)
]
.>>
checkStatus
-- ------------------------------------------------------------
--
-- the boring option definition and evaluation part
--
-- see doc for System.Console.GetOpt
progName :: String
progName = "DTDtoHXml"
options :: [OptDescr (String, String)]
options
= selectOptions [ a_help
] generalOptions
++
selectOptions [ a_trace
, a_proxy
, a_use_curl
, a_options_curl
, a_encoding
, a_validate
, a_check_namespaces
] inputOptions
++
selectOptions [ a_output_file
] outputOptions
++
[ Option "u" [prefixUnderline] (NoArg (prefixUnderline, v_1)) "separate tag and attribute names with a '_'"
, Option "U" [uppercaseInitials] (NoArg (uppercaseInitials, v_1)) "transform the first char of tag and attribute names to uppercase"
, Option "N" [namespaceAware] (NoArg (namespaceAware, v_1)) "filter are namespace aware, if namespace attributes occur in the DTD"
]
++
showOptions
usage :: [String] -> IO a
usage errl
| null errl
= do
hPutStrLn stdout use
exitProg False
| otherwise
= do
hPutStrLn stderr (concat errl ++ "\n" ++ use)
exitProg True
where
header = "DTDtoHXml - Generation of access function for the Haskell XML Toolbox from a DTD\n" ++
"Usage: " ++ progName ++ " [OPTION...] [URI or FILE]"
use = usageInfo header options
cmdlineOpts :: [String] -> IO (Attributes)
cmdlineOpts argv
= case (getOpt Permute options argv) of
(ol,n,[] )
-> do
sa <- src n
help (lookup a_help ol)
return (ol ++ sa)
(_,_,errs)
-> usage errs
where
src [] = return [(a_source, "")]
src [uri] = return [(a_source, uri)]
src _ = usage ["only one input url or file allowed\n"]
help Nothing = return ()
help (Just _) = usage []
-- ------------------------------------------------------------