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

    {- |
       Module     : Text.XML.HXT.Arrow.Pickle.DTD
       Copyright  : Copyright (C) 2005 Uwe Schmidt
       License    : MIT

       Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
       Stability  : experimental
       Portability: portable
       Version    : $Id$

    Functions for converting a pickler schema
    into a DTD

    -}

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

    module Text.XML.HXT.Arrow.Pickle.DTD
    where

    import           Data.Maybe

    import qualified Text.XML.HXT.DOM.XmlNode as XN

    import           Text.XML.HXT.DOM.Interface
    import           Text.XML.HXT.Arrow.Pickle.Schema
    import           Text.XML.HXT.RelaxNG.XmlSchema.DataTypeLibW3C

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

    data DTDdescr			= DTDdescr Name Schemas [(Name,Schemas)]

    instance Show DTDdescr where
        show (DTDdescr n es as)
    	= "root element: " ++ n ++ "\n"
    	  ++
    	  "elements:\n"
    	  ++
    	  concatMap ((++ "\n") .show) es
    	  ++
    	  "attributes:\n"
    	  ++
    	  concatMap ((++ "\n") . showAttr) as
    	where
    	showAttr (n1, sc) = n1 ++ ": " ++ show sc

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

    -- | convert a DTD descr into XmlTrees

    dtdDescrToXml	:: DTDdescr -> XmlTrees
    dtdDescrToXml (DTDdescr rt es as)
        = checkErr (null rt) "no unique root element found in pickler DTD, add an \"xpElem\" pickler"
          ++
          concatMap (checkErr True . ("no element decl found in: " ++) . show) (filter (not . isScElem) es)
          ++
          concatMap (uncurry checkContentModell . \ (Element n sc) -> (n,sc)) es1
          ++
          concatMap (uncurry checkAttrModell) as
          ++
          [ XN.mkDTDElem DOCTYPE docAttrs ( concatMap elemDTD es1
    					++
    					concatMap (uncurry attrDTDs) as
    				      ) ]
        where
        es1 		= filter isScElem es

        docAttrs		= [(a_name, if null rt then "no-unique-root-element-found" else rt)]

        elemDTD (Element n sc)
    	| lookup1 a_type al == "unknown"
    	    = cl
    	| otherwise
    	    = [ XN.mkDTDElem ELEMENT ((a_name, n) : al) cl ]
    	where
    	(al, cl) = scContToXml sc
        elemDTD _
    	= error "illegal case in elemDTD"

        attrDTDs en		= concatMap (attrDTD en)
        attrDTD en (Attribute an sc)
    	    		= [ XN.mkDTDElem ATTLIST ((a_name, en) : (a_value, an) : al) cl ]
    			  where
    			  (al, cl) = scAttrToXml sc
        attrDTD _ _		= error "illegal case in attrDTD"

    checkAttrModell					:: Name -> Schemas -> XmlTrees
    checkAttrModell n				= concatMap (checkAM n)

    checkAM						:: Name -> Schema -> XmlTrees
    checkAM en (Attribute an sc)			= checkAMC en an sc
    checkAM _ _					= []

    checkAMC					:: Name -> Name -> Schema -> XmlTrees
    checkAMC _en _an (CharData _)			= []
    checkAMC en an sc
        | isScCharData sc	= []
        | isScList sc
          &&
          (sc_1 sc == scNmtoken)
    			= []
        | isScOpt sc	= checkAMC en an (sc_1 sc)
        | otherwise		= foundErr
    			  ( "weird attribute type found for attribute "
    			    ++ show an
    			    ++ " for element "
    			    ++ show en
    			    ++ "\n\t(internal structure: " ++ show sc ++ ")"
    			    ++ "\n\thint: create an element instead of an attribute for "
    			    ++ show an
    			  )

    -- checkContentModell1 n sc = foundErr (n ++ " : " ++ show sc) ++ checkContentModell n sc

    checkContentModell				:: Name -> Schema -> XmlTrees

    checkContentModell _ Any
        = []

    checkContentModell _ (ElemRef _)
        = []

    checkContentModell _ (CharData _)
        = []

    checkContentModell _ (Seq [])
        = []

    checkContentModell n (Seq scs)
        = checkErr pcDataInCM
          ( "PCDATA found in a sequence spec in the content modell for "
    	++ show n
    	++ "\n\thint: create an element for this data"
          )
          ++
          checkErr somethingElseInCM
          ( "something weired found in a sequence spec in the content modell for "
    	++ show n
          )
          ++
          concatMap (checkContentModell n) scs
        where
        pcDataInCM        = any isScCharData scs
        somethingElseInCM = any (\ sc -> not (isScSARE sc) && not (isScCharData sc)) scs

    checkContentModell n (Alt scs)
        = checkErr mixedCM
          ( "PCDATA mixed up with illegal content spec in mixed contents for "
    	++ show n
    	++ "\n\thint: create an element for this data"
          )
          ++
          concatMap (checkContentModell n) scs
        where
        mixedCM
    	| any isScCharData scs
    	    = any (not . isScElemRef) . filter (not . isScCharData) $ scs
    	| otherwise
    	    = False

    checkContentModell _ (Rep _ _ (ElemRef _))
        = []

    checkContentModell n (Rep _ _ sc@(Seq _))
        = checkContentModell n sc

    checkContentModell n (Rep _ _ sc@(Alt _))
        = checkContentModell n sc

    checkContentModell n (Rep _ _ _)
        = foundErr
          ( "illegal content spec found for "
    	++ show n
          )

    checkContentModell _ _
        = []

    scContToXml			:: Schema -> (Attributes, XmlTrees)

    scContToXml Any			= ( [(a_type, v_any)],    [] )
    scContToXml (CharData _)	= ( [(a_type, v_pcdata)], [] )
    scContToXml (Seq [])		= ( [(a_type, v_empty)],  [] )
    scContToXml sc@(ElemRef _)	= scContToXml (Seq [sc])
    scContToXml sc@(Seq _)		= ( [(a_type, v_children)]
    				  , scCont [] sc
    				  )
    scContToXml sc@(Alt sc1)
        | isMixed sc1		= ( [(a_type, v_mixed)]
    				  , scCont [ (a_modifier, "*") ] sc
    				  )
        | otherwise			= ( [(a_type, v_children)]
    				  , scCont [] sc
    				  )
        where
        isMixed			= not . null . filter isScCharData
    scContToXml sc@(Rep _ _ _)	= ( [(a_type, v_children)]
    				  , scCont [] sc
    				  )
    scContToXml _sc			= ( [(a_type, v_any)]		-- default: everything is allowed
    				  , []
    				  )

    scWrap				:: Schema -> Schema
    scWrap sc@(Alt _)		= sc
    scWrap sc@(Seq _)		= sc
    scWrap sc@(Rep _ _  _)		= sc
    scWrap sc			= Seq [sc]

    scCont				:: Attributes -> Schema -> XmlTrees
    scCont al (Seq scs)		= scConts ((a_kind, v_seq   ) : al) scs
    scCont al (Alt scs)		= scConts ((a_kind, v_choice) : al) scs
    scCont al (Rep 0 (-1) sc)	= scCont ((a_modifier, "*")   : al) (scWrap sc)
    scCont al (Rep 1 (-1) sc)	= scCont ((a_modifier, "+")   : al) (scWrap sc)
    scCont al (Rep 0 1    sc)	= scCont ((a_modifier, "?")   : al) (scWrap sc)
    scCont al (ElemRef n)		= [XN.mkDTDElem NAME ((a_name, n) : al) []]
    scCont _  (CharData _)		= [XN.mkDTDElem NAME [(a_name, "#PCDATA")] []]
    scCont _  _sc			= [XN.mkDTDElem NAME [(a_name, "bad-content-spec")] []]		-- error case

    scConts				:: Attributes -> Schemas -> XmlTrees
    scConts al scs			= [XN.mkDTDElem CONTENT al (concatMap (scCont []) scs)]

    scAttrToXml			:: Schema -> (Attributes, XmlTrees)

    scAttrToXml sc
        | isScFixed	sc		= ( [ (a_kind, k_fixed)
    				    , (a_type, k_cdata)
    				    , (a_default, (xsdParam xsd_enumeration sc))
    				    ]
    				  , [])
        | isScEnum sc		= ( [ (a_kind, k_required)
    				    , (a_type, k_enumeration)
    				    ]
    				  , map (\ n -> XN.mkDTDElem NAME [(a_name, n)] []) enums
    				  )
        | isScCharData sc		= ( [ (a_kind, k_required)
    				    , (a_type, d_type)
    				    ]
    				  , [])
        | isScOpt sc		= (addEntry a_kind k_implied al, cl)
        | isScList sc		= (addEntry a_type k_nmtokens al, cl)
        | otherwise			= ( [ (a_kind, k_fixed)
    				    , (a_default, "bad-attribute-type: " ++ show sc)
    				    ]
    				  , [] )
        where
        (al, cl)			= scAttrToXml (sc_1 sc)
        d_type
    	| sc == scNmtoken	= k_nmtoken
    	| otherwise		= k_cdata
        enums			= words . xsdParam xsd_enumeration $ sc

    checkErr			:: Bool -> String -> XmlTrees
    checkErr True s			= [XN.mkError c_err s]
    checkErr _    _			= []

    foundErr			:: String -> XmlTrees
    foundErr			= checkErr True

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

    -- | convert a pickler schema into a DTD descr

    dtdDescr	:: Schema -> DTDdescr
    dtdDescr sc
        = DTDdescr rt es1 as
        where
        es  = elementDeclarations sc
        es1 = map remAttrDec es
        as  = filter (not. null . snd) . concatMap attrDec $ es
        rt  = fromMaybe "" . elemName $ sc

    elementDeclarations	:: Schema -> Schemas
    elementDeclarations sc	= elemRefs . elementDecs [] $ [sc]

    elementDecs		:: Schemas -> Schemas -> Schemas
    elementDecs es []
        = es
    elementDecs es (s:ss)
        = elementDecs (elemDecs s) ss
        where
        elemDecs (Seq scs)		= elementDecs es scs
        elemDecs (Alt scs)		= elementDecs es scs
        elemDecs (Rep _ _ sc)	= elemDecs sc
        elemDecs e@(Element n sc)
    	| n `elem` elemNames es	= es
    	| otherwise             = elementDecs (e:es) [sc]
        elemDecs _			= es

    elemNames		:: Schemas -> [Name]
    elemNames               = concatMap (maybeToList . elemName)

    elemName		:: Schema -> Maybe Name
    elemName (Element n _)  = Just n
    elemName _              = Nothing

    elemRefs	:: Schemas -> Schemas
    elemRefs	= map elemRef
        where
        elemRef (Element n sc)   = Element n (pruneElem sc)
        elemRef sc               = sc
        pruneElem (Element n _)  = ElemRef n
        pruneElem (Seq scs)      = Seq (map pruneElem scs)
        pruneElem (Alt scs)      = Alt (map pruneElem scs)
        pruneElem (Rep l u sc)   = Rep l u (pruneElem sc)
        pruneElem sc             = sc

    attrDec			:: Schema -> [(Name, Schemas)]
    attrDec (Element n sc)
        = [(n, attrDecs sc)]
          where
          attrDecs a@(Attribute _ _)	= [a]
          attrDecs (Seq scs)		= concatMap attrDecs scs
          attrDecs _			= []
    attrDec _		= []

    remAttrDec		:: Schema -> Schema
    remAttrDec (Element n sc)
        = Element n (remA sc)
          where
          remA (Attribute _ _) = scEmpty
          remA (Seq scs)       = scSeqs . map remA $ scs
          remA sc1             = sc1
    remAttrDec _
        = error "illegal case in remAttrDec"

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