diff --git a/Database/HSparql/QueryGenerator.hs b/Database/HSparql/QueryGenerator.hs --- a/Database/HSparql/QueryGenerator.hs +++ b/Database/HSparql/QueryGenerator.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ExistentialQuantification, OverloadedLists #-} -- |The query generator DSL for SPARQL, used when connecting to remote -- endpoints. @@ -12,29 +12,30 @@ -- * Query Actions , prefix , var - , Database.HSparql.QueryGenerator.triple + , Database.HSparql.QueryGenerator.triple, triple_ , mkPredicateObject - , constructTriple - , askTriple - , updateTriple - , describeIRI - , optional - , union - , filterExpr - , bind + , constructTriple, constructTriple_ + , askTriple, askTriple_ + , updateTriple, updateTriple_ + , describeIRI, describeIRI_ + , optional, optional_ + , union, union_ + , filterExpr, filterExpr_ + , bind, bind_ + , subQuery, subQuery_ , select , selectVars , as -- ** Duplicate handling - , distinct - , reduced + , distinct, distinct_ + , reduced, reduced_ -- ** Limit handling - , limit + , limit, limit_ -- ** Groups handling - , groupBy + , groupBy, groupBy_ -- ** Order handling , orderNext @@ -81,6 +82,7 @@ -- * Types , Query + , Prefix , Variable , VarOrNode(..) , BlankNodePattern @@ -100,8 +102,11 @@ ) where -import Control.Monad.State -import Data.List (intercalate) +import Control.Monad.State +import Data.List (intercalate, intersperse) +import qualified Data.List as L +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NE import qualified Data.Text as T import qualified Data.RDF as RDF @@ -110,22 +115,28 @@ -- |The 'State' monad applied to 'QueryData'. type Query a = State QueryData a +-- |Execute a 'Query' action, starting with initial 'QueryData', then process +-- the resulting 'QueryData'. +execQuery :: QueryData -> Query a -> (QueryData -> b) -> b +execQuery qd q f = f $ execState q qd + -- |Execute a 'Query' action, starting with the empty 'queryData', then process -- the resulting 'QueryData'. -execQuery :: Query a -> (QueryData -> b) -> b -execQuery q f = f $ execState q queryData +execQuery0 :: Query a -> (QueryData -> b) -> b +execQuery0 = execQuery queryData -- |Execute a 'Select Query' action, returning the 'String' representation of the query. createSelectQuery :: Query SelectQuery -> String -createSelectQuery q = execQuery specifyVars qshow - where specifyVars :: Query () - specifyVars = do - query <- q - modify $ \s -> s { vars = queryExpr query, queryType = SelectType } +createSelectQuery q = execQuery0 (specifyVars q) qshow +specifyVars :: Query SelectQuery -> Query () +specifyVars q = do + query <- q + modify $ \s -> s { vars = queryExpr query, queryType = SelectType } + -- |Execute a 'Construct Query' action, returning the 'String' representation of the query. createConstructQuery :: Query ConstructQuery -> String -createConstructQuery q = execQuery specifyType qshow +createConstructQuery q = execQuery0 specifyType qshow where specifyType :: Query () specifyType = do query <- q @@ -133,7 +144,7 @@ -- |Execute a 'Ask Query' action, returning the 'String' representation of the query. createAskQuery :: Query AskQuery -> String -createAskQuery q = execQuery specifyType qshow +createAskQuery q = execQuery0 specifyType qshow where specifyType :: Query () specifyType = do query <- q @@ -141,7 +152,7 @@ -- |Execute a 'Update Query' action, returning the 'String' representation of the query. createUpdateQuery :: Query UpdateQuery -> String -createUpdateQuery q = execQuery specifyType qshow +createUpdateQuery q = execQuery0 specifyType qshow where specifyType :: Query () specifyType = do query <- q @@ -149,7 +160,7 @@ -- |Execute a 'Describe Query' action, returning the 'String' representation of the query. createDescribeQuery :: Query DescribeQuery -> String -createDescribeQuery q = execQuery specifyType qshow +createDescribeQuery q = execQuery0 specifyType qshow where specifyType :: Query () specifyType = do query <- q @@ -167,9 +178,11 @@ -- |Create and return a variable to the query, usable in later expressions. var :: Query Variable -var = do n <- gets varsIdx +var = do qis <- gets (NE.init . subQueryIdx) + n <- gets varsIdx + let sqis = NE.fromList (qis ++ [n]) modify $ \s -> s { varsIdx = n + 1 } - return $ Variable n + return $ Variable sqis -- |Restrict the query to only results for which values match constants in this -- triple, or for which the variables can be bound. @@ -179,29 +192,44 @@ modify $ \s -> s { pattern = appendPattern t (pattern s) } return t +triple_ :: (SubjectTermLike a, PredicateTermLike b, ObjectTermLike c) => a -> b -> c -> Query () +triple_ a b c = void $ triple a b c + constructTriple :: (SubjectTermLike a, PredicateTermLike b, ObjectTermLike c) => a -> b -> c -> Query Pattern constructTriple a b c = do let t = QTriple (varOrTerm a) (varOrTerm b) (varOrTerm c) modify $ \s -> s { constructTriples = appendTriple t (constructTriples s) } return t +constructTriple_ :: (SubjectTermLike a, PredicateTermLike b, ObjectTermLike c) => a -> b -> c -> Query () +constructTriple_ a b c = void $ constructTriple a b c + askTriple :: (SubjectTermLike a, PredicateTermLike b, ObjectTermLike c) => a -> b -> c -> Query Pattern askTriple a b c = do let t = QTriple (varOrTerm a) (varOrTerm b) (varOrTerm c) modify $ \s -> s { askTriples = appendTriple t (askTriples s) } return t +askTriple_ :: (SubjectTermLike a, PredicateTermLike b, ObjectTermLike c) => a -> b -> c -> Query () +askTriple_ a b c = void $ askTriple a b c + updateTriple :: (SubjectTermLike a, PredicateTermLike b, ObjectTermLike c) => a -> b -> c -> Query Pattern updateTriple a b c = do let t = QTriple (varOrTerm a) (varOrTerm b) (varOrTerm c) -- TODO: should only allow terms modify $ \s -> s { updateTriples = appendTriple t (updateTriples s) } return t +updateTriple_ :: (SubjectTermLike a, PredicateTermLike b, ObjectTermLike c) => a -> b -> c -> Query () +updateTriple_ a b c = void $ updateTriple a b c + describeIRI :: IRIRef -> Query IRIRef describeIRI newIri = do modify $ \s -> s { describeURI = Just newIri } return newIri +describeIRI_ :: IRIRef -> Query () +describeIRI_ = void . describeIRI + selectVars :: [Variable] -> Query SelectQuery selectVars vs = return SelectQuery { queryExpr = fmap SelectVar vs } @@ -215,20 +243,26 @@ optional q = do -- Determine the patterns by executing the action on a blank QueryData, and -- then pulling the patterns out from there. - let option = execQuery q $ OptionalGraphPattern . pattern + let option = execQuery0 q $ OptionalGraphPattern . pattern modify $ \s -> s { pattern = appendPattern option (pattern s) } return option +optional_ :: Query a -> Query () +optional_ = void . optional + -- |Add a union structure to the query pattern. As with 'optional' blocks, -- variables must be defined prior to the opening of any block. union :: Query a -> Query b -> Query Pattern union q1 q2 = do - let p1 = execQuery q1 pattern - p2 = execQuery q2 pattern + let p1 = execQuery0 q1 pattern + p2 = execQuery0 q2 pattern union' = UnionGraphPattern p1 p2 modify $ \s -> s { pattern = appendPattern union' (pattern s) } return union' +union_ :: Query a -> Query b -> Query () +union_ a b = void $ union a b + -- |Restrict results to only those for which the given expression is true. filterExpr :: (TermLike a) => a -> Query Pattern filterExpr e = do @@ -236,12 +270,44 @@ modify $ \s -> s { pattern = appendPattern f (pattern s) } return f +filterExpr_ :: (TermLike a) => a -> Query () +filterExpr_ = void . filterExpr + +-- |Bind the result of an expression to a variable. bind :: Expr -> Variable -> Query Pattern bind e v = do let b = Bind (expr e) v modify $ \s -> s { pattern = appendPattern b (pattern s) } return b +bind_ :: Expr -> Variable -> Query () +bind_ a b = void $ bind a b + +-- |Perform a subquery. +subQuery :: Query SelectQuery -> Query Pattern +subQuery q = do + -- Manage subquery indexes + qis <- gets subQueryIdx + let sqis = qis |> 0 + qis' = NE.fromList $ NE.init qis ++ [NE.last qis + 1] + -- Execute the subquery action + let subQueryData0 = queryData { subQueryIdx = sqis } + subQueryData = execQuery subQueryData0 (specifyVars q) id + -- Merge prefixes + prefixesParentQuery <- gets prefixes + let prefixesSubQuery = prefixes subQueryData + newPrefixes = prefixesParentQuery `L.union` prefixesSubQuery + -- Create the subquery pattern and remove prefixes from the subquery + let sq = SubQuery $ subQueryData { prefixes = [] } + -- Append the subquery pattern, update the subquery index and the prefixes. + modify $ \s -> s { pattern = appendPattern sq (pattern s) + , subQueryIdx = qis' + , prefixes = newPrefixes } + return sq + +subQuery_ :: Query SelectQuery -> Query () +subQuery_ = void . subQuery + -- Random auxiliary -- |Form a 'Node', with the 'Prefix' and reference name. @@ -256,17 +322,26 @@ distinct = do modify $ \s -> s { duplicates = Distinct } gets duplicates +distinct_ :: Query () +distinct_ = void distinct + -- |Set duplicate handling to 'Reduced'. By default, there are no reductions. reduced :: Query Duplicates reduced = do modify $ \s -> s { duplicates = Reduced } gets duplicates +reduced_ :: Query () +reduced_ = void reduced + -- |Set limit handling to the given value. By default, there are no limits. -- Note: negative numbers cause no query results to be returned. limit :: Int -> Query Limit limit n = do modify $ \s -> s { limits = Limit n } gets limits +limit_ :: Int -> Query () +limit_ = void . limit + -- Grouping -- |Divide the solution into one or more groups. @@ -275,6 +350,9 @@ modify $ \s -> s { groups = groups s ++ [GroupBy . expr $ e] } gets groups +groupBy_ :: (TermLike a) => a -> Query () +groupBy_ = void . groupBy + -- Order handling -- |Alias of 'orderNextAsc'. @@ -518,6 +596,7 @@ , varsIdx = 0 , vars = [] , queryType = TypeNotSet + , subQueryIdx = [0] , pattern = GroupGraphPattern [] , constructTriples = [] , askTriples = [] @@ -543,9 +622,9 @@ deriving (Show) data Prefix = Prefix T.Text RDF.Node - deriving (Show) + deriving (Show, Eq) -data Variable = Variable Int +data Variable = Variable (NonEmpty Int) deriving (Show) data DynamicPredicate = forall a. (PredicateTermLike a, QueryShow a, Show a) => DynamicPredicate a @@ -653,6 +732,7 @@ | Bind Expr Variable | OptionalGraphPattern GroupGraphPattern | UnionGraphPattern GroupGraphPattern GroupGraphPattern + | SubQuery QueryData data GroupGraphPattern = GroupGraphPattern [Pattern] @@ -674,6 +754,7 @@ , varsIdx :: Int , vars :: [SelectExpr] , queryType :: QueryType + , subQueryIdx :: NonEmpty Int , pattern :: GroupGraphPattern , constructTriples :: [Pattern] -- QTriple , askTriples :: [Pattern] @@ -688,8 +769,6 @@ data QueryType = SelectType | ConstructType | AskType | UpdateType | DescribeType | TypeNotSet -data QueryForm = SelectForm QueryData | ConstructForm QueryData | AskForm QueryData | UpdateForm QueryData | DescribeForm QueryData - data ConstructQuery = ConstructQuery { queryConstructs :: [Pattern] } @@ -740,7 +819,8 @@ qshow = unwords . fmap qshow instance QueryShow Variable where - qshow (Variable v) = "?x" ++ show v + qshow (Variable vs) = "?x" ++ indexes + where indexes = mconcat . intersperse "_" . fmap show . NE.toList $ vs instance QueryShow [Variable] where qshow = unwords . fmap qshow @@ -832,6 +912,7 @@ qshow (Bind e v) = "BIND(" ++ qshow e ++ " AS " ++ qshow v ++ ")" qshow (OptionalGraphPattern p) = "OPTIONAL " ++ qshow p qshow (UnionGraphPattern p1 p2) = qshow p1 ++ " UNION " ++ qshow p2 + qshow (SubQuery qd) = intercalate " " ["{", qshow qd, "}"] instance QueryShow [Pattern] where qshow = unwords . fmap qshow @@ -854,17 +935,6 @@ qshow [] = "" qshow os = unwords $ "ORDER BY" : fmap qshow os -instance QueryShow QueryForm where - qshow (SelectForm qd) = unwords - [ "SELECT" - , qshow (duplicates qd) - , qshow (vars qd) - ] - qshow (ConstructForm qd) = "CONSTRUCT { " ++ qshow (constructTriples qd) ++ " }" - qshow (AskForm qd) = "ASK { " ++ qshow (askTriples qd) ++ " }" - qshow (UpdateForm qd) = "INSERT DATA { " ++ qshow (updateTriples qd) ++ " }" - qshow (DescribeForm qd) = "DESCRIBE " ++ qshow (describeURI qd) - instance QueryShow QueryData where qshow qd = query where prefixDecl = qshow (prefixes qd) @@ -878,27 +948,36 @@ query = case queryType qd of SelectType -> unwords' [ prefixDecl - , qshow (SelectForm qd) + , "SELECT" + , qshow (duplicates qd) + , qshow (vars qd) , whereClause , solutionModifier ] ConstructType -> unwords [ prefixDecl - , qshow (ConstructForm qd) + , "CONSTRUCT {" + , qshow (constructTriples qd) + , "}" , whereClause ] DescribeType -> unwords [ prefixDecl - , qshow (DescribeForm qd) + , "DESCRIBE" + , qshow (describeURI qd) , whereClause ] AskType -> unwords [ prefixDecl - , qshow (AskForm qd) + , "ASK {" + , qshow (askTriples qd) + , "}" ] UpdateType -> unwords [ prefixDecl - , qshow (UpdateForm qd) + , "INSERT DATA {" + , qshow (updateTriples qd) + , "}" ] -- FIXME TypeNotSet -> @@ -919,9 +998,14 @@ -- | Alternative version of 'unwords' that avoid adding spaces on empty strings. {-# NOINLINE [1] unwords' #-} unwords' :: [String] -> String -unwords' [] = "" -unwords' (w:ws) = w ++ go ws +unwords' [] = "" +unwords' ("":ws) = unwords' ws +unwords' (w:ws) = w ++ go ws where go [] = "" go ("":vs) = go vs go (v:vs) = ' ' : (v ++ go vs) + +-- | Append a element to a 'NonEmpty' list. +(|>) :: NonEmpty a -> a -> NonEmpty a +xs |> x = NE.fromList $ NE.toList xs ++ [x] diff --git a/hsparql.cabal b/hsparql.cabal --- a/hsparql.cabal +++ b/hsparql.cabal @@ -1,6 +1,6 @@ Name: hsparql Homepage: https://github.com/robstewart57/hsparql -Version: 0.3.4 +Version: 0.3.5 Synopsis: A SPARQL query generator and DSL, and a client to query a SPARQL server. Category: Database Description: diff --git a/tests/AllTests.hs b/tests/AllTests.hs --- a/tests/AllTests.hs +++ b/tests/AllTests.hs @@ -21,7 +21,7 @@ app req respond = respond $ response req where response req_ = case rawQueryString req_ of - "?query=PREFIX%20foaf%3A%20%3Chttp%3A%2F%2Fxmlns.com%2Ffoaf%2F0.1%2F%3E%20PREFIX%20dbpedia%3A%20%3Chttp%3A%2F%2Fdbpedia.org%2Fproperty%2F%3E%20PREFIX%20dbprop%3A%20%3Chttp%3A%2F%2Fdbpedia.org%2Fresource%2F%3E%20SELECT%20%20%3Fx1%20WHERE%20%7B%3Fx0%20dbpedia%3Agenre%20dbprop%3AWeb_browser%20.%20%3Fx0%20foaf%3Aname%20%3Fx1%20.%7D" + "?query=PREFIX%20foaf%3A%20%3Chttp%3A%2F%2Fxmlns.com%2Ffoaf%2F0.1%2F%3E%20PREFIX%20dbpedia%3A%20%3Chttp%3A%2F%2Fdbpedia.org%2Fproperty%2F%3E%20PREFIX%20dbprop%3A%20%3Chttp%3A%2F%2Fdbpedia.org%2Fresource%2F%3E%20SELECT%20%3Fx1%20WHERE%20%7B%3Fx0%20dbpedia%3Agenre%20dbprop%3AWeb_browser%20.%20%3Fx0%20foaf%3Aname%20%3Fx1%20.%7D" -> selectResponse "?query=PREFIX%20dbprop%3A%20%3Chttp%3A%2F%2Fdbpedia.org%2Fproperty%2F%3E%20PREFIX%20dbpedia%3A%20%3Chttp%3A%2F%2Fdbpedia.org%2Fresource%2F%3E%20ASK%20%7B%20%3Fx0%20dbprop%3Agenre%20dbpedia%3AWeb_browser%20.%20%7D" -> askResponse