hxt-9.0.0: examples/arrows/dtd2hxt/DTDtoHXT.hs
-- |
-- DTDtoHXT - A program for generating access functions for the Haskell XML Toolbox
-- from a DTD (Arrow Version)
--
-- Author : Uwe Schmidt
--
-- this program may be used as example main program for the
-- Haskell XML Toolbox
module Main
where
import Text.XML.HXT.Core -- import all stuff for parsing, validating, and transforming XML
import Text.XML.HXT.Curl
import System.IO -- import the IO and commandline option stuff
import System.Environment
import System.Console.GetOpt
import System.Exit
import Data.Char
import Data.List
-- ------------------------------------------------------------
-- |
-- the main program
main :: IO ()
main
= do
argv <- getArgs -- get the commandline arguments
(al, src) <- cmdlineOpts argv -- and evaluate them, return a key-value list
[rc] <- runX (dtd2hxt al src)
exitProg (rc >= c_err)
-- ------------------------------------------------------------
exitProg :: Bool -> IO a
exitProg True = exitWith (ExitFailure (-1))
exitProg False = exitWith ExitSuccess
-- ------------------------------------------------------------
--
-- options
uppercaseInitials, namespaceAware, prefixUnderline :: String
uppercaseInitials = "uppercase-initials"
namespaceAware = "namespace-aware"
prefixUnderline = "prefix-underline"
-- name prefixes
tagPrefix, attPrefix, nsPrefix, isPrefix, mkPrefix, hasPrefix, getPrefix
, mkAttPrefix, mkSAttPrefix
, nsDefault :: String
tagPrefix = "tag"
attPrefix = "attr"
nsPrefix = "ns"
isPrefix = "is"
mkPrefix = "e"
hasPrefix = "has"
getPrefix = "get"
mkAttPrefix = "a"
mkSAttPrefix = "sa"
nsDefault = "default"
-- ------------------------------------------------------------
-- |
-- the /real/ main program
--
-- get wellformed document, validates document, but not canonicalize
-- (this would remove the DTD),
-- and controls output
dtd2hxt :: SysConfigList -> String -> IOSArrow b Int
dtd2hxt config src
= configSysVars config -- set all global config options
>>>
readDocument [withCanonicalize no
,withCurl []
] src
>>>
traceMsg 1 "start processing DTD"
>>>
processChildren (isDTD `guards` genHXT)
>>>
traceMsg 1 "processing finished"
>>>
traceSource
>>>
traceTree
>>>
( writeDocument [withOutputPLAIN] $< getSysAttr "output-file" )
>>>
getErrStatus
where
genHXT
= catA $ map (>>> mkText) $
[ getModuleName -- the module header
>>>
arr genModHead
, constA $ comm "namespace declarations"
, getNSAttr -- namespace constants
>>> -- declared as "xmlns" or "xmlns:<ns>" attribute with #FIXED values
arr2 genNSCode
, constA $ comm "element arrows"
, getElems >>. sort -- element processing
>>>
arr genElemCode
, getAttrs >>. ( sort . nub ) -- attribute processing
>>>
arr genAttrCode
, getModuleName -- module footer
>>> arr genModFoot
]
-- auxiliary arrows --------------------------------------------------
getModuleName :: (ArrowXml a, ArrowDTD a) => a XmlTree String
getModuleName
= isDTDDoctype
>>>
getDTDAttrValue a_name
>>>
arr moduleName
-- filter namespace attributes ----------------------------------------
getNSAttr :: (ArrowXml a, ArrowDTD a) => a XmlTree (String, String)
getNSAttr
= deep isDTDAttlist
>>>
( ( getDTDAttrValue a_value >>> isA (\ s -> s == "xmlns" || "xmlns:" `isPrefixOf` s)
)
`guards`
( ( getDTDAttrValue a_kind >>> isA (== k_fixed)
)
`guards`
( ( getDTDAttrValue a_value >>> arr (drop 6) ) -- remove "xmlns:" prefix
&&&
getDTDAttrValue a_default
)
)
)
getElems :: (ArrowXml a, ArrowDTD a) => a XmlTree String
getElems
= deep isDTDElement
>>>
getDTDAttrValue a_name
getAttrs :: (ArrowXml a, ArrowDTD a) => a XmlTree String
getAttrs
= deep isDTDAttlist
>>>
getDTDAttrValue a_value
-- code generation ------------------------------------------------------------
genModHead :: String -> String
genModHead rootElem
= code [ sepl
, "--"
, "-- don't edit this module"
, "-- generated with " ++ progName
, "-- simple access function for Haskell XML Toolbox"
, "-- generated from DTD of document: " ++ show src
, ""
, "module " ++ rootElem ++ " ( module " ++ rootElem ++ " )"
, "where"
, ""
, "import Text.XML.HXT.Core (XmlTree, ArrowXml, (>>>))"
, "import qualified Text.XML.HXT.Core as X (attr, eelem, getAttrValue, hasAttr, hasName, isElem, sattr)"
]
genNSCode :: String -> String -> String
genNSCode prefix ns
= code [ ns' ++ "\t:: String"
, ns' ++ "\t= " ++ show ns
]
where
ns' = nsPrefix ++ nn (if null prefix then nsDefault else prefix)
genElemCode :: String -> String
genElemCode n
= code [ comm ("arrows for element " ++ show n)
, tagN ++ "\t:: String"
, tagN ++ "\t= " ++ show n
, ""
, isN ++ "\t:: ArrowXml a => a XmlTree XmlTree"
, isN ++ "\t= X.isElem >>> X.hasName " ++ tagN
, ""
, mkN ++ "\t:: ArrowXml a => a n XmlTree"
, mkN ++ "\t= X.eelem " ++ tagN
]
where
tagN = tagPrefix ++ nn n
isN = isPrefix ++ nn n
mkN = mkPrefix ++ nn n
genAttrCode :: String -> String
genAttrCode n
= code [ comm ("arrows for attribute " ++ show n)
, attN ++ "\t:: String"
, attN ++ "\t= " ++ show n
, ""
, hasN ++ "\t:: ArrowXml a => a XmlTree XmlTree"
, hasN ++ "\t= X.hasAttr " ++ attN
, ""
, getN ++ "\t:: ArrowXml a => a XmlTree String"
, getN ++ "\t= X.getAttrValue " ++ attN
, ""
, mkN ++ "\t:: ArrowXml a => a n XmlTree -> a n XmlTree"
, mkN ++ "\t= X.attr " ++ attN
, ""
, mksN ++ "\t:: ArrowXml a => String -> a n XmlTree"
, mksN ++ "\t= X.sattr " ++ attN
]
where
attN = attPrefix ++ nn n
hasN = hasPrefix ++ nn n
getN = getPrefix ++ nn n ++ nn "value"
mkN = mkAttPrefix ++ nn n
mksN = mkSAttPrefix ++ nn n
genModFoot :: String -> String
genModFoot rootElem
= comm ( "end of module " ++ rootElem)
-- string manipulation --------------------------------------------------
code :: [String] -> String
code = concatMap (++ "\n")
comm :: String -> String
comm cm = code [ "", sepl, "--", "-- " ++ cm, ""]
sepl :: String
sepl = "-- ----------------------------------------"
moduleName :: String -> String
moduleName rootElem
= modname . (\ x -> if null x then rootElem else x) . getConfigAttr "output_file" $ config
modname
= (\ x -> toUpper (head x) : tail x)
. reverse
. (\ n -> if '.' `elem` n -- remove extension
then drop 1 . dropWhile (/= '.') $ n
else n
)
. takeWhile (/= '/') -- remove dir path
. reverse
nn :: String -> String
nn
= trInitial . concatMap nc -- normalize names
nc :: Char -> String
nc c
| c `elem` ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_" = [c]
| c == ':' || c == '-' = "_"
| otherwise = ("_" ++) . show . fromEnum $ c
trInitial :: String -> String
trInitial str
| null str = str
| underLn = '_' : str
| upperCs = toUpper (head str) : tail str
| otherwise = str
upperCs, underLn {-, nsAware -} :: Bool
upperCs = (== "1") . getConfigAttr uppercaseInitials $ config
underLn = (== "1") . getConfigAttr prefixUnderline $ config
_nsAware = (== "1") . getConfigAttr namespaceAware $ config
-- ------------------------------------------------------------
--
-- the boring option definition and evaluation part
--
-- see doc for System.Console.GetOpt
progName :: String
progName = "DTDtoHXT"
options :: [OptDescr SysConfig]
options
= selectOptions [ a_help
] generalOptions
++
selectOptions [ a_trace
, a_proxy
, a_encoding
, a_validate
, a_check_namespaces
] inputOptions
++
selectOptions [ "output-file"
] outputOptions
++
[ Option "u" [prefixUnderline] (NoArg $ withSysAttr prefixUnderline "1") "separate tag and attribute names with a '_'"
, Option "U" [uppercaseInitials] (NoArg $ withSysAttr uppercaseInitials "1") "transform the first char of tag and attribute names to uppercase"
, Option "N" [namespaceAware] (NoArg $ withSysAttr namespaceAware "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 (SysConfigList, String)
cmdlineOpts argv
= case (getOpt Permute options argv) of
(ol,n,[] )
-> do
sa <- src n
help (getConfigAttr a_help ol)
return (ol, sa)
(_,_,errs)
-> usage errs
where
src [uri] = return uri
src [] = usage ["input file/uri missing"]
src _ = usage ["only one input url or file allowed\n"]
help "1" = usage []
help _ = return ()
-- ------------------------------------------------------------