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

{- |
   Module     : Text.XML.HXT.DTDValidation.TypeDefs
   Copyright  : Copyright (C) 2008 Uwe Schmidt
   License    : MIT

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

   This module provides all datatypes for DTD validation

-}

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

module Text.XML.HXT.DTDValidation.TypeDefs
    ( module Text.XML.HXT.DTDValidation.TypeDefs
    , module Text.XML.HXT.DOM.Interface
    , module Text.XML.HXT.Arrow.XmlArrow
    , module Control.Arrow
    , module Control.Arrow.ArrowList
    , module Control.Arrow.ArrowIf
    , module Control.Arrow.ArrowState
    , module Control.Arrow.ArrowTree
    , module Control.Arrow.ListArrow
    , module Control.Arrow.StateListArrow
    )
where

import Control.Arrow                    -- classes
import Control.Arrow.ArrowList
import Control.Arrow.ArrowIf
import Control.Arrow.ArrowState
import Control.Arrow.ArrowTree

import Control.Arrow.ListArrow          -- arrow types
import Control.Arrow.StateListArrow

import Text.XML.HXT.Arrow.XmlArrow

import           Text.XML.HXT.DOM.Interface

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

infixr 0 $$

type XmlArrow   = LA XmlTree XmlTree
type XmlArrowS  = LA XmlTree XmlTrees

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

dtd_name
 , dtd_value
 , dtd_type
 , dtd_kind
 , dtd_modifier
 , dtd_default  :: Attributes -> String

dtd_name        = lookup1 a_name
dtd_value       = lookup1 a_value
dtd_type        = lookup1 a_type
dtd_kind        = lookup1 a_kind
dtd_modifier    = lookup1 a_modifier
dtd_default     = lookup1 a_default

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

isUnparsedEntity        :: ArrowDTD a => a XmlTree XmlTree
isUnparsedEntity        = filterA $
                          getDTDAttrl >>> isA (hasEntry k_ndata)

hasDTDAttrValue         :: ArrowDTD a => String -> (String -> Bool) -> a XmlTree XmlTree
hasDTDAttrValue an p    = filterA $
                          getDTDAttrl >>> isA (p . lookup1 an)

isRequiredAttrKind      :: ArrowDTD a => a XmlTree XmlTree
isRequiredAttrKind      = hasDTDAttrValue a_kind (== k_required)

isDefaultAttrKind       :: ArrowDTD a => a XmlTree XmlTree
isDefaultAttrKind       = hasDTDAttrValue a_kind (== k_default)

isFixedAttrKind         :: ArrowDTD a => a XmlTree XmlTree
isFixedAttrKind         = hasDTDAttrValue a_kind (== k_fixed)

isMixedContentElement   :: ArrowDTD a => a XmlTree XmlTree
isMixedContentElement   = hasDTDAttrValue a_type (== v_mixed)

isEmptyElement          :: ArrowDTD a => a XmlTree XmlTree
isEmptyElement          = hasDTDAttrValue a_type (== k_empty)

isEnumAttrType          :: ArrowDTD a => a XmlTree XmlTree
isEnumAttrType          = hasDTDAttrValue a_type (== k_enumeration)

isIdAttrType            :: ArrowDTD a => a XmlTree XmlTree
isIdAttrType            = hasDTDAttrValue a_type (== k_id)

isIdRefAttrType         :: ArrowDTD a => a XmlTree XmlTree
isIdRefAttrType         = hasDTDAttrValue a_type (`elem` [k_idref, k_idrefs])

isNotationAttrType      :: ArrowDTD a => a XmlTree XmlTree
isNotationAttrType      = hasDTDAttrValue a_type (== k_notation)

isAttlistOfElement      :: ArrowDTD a => String -> a XmlTree XmlTree
isAttlistOfElement el   = isDTDAttlist
                          >>>
                          hasDTDAttrValue a_name (== el)

valueOfDTD              :: String -> XmlTree -> String
valueOfDTD n            = concat . runLA ( getDTDAttrl >>^ lookup1 n )

valueOf                 :: String -> XmlTree -> String
valueOf n               = concat . runLA ( getAttrValue n )

getDTDAttributes        :: XmlTree -> Attributes
getDTDAttributes        = concat . runLA getDTDAttrl

isDTDDoctypeNode        :: XmlTree -> Bool
isDTDDoctypeNode        = not . null . runLA isDTDDoctype

isDTDElementNode        :: XmlTree -> Bool
isDTDElementNode        = not . null . runLA isDTDElement

isDTDAttlistNode        :: XmlTree -> Bool
isDTDAttlistNode        = not . null . runLA isDTDAttlist

isDTDContentNode        :: XmlTree -> Bool
isDTDContentNode        = not . null . runLA isDTDContent

isDTDNameNode           :: XmlTree -> Bool
isDTDNameNode           = not . null . runLA isDTDName

isElemNode              :: XmlTree -> Bool
isElemNode              = not . null . runLA isElem

nameOfAttr              :: XmlTree -> String
nameOfAttr              = concat . runLA (getAttrName >>^ qualifiedName)

nameOfElem              :: XmlTree -> String
nameOfElem              = concat . runLA (getElemName >>^ qualifiedName)

-- |
-- infix operator for applying an arrow to a list of trees
--
--    * 1.parameter f :  the arrow
--
--    - 2.parameter ts :  the list of trees
--
--    - returns : list of results

($$)            :: XmlArrow -> XmlTrees -> XmlTrees
f $$ l          = runLA (unlistA >>> f) l

-- | create an error message

msgToErr        :: (String -> String) -> LA String XmlTree
msgToErr f      = mkErr $< this
                  where
                  mkErr "" = none
                  mkErr s  = err (f s)


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