X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FValidation.hs;h=417e4f24ce095deabba38d53e4ad82552b85f7e5;hb=HEAD;hp=70129a47f15ff34ac8c92030dca555bee16159a5;hpb=88747f2463963ff2895a597b3054b12b2288530e;p=Rakka.git

diff --git a/Rakka/Validation.hs b/Rakka/Validation.hs
index 70129a4..417e4f2 100644
--- a/Rakka/Validation.hs
+++ b/Rakka/Validation.hs
@@ -1,53 +1,39 @@
+{-# 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.DOM.TypeDefs
+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 ∷ 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