content: {-# 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"
  
  -- ------------------------------------------------------------
  
  