Slightly improved something...

[Rakka.git] / Rakka / Validation.hs

diff --git a/Rakka/Validation.hs b/Rakka/Validation.hs
new file mode 100644 (file)
index 0000000..73a83e7
--- /dev/null
+++ b/Rakka/Validation.hs
@@ -0,0 +1,58 @@
+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