-- |
-- 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 ()

-- ------------------------------------------------------------