module Rakka.Validation
    ( getValidator
    )
    where

import           Control.Arrow
import           Control.Arrow.ArrowList
import           Control.Arrow.ArrowTree
import           Control.Monad.Reader
import           Paths_Rakka -- Cabal が用意する。
import           Rakka.Environment
import           System.Directory
import           System.FilePath
import           Text.XML.HXT.Arrow.XmlArrow
import           Text.XML.HXT.Arrow.XmlIOStateArrow
import           Text.XML.HXT.DOM.TypeDefs
import qualified Text.XML.HXT.RelaxNG.Schema as S
import           Text.XML.HXT.RelaxNG.Validator


loadSchema :: FilePath -> IO (IOSArrow XmlTree XmlTree)
loadSchema fpath
    = do [schema] <- runX ( setErrorMsgHandler False fail
                            >>>
                            readForRelax [] fpath
                            >>>
                            perform (validateWithRelaxAndHandleErrors S.relaxSchemaArrow)
                            >>>
                            createSimpleForm [] True True True
                            >>>
                            perform ( getErrors
                                      >>>
                                      getChildren >>> getAttrValue "desc"
                                      >>>
                                      arr ("Relax NG validation: " ++ )
                                      >>>
                                      mkError c_err
                                      >>>
                                      filterErrorMsg
                                    )
                          )
         return $ validateDocumentWithRelax schema


doesLocalDirExist :: IO Bool
doesLocalDirExist = doesDirectoryExist "schemas"


getValidator :: MonadIO m => Environment -> FilePath -> m (IOSArrow XmlTree XmlTree)
getValidator _ fname
    = liftIO $
      do let schemaPath = "schemas" </> fname

         localDirExists <- doesLocalDirExist
         if localDirExists then
             loadSchema schemaPath
           else
             getDataFileName ("schemas" </> fname) >>= loadSchema