-- |
-- 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 []

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