Rakka/Validation.hs

   1 {-# LANGUAGE
   2     DoAndIfThenElse
   3   , UnicodeSyntax
   4   #-}
   5 module Rakka.Validation
   6     ( getValidator
   7     )
   8     where
   9 import Control.Applicative
  10 import Control.Arrow.Unicode
  11 import Control.Monad.Trans
  12 import Control.Monad.Unicode
  13 import Paths_Rakka
  14 import System.Directory
  15 import System.FilePath
  16 import Text.XML.HXT.Arrow.XmlState
  17 import Text.XML.HXT.DOM.TypeDefs
  18 import Text.XML.HXT.RelaxNG
  19
  20 loadSchema ∷ FilePath → IO (IOSArrow XmlTree XmlTree)
  21 loadSchema fpath
  22     = do [schema] ← runX ( setErrorMsgHandler False fail
  23                            ⋙
  24                            validateSchemaWithRelax fpath
  25                          )
  26          pure $ validateDocumentWithRelax schema
  27
  28 doesLocalDirExist ∷ IO Bool
  29 doesLocalDirExist = doesDirectoryExist "schemas"
  30
  31 getValidator ∷ MonadIO m ⇒ FilePath → m (IOSArrow XmlTree XmlTree)
  32 getValidator fname
  33     = liftIO $
  34       do let schemaPath = "schemas" </> fname
  35          localDirExists ← doesLocalDirExist
  36          if localDirExists then
  37              loadSchema schemaPath
  38          else
  39              getDataFileName ("schemas" </> fname) ≫= loadSchema