From b52e6bf3822150fbca9a6aadd3ce73dcdf7ed0ad Mon Sep 17 00:00:00 2001
From: defanor <defanor@uberspace.net>
Date: Wed, 21 Feb 2018 18:36:52 +0300
Subject: Initial commit

The bindings are incomplete, but usable at this point.
---
 Redland/Util.hs | 140 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 140 insertions(+)
 create mode 100644 Redland/Util.hs

(limited to 'Redland/Util.hs')

diff --git a/Redland/Util.hs b/Redland/Util.hs
new file mode 100644
index 0000000..0472dde
--- /dev/null
+++ b/Redland/Util.hs
@@ -0,0 +1,140 @@
+{- |
+Module      :  Redland.Util
+Maintainer  :  defanor <defanor@uberspace.net>
+Stability   :  unstable
+Portability :  non-portable (GHC extensions are used)
+
+Utility functions based on mid-level bindings.
+
+-}
+
+module Redland.Util where
+
+import Foreign
+import Control.Exception
+
+import Redland.LowLevel
+import Redland.MidLevel
+
+
+-- * Hashes
+
+withHash :: ForeignPtr RedlandWorld
+         -> String
+         -> [(String, String)]
+         -> (ForeignPtr RedlandHash -> IO a)
+         -> IO a
+withHash world factory l f =
+  withNew (redlandHash world factory) $ \hash -> do
+  mapM_ (uncurry (hashPutStrings hash)) l
+  f hash
+
+
+-- * RDF term (librdf_node)
+
+data Node = BlankNode String
+          | LiteralNode String
+          | ResourceNode String
+          deriving (Eq, Show)
+
+redlandNodeToNode :: ForeignPtr RedlandNode -> IO Node
+redlandNodeToNode rn = do
+  isBlank <- nodeIsBlank rn
+  isLiteral <- nodeIsLiteral rn
+  isResource <- nodeIsResource rn
+  case (isBlank, isLiteral, isResource) of
+    (True, _, _) -> BlankNode <$> nodeGetBlankIdentifier rn
+    (_, True, _) -> LiteralNode <$> nodeGetLiteralValue rn
+    _ -> ResourceNode <$> (nodeGetURI rn >>= uriAsString)
+
+
+-- * Parsers
+
+-- | Tries different parsers until one of them succeeds.
+tryParseStringIntoModel :: ForeignPtr RedlandWorld
+                        -> [String]
+                        -- ^ parsers to try
+                        -> ForeignPtr RedlandModel
+                        -> ForeignPtr RedlandURI
+                        -- ^ base URI
+                        -> String
+                        -- ^ string to parse
+                        -> IO ()
+tryParseStringIntoModel world (parser:parsers) model uri str =
+  handle tryNext $
+  withNew (redlandParser world (Just parser) Nothing Nothing) $ \parser ->
+  parseStringIntoModel parser str uri model
+  where
+    tryNext :: RedlandException -> IO ()
+    tryNext (OperationException _) = tryParseStringIntoModel world parsers model uri str
+    tryNext e = throw e
+tryParseStringIntoModel world [] model uri str = throw ParseFailure
+
+
+-- * Querying
+
+withQuery :: ForeignPtr RedlandWorld
+          -> ForeignPtr RedlandModel
+          -> String
+          -- ^ query language
+          -> String
+          -- ^ query string
+          -> Maybe (ForeignPtr RedlandURI)
+          -- ^ base URI
+          -> (QueryResults -> IO a)
+          -> IO a
+withQuery world model ql qs bURI f =
+  withNew (redlandQuery world ql Nothing qs bURI) $ \query ->
+  withNew (modelQueryExecute model query) $ \results ->
+  queryResultsToList results >>= f
+
+
+-- * Query results
+
+type QueryResults = [[(String, Node)]]
+
+queryResultsToList :: ForeignPtr RedlandQueryResults -> IO QueryResults
+queryResultsToList qr = do
+  done <- queryResultsFinished qr
+  if done
+    then pure []
+    else do
+    bindingCnt <- queryResultsGetBindingsCount qr
+    bindings <- mapM readBinding [0..bindingCnt - 1]
+    next <- queryResultsNext qr
+    rest <- if next then queryResultsToList qr else pure []
+    pure (bindings : rest)
+      where
+        readBinding :: Int -> IO (String, Node)
+        readBinding n = do
+          name <- queryResultsGetBindingName qr n
+          val <- queryResultsGetBindingValue qr n >>= redlandNodeToNode
+          pure (name, val)
+
+
+-- * Other
+
+-- | Initializes world, storage, model, and base URI at once.
+withWSMU :: String
+        -- ^ storage factory
+        -> [(String, String)]
+        -- ^ storage options
+        -> String
+        -- ^ storage identifier
+        -> String
+        -- ^ model options
+        -> String
+        -- ^ base URI
+        -> (ForeignPtr RedlandWorld ->
+             ForeignPtr RedlandStorage ->
+             ForeignPtr RedlandModel ->
+             ForeignPtr RedlandURI ->
+             IO a)
+        -> IO a
+withWSMU sFactory sOpt sIdent mOpt bURI f =
+  withNew redlandWorld $ \world ->
+  withHash world "memory" sOpt $ \sOpt' ->
+  withNew (redlandStorageWithOptions world sFactory sIdent sOpt') $ \storage ->
+  withNew (redlandModel world storage mOpt) $ \model ->
+  withNew (redlandURI world bURI) $ \uri ->
+  f world storage model uri
-- 
cgit v1.2.3