    {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}

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

    {- |
       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.XMLSchema.DataTypeLibW3CNames

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

    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"

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