content: {-# LANGUAGE FlexibleInstances    #-}
  {-# LANGUAGE TypeSynonymInstances #-}
  {-# OPTIONS -fno-warn-orphans #-}
  
  {- |
     Module     : Text.XML.HXT.XMLSchema.ValidationTypes
     Copyright  : Copyright (C) 2012 Thorben Guelck, Uwe Schmidt
     License    : MIT
  
     Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
     Stability  : experimental
     Portability: portable
  
     Contains the basic datatypes which are used during validation.
  -}
  
  module Text.XML.HXT.XMLSchema.ValidationTypes
  where
  
  import           Text.XML.HXT.Core            (QName, XmlTree, c_err, c_warn)
  import           Text.XML.HXT.DOM.ShowXml     (xshow)
  
  -- import Text.XML.HXT.Arrow.XmlRegex ( XmlRegex )
  
  import           Control.Monad.Identity       (Identity, runIdentity)
  
  import           Control.Monad.Reader         (ReaderT, asks, runReaderT)
  
  import           Control.Monad.Writer         (WriterT, runWriterT, tell)
  
  import           Data.Map                     (Map, keys)
  
  import           Text.XML.HXT.XMLSchema.Regex
  
  -- ----------------------------------------
  
  -- | The environment used during validation
  data SValEnv       = SValEnv
                     { xpath       :: XPath
                     , elemDesc    :: ElemDesc
                     , allElemDesc :: SubElemDesc     -- all declared elements, used with wilcard contents
                     }
  
  -- | Simple XPath representation
  type XPath         = String
  
  -- | Description for an element under test
  data ElemDesc      = ElemDesc
                     { errmsg       :: Maybe String
                     , attrDesc     :: AttrDesc
                     , mixedContent :: Bool
                     , contentModel :: XmlRegex'
                     , subElemDesc  :: SubElemDesc
                     , wildcards    :: Wildcards          -- redundant: never read, only set
                     , sttf         :: MaybeSTTF          -- in case of simple types Just the string test, else Nothing
                     }
  
  -- | Description for allowed attributes of an element
  type AttrDesc      = (AttrMap, AttrWildcards)
  
  -- | Table for regular attributes
  type AttrMap       = Map QName AttrMapVal
  
  -- | Entry for AttrMap: required-flag and test function
  type AttrMapVal    = (Bool, STTF)
  
  -- | List of test functions for attribute wildcards
  type AttrWildcards = [QName -> Bool]
  
  -- | Table of possible subelems and their descriptions
  type SubElemDesc   = Map QName ElemDesc
  
  -- | List of wildcard specs
  type Wildcards     = [Wildcard]
  
  -- | Pair of namespace test and action
  data Wildcard      = WC (QName -> Bool) WildcardClass
  
  -- | wildcard validation strategie
  data WildcardClass = Skip | Lax | Strict
  
  -- | SimpleType test function to validate basic values
  type STTF          = String -> SVal Bool
  
  -- | SimpleType test function to validate basic values
  type MaybeSTTF     = Maybe STTF
  
  -- | Validation result contains the validation status and log
  type SValResult    = (Bool, SValLog)
  
  -- | Validation log is a list of error levels, XPaths and messages
  type SValLog       = [SValLogMsg]
  
  -- | Validation log message
  type SValLogMsg    = (Int, XPath, String)
  
  -- | Schema validation monad
  type SVal a        = ReaderT SValEnv (WriterT SValLog Identity) a
  
  -- | Runs a computation in the schema validation monad
  runSVal :: SValEnv -> SVal a -> (a, SValLog)
  runSVal env val = runIdentity $ runWriterT $ runReaderT val env
  
  -- | the result state of a matching test with XmlTree regular expressions
  --
  -- the result is a function for testing the content model of all elements
  -- contained in the children of an element
  
  type XmlRegexState = SVal Bool
  
  -- | A substitute for XmlRegex from hxt Arrow.XmlRegex
  
  type XmlRegex' = Regex XmlRegexState XmlTree
  
  instance ShowSym XmlTree where
      showSym = cut 80 . xshow . (:[])
  
  cut :: Int -> String -> String
  cut n s
      | null rest   = s'
      | otherwise   = s' ++ "..."
      where
        (s', rest)  = splitAt n s
  
  
  -- ----------------------------------------
  
  -- | Creates a SimpleType test function which creates a warning and always succeeds
  mkWarnSTTF :: String -> STTF
  mkWarnSTTF msg
    = \ _ -> mkLogSTTF c_warn id msg
  
  mkWarnSTTF'' :: (XPath -> XPath) -> String -> SVal Bool
  mkWarnSTTF''
      = mkLogSTTF c_warn
  
  -- | Creates a SimpleType test function which creates an error and always fails
  mkErrorSTTF :: String -> STTF
  mkErrorSTTF msg
    = \ _ -> mkErrorSTTF' msg
  
  mkErrorSTTF' :: STTF
  mkErrorSTTF' msg
      = mkLogSTTF c_err id msg
  
  mkErrorSTTF'' :: (XPath -> XPath) -> String -> SVal Bool
  mkErrorSTTF''
      = mkLogSTTF c_err
  
  mkLogSTTF :: Int -> (XPath -> XPath) -> String -> SVal Bool
  mkLogSTTF lev fpos msg
    = do pos <- asks xpath
         tell [(lev, fpos pos, msg)]
         return (lev < c_err)
  
  -- ----------------------------------------
  --
  -- simple tracing
  
  -- {-
  logg :: [String] -> SVal ()
  logg msg
      = do pos <- asks xpath
           tell [(0, pos, unwords msg)]
  -- -}
  
  {-
  logg :: [String] -> SVal ()
  logg msg
      = return ()
  {-# INLINE #-}
  -- -}
  
  showElemDesc :: ElemDesc -> String
  showElemDesc e
      = unwords [ "ElemDesc {"
                , show $ errmsg e
                , ",attrDesc ="
                , showAttrDesc $ attrDesc e
                , ",mixedDontent ="
                , show $ mixedContent e
                , ",contentModel ="
                , show $ contentModel e
                , ",subElemDesc = "
                , show . keys $ subElemDesc e
                , ",sttf ="
                , show . fmap (const "<sttf>") $ sttf e
                ]
  
  showAttrDesc :: AttrDesc -> String
  showAttrDesc a
      = unwords [ "("
                , show . keys . fst $ a
                , ","
                , show . map (const "<wcf>") . snd $ a
                , ")"
                ]
  
  -- ----------------------------------------
  
  