----------------------------------------------------------------------------
-- |
-- Module      :  Text.XML.Schema.Validator
-- Copyright   :  (c) Simon Foster 2004
-- License     :  GPL version 2 (see COPYING)
-- 
-- Maintainer  :  aca01sdf@shef.ac.uk
-- Stability   :  experimental
-- Portability :  non-portable (ghc >= 6 only)
--
-- A Validator for XML Schema.
--
-- @This file is part of HAIFA.@
--
-- @HAIFA is free software; you can redistribute it and\/or modify it under the terms of the 
-- GNU General Public License as published by the Free Software Foundation; either version 2 
-- of the License, or (at your option) any later version.@
--
-- @HAIFA is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without 
-- even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.@
--
-- @You should have received a copy of the GNU General Public License along with HAIFA; if not, 
-- write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA@
----------------------------------------------------------------------------

module Text.XML.Schema.Validator where

import Text.XML.Schema.Structure
import Utils
import Data.List
import Control.Monad
import Control.Monad.Error
import Maybe
import Text.XML.Schema.BasicTypes
import Text.Regex
import Data.FiniteMap
import Governor

-- | The base type, which will validate any String.
anySimpleType = 
    Simp (S_Sel []) Nothing (return $ newNCName "anySimpleType") (Just (S_Restr (R_SimpRestr Nothing Nothing Nothing [] [] Nothing)))

simpleTypeValidate :: FiniteMap (String, String) SimpleType -> String -> SimpleType -> Either String ()
simpleTypeValidate m s t = do
    x <- (maybe2Either "FIXME: Do we fail on no restriction or extension in SimpleType?" $ se_cont t)
    case x of
        S_Restr r       -> validateSimpRestricted m s r
        S_List  _ lt st -> let l = (delimit s ' ') in 
                            listType lt >>= valList l >> (st ?> (valList l . fromJust, return ()))
        S_Union _ ut st -> let tl = (map fromJust $ filter isJust $ map lookupType ut) ++ st in
                                valUnion tl s
        
    where
        lookupType = lookupFM m . qn2pair 
        listType lt = 
            lt ?> (maybe2Either "Type not found in given namespaces" . lookupType . fromJust, return anySimpleType)
        valList [] _      = return ()
        valList (h:t) st  = simpleTypeValidate m h st >> valList t st 
        valUnion [] _     = fail "Value does not validate against any types in the union type"
        -- If we catch an error, we need to see if it validates against the next item in the Union. Otherwise
        -- we have a valid value.
        valUnion (h:t) st = catchError (simpleTypeValidate m st h) (\e -> valUnion t st)
        

-- | Validate a restricted type, first validate it by it's base type by calling simpleTypeValidate and
-- then check the list of restrictions on it.
validateSimpRestricted :: FiniteMap (String, String) SimpleType -> String -> Restriction -> Either String ()
validateSimpRestricted m s r = (validBase) >> (validSimp) >> (validRestr)
    where         
        validBase = ((isNothing base) || ((snd basePair)=="anySimpleType")) ? (return (), baseType >>= simpleTypeValidate m s)
            where
                base        = ra_base r
                basePair    = qn2pair $ fromJust base
                baseType    = maybe2Either "Type not found in given namespaces" $ lookupFM m basePair
        validSimp = (re_simpleType r) ?> (simpleTypeValidate m s . fromJust, return ())
        validRestr = {-checkEnums ens >>-} checkRestr res
            where
                ens = filter (\x->case x of Enumeration _ _->True;_->False) (re_restrParam r)
                res = filter (\x->case x of Enumeration _ _->False;_->True) (re_restrParam r)
                checkEnums [] = return (Enumeration Nothing "")
                checkEnums e  = maybe2Either "Does not match any of the enumeration options" $ find (\(Enumeration _ x)->x==s) e
                checkRestr []    = return ()
                checkRestr (h:t) = do
                    checkRestr t
                    case h of 
                        MinExclusive   _ x _ -> rng s x (>)
                        MinInclusive   _ x _ -> rng s x (>=)
                        MaxExclusive   _ x _ -> rng s x (<)
                        MaxInclusive   _ x _ -> rng s x (<=)
                        TotalDigits    _ x _ -> 
                            ((length $ delete '.' s)<=x) ? (return (), fail "Too many digits")
                        FractionDigits _ x _ -> 
                            (('.' `elem` s) && ((length $ tail $ snd $ span (/='.') s)>=x)) ? (fail "Too many fractional digits", return ())
                        Length         _ x _ -> len s x (==)
                        MinLength      _ x _ -> len s x (>=)
                        MaxLength      _ x _ -> len s x (<=)
                        WhiteSpace     _ _ _ -> return () -- FIXME : Implement
                        Pattern        _ p   -> 
                            (isNothing $ matchRegex (mkRegex $ formReg p) s) ? (fail "Does not match pattern", return ())
                            -- FIXME : The Pattern matcher is untested and I dunno if it provides the full set
                            -- of escape characters and shorthands.
                    where
                        rng s x f = (s `f` x) ? (return (), fail "Value out of range")
                        len s x f = ((length s) `f` x) ? (return (), fail "Incorrect length")
                        -- Nasty hack; Text.Regex won't accept the regular expressions supplied in XSD if
                        -- the contain escaped minus signs, thus this de-escapes them. Which is right and
                        -- which is wrong, I have no idea, but this works. If you have a better solution
                        -- please implement it!
                        formReg p = replace ("^"++p++"$") ("\\-", "-") 


