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

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

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

   This module provides functions for validating XML documents represented as
   XmlTree.

   Unlike other popular XML validation tools the validation functions return
   a list of errors instead of aborting after the first error was found.

   Note: The validation process has been split into validation and transformation!
   If @validate@ did not report any errors, @transform@
   should be called, to change the document the way a validating parser
   is expected to do.

-}

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

module Text.XML.HXT.DTDValidation.Validation
    ( getDTDSubset
    , generalEntitiesDefined
    , validate
    , validateDTD
    , validateDoc
    , removeDoublicateDefs
    , transform
    )

where

import           Text.XML.HXT.DTDValidation.TypeDefs

import qualified Text.XML.HXT.DTDValidation.DocTransformation as DocTransformation
import qualified Text.XML.HXT.DTDValidation.DocValidation     as DocValidation
import qualified Text.XML.HXT.DTDValidation.DTDValidation     as DTDValidation
import qualified Text.XML.HXT.DTDValidation.IdValidation      as IdValidation

-- |
-- Main validation filter. Check if the DTD and the document are valid.
--
--
--    - returns : a function which expects a complete document as XmlTree input
--                     and returns a list of all errors found.

validate        :: XmlArrow
validate :: XmlArrow
validate        = XmlArrow
validateDTD XmlArrow -> XmlArrow -> XmlArrow
forall b c. LA b c -> LA b c -> LA b c
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+> XmlArrow
validateDoc

-- |
-- Check if the DTD is valid.
--
--
--    - returns : a function which expects an XmlTree from the parser as input
--                     and returns a list of all errors found in the DTD.

validateDTD     :: XmlArrow
validateDTD :: XmlArrow
validateDTD     = [IfThen XmlArrow XmlArrow] -> XmlArrow
forall b c d. [IfThen (LA b c) (LA b d)] -> LA b d
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
[IfThen (a b c) (a b d)] -> a b d
choiceA
                  [ XmlArrow
getDTDSubset        XmlArrow -> XmlArrow -> IfThen XmlArrow XmlArrow
forall a b. a -> b -> IfThen a b
:-> XmlArrow
DTDValidation.validateDTD
                  , XmlArrow
forall b. LA b b
forall (a :: * -> * -> *) b. ArrowList a => a b b
this                XmlArrow -> XmlArrow -> IfThen XmlArrow XmlArrow
forall a b. a -> b -> IfThen a b
:-> String -> XmlArrow
forall n. String -> LA n XmlTree
forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
err String
"Can't validate DTD: There is no DOCTYPE declaration in the document."
                  ]
-- |
-- Check if the document corresponds to the given DTD.
--
--
--    - returns : a function which expects a complete document as XmlTree input
--                     and returns a list of all errors found in the content part.

validateDoc     :: XmlArrow
validateDoc :: XmlArrow
validateDoc
    = [XmlTree] -> XmlArrow
validateDoc' ([XmlTree] -> XmlArrow) -> LA XmlTree [XmlTree] -> XmlArrow
forall c b d. (c -> LA b d) -> LA b c -> LA b d
forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< LA XmlTree [XmlTree]
getDTD
    where
    validateDoc' :: [XmlTree] -> XmlArrow
validateDoc' []             = String -> XmlArrow
forall n. String -> LA n XmlTree
forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
err String
"Can't validate document: There is no DOCTYPE declaration in the document."
    validateDoc' (XmlTree
dtdPart:[XmlTree]
_)    = XmlTree -> XmlArrow
DocValidation.validateDoc XmlTree
dtdPart
                                  XmlArrow -> XmlArrow -> XmlArrow
forall b c. LA b c -> LA b c -> LA b c
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
                                  XmlTree -> XmlArrow
IdValidation.validateIds  XmlTree
dtdPart

getDTD          :: XmlArrowS
getDTD :: LA XmlTree [XmlTree]
getDTD          = XmlArrow -> LA XmlTree [XmlTree]
forall b c. LA b c -> LA b [c]
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA ( XmlArrow
getDTDSubset
                          XmlArrow -> XmlArrow -> XmlArrow
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                          XmlArrow
removeDoublicateDefs
                        )

-- |
-- filter for transforming a document with respect to the given DTD.
--
-- Validating parsers
-- are expected to  normalize attribute values and add default values.
-- This function should be called after a successful validation.
--
--
--    - returns : a function which expects a complete XML document tree
--                and returns the transformed XmlTree

transform       :: XmlArrow
transform :: XmlArrow
transform       = [IfThen XmlArrow XmlArrow] -> XmlArrow
forall b c d. [IfThen (LA b c) (LA b d)] -> LA b d
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
[IfThen (a b c) (a b d)] -> a b d
choiceA
                  [ XmlArrow
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isRoot      XmlArrow -> XmlArrow -> IfThen XmlArrow XmlArrow
forall a b. a -> b -> IfThen a b
:-> ([XmlTree] -> XmlArrow
transformDoc ([XmlTree] -> XmlArrow) -> LA XmlTree [XmlTree] -> XmlArrow
forall c b d. (c -> LA b d) -> LA b c -> LA b d
forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< LA XmlTree [XmlTree]
getDTD)
                  , XmlArrow
forall b. LA b b
forall (a :: * -> * -> *) b. ArrowList a => a b b
this        XmlArrow -> XmlArrow -> IfThen XmlArrow XmlArrow
forall a b. a -> b -> IfThen a b
:-> String -> XmlArrow
forall n. String -> LA n XmlTree
forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
fatal String
"Can't transform document: No document root given"
                  ]
                  where
                  transformDoc :: [XmlTree] -> XmlArrow
transformDoc []       = XmlArrow
forall b. LA b b
forall (a :: * -> * -> *) b. ArrowList a => a b b
this
                  transformDoc [XmlTree]
dtd      = XmlTree -> XmlArrow
DocTransformation.transform ([XmlTree] -> XmlTree
forall a. HasCallStack => [a] -> a
head [XmlTree]
dtd)

-- |
-- Removes doublicate declarations from the DTD which first declaration is
-- binding. This is the case for ATTLIST and ENTITY declarations.
--
--
--    - returns : A function that replaces the children of DOCTYPE nodes by a list
--               where all multiple declarations are removed.

removeDoublicateDefs    :: XmlArrow
removeDoublicateDefs :: XmlArrow
removeDoublicateDefs    = XmlArrow
DTDValidation.removeDoublicateDefs

--
-- selects the DTD part of a document
-- but only, if there is more than the internal part for the 4 predefined XML entities

getDTDSubset            :: XmlArrow
getDTDSubset :: XmlArrow
getDTDSubset            = XmlArrow
forall (t :: * -> *) b. Tree t => LA (t b) (t b)
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren
                          XmlArrow -> XmlArrow -> XmlArrow
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                          ( LA XmlTree Attributes -> XmlArrow
forall b c. LA b c -> LA b b
forall (a :: * -> * -> *) b c. ArrowIf a => a b c -> a b b
filterA (LA XmlTree Attributes -> XmlArrow)
-> LA XmlTree Attributes -> XmlArrow
forall a b. (a -> b) -> a -> b
$ XmlArrow
forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDDoctype XmlArrow -> LA XmlTree Attributes -> LA XmlTree Attributes
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> LA XmlTree Attributes
forall (a :: * -> * -> *). ArrowXml a => a XmlTree Attributes
getDTDAttrl LA XmlTree Attributes
-> LA Attributes Attributes -> LA XmlTree Attributes
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Attributes -> Bool) -> LA Attributes Attributes
forall b. (b -> Bool) -> LA b b
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA (String -> Attributes -> Bool
forall k v. Eq k => k -> AssocList k v -> Bool
hasEntry String
a_name) )

generalEntitiesDefined  :: XmlArrow
generalEntitiesDefined :: XmlArrow
generalEntitiesDefined  = XmlArrow
getDTDSubset
                          XmlArrow -> XmlArrow -> XmlArrow
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                          XmlArrow -> XmlArrow
forall (t :: * -> *) b c. Tree t => LA (t b) c -> LA (t b) c
forall (a :: * -> * -> *) (t :: * -> *) b c.
(ArrowTree a, Tree t) =>
a (t b) c -> a (t b) c
deep XmlArrow
forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDEntity

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