Resurrection from bitrot

[Rakka.git] / Rakka / Validation.hs

diff --git a/Rakka/Validation.hs b/Rakka/Validation.hs
index 73a83e78105c13a1b476b4e6cc107de4293e68f9..417e4f24ce095deabba38d53e4ad82552b85f7e5 100644 (file)
--- a/Rakka/Validation.hs
+++ b/Rakka/Validation.hs
@@ -1,58 +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.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