+{-# LANGUAGE
+ DoAndIfThenElse
+ , UnicodeSyntax
+ #-}
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)
+import Control.Applicative
+import Control.Arrow.Unicode
+import Control.Monad.Trans
+import Control.Monad.Unicode
+import Paths_Rakka
+import System.Directory
+import System.FilePath
+import Text.XML.HXT.Arrow.XmlState
+import Text.XML.HXT.DOM.TypeDefs
+import Text.XML.HXT.RelaxNG
+
+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
+ = do [schema] ← runX ( setErrorMsgHandler False fail
+ ⋙
+ validateSchemaWithRelax fpath
+ )
+ pure $ validateDocumentWithRelax schema
-
-doesLocalDirExist :: IO Bool
+doesLocalDirExist ∷ IO Bool
doesLocalDirExist = doesDirectoryExist "schemas"
-
-getValidator :: MonadIO m => Environment -> FilePath -> m (IOSArrow XmlTree XmlTree)
-getValidator _ fname
+getValidator ∷ MonadIO m ⇒ FilePath → m (IOSArrow XmlTree XmlTree)
+getValidator fname
= liftIO $
do let schemaPath = "schemas" </> fname
-
- localDirExists <- doesLocalDirExist
+ localDirExists ← doesLocalDirExist
if localDirExists then
loadSchema schemaPath
- else
- getDataFileName ("schemas" </> fname) >>= loadSchema
+ else
+ getDataFileName ("schemas" </> fname) ≫= loadSchema