HXQ 0.9.0 → 0.10.0
raw patch · 27 files changed
+894/−500 lines, 27 filesdep +HDBC-odbcPVP ok
version bump matches the API change (PVP)
Dependencies added: HDBC-odbc
API changes (from Hackage documentation)
+ Text.XML.HXQ.XQuery: CommentEvent :: String -> XMLEvent
+ Text.XML.HXQ.XQuery: EmptyEvent :: Name -> [(Name, String)] -> XMLEvent
+ Text.XML.HXQ.XQuery: EndEvent :: Name -> XMLEvent
+ Text.XML.HXQ.XQuery: ErrorEvent :: String -> XMLEvent
+ Text.XML.HXQ.XQuery: GERefEvent :: Name -> XMLEvent
+ Text.XML.HXQ.XQuery: PIEvent :: Name -> String -> XMLEvent
+ Text.XML.HXQ.XQuery: StartEvent :: Name -> [(Name, String)] -> XMLEvent
+ Text.XML.HXQ.XQuery: TextEvent :: String -> XMLEvent
+ Text.XML.HXQ.XQuery: data XMLEvent
+ Text.XML.HXQ.XQuery: genSchema :: (IConnection conn) => conn -> String -> String -> IO Table
+ Text.XML.HXQ.XQuery: shredC :: String -> String -> String -> Q Exp
Files
- HXQ.cabal +31/−11
- Main.hs +5/−5
- Makefile +23/−5
- Test2.hs +1/−0
- TestDB.hs +1/−2
- TestDB2.hs +2/−4
- TestDBPL1.hs +8/−0
- TestDBPL2.hs +12/−0
- compile.bat +6/−4
- data/cs.xml +3/−3
- data/q4.xq +8/−0
- data/testdb.xq +19/−12
- db.html +156/−0
- index.html +13/−116
- src/Text/XML/HXQ/Compiler.hs +34/−29
- src/Text/XML/HXQ/Functions.hs +31/−31
- src/Text/XML/HXQ/Interpreter.hs +67/−57
- src/Text/XML/HXQ/Optimizer.hs +73/−65
- src/Text/XML/HXQ/XQuery.hs +5/−2
- src/Text/XML/HXQ/XTree.hs +3/−4
- src/hxml-0.2/XMLScanner.hs +1/−1
- src/mysql/Connect.hs +28/−0
- src/noDB/Text/XML/HXQ/OptionalDB.hs +14/−2
- src/sqlite/Connect.hs +28/−0
- src/withDB/Text/XML/HXQ/DB.hs +319/−119
- src/withDB/Text/XML/HXQ/DBConnect.hs +0/−26
- src/withDB/Text/XML/HXQ/OptionalDB.hs +3/−2
HXQ.cabal view
@@ -1,13 +1,13 @@ Cabal-Version: >= 1.2 Name: HXQ-Version: 0.9.0+Version: 0.10.0 Synopsis: A Compiler from XQuery to Haskell Description: HXQ is a fast and space-efficient compiler from XQuery (the standard query language for XML) to embedded Haskell code. The translation is based on Haskell templates. It also provides an interpreter for evaluating XQueries from input and an optional database connectivity- using HDBC and SQLite3.+ using HDBC with MySQL/ODBC or sqlite3. Category: XML Build-type: Simple License-file: LICENSE@@ -20,8 +20,9 @@ Extra-Source-Files: src/noDB/Text/XML/HXQ/OptionalDB.hs src/withDB/Text/XML/HXQ/DB.hs- src/withDB/Text/XML/HXQ/DBConnect.hs src/withDB/Text/XML/HXQ/OptionalDB.hs+ src/mysql/Connect.hs+ src/sqlite/Connect.hs src/readline/System/Console/Readline.hs Makefile XQueryParser.y@@ -29,16 +30,20 @@ Test2.hs TestDB.hs TestDB2.hs+ TestDBPL1.hs+ TestDBPL2.hs compile compile.bat data-files: index.html+ db.html data/cs.xml data/a.xml data/c.xml data/q1.xq data/q2.xq data/q3.xq+ data/q4.xq data/dblp.xq data/dblp2.xq data/test.xq@@ -48,10 +53,14 @@ src/hxml-0.2/00-LICENSE.txt src/hxml-0.2/00-README.txt -Flag db- Description: provides database connectivity using HDBC and HDBC-sqlite3.+Flag mysql+ Description: provides database connectivity using HDBC and HDBC-odbc. Default: False +Flag sqlite+ Description: provides database connectivity using HDBC and HDBC-sqlite.+ Default: False+ Library Exposed-Modules: Text.XML.HXQ.XQuery Other-Modules: Text.XML.HXQ.XTree, Text.XML.HXQ.Functions, Text.XML.HXQ.Compiler,@@ -65,12 +74,18 @@ Other-Modules: System.Console.Readline else Build-Depends: readline- if flag(db)- Other-Modules: Text.XML.HXQ.DB, Text.XML.HXQ.DBConnect+ if flag(mysql)+ Other-Modules: Text.XML.HXQ.DB, Connect+ Build-Depends: HDBC < 1.1.5, HDBC-odbc+ hs-source-dirs: src/withDB, src/mysql+ else {+ if flag(sqlite)+ Other-Modules: Text.XML.HXQ.DB, Connect Build-Depends: HDBC < 1.1.5, HDBC-sqlite3- hs-source-dirs: src/withDB+ hs-source-dirs: src/withDB, src/sqlite else hs-source-dirs: src/noDB+} Executable xquery Main-is: Main.hs@@ -81,8 +96,13 @@ Other-Modules: System.Console.Readline else Build-Depends: readline- if flag(db)- Build-Depends: HDBC < 1.1.5, HDBC-sqlite3- hs-source-dirs: src/withDB+ if flag(mysql)+ Build-Depends: HDBC < 1.1.5, HDBC-odbc+ hs-source-dirs: src/withDB, src/mysql+ else {+ if flag(sqlite)+ Build-Depends: HDBC < 1.1.5, HDBC-odbc+ hs-source-dirs: src/withDB, src/sqlite else hs-source-dirs: src/noDB+}
Main.hs view
@@ -2,7 +2,7 @@ - - The main program of the XQuery interpreter - Programmer: Leonidas Fegaras (fegaras@cse.uta.edu)-- Date: 08/14/2008+- Date: 10/14/2008 - ---------------------------------------------------------------} @@ -15,7 +15,7 @@ import Text.XML.HXQ.Interpreter(evalInput,xqueryE) import Text.XML.HXQ.XQuery -version = "0.9.0"+version = "0.10.0" parseEnv :: [String] -> [(String,String)]@@ -42,14 +42,14 @@ case lookup "help" env of Just _ -> do putStrLn ("HXQ: XQuery Interpreter version "++version++".") putStrLn "Command line options and files:"- putStrLn " xquery-file interpret the XQuery in xquery-file"+ putStrLn " xquery-file evaluate the XQuery in xquery-file using the interpreter" putStrLn " -db file-path use the relational database in file-path during querying" putStrLn " -c xquery-file compile the XQuery in xquery-file into Haskell code" putStrLn " -o haskell-file set the Haskell file for -c (default is Temp.hs)" putStrLn " -p XPath-query xml-file interpret the XPath query against the xml-file" putStrLn " -v verbose information"- putStrLn "Without an xquery-file, it reads and interprets the input"- putStrLn " The input may be an XQuery or a declare variable/function"+ putStrLn "Without an xquery-file, it reads and evaluates the input using the HXQ interpreter."+ putStrLn " The input may be an XQuery or a 'declare variable' or a 'declare function'." putStrLn " To write an XQuery in multiple lines, wrap it in {}" putStrLn ("Functions: "++(foldr (\(f,_,_) r -> f++" "++r) "" functions)) _ -> case lookup "c" env of
Makefile view
@@ -1,6 +1,16 @@+driver = mysql++ifeq (${driver},mysql)+args = -isrc -isrc/hxml-0.2 -isrc/withDB -isrc/mysql+else ifeq (${driver},sqlite)+args = -isrc -isrc/hxml-0.2 -isrc/withDB -isrc/sqlite+else+args = -isrc -isrc/hxml-0.2 -isrc/noDB+endif+ parser = src/Text/XML/HXQ/Parser.hs-ghc = ghc -O2 -isrc -isrc/hxml-0.2 -isrc/withDB-src = * src/hxml-0.2/* src/noDB/Text/XML/HXQ/* src/withDB/Text/XML/HXQ/* src/readline/System/Console/* src/Text/XML/HXQ/*+ghc = ghc -O2 ${args}+src = * src/hxml-0.2/* src/noDB/Text/XML/HXQ/* src/withDB/Text/XML/HXQ/* src/readline/System/Console/* src/Text/XML/HXQ/* src/mysql/* src/sqlite/* # xquery interpreter all: $(parser) Main.hs@@ -8,7 +18,7 @@ # on-the-fly compiler: unstable; use xquery instead hxqc: $(parser) HXQ-unstable.hs- $(ghc) -optl-s -package ghc --make HXQ-unstable.hs -o hxqc+ $(ghc) -optl-s -no-recomp -package ghc --make HXQ-unstable.hs -o hxqc # generate the XQuery parser using happy $(parser): XQueryParser.y@@ -30,13 +40,21 @@ $(ghc) --make TestDB2.hs -o a.out ./a.out +dbpl1: $(parser) TestDBPL1.hs+ $(ghc) --make TestDBPL1.hs -o a.out+ ./a.out +RTS -H200m -K100m++dbpl2: $(parser) TestDBPL2.hs+ $(ghc) --make TestDBPL2.hs -o a.out+ ./a.out+ # run in the ghci interpreter and load HXQ ghci: $(parser)- ghci -fth -isrc -isrc/hxml-0.2 -isrc/withDB Main.hs+ ghci -fth ${args} Main.hs # create the cabal distribution cabal: $(parser)- runhaskell Setup.lhs configure --ghc -fdb --user --prefix=$(HOME)+ runhaskell Setup.lhs configure --ghc -fmysql --user --prefix=$(HOME) runhaskell Setup.lhs build runhaskell Setup.lhs sdist
Test2.hs view
@@ -16,6 +16,7 @@ f(x,y) = $(xe "<a>{$x,$y}</a>") + main = do a <- $(xq ("<result>{ " ++" for $x at $i in doc('data/dblp.xml')//inproceedings " ++" where $x/author = 'Leonidas Fegaras' "
TestDB.hs view
@@ -15,7 +15,7 @@ import Text.XML.HXQ.XQuery -main = do db <- connect "myDB"+main = do db <- connect "hxq" e <- $(xqdb (" for $r in sql(' select e.fname, d.dname " ++" from employee e, department d " ++" where e.dno = d.dnumber "@@ -23,4 +23,3 @@ ++" 'English') " ++" return <result>{$r/fname,$r/dname}</result> ")) db putXSeq e- -- disconnect db
TestDB2.hs view
@@ -14,10 +14,8 @@ import Text.XML.HXQ.XQuery -main = do db <- connect "myDB"- -- Before compilation, you do: shred db "data/cs.xml" "c"- res <- $(xqdb (" for $s in publish('myDB','c')//gradstudent "+main = do db <- connect "hxq"+ res <- $(xqdb (" for $s in publish('hxq','c')//gradstudent " ++ " where $s//lastname='Galanis' " ++ " return $s//gpa ")) db putXSeq res- -- disconnect db
+ TestDBPL1.hs view
@@ -0,0 +1,8 @@+module Main where++import Text.XML.HXQ.XQuery+++main = do db <- connect "hxq"+ -- generate the relational schema for the DBPL database using hybrid inlining+ genSchema db "data/dblp.xml" "d"
+ TestDBPL2.hs view
@@ -0,0 +1,12 @@+{-# OPTIONS_GHC -fth #-}++module Main where++import Text.XML.HXQ.XQuery+++main = do db <- connect "hxq"+ -- populate the DBPL database (it takes about 12 minutes)+ $(shredC "hxq" "data/dblp.xml" "d")+ -- create an index on author name+ createIndex db "d" "author"
compile.bat view
@@ -1,11 +1,13 @@+@echo off+ rem -- compile an XQuery file rem usage: compile xquery-file object-file -@echo off- xquery -c %1-set FILE="%2" if "%2"=="" goto Exit-set FILE="a.out"+set FILE="%2"+goto End :Exit+set FILE="a.exe"+:End ghc -O2 --make Temp.hs -o %FILE%
data/cs.xml view
@@ -93,16 +93,16 @@ <lastname>Galanis</lastname> <firstname>Leonidas</firstname> </name>+ <gpa>3.5</gpa> <phone>2625596</phone> <email>lgalanis@cs.wisc.edu</email> <address> <city>Madison</city>- <state>WI</state>- <zip>53705</zip> + <zip>53705</zip> + <state>WI</state> </address> <office>1343</office> <url>www.cs.wisc.edu/~lgalanis</url>- <gpa>3.5</gpa> </gradstudent> <gradstudent>
+ data/q4.xq view
@@ -0,0 +1,8 @@+<result>{+ for $x in publish('hxq','d')//inproceedings+ where $x/author = 'Leonidas Fegaras'+ order by $x/year descending+ return <paper>{ $x/booktitle/text(),+ ':', $x/title/text()+ }</paper>+}</result>
data/testdb.xq view
@@ -6,26 +6,33 @@ declare function q ($n,$q) { "Query {$n}:\n{$q}\n" } ;-q(0,sql("select e.fname, e.lname from employee e, department d where e.dno=d.dnumber and d.dname=?","Research"))+q(1,publish('hxq','c')//gradstudent[.//lastname='Galanis']/gpa) ;-q(1,publish('myDB','c')//gradstudent[.//lastname='Galanis']/gpa)+q(2,for $s in publish('hxq','c')//gradstudent where $s//lastname='Galanis' return $s//gpa) ;-q(2,for $s in publish('myDB','c')//gradstudent where $s//lastname='Galanis' return $s//gpa)+q(3,publish('hxq','c')//department[deptname]//gradstudent[.//lastname='Galanis']/gpa) ;-q(3,publish('myDB','c')//department[deptname]//gradstudent[.//lastname='Galanis']/gpa)+q(4,publish('hxq','c')//department[deptname='Computer Sciences']//gradstudent[.//lastname='Galanis']/gpa) ;-q(4,publish('myDB','c')//department[deptname='Computer Sciences']//gradstudent[.//lastname='Galanis']/gpa)+q(5,publish('hxq','c')//department/*[.//lastname='Galanis']/gpa) ;-q(5,publish('myDB','c')//department/*[.//lastname='Galanis']/gpa)+q(6,publish('hxq','c')//*[.//lastname='Galanis']/gpa) ;-q(6,publish('myDB','c')//*[.//lastname='Galanis']/gpa)+q(7,publish('hxq','c')//department[deptname]/deptname) ;-q(7,publish('myDB','c')//department[deptname]/deptname)+q(8,publish('hxq','c')//gradstudent[.//lastname='Galanis']/../deptname) ;-q(8,publish('myDB','c')//gradstudent[.//lastname='Galanis']/../deptname)+q(9,for $s in publish('hxq','c')/department/gradstudent return $s/../deptname) ;-q(9,for $s in publish('myDB','c')/department/gradstudent return $s/../deptname)+q(10,publish('hxq','d')//article[author='Leonidas Fegaras']//title) ;-q(10,publish('myDB','s')//article[.//author='David Maier']//title)+q(11,publish('hxq','d')//inproceedings[author='David Maier'][booktitle='SIGMOD Conference']/title) ;-q(11,publish('myDB','s')//article[.//author='David Maier'][initPage=35]/title)+q(12,<result>{+ for $x in publish('hxq','d')//inproceedings+ where $x/author = 'Leonidas Fegaras'+ order by $x/year descending+ return <paper>{ $x/booktitle/text(),+ ':', $x/title/text()+ }</paper>+ }</result>)
+ db.html view
@@ -0,0 +1,156 @@+<html>+<head><title>HXQ with Database Connectivity</title></head>+<body>+<center>+<h1>HXQ with Database Connectivity</h1>+<h3>Download <a href="/HXQ-0.10.0.tar.gz">HXQ-0.10.0.tar.gz</a></h3>+</center>+<p>+<h2>Installation Instructions (HXQ with database connectivity)</h2>+<p>+You may use either MySQL or sqlite.+The best is MySQL through an ODBC driver. The easiest to install+is sqlite but it cannot be used to store large XML files.+<p>+<h3>Installation with MySQL</h3>+<p>+Here is a <a href="http://www.yolinux.com/TUTORIALS/LinuxTutorialMySQL.html">MySQL on Linux Tutorial</a>.+To install the <a href="http://dev.mysql.com/">MySQL</a> database server and the MySQL/ODBC driver on Linux you do:+<pre>+yum install mysql mysql-devel mysql-server unixODBC-devel mysql-connector-odbc+</pre>+and you may use the following sample top-level file <tt>.odbc.ini</tt>:+<pre>+[ODBC Data Sources]+HXQ = MyODBC 3.51 Driver DSN++[HXQ]+Driver = /usr/lib/libmyodbc3.so+Description = Connector/ODBC 3.51 Driver DSN+user=root+password=xxxxx+option=262144+</pre>+(Make sure that your username/password works and that the Driver has the correct path.)+Then, start the mysql server (using <tt>service mysqld start</tt> as root on Linux)+and create a database using the mysql command+<tt>create database hxq</tt>.+<p>+Then, you need to install the Haskell packages:+<a href="http://hackage.haskell.org/cgi-bin/hackage-scripts/package/HDBC-1.1.4">HDBC 1.1.4</a> (but not version 1.1.5)+and the+<a href="http://hackage.haskell.org/cgi-bin/hackage-scripts/package/HDBC-odbc">HDBC-odbc</a> driver.+Then you do:+<pre>+runhaskell Setup.lhs configure -fmysql+runhaskell Setup.lhs build+runhaskell Setup.lhs install+</pre>+<p>+<h3>Installation with sqlite</h3>+<p>+To use sqlite, you need to install <a href="http://sqlite.org/">SQLite</a>.+On Linux, you can install it using <tt>yum install sqlite</tt>.+Then you need to install the Haskell packages:+<a href="http://hackage.haskell.org/cgi-bin/hackage-scripts/package/HDBC-1.1.4">HDBC 1.1.4</a> (but not version 1.1.5)+and the+<a href="http://hackage.haskell.org/cgi-bin/hackage-scripts/package/HDBC-sqlite3">HDBC-sqlite3</a> driver.+Then you do:+<pre>+runhaskell Setup.lhs configure -fsqlite+runhaskell Setup.lhs build+runhaskell Setup.lhs install+</pre>+<p>+<h2>Working with Databases</h2>+<p>+HXQ provides an interface to HDBC to query relational data inside an XQuery.+For the HXQ compiler, the main function that allows database connectivity is:+<pre>+$(xqdb query) :: (IConnection conn) => conn -> IO XSeq+</pre>+For example, if the database name is "hxq", then+<pre>+do db <- connect "hxq"+ result <- $(xqdb xquery) db+</pre>+For the HXQ interpreter, the function is:+<pre>+xqueryDB :: (IConnection conn) => String -> conn -> IO XSeq+</pre>+The <tt>xquery</tt> executable can also run XQueries that use a database by+specifying the database name using the -db option, eg. <tt>xquery -db hxq</tt>.+<p>+<h2>Querying an Existing Database</h2>+<p>+An XQuery may contain multiple SQL queries in the+form <tt>sql(query,args)</tt>, where <tt>query</tt> is the sql query+that may contain parameters (denoted by ?), which are bound to the+values in <tt>args</tt> (an XSeq). An example can be found+in <a href="TestDB.hs">TestDB.hs</a>. To run this example, you need to+install the <a href="data/company.sql">company</a> database+(using <tt>source data/company.sql</tt> in mysql or+<tt>.read data/company.sql</tt> in sqlite3)+and then compile and run <tt>TestDB.hs</tt>.+<p>+<h2>Shredding</h2>+<p>+To synthesize a relational schema <tt>schemaname</tt> to store an XML document located at <tt>pathname</tt>, use the following Haskell function:+<pre>+genSchema :: (IConnection conn) => conn -> String -> String -> IO ()+genSchema db pathname schemaname+</pre>+for a database <tt>db</tt>. HXQ will find a good+relational schema (using hybrid inlining) to store the XML data by+scanning the document to extract its structural summary and then+deriving a good relational schema from the summary.+To actually store the data from the XML document into the relational schema, use the following Haskell function:+<pre>+shred :: (IConnection conn) => conn -> String -> String -> IO ()+shred db pathname schemaname+</pre>+For example,+<pre>+do db <- connect "hxq"+ genSchema db "data/cs.xml" "c"+ shred db "data/cs.xml" "c"+</pre>+For large XML documents, you better use the compiled version of <tt>shred</tt>, <tt>$(shredC db pathname schemaname)</tt>.+<p>+The Haskell function+<pre>+printSchema db schemaname+</pre>+displays the relational schema for the shredded document under the given schemaname, while+<pre>+createIndex db schemaname tagname+</pre>+creates a secondary index on tagname for the shredded document.+<p>+<h2>Publishing</h2>+<p>+You can query a shredded XML document using the XQuery function:+<pre>+publish(dbame,schemaname)+</pre>+where dbname is the database file name and schemaname is the unique schema name+assigned to the XML document when was shredded. The translation from+XQuery to SQL is done at compile-time, so both dbname and schemaname must be+constant strings. HXQ will do its best to push relevant predicates to+the generated SQL query (using partial evaluation and code folding),+thus deriving an efficient execution. One example+is <a href="TestDB2.hs">TestDB2.hs</a>.+<p>+<h2>Example: Installing and Querying the DBPL Database</h2>+<p>+First download and uncompress <tt>dbpl.xml.gz</tt> from <a href="http://dblp.uni-trier.de/xml/">DBLP</a>.+To install the DBPL database using MySQL, compile and execute first+<a href="TestDBPL1.hs">TestDBPL1.hs</a> and then+<a href="TestDBPL2.hs">TestDBPL2.hs</a>.+Then you may evaluete queries, such as <a href="data/q4.xq">data/q4.xq</a>, using the HXQ interpreter,+which takes about 4 seconds.++<p>+<hr>+<p>+<address>Last modified: 10/26/08 by <a href="http://lambda.uta.edu/">Leonidas Fegaras</a></address>
index.html view
@@ -3,7 +3,7 @@ <body> <center> <h1>HXQ: A Compiler from XQuery to Haskell</h1>-<h3>Download <a href="/HXQ-0.9.0.tar.gz">HXQ-0.9.0.tar.gz</a></h3>+<h3>Download <a href="/HXQ-0.10.0.tar.gz">HXQ-0.10.0.tar.gz</a></h3> </center> <p> <h2>Description</h2>@@ -22,7 +22,7 @@ <p> For example, the <a href="Test2.hs">XQuery given below</a>, which is against the <a href="http://dblp.uni-trier.de/xml/">DBLP XML-database</a> (420MB), runs in 39 seconds on my laptop PC (using 18MB of max heap space).+file</a> (420MB), runs in 39 seconds on my laptop PC (using 18MB of max heap space). To contrast this, <a href="http://www.gnu.org/software/qexo/">Qexo</a>, which compiles XQueries to Java bytecode, took 1 minute 17 seconds (using no less than 1400MB of heap space). Also <a href="http://xqilla.sourceforge.net/HomePage">XQilla</a>, which is written in C++, took 1 minute and 10 secs@@ -33,47 +33,25 @@ translating XQueries over the shredded documents into optimized SQL queries. <p>-<h2>Installation Instructions</h2>+<h2>Installation Instructions (HXQ without Database Connectivity)</h2> <p> HXQ can be installed on most platforms but I have only tested it on-Linux and Windows XP. The simplest installation is without database+Linux, MAC OS X, and Windows XP. The simplest installation is without database connectivity (ie, it can only process XQueries against XML text-documents).+documents). If you want database connectivity+(over mysql or sqlite relational databases), look at the <a href="db.html">installation instructions with database connectivity</a>. <p> First, you need to install the Glasgow Haskell Compiler, <a href="http://www.haskell.org/ghc/">ghc</a>. Optionally, if you want to modify the XQuery parser, you need to install the parser generator for Haskell, <a href="http://www.haskell.org/happy/">happy</a>. Then,-download <a href="/HXQ-0.9.0.tar.gz">HXQ version 0.9.0</a> and untar+download <a href="/HXQ-0.10.0.tar.gz">HXQ version 0.10.0</a> and untar it (using <tt>tar xfz</tt> on Linux-or <a href="http://www.7-zip.org/">7z x</a> on Windows). Then-configure cabal without or with database connectivity:-<dl>-<dt><b>Without database connectivity:</b></dt>-<dd>-To configure HXQ, do:+or <a href="http://www.7-zip.org/">7z x</a> on Windows). Then,+you do: <pre> runhaskell Setup.lhs configure-</pre>-</dd>-<p>-<dt><b>With database connectivity:</b></dt>-<dd>-For database connectivity, you need to install <a href="http://sqlite.org/">SQLite</a>.-(On Linux, you can install it using <tt>yum install sqlite</tt>.)-Then you need to install the Haskell packages:-<a href="http://hackage.haskell.org/cgi-bin/hackage-scripts/package/HDBC-1.1.4">HDBC 1.1.4</a> (but not version 1.1.5)-and the-<a href="http://hackage.haskell.org/cgi-bin/hackage-scripts/package/HDBC-sqlite3-1.1.4.0">HDBC-sqlite3 1.1.4</a> driver-to connect to SQLite relational databases.-Then you configure HXQ:-<pre>-runhaskell Setup.lhs configure -fdb-</pre>-</dd>-Finally, you do:-<pre> runhaskell Setup.lhs build runhaskell Setup.lhs install </pre>@@ -82,6 +60,9 @@ HXQ library. To use the HXQ library in a Haskell program, simply <tt>import Text.XML.HXQ.XQuery</tt>. <p>+<h2><a href="db.html">Installation Instructions for Database Connectivity</a></h2>+<p>+<p> <h2>Current Status</h2> <p> HXQ supports most essential XQuery features, although some system@@ -178,90 +159,6 @@ With <tt>xquery -help</tt> you get the list of system functions and usage information. <p>-<h2>Database Connectivity</h2>-<p>-HXQ provides an interface to <a href="http://hackage.haskell.org/cgi-bin/hackage-scripts/package/HDBC">HDBC</a>-to query relational data inside an XQuery.-For the HXQ compiler, the main function that allows database connectivity is:-<pre>-$(xqdb query) :: (IConnection conn) => conn -> IO XSeq-</pre>-For example, if the database name is "myDB", then-<pre>-do db <- connect "myDB"- result <- $(xqdb xquery) db-</pre>-For the HXQ interpreter, the function is:-<pre>-xqueryDB :: (IConnection conn) => String -> conn -> IO XSeq-</pre>-The xquery executable can also run XQueries that use a database by-specifying the database name using the -db option.-<p>-Currently, HXQ works with <a href="http://sqlite.org/">SQLite</a> only, but is very easy to make it work-with any relational database that supports ODBC: simply install -<a href="http://hackage.haskell.org/cgi-bin/hackage-scripts/package/HDBC-odbc">HDBC-odbc</a>-and change the file <a href="src/withDB/Text/XML/HXQ/DBConnect.hs">src/withDB/Text/XML/HXQ/DBConnect.hs</a> accordingly.-<p>-<h3>Querying an Existing Database</h3>-<p>-An XQuery may contain multiple SQL queries in the-form <tt>sql(query,args)</tt>, where <tt>query</tt> is the sql query-that may contain parameters (denoted by ?), which are bound to the-values in <tt>args</tt> (an XSeq). An example can be found-in <a href="TestDB.hs">TestDB.hs</a>. To run this example, you need to-install the <a href="data/company.sql">company</a> database. For-example, using the sqlite3 interpreter, you do:-<pre>-sqlite3 myDB-.read data/company.sql-.quit-</pre>-and then compile and run <tt>TestDB.hs</tt>.-<p>-<h3>Shredding</h3>-<p>-To store an XML document into a relational database, use the following Haskell function:-<pre>-shred :: (IConnection conn) => conn -> String -> String -> IO ()-shred db file name-</pre>-that shreds and stores the XML document located at the file pathname-in the database db under a unique name. HXQ will find a good-relational schema (using hybrid inlining) to store the XML data by-first scanning the document to extract its structural summary, then-deriving a good relational schema, and finally scanning the document-for a second time to store its data into the relational tables. For-example,-<pre>-do db <- connect "myDB"- shred db "data/cs.xml" "c"-</pre>-<p>-The Haskell function-<pre>-printSchema db name-</pre>-displays the relational schema for the shredded document under the given name, while-<pre>-createIndex db name tagname-</pre>-creates a secondary index on tagname for the shredded document.-<p>-<h3>Publishing</h3>-<p>-You can query a shredded XML document using the XQuery function:-<pre>-publish(dbame,name)-</pre>-where dbname is the database file name and name is the unique name-assigned to the XML document when was shredded. The translation from-XQuery to SQL is done at compile-time, so both dbname and name must be-constant strings. HXQ will do its best to push relevant predicates to-the generated SQL query (using partial evaluation and code folding),-thus deriving an efficient execution. One example-is <a href="TestDB2.hs">TestDB2.hs</a>.-<p> <hr> <p>-<address>Last modified: 08/23/08 by <a href="http://lambda.uta.edu/">Leonidas Fegaras</a></address>+<address>Last modified: 10/25/08 by <a href="http://lambda.uta.edu/">Leonidas Fegaras</a></address>
src/Text/XML/HXQ/Compiler.hs view
@@ -4,7 +4,7 @@ - Programmer: Leonidas Fegaras - Email: fegaras@cse.uta.edu - Web: http://lambda.uta.edu/-- Creation: 02/15/08, last update: 08/20/08+- Creation: 02/15/08, last update: 10/20/08 - - Copyright (c) 2008 by Leonidas Fegaras, the University of Texas at Arlington. All rights reserved. - This material is provided as is, with absolutely no warranty expressed or implied.@@ -150,29 +150,37 @@ Ast "filter" (e:preds) -> compilePredicates preds (compile e context position last effective_axis) True Ast "predicate" [condition,body]- -> let xs = compile body context position last effective_axis- in [| foldr (\x r -> if conditionTest $(compile condition undef1 undef2 undef3 "")- then x:r else r) [] $xs |]+ -> [| if conditionTest $(compile condition undef1 undef2 undef3 "")+ then $(compile body context position last effective_axis)+ else [] |] Ast "append" args -> [| appendText $(listE (map (\x -> compile x context position last effective_axis) args)) |] Ast "call" ((Avar f):args) -> callF f (map (\x -> compile x context position last effective_axis) args)- Ast "construction" [Astring tag,Ast "attributes" [],body]+ Ast "construction" [Astring tag,id,parent,Ast "attributes" [],body] -> let ct = litE (StringL tag) bc = compile body context position last effective_axis- in [| [ XElem $ct [] 0 parent_error $bc ] |]- Ast "construction" [tag,Ast "attributes" al,body]+ cid = compile id context position last effective_axis+ cparent = compile parent context position last effective_axis+ in [| let [XText vid] = $cid+ [vparent] = $cparent+ in [ XElem $ct [] (read vid) vparent $bc ] |]+ Ast "construction" [tag,id,parent,Ast "attributes" al,body] -> let alc = foldr (\(Ast "pair" [a,v]) r -> let ac = compile a context position last effective_axis vc = compile v context position last effective_axis in [| (qName $ac,showXS $vc) : $r |]) [| [] |] al ct = compile tag context position last effective_axis bc = compile body context position last effective_axis- in [| [ XElem (qName $ct) $alc 0 parent_error $bc ] |]+ cid = compile id context position last effective_axis+ cparent = compile parent context position last effective_axis+ in [| let [XText vid] = $cid+ [vparent] = $cparent+ in [ XElem (qName $ct) $alc (read vid) vparent $bc ] |] Ast "let" [Avar var,source,body] -> do s <- compile source context position last effective_axis b <- compile body context position last effective_axis- return (AppE (LamE [VarP (mkName var)] b) s)+ return $! (AppE (LamE [VarP (mkName var)] b) s) Ast "for" [Avar var,Avar "$",source,body] -- a for-loop without an index -> let b = compile body [| head $(varE (mkName var)) |] undef2 undef3 "" f = lamE [varP (mkName var)] [| \r -> $b ++ r |]@@ -286,11 +294,10 @@ ->[| do vs <- $(compileM e context position last effective_axis) $(compilePredicatesM preds [| vs |] True) |] Ast "predicate" [condition,body]- -> [| do vs <- $(compileM body context position last effective_axis)- foldr (\x r -> do vs <- $(compileM condition undef1 undef2 undef3 "")- s <- r- return (if conditionTest vs then x:s else s))- (return []) vs |]+ -> [| do eb <- $(compileM condition undef1 undef2 undef3 "")+ if conditionTest eb+ then $(compileM body context position last effective_axis)+ else return [] |] Ast "executeSQL" [Avar stmt,args] -> [| do as <- $(compileM args context position last effective_axis) $(varE (mkName "executeSQL")) $(varE (mkName stmt)) as |]@@ -302,12 +309,16 @@ -> let binds = zipWith (\i x -> (mkName ("x"++(show i)),x)) [1..(length args)] args in foldr (\(n,x) r -> [| $(compileM x context position last effective_axis) >>= $(lamE [varP n] r) |]) [| return $(callF f (map (\(n,_) -> varE n) binds)) |] binds- Ast "construction" [Astring tag,Ast "attributes" [],body]+ Ast "construction" [Astring tag,id,parent,Ast "attributes" [],body] -> let ct = litE (StringL tag) bc = compileM body context position last effective_axis+ cid = compile id context position last effective_axis+ cparent = compile parent context position last effective_axis in [| do b <- $bc- return [ XElem $ct [] 0 parent_error b ] |]- Ast "construction" [tag,Ast "attributes" al,body]+ let [XText vid] = $cid+ [vparent] = $cparent+ return [ XElem $ct [] (read vid) vparent b ] |]+ Ast "construction" [tag,id,parent,Ast "attributes" al,body] -> let alc = foldr (\(Ast "pair" [a,v]) r -> [| do ac <- $(compileM a context position last effective_axis) vc <- $(compileM v context position last effective_axis)@@ -315,10 +326,14 @@ return ((qName ac,showXS vc):s) |]) [| return [] |] al ct = compileM tag context position last effective_axis bc = compileM body context position last effective_axis+ cid = compile id context position last effective_axis+ cparent = compile parent context position last effective_axis in [| do a <- $alc c <- $ct b <- $bc- return [ XElem (qName c) a 0 parent_error b ] |]+ let [XText vid] = $cid+ [vparent] = $cparent+ return [ XElem (qName c) a (read vid) vparent b ] |] Ast "let" [Avar var,source,body] -> [| $(compileM source context position last effective_axis) >>= $(lamE [varP (mkName var)] (compileM body context position last effective_axis)) |]@@ -402,7 +417,7 @@ (\c -> ([],c,[])) args count in (Ast n s,c,backward,ns) _ -> (query,count,backward,[])- where union xs ((n,b,s):ys) = (n,b,foldr(\(m,_,d) r -> if s==d then Avar m else r) s xs):(union xs ys)+ where union xs ((n,b,s):ys) = (n,b,foldr(\(m,_,d) r -> if s==d && take 4 m /= "_sql" then Avar m else r) s xs):(union xs ys) union xs [] = xs @@ -479,16 +494,6 @@ $d [materialize b (parseDocument doc)] |]) [| (liftM2 (++)) $code $rest |] ns compileQueryM [] = [| return [] |]----- Debugging: display the AST and the Haskell code of an input XQuery-cq :: String -> IO ()-cq query = do putStrLn "Abstract Syntax Tree:"- let ast = parse (scan query)- putStrLn (show ast)- let opt = optimize (last ast)- putStrLn "Optimized AST:"- putStrLn (show opt) -- | Run an XQuery expression that does not perform IO.
src/Text/XML/HXQ/Functions.hs view
@@ -18,7 +18,7 @@ module Text.XML.HXQ.Functions where -import Data.List+import Data.List(foldl') import Char(isDigit) import Language.Haskell.TH import HXML(AttList)@@ -41,9 +41,9 @@ child_step tag x = case x of XElem _ _ _ _ bs- -> foldr (\b s -> case b of- XElem t _ _ _ _ | (t==tag || tag=="*") -> b:s- _ -> s) [] bs+ -> foldl' (\s b -> case b of+ XElem t _ _ _ _ | (t==tag || tag=="*") -> b:s+ _ -> s) [] bs _ -> [] @@ -65,12 +65,12 @@ -- It's like //* but has tagged children, which are derived statically--- After examing 100 children it gives up: this avoids space leaks+-- After examining 100 children it gives up: this avoids space leaks descendant_any_with_tagged_children :: [Tag] -> XTree -> XSeq descendant_any_with_tagged_children tags (x@(XElem t _ _ _ cs))- | all (\tag -> foldr (\b s -> case b of- (XElem k _ _ _ _) -> s || k == tag- _ -> s) False cs100) tags+ | all (\tag -> foldl' (\s b -> case b of+ (XElem k _ _ _ _) -> s || k == tag+ _ -> s) False cs100) tags = x:(concatMap (descendant_any_with_tagged_children tags) cs) where cs100 = take 100 cs descendant_any_with_tagged_children tags (XElem t _ _ _ cs)@@ -82,18 +82,18 @@ attribute_step :: Tag -> XTree -> XSeq attribute_step attr x = case x of- (XElem _ al _ _ _) -> foldr (\(a,v) s -> if a==attr || attr=="*"- then (XText v):s- else s) [] al+ XElem _ al _ _ _ -> foldl' (\s (a,v) -> if a==attr || attr=="*"+ then (XText v):s+ else s) [] al _ -> [] -- XPath step //@attr or //@* attribute_descendant_step :: Tag -> XTree -> XSeq attribute_descendant_step attr (x@(XElem _ al _ _ cs))- = foldr (\(a,v) s -> if a==attr || attr=="*"- then (XText v):s- else s)+ = foldl' (\s (a,v) -> if a==attr || attr=="*"+ then (XText v):s+ else s) (concatMap (attribute_descendant_step attr) cs) al attribute_descendant_step _ _ = [] @@ -237,15 +237,15 @@ text :: XSeq -> XSeq-text xs = foldr (\x r -> case x of- XElem _ _ _ _ zs- -> (filter (\a -> case a of XText _ -> True; XInt _ -> True;- XFloat _ -> True; XBool _ -> True; _ -> False) zs)++r- XText _ -> x:r- XInt _ -> x:r- XFloat _ -> x:r- XBool _ -> x:r- _ -> r) [] xs+text xs = foldl' (\r x -> case x of+ XElem _ _ _ _ zs+ -> (filter (\a -> case a of XText _ -> True; XInt _ -> True;+ XFloat _ -> True; XBool _ -> True; _ -> False) zs)++r+ XText _ -> x:r+ XInt _ -> x:r+ XFloat _ -> x:r+ XBool _ -> x:r+ _ -> r) [] xs toString :: XSeq -> [String]@@ -261,17 +261,17 @@ appendText :: [XSeq] -> XSeq appendText [] = [] appendText [x] = x-appendText (x:xs) = x++[XNoPad]++appendText xs+appendText (x:xs) = x++(XNoPad:(appendText xs)) toNum :: XSeq -> XSeq-toNum xs = foldr (\x r -> case x of- XInt n -> x:r- XFloat n -> x:r- XText s -> case readNum s of- Just t -> t:r- _ -> r- _ -> r) [] (text xs)+toNum xs = foldl' (\r x -> case x of+ XInt n -> x:r+ XFloat n -> x:r+ XText s -> case readNum s of+ Just t -> t:r+ _ -> r+ _ -> r) [] (text xs) toFloat :: XTree -> Float
src/Text/XML/HXQ/Interpreter.hs view
@@ -4,7 +4,7 @@ - Programmer: Leonidas Fegaras - Email: fegaras@cse.uta.edu - Web: http://lambda.uta.edu/-- Creation: 03/22/08, last update: 08/20/08+- Creation: 03/22/08, last update: 10/20/08 - - Copyright (c) 2008 by Leonidas Fegaras, the University of Texas at Arlington. All rights reserved. - This material is provided as is, with absolutely no warranty expressed or implied.@@ -107,14 +107,15 @@ in foldr (\x r -> (applyPredicates preds (descendant_any_with_tagged_children ts x) True env fncs)++r) [] (eval e context position last effective_axis env fncs) Ast "step" (Avar step:Astring tag:e:preds)- -> foldr (\x r -> (applyPredicates preds ((findV step pathFunctions) tag x) True env fncs)++r)- [] (eval e context position last effective_axis env fncs)+ -> let step_fnc = findV step pathFunctions+ in foldr (\x r -> (applyPredicates preds (step_fnc tag x) True env fncs)++r)+ [] (eval e context position last effective_axis env fncs) Ast "filter" (e:preds) -> applyPredicates preds (eval e context position last effective_axis env fncs) True env fncs Ast "predicate" [condition,body]- -> let xs = eval body context position last effective_axis env fncs- in foldr (\x r -> if conditionTest (eval condition undefv1 undefv2 undefv3 "" env fncs)- then x:r else r) [] xs+ -> if conditionTest (eval condition undefv1 undefv2 undefv3 "" env fncs)+ then eval body context position last effective_axis env fncs+ else [] Ast "append" args -> appendText (map (\x -> eval x context position last effective_axis env fncs) args) Ast "call" ((Avar fname):args)@@ -129,16 +130,20 @@ params args)++env) fncs else error ("Wrong number of arguments in function call: "++fname) _ -> error ("Undefined function: "++fname)- Ast "construction" [Astring tag,Ast "attributes" [],body]- -> [ XElem tag [] 0 parent_error (eval body context position last effective_axis env fncs) ]- Ast "construction" [tag,Ast "attributes" al,body]+ Ast "construction" [Astring tag,id,parent,Ast "attributes" [],body]+ -> let [XText vid] = eval id context position last effective_axis env fncs+ [vparent] = eval parent context position last effective_axis env fncs+ in [ XElem tag [] (read vid) vparent (eval body context position last effective_axis env fncs) ]+ Ast "construction" [tag,id,parent,Ast "attributes" al,body] -> let alc = map (\(Ast "pair" [a,v]) -> let ac = eval a context position last effective_axis env fncs vc = eval v context position last effective_axis env fncs in (qName ac,showXS vc)) al ct = eval tag context position last effective_axis env fncs bc = eval body context position last effective_axis env fncs- in [ XElem (qName ct) alc 0 parent_error bc ]+ [XText vid] = eval id context position last effective_axis env fncs+ [vparent] = eval parent context position last effective_axis env fncs+ in [ XElem (qName ct) alc (read vid) vparent bc ] Ast "let" [Avar var,source,body] -> eval body context position last effective_axis ((var,eval source context position last effective_axis env fncs):env) fncs@@ -153,9 +158,10 @@ in foldir (\a i r -> (eval body a i undefv3 "" ((var,[a]):(ivar,[XInt i]):env) fncs)++r) [] (eval ns context position last effective_axis env fncs) 1 Ast "sortTuple" (exp:orderBys) -- prepare each FLWOR tuple for sorting- -> [ XElem "" [] 0 parent_error+ -> let ee = eval exp context position last effective_axis env fncs+ in [ XElem "" [] 0 parent_error (foldl (\r a -> r++[XElem "" [] 0 parent_error (text (eval a context position last effective_axis env fncs))])- [XElem "" [] 0 parent_error (eval exp context position last effective_axis env fncs)] orderBys) ]+ [XElem "" [] 0 parent_error ee] orderBys) ] Ast "sort" (exp:ordList) -- blocking -> let ce = map (\(XElem _ _ _ _ xs) -> map (\(XElem _ _ _ _ ys) -> ys) xs) (eval exp context position last effective_axis env fncs)@@ -173,7 +179,7 @@ -- The monadic applyPredicates that propagates IO state applyPredicatesM :: [Ast] -> XSeq -> Bool -> Environment -> Functions -> Statements -> IO XSeq-applyPredicatesM [] xs _ _ _ _ = return xs+applyPredicatesM [] xs _ _ _ _ = return $! xs applyPredicatesM ((Aint n):preds) xs _ env fncs stmts -- shortcut that improves laziness = applyPredicatesM preds [xs !! (n-1)] True env fncs stmts applyPredicatesM (pred:preds) xs True env fncs stmts -- top-k like@@ -184,19 +190,19 @@ = do let last = length xs vs <- foldir (\x i r -> do vs <- evalM pred x i last "" env fncs stmts s <- r- return (if case vs of- [XInt k] -> k == i -- indexing- b -> conditionTest b- then x:s else s))+ return $! (if case vs of+ [XInt k] -> k == i -- indexing+ b -> conditionTest b+ then x:s else s)) (return []) xs 1 applyPredicatesM preds vs True env fncs stmts applyPredicatesM (pred:preds) xs _ env fncs stmts = do vs <- foldir (\x i r -> do vs <- evalM pred x i undefv3 "" env fncs stmts s <- r- return (if case vs of- [XInt k] -> k == i -- indexing- b -> conditionTest b- then x:s else s))+ return $! (if case vs of+ [XInt k] -> k == i -- indexing+ b -> conditionTest b+ then x:s else s)) (return []) xs 1 applyPredicatesM preds vs True env fncs stmts @@ -205,19 +211,19 @@ evalM :: Ast -> XTree -> Int -> Int -> String -> Environment -> Functions -> Statements -> IO XSeq evalM e context position last effective_axis env fncs stmts = case e of- Avar "." -> return [ context ]- Avar v -> return (findV v env)- Aint n -> return [ XInt n ]- Afloat n -> return [ XFloat n ]- Astring s -> return [ XText s ]+ Avar "." -> return $! [ context ]+ Avar v -> return $! (findV v env)+ Aint n -> return $! [ XInt n ]+ Afloat n -> return $! [ XFloat n ]+ Astring s -> return $! [ XText s ] -- for non-IO XQuery, use the regular eval- Ast "nonIO" [u] -> return (eval u context position last effective_axis env fncs)+ Ast "nonIO" [u] -> return $! (eval u context position last effective_axis env fncs) Ast "context" [v,Astring dp,body] -> do vs <- evalM v context position last effective_axis env fncs stmts foldr (\x r -> (liftM2 (++)) (evalM body x position last dp env fncs stmts) r) (return []) vs- Ast "call" [Avar "position"] -> return [XInt position]- Ast "call" [Avar "last"] -> return [XInt last]+ Ast "call" [Avar "position"] -> return $! [XInt position]+ Ast "call" [Avar "last"] -> return $! [XInt last] Ast "step" (Avar "child":tag:Avar ".":preds) | effective_axis /= "" -> evalM (Ast "step" (Avar effective_axis:tag:Avar ".":preds)) context position last "" env fncs stmts@@ -227,18 +233,18 @@ foldr (\x r -> (liftM2 (++)) (applyPredicatesM preds (descendant_any_with_tagged_children ts x) True env fncs stmts) r) (return []) vs Ast "step" (Avar step:Astring tag:e:preds)- -> do vs <- evalM e context position last effective_axis env fncs stmts- foldr (\x r -> (liftM2 (++)) (applyPredicatesM preds ((findV step pathFunctions) tag x) True env fncs stmts) r)- (return []) vs+ -> let step_fnc = findV step pathFunctions+ in do vs <- evalM e context position last effective_axis env fncs stmts+ foldr (\x r -> (liftM2 (++)) (applyPredicatesM preds (step_fnc tag x) True env fncs stmts) r)+ (return []) vs Ast "filter" (e:preds) -> do vs <- evalM e context position last effective_axis env fncs stmts applyPredicatesM preds vs True env fncs stmts Ast "predicate" [condition,body]- -> do vs <- evalM body context position last effective_axis env fncs stmts- foldr (\x r -> do vs <- evalM condition undefv1 undefv2 undefv3 "" env fncs stmts- s <- r- return (if conditionTest vs then x:s else s))- (return []) vs+ -> do eb <- evalM condition undefv1 undefv2 undefv3 "" env fncs stmts+ if conditionTest eb+ then evalM body context position last effective_axis env fncs stmts+ else return [] Ast "executeSQL" [Avar var,args] -> do as <- evalM args context position last effective_axis env fncs stmts executeSQL (findV var stmts) as@@ -260,17 +266,21 @@ ((zipWith (\p a -> (p,a)) params vs)++env) fncs stmts else error ("Wrong number of arguments in function call: "++fname) _ -> error ("Undefined function: "++fname)- Ast "construction" [Astring tag,Ast "attributes" [],body]+ Ast "construction" [Astring tag,id,parent,Ast "attributes" [],body] -> do b <- evalM body context position last effective_axis env fncs stmts- return [ XElem tag [] 0 parent_error b ]- Ast "construction" [tag,Ast "attributes" al,body]+ [XText vid] <- evalM id context position last effective_axis env fncs stmts+ [vparent] <- evalM parent context position last effective_axis env fncs stmts+ return $! [ XElem tag [] (read vid) vparent b ]+ Ast "construction" [tag,id,parent,Ast "attributes" al,body] -> do alc <- mapM (\(Ast "pair" [a,v]) -> do ac <- evalM a context position last effective_axis env fncs stmts vc <- evalM v context position last effective_axis env fncs stmts- return (qName ac,showXS vc)) al+ return $! (qName ac,showXS vc)) al ct <- evalM tag context position last effective_axis env fncs stmts bc <- evalM body context position last effective_axis env fncs stmts- return [ XElem (qName ct) alc 0 parent_error bc ]+ [XText vid] <- evalM id context position last effective_axis env fncs stmts+ [vparent] <- evalM parent context position last effective_axis env fncs stmts+ return $! [ XElem (qName ct) alc (read vid) vparent bc ] Ast "let" [Avar var,source,body] -> do s <- evalM source context position last effective_axis env fncs stmts evalM body context position last effective_axis ((var,s):env) fncs stmts@@ -289,8 +299,8 @@ Ast "sortTuple" (exp:orderBys) -- prepare each FLWOR tuple for sorting -> do vs <- evalM exp context position last effective_axis env fncs stmts os <- mapM (\a -> evalM a context position last effective_axis env fncs stmts) orderBys- return [ XElem "" [] 0 parent_error (foldl (\r a -> r++[XElem "" [] 0 parent_error (text a)])- [XElem "" [] 0 parent_error vs] os) ]+ return $! [ XElem "" [] 0 parent_error (foldl (\r a -> r++[XElem "" [] 0 parent_error (text a)])+ [XElem "" [] 0 parent_error vs] os) ] Ast "sort" (exp:ordList) -- blocking -> do vs <- evalM exp context position last effective_axis env fncs stmts let ce = map (\(XElem _ _ _ _ xs) -> map (\(XElem _ _ _ _ ys) -> ys) xs) vs@@ -299,7 +309,7 @@ EQ -> r xs ys o -> o) (\xs ys -> EQ) ordList- return (concatMap head (sortBy (\(_:xs) (_:ys) -> ordering xs ys) ce))+ return $! (concatMap head (sortBy (\(_:xs) (_:ys) -> ordering xs ys) ce)) _ -> error ("Illegal XQuery: "++(show e)) @@ -311,19 +321,19 @@ Nothing -> return "quit" Just t -> if t == "" then oneline prompt- else return t+ else return $! t readlines x = do line <- oneline ": " if last line == '}'- then return (x++" "++(init line))+ then return $! (x++" "++(init line)) else if line == "quit"- then return line+ then return $! line else readlines (x++" "++line) line <- oneline "> " stmt <- if head line == '{' then if last line == '}'- then return (init (tail line))+ then return $! (init (tail line)) else readlines (tail line)- else return line+ else return $! line if stmt == "quit" then putStrLn "Bye!" else do addHistory stmt@@ -333,7 +343,7 @@ evalQueryM :: [Ast] -> Environment -> Functions -> (String -> IO Statement) -> Bool -> IO (XSeq,Environment,Functions) evalQueryM [] variables functions dbmapper verbose- = return ([],variables,functions)+ = return $! ([],variables,functions) evalQueryM (query:xs) variables functions dbmapper verbose = case query of Ast "function" ((Avar f):b:args)@@ -353,23 +363,23 @@ env <- foldr (\(n,b,s) r -> case s of Avar m -> do env <- r- return ((n,findV m env):env)+ return $! ((n,findV m env):env) Astring file -> do doc <- readFile file env <- r- return ((n,[materialize b (parseDocument doc)]):env)+ return $! ((n,[materialize b (parseDocument doc)]):env) _ -> r) (return []) ns stmts <- foldr (\(n,_,s) r -> case s of Ast "prepareSQL" [Astring sql] -> do stmts <- r t <- dbmapper sql- return ((n,t):stmts)+ return $! ((n,t):stmts) _ -> r) (return []) ns result <- evalM ast undefv1 undefv2 undefv3 "" (env++variables) functions stmts (rest,renv,rfuns) <- evalQueryM xs variables functions dbmapper verbose- return (result++rest,renv,rfuns)+ return $! (result++rest,renv,rfuns) xqueryE :: String -> Environment -> Functions -> (String -> IO Statement) -> Bool -> IO (XSeq,Environment,Functions)@@ -380,7 +390,7 @@ -- | Evaluate the XQuery using the interpreter. xquery :: String -> IO XSeq xquery query = do (u,_,_) <- xqueryE query [] [] (\sql -> error "No database connectivity") False- return u+ return $! u -- | Read an XQuery from a file and run it using the interpreter.@@ -392,7 +402,7 @@ -- | Evaluate the XQuery with database connectivity using the interpreter. xqueryDB :: (IConnection conn) => String -> conn -> IO XSeq xqueryDB query db = do (u,_,_) <- xqueryE query [] [] (prepareSQL db) False- return u+ return $! u -- | Read an XQuery with database connectivity from a file and run it using the interpreter.
src/Text/XML/HXQ/Optimizer.hs view
@@ -4,7 +4,7 @@ - Programmer: Leonidas Fegaras - Email: fegaras@cse.uta.edu - Web: http://lambda.uta.edu/-- Creation: 05/01/08, last update: 08/23/08+- Creation: 05/01/08, last update: 10/25/08 - - Copyright (c) 2008 by Leonidas Fegaras, the University of Texas at Arlington. All rights reserved. - This material is provided as is, with absolutely no warranty expressed or implied.@@ -18,11 +18,12 @@ import Control.Monad import Char(toLower)+import List(union) import HXML(AttList) import Text.XML.HXQ.Parser import Text.XML.HXQ.XTree import Text.XML.HXQ.OptionalDB-+import Debug.Trace empty = Ast "call" [Avar "empty"]@@ -170,8 +171,10 @@ Nothing -> Ast "for" [Avar var,Avar "$",simplify source,simplify body] -- pull out attributes from a general element construction simplify (Ast "element_construction" [tag,Ast "attributes" as,content])- = let (nc,attrs) = collect_attributes content- in simplify (Ast "construction" [tag,Ast "attributes" (as++attrs),nc])+ = case collect_attributes content of+ (nc,(Ast "pair" [Astring "_id",id]):(Ast "pair" [Astring "_parent",parent]):attrs)+ -> simplify (Ast "construction" [tag,id,parent,Ast "attributes" (as++attrs),nc])+ (nc,attrs) -> simplify (Ast "construction" [tag,Astring "0",Aint 0,Ast "attributes" (as++attrs),nc]) -- if //* collect all children tagnames to use descendant_any simplify (Ast "for" [Avar var,i,Ast "step" (Avar "descendant-or-self":Astring "*":path:preds),body]) | not (null ((tagged_children var body))) || any (not . null . (tagged_children ".")) preds@@ -189,7 +192,7 @@ in simplify (Ast "step" (Avar "descendant_any":tags:path:preds)) -- expand the wrapper of a stored document simplify (Ast "call" [Avar "publish",Astring dbpath,Astring name])- = simplify (publishXmlDoc dbpath name)+ = simplify (publishXmlDoc dbpath name False) -- default simplify (Ast n args) = Ast n (map simplify args) simplify e = e@@ -197,11 +200,11 @@ -- simplify e/tag taggedElement :: [Ast] -> String -> Maybe [Ast]-taggedElement (e@(Ast "construction" [Astring ctag,_,x]):xs) tag+taggedElement (e@(Ast "construction" [Astring ctag,_,_,_,x]):xs) tag | ctag == tag || tag == "*" = do s <- taggedElement xs tag return (e:s)-taggedElement ((Ast "construction" [_,_,_]):xs) tag+taggedElement ((Ast "construction" [_,_,_,_,_]):xs) tag = taggedElement xs tag taggedElement ((Ast "call" [Avar "concatenate",x,y]):xs) tag = do tx <- taggedElement (x:xs) tag@@ -227,7 +230,7 @@ = case e of Ast "step" (Avar "child":Astring tag:Avar v:preds) -> (elem v tables) && (all (sqlPredicate tables) preds)- Ast "construction" [_,_,Ast "append" xs]+ Ast "construction" [_,_,_,_,Ast "append" xs] -> all (sqlPredicate tables) xs Ast "call" [Avar "text",x] -> sqlPredicate tables x@@ -244,7 +247,7 @@ Aint n -> True Ast "step" (Avar "child":Astring tag:Avar v:preds) -> elem v tables- Ast "construction" [_,_,Ast "append" xs]+ Ast "construction" [_,_,_,_,Ast "append" xs] -> all (sqlExpr tables) xs Ast "call" [Avar "text",x] -> sqlExpr tables x@@ -254,80 +257,76 @@ -- Convert a predicate AST to an SQL predicate that uses the tables-predToSQL :: [String] -> Ast -> (String,[Ast])+predToSQL :: [String] -> Ast -> (String,[Ast],[String]) predToSQL tables e = case e of Ast "step" [Avar "child",Astring tag,Avar v] -> if (elem v tables)- then ("",[])+ then ("",[],[]) else error ("Cannot convert to an SQL predicate: "++show e) Ast "step" (Avar "child":Astring tag:Avar v:pred:preds) -> if (elem v tables) && (all (sqlPredicate tables) preds)- then let (p,ps) = foldl (\(r,rs) (p,ps) -> (r ++ " and " ++ p,rs++ps))- (predToSQL tables pred)- (map (predToSQL tables) preds)- in (p,ps)+ then foldl (\(p',ps',ts') (p,ps,ts) -> (p' ++ " and " ++ p,ps++ps,union ts' ts))+ (predToSQL tables pred)+ (map (predToSQL tables) preds) else error ("Cannot convert to an SQL predicate: "++show e)- Ast "construction" [_,_,Ast "append" xs]+ Ast "construction" [_,_,_,_,Ast "append" xs] -> orAll (map (predToSQL tables) xs) Ast "call" [Avar "text",x] -> predToSQL tables x- Ast "call" [Avar cmp,Ast "for" [Avar v,i,q@(Ast "call" ((Avar "SQL"):_)),x],y]+ Ast "call" [Avar cmp,Ast "for" [Avar v,i,Ast "call" [Avar "SQL",_,Ast "call" ((Avar "from"):t),pred],x],y] | any (\(f,_) -> f==cmp) sqlComparisson- -> let (p,ps) = predToSQL (v:tables) (Ast "call" [Avar cmp,x,y])- Ast "call" [Avar "sql",Astring sql,vs] = foldSQL q- in ("exists ("++sql++" and "++p++")",vs:ps)- Ast "call" [Avar cmp,x,Ast "for" [Avar v,i,q@(Ast "call" ((Avar "SQL"):_)),y]]+ -> let ts = [ x | Avar x <- t ]+ (p,ps,ts') = predToSQL (tables++ts) (call "and" [Ast "call" [Avar cmp,x,y],pred])+ in (p,ps,union ts' ts)+ Ast "call" [Avar cmp,x,Ast "for" [Avar v,i,Ast "call" [Avar "SQL",_,Ast "call" ((Avar "from"):t),pred]],y] | any (\(f,_) -> f==cmp) sqlComparisson- -> let (p,ps) = predToSQL (v:tables) (Ast "call" [Avar cmp,x,y])- Ast "call" [Avar "sql",Astring sql,vs] = foldSQL q- in ("exists ("++sql++" and "++p++")",vs:ps)+ -> let ts = [ x | Avar x <- t ]+ (p,ps,ts') = predToSQL (tables++ts) (call "and" [Ast "call" [Avar cmp,x,y],pred])+ in (p,ps,union ts' ts) Ast "call" [Avar cmp,x,y] | any (\(f,_) -> f==cmp) sqlComparisson- -> let (nx,vx,px) = expToSQL tables x- (ny,vy,py) = expToSQL tables y+ -> let (nx,vx,px,tx) = expToSQL tables x+ (ny,vy,py,ty) = expToSQL tables y p = if (null vx) && (null vy) then "" else foldl (\r p -> r++" and "++p) "" (px++py) in if nx == ""- then (ny,vx)+ then (ny,vx,union tx ty) else if ny == ""- then (nx++p,vy)- else (nx ++ " " ++ snd (head (filter (\(f,_) -> f==cmp) sqlComparisson)) ++ " " ++ ny++p,vx++vy)+ then (nx++p,vy,union tx ty)+ else (nx ++ " " ++ snd (head (filter (\(f,_) -> f==cmp) sqlComparisson)) ++ " " ++ ny++p,vx++vy,union tx ty) Ast "call" [Avar cmp,x,y] | any (\(f,_) -> f==cmp) sqlBoolean- -> let (nx,vx) = predToSQL tables x- (ny,vy) = predToSQL tables y+ -> let (nx,vx,tx) = predToSQL tables x+ (ny,vy,ty) = predToSQL tables y in if nx == ""- then (ny,vy)+ then (ny,vy,union tx ty) else if ny == ""- then (nx,vx)- else (nx ++ " " ++ snd (head (filter (\(f,_) -> f==cmp) sqlBoolean)) ++ " " ++ ny,vx++vy)+ then (nx,vx,union tx ty)+ else (nx ++ " " ++ snd (head (filter (\(f,_) -> f==cmp) sqlBoolean)) ++ " " ++ ny,vx++vy,union tx ty) _ -> error ("Cannot convert to an SQL predicate: "++show e)- where expToSQL :: [String] -> Ast -> (String,[Ast],[String])+ where expToSQL :: [String] -> Ast -> (String,[Ast],[String],[String]) expToSQL tables e = case e of- Astring s -> ("\'"++s++"\'",[],[])- Aint n -> (show n,[],[])+ Astring s -> ("\'"++s++"\'",[],[],[])+ Aint n -> (show n,[],[],[]) Ast "step" [Avar "child",Astring tag,Avar v] -> if elem v tables- then (v++"."++tag,[],[])- else ("?",[e],[])+ then (v++"."++tag,[],[],[])+ else ("?",[e],[],[]) Ast "step" (Avar "child":Astring tag:Avar v:pred:preds)- -> let (p,ps) = foldl (\(r,rs) (p,ps) -> (r ++ " and " ++ p,rs++ps))- (predToSQL tables pred)- (map (predToSQL tables) preds)+ -> let (p,ps,ts) = foldl (\(p',ps',ts') (p,ps,ts) -> (p' ++ " and " ++ p,ps'++ps,union ts' ts))+ (predToSQL tables pred)+ (map (predToSQL tables) preds) in if elem v tables- then (v++"."++tag,ps,[p])- else ("?",e:ps,[p])- Ast "construction" [_,_,Ast "append" [x]]+ then (v++"."++tag,ps,[p],ts)+ else ("?",e:ps,[p],ts)+ Ast "construction" [_,_,_,_,Ast "append" [x]] -> expToSQL tables x Ast "call" [Avar "text",x] -> expToSQL tables x- _ -> ("?",[e],[])- foldSQL (Ast "call" [Avar "SQL",Ast "call" ((Avar "select"):cols),Ast "call" ((Avar "from"):ts),pred])- = let (sql,args) = makeSQL tables ts pred cols- in Ast "call" [Avar "sql",Astring sql,concatenateAll args]+ _ -> ("?",[e],[],[]) orAll [x] = x- orAll (x:xs) = foldl (\(a,as) (b,bs) -> ("("++a++" or "++b++")",as++bs)) x xs+ orAll (x:xs) = foldl (\(a,as,at) (b,bs,bt) -> ("("++a++" or "++b++")",as++bs,union at bt)) x xs -- Convert an AST to an SQL query@@ -346,10 +345,10 @@ then (if null cs then "select * from "++ts else "select "++cs++" from "++ts,[])- else let (p,args) = predToSQL (tables++tnames) pred+ else let (p,args,nts) = predToSQL (tables++tnames) pred in (if null cs- then "select * from "++ts++" where "++p- else "select "++cs++" from "++ts++" where "++p,args)+ then "select * from "++combine (union tnames nts)++" where "++p+ else "select "++cs++" from "++combine (union tnames nts)++" where "++p,args) findAttr :: String -> [Ast] -> Ast@@ -532,16 +531,16 @@ Ast "call" [Avar "=",x,y] | (x == empty && is_constant y) || (y == empty && is_constant x) -> (false,True,count)- Ast "call" [Avar cmp,Ast "construction" [_,_,Ast "append" xs],y]+ Ast "call" [Avar cmp,Ast "construction" [_,_,_,_,Ast "append" xs],y] | any (\(f,_) -> f==cmp) sqlComparisson -> norm (orAll (map (\x -> Ast "call" [Avar cmp,x,y]) xs))- Ast "call" [Avar cmp,x,Ast "construction" [_,_,Ast "append" ys]]+ Ast "call" [Avar cmp,x,Ast "construction" [_,_,_,_,Ast "append" ys]] | any (\(f,_) -> f==cmp) sqlComparisson -> norm (orAll (map (\y -> Ast "call" [Avar cmp,x,y]) ys))- Ast "call" [Avar cmp,Ast "for" [v,i,s,Ast "construction" [_,_,Ast "append" xs]],y]+ Ast "call" [Avar cmp,Ast "for" [v,i,s,Ast "construction" [_,_,_,_,Ast "append" xs]],y] | any (\(f,_) -> f==cmp) sqlComparisson -> norm (orAll (map (\x -> Ast "call" [Avar cmp,Ast "for" [v,i,s,x],y]) xs))- Ast "call" [Avar cmp,x,Ast "for" [v,i,s,Ast "construction" [_,_,Ast "append" ys]]]+ Ast "call" [Avar cmp,x,Ast "for" [v,i,s,Ast "construction" [_,_,_,_,Ast "append" ys]]] | any (\(f,_) -> f==cmp) sqlComparisson -> norm (orAll (map (\y -> Ast "call" [Avar cmp,x,Ast "for" [v,i,s,y]]) ys)) Ast "call" [Avar cmp,Ast "call" [Avar "empty"],y]@@ -586,32 +585,32 @@ Ast "step" (step:tag:x:preds), Ast "step" (step:tag:y:preds)]) -- (<ctag>...<tag>...</tag>...</ctag>)/tag --> ...<tag>...</tag>...- Ast "step" [Avar "child",Astring tag,Ast "construction" [_,_,Ast "append" x]]+ Ast "step" [Avar "child",Astring tag,Ast "construction" [_,_,_,_,Ast "append" x]] | taggedElement x tag /= Nothing -> case taggedElement x tag of Just [] -> (empty,True,count) Just s -> norm (concatenateAll s)- Ast "step" (Avar "child":tag:Ast "construction" [ctag,al,Ast "append" x]:preds)+ Ast "step" (Avar "child":tag:Ast "construction" [ctag,_,_,al,Ast "append" x]:preds) -> norm (Ast "step" (Avar "self":tag:concatenateAll x:preds))- Ast "step" (Avar "self":Astring tag:e@(Ast "construction" [Astring ctag,al,Ast "append" x]):preds)+ Ast "step" (Avar "self":Astring tag:e@(Ast "construction" [Astring ctag,_,_,al,Ast "append" x]):preds) | tag /= "*" -> if tag == ctag then norm (Ast "step" (Avar "self":Astring "*":e:preds)) else (empty,True,count) -- (<tag>x</tag>)//tag --> (x,x//tag)- Ast "step" (Avar "descendant_any":tags:z@(Ast "construction" [Astring ctag,al,Ast "append" x]):preds)+ Ast "step" (Avar "descendant_any":tags:z@(Ast "construction" [Astring ctag,_,_,al,Ast "append" x]):preds) -> norm (Ast "call" [Avar "concatenate",predicates z preds, Ast "step" (Avar "descendant_any":tags:concatenateAll x:preds)])- Ast "step" (Avar "descendant-or-self":Astring tag:z@(Ast "construction" [Astring ctag,al,Ast "append" x]):preds)+ Ast "step" (Avar "descendant-or-self":Astring tag:z@(Ast "construction" [Astring ctag,_,_,al,Ast "append" x]):preds) -> norm (if tag == ctag || tag == "*" then Ast "call" [Avar "concatenate",predicates z preds, Ast "step" (Avar "descendant-or-self":Astring tag:concatenateAll x:preds)] else Ast "step" (Avar "descendant-or-self":Astring tag:concatenateAll x:preds)) -- (<tag A=s>x</tag>)/@A --> s- Ast "step" (Avar "attribute":Astring tag:Ast "construction" [ctag,Ast "attributes" as,x]:preds)+ Ast "step" (Avar "attribute":Astring tag:Ast "construction" [ctag,_,_,Ast "attributes" as,x]:preds) -> norm (predicates (findAttr tag as) preds) -- (<tag A=s>x</tag>)//@A --> (s,x//@A)- Ast "step" (Avar "attribute_descendant":Astring tag:Ast "construction" [ctag,Ast "attributes" as,Ast "append" x]:preds)+ Ast "step" (Avar "attribute_descendant":Astring tag:Ast "construction" [ctag,_,_,Ast "attributes" as,Ast "append" x]:preds) -> norm (Ast "call" [Avar "concatenate",predicates (findAttr tag as) preds, Ast "step" (Avar "attribute_descendant":Astring tag:concatenateAll x:preds)]) -- SQL folding@@ -663,12 +662,21 @@ ([],changed,count) args in (Ast n r,b,c) _ -> (exp,changed,count)- where norm e = normalize e True count+ where --norm e = trace ("*** "++pp exp 4++"\n "++pp e 4) (normalize e True count)+ norm e = normalize e True count+ pp (Ast _ _) 0 = "."+ pp (Ast nm (t:ts)) n = nm ++ "(" ++ pp t (n-1) ++ concatMap (\x -> "," ++ pp x (n-1)) ts ++ ")"+ pp x n = show x foldSQL :: Ast -> Ast foldSQL e = case e of+ Ast "for" [Avar v,Avar "$",Ast "call" [Avar "SQL",Ast "call" [Avar "select"],+ Ast "call" ((Avar "from"):tables),pred],body]+ | any (\(Avar x) -> x==v) tables+ -> foldSQL (Ast "for" [Avar v,Avar "$",Ast "call" [Avar "SQL",Ast "call" [Avar "select",Avar (v++".*")],+ Ast "call" ((Avar "from"):tables),pred],body]) Ast "call" [Avar "SQL",Ast "call" ((Avar "select"):cols),Ast "call" ((Avar "from"):tables),pred] -> let (sql,args) = makeSQL [] tables pred cols in Ast "call" [Avar "sql",Astring sql,concatenateAll args]
src/Text/XML/HXQ/XQuery.hs view
@@ -28,11 +28,13 @@ -- * The XQuery Interpreter xquery, xfile, -- * The XQuery Compiler with Database Connectivity- xqdb, connect, disconnect, prepareSQL, executeSQL,+ xqdb, connect, disconnect, -- * The XQuery Interpreter with Database Connectivity xqueryDB, xfileDB, -- * Shredding and Publishing XML Documents Using a Relational Database- shred, printSchema, createIndex+ genSchema, shred, shredC, printSchema, createIndex,+ -- * Other functions+ XMLEvent(..), prepareSQL, executeSQL ) where import HXML(AttList)@@ -40,3 +42,4 @@ import Text.XML.HXQ.Compiler import Text.XML.HXQ.Interpreter import Text.XML.HXQ.OptionalDB+import XMLParse
src/Text/XML/HXQ/XTree.hs view
@@ -4,7 +4,7 @@ - Programmer: Leonidas Fegaras - Email: fegaras@cse.uta.edu - Web: http://lambda.uta.edu/-- Creation: 05/01/08, last update: 07/24/08+- Creation: 05/01/08, last update: 10/24/08 - - Copyright (c) 2008 by Leonidas Fegaras, the University of Texas at Arlington. All rights reserved. - This material is provided as is, with absolutely no warranty expressed or implied.@@ -28,8 +28,8 @@ type Tag = String --- | Rose tree representation of XML data.--- An XML element is: XElem tagname atributes preorder parent children+-- | A rose tree representation of XML data.+-- An XML element is: @XElem tagname atributes preorder parent children@. -- The preorder numbering is the document order of elements. -- The parent is a cyclic reference to the parent element. data XTree = XElem !Tag !AttList !Int XTree [XTree] -- ^ an XML tree node (element)@@ -80,7 +80,6 @@ -- | Print the XQuery result (which is a sequence of XML fragments) without buffering. putXSeq :: XSeq -> IO () putXSeq xs = hSetBuffering stdout NoBuffering >> putStrLn (showXS xs)- {--------------- Build the rose tree from the XML stream ----------------------------}
src/hxml-0.2/XMLScanner.hs view
@@ -160,7 +160,7 @@ doCharRef :: Int -> (String -> String) -> [Char] -> [Char] doCharRef base k = doSpan (';'/=) (:) (chr . stringToInt base) (k . drop1) stringToInt :: Int -> String -> Int-stringToInt base = foldl digit 0 . map digitToInt+stringToInt base = foldl digit 0 . map (\x -> if isDigit x then digitToInt x else 0) where digit num next = base*num + next -- @@@ This is not quite right: should rescan the replacement text.
+ src/mysql/Connect.hs view
@@ -0,0 +1,28 @@+{-------------------------------------------------------------------------------------+-+- The HDBC driver that uses MySql through ODBC+- Programmer: Leonidas Fegaras+- Email: fegaras@cse.uta.edu+- Web: http://lambda.uta.edu/+- Creation: 05/30/08, last update: 10/24/08+- +- Copyright (c) 2008 by Leonidas Fegaras, the University of Texas at Arlington. All rights reserved.+- This material is provided as is, with absolutely no warranty expressed or implied.+- Any use is at your own risk. Permission is hereby granted to use or copy this program+- for any purpose, provided the above notices are retained on all copies.+-+--------------------------------------------------------------------------------------}+++module Connect where++import Database.HDBC(handleSqlError)+import Database.HDBC.ODBC+++connectionDriver = "mysql"+++-- | Connect to the relational database in filepath using the HDBC ODBC driver for MySql+connect :: FilePath -> IO Connection+connect name = handleSqlError (connectODBC ("DSN=HXQ;Database="++name++";"))
src/noDB/Text/XML/HXQ/OptionalDB.hs view
@@ -18,9 +18,11 @@ import Text.XML.HXQ.XTree import Text.XML.HXQ.Parser+import Language.Haskell.TH type Statement = String+type Table = String class IConnection conn @@ -32,8 +34,8 @@ noDBerror = error "This version of HXQ does not provide database connectivity" -publishXmlDoc :: FilePath -> String -> Ast-publishXmlDoc filepath name = noDBerror+publishXmlDoc :: FilePath -> String -> Bool -> Ast+publishXmlDoc filepath name _ = noDBerror executeSQL :: Statement -> XSeq -> IO XSeq@@ -58,9 +60,19 @@ printSchema db name = noDBerror +-- | Create a schema for an XML document into the database under the given name.+genSchema :: (IConnection conn) => conn -> String -> String -> IO Table+genSchema db file name = noDBerror++ -- | Store an XML document into the database under the given name. shred :: (IConnection conn) => conn -> String -> String -> IO () shred db file name = noDBerror+++-- | Store an XML document into the database under the given name. Generates Haskell code.+shredC :: String -> String -> String -> Q Exp+shredC db file name = noDBerror -- | Create a secondary index on tagname for the shredded document under the given name..
+ src/sqlite/Connect.hs view
@@ -0,0 +1,28 @@+{-------------------------------------------------------------------------------------+-+- The HDBC driver that use sqlite3+- Programmer: Leonidas Fegaras+- Email: fegaras@cse.uta.edu+- Web: http://lambda.uta.edu/+- Creation: 05/30/08, last update: 10/24/08+- +- Copyright (c) 2008 by Leonidas Fegaras, the University of Texas at Arlington. All rights reserved.+- This material is provided as is, with absolutely no warranty expressed or implied.+- Any use is at your own risk. Permission is hereby granted to use or copy this program+- for any purpose, provided the above notices are retained on all copies.+-+--------------------------------------------------------------------------------------}+++module Connect where+++import Database.HDBC.Sqlite3+++connectionDriver = "sqlite"+++-- | Connect to the relational database in filepath using the HDBC Sqlite3 driver+connect :: FilePath -> IO Connection+connect filepath = connectSqlite3 filepath
src/withDB/Text/XML/HXQ/DB.hs view
@@ -4,7 +4,7 @@ - Programmer: Leonidas Fegaras - Email: fegaras@cse.uta.edu - Web: http://lambda.uta.edu/-- Creation: 05/12/08, last update: 08/14/08+- Creation: 05/12/08, last update: 10/25/08 - - Copyright (c) 2008 by Leonidas Fegaras, the University of Texas at Arlington. All rights reserved. - This material is provided as is, with absolutely no warranty expressed or implied.@@ -14,19 +14,25 @@ --------------------------------------------------------------------------------------} +{-# OPTIONS_GHC -fth -funbox-strict-fields #-}++ module Text.XML.HXQ.DB where import System.IO.Unsafe import Char(isSpace,toLower)-import Control.Monad.State+import List(union,zip)+import Data.List(foldl')+import Language.Haskell.TH import Database.HDBC import Text.XML.HXQ.XTree import XMLParse(XMLEvent(..),parseDocument) import HXML(AttList) import Text.XML.HXQ.Parser-import Text.XML.HXQ.DBConnect+import Connect + sql2xml :: SqlValue -> XTree sql2xml value = case value of@@ -64,7 +70,8 @@ executeSQL stmt args = do n <- handleSqlError (execute stmt (map xml2sql args)) result <- handleSqlError (fetchAllRowsAL stmt)- return (map (\x -> XElem "row" [] 0 perror (map (\(s,v) -> XElem s [] 0 perror [sql2xml v]) x)) result)+ return (map (\x -> XElem "row" [] 0 perror (map (\(s,v) -> XElem (column s) [] 0 perror [sql2xml v]) x)) result)+ where column s = if elem '.' s then tail(dropWhile (/= '.') s) else s prepareSQL :: (IConnection conn) => conn -> String -> IO Statement@@ -72,51 +79,50 @@ {------------------------------------------------------------------------------------------ extract the structural summary and statistics of an XML file+-- extract the structural summary and statistics from an XML file ----------------------------------------------------------------------------------------} --- structural summary: tag id max# hasText children-data SSnode = SSnode String !Int !Int !Int !Bool [SSnode]+-- structural summary: tag id max# hasText size children+data SSnode = SSnode String !Int !Int !Int !Bool !Int [SSnode] deriving (Eq,Show) -insertSS :: String -> [SSnode] -> State Int (Int,SSnode,[SSnode])-insertSS tag ((SSnode n i j l b ts):s)+insertSS :: String -> Int -> Int -> [SSnode] -> (Int,SSnode,[SSnode])+insertSS tag count size ((SSnode n i j l b len ts):s) | n == tag- = return (i,SSnode n i j (l+1) b ts,s)-insertSS tag (x:xs)- = do (i,t,ts) <- insertSS tag xs- return (i,t,x:ts)-insertSS tag []- = do count <- get- put (count+1)- return (count+1,SSnode tag (count+1) 1 1 False [],[])+ = (count,SSnode n i j (l+1) b (max size len) ts,s)+insertSS tag count size (x:xs)+ = let (c,t,ts) = ((insertSS tag $! count) $! size) $! xs+ in (c,t,x:ts)+insertSS tag count size []+ = (count+1,SSnode tag (count+1) 1 1 False size [],[]) -insSS :: String -> [SSnode] -> State Int [SSnode]-insSS tag ns = do (k,t,s) <- insertSS tag ns- return (t:s)+insSS :: String -> Int -> Int -> [SSnode] -> (Int,[SSnode])+insSS tag count size ns+ = let (c,t,s) = ((insertSS tag $! count) $! size) $! ns+ in (c,t:s) -getSS :: [XMLEvent] -> [SSnode] -> State Int [SSnode]-getSS ((EmptyEvent n atts):xs) rs- = getSS ((StartEvent n atts):(EndEvent n):xs) rs-getSS ((StartEvent n atts):xs) ((SSnode m i j l b ns):rs)- = do (k,SSnode m' i' j' l' b' ks,ts) <- insertSS n ns- as <- foldM (\r (a,_) -> insSS ('@':a) r) ks atts- getSS xs (reset(SSnode m' i' j' l' b' as):(SSnode m i j l b ts):rs)- where r (SSnode m i j _ b ts) = SSnode m i j 0 b ts- reset (SSnode m i j l b ts) = SSnode m i j l b (map r ts)-getSS ((EndEvent n):xs) (t:(SSnode m i j l b ns):rs)- = getSS xs ((SSnode m i j l b (set t:ns):rs))- where s (SSnode m i j l b ts) = SSnode m i (max j l) 0 b ts- set (SSnode m i j l b ts) = SSnode m i j l b (map s ts)-getSS ((TextEvent t):xs) ((SSnode m i j l False ns):rs)+getSS :: [XMLEvent] -> Int -> [SSnode] -> [SSnode]+getSS ((EmptyEvent n atts):xs) count rs+ = (getSS ((StartEvent n atts):(EndEvent n):xs) $! count) $! rs+getSS ((StartEvent n atts):xs) count ((SSnode m i j l b len ns):rs)+ = let (c,SSnode m' i' j' l' b' len' ks,ts) = (insertSS n $! count) 0 $! ns+ (nc,as) = foldr (\(a,v) (i,s) -> ((insSS ('@':a) $! i) $! (length v)) $! s) (c,ks) atts+ r (SSnode m i j _ b len ts) = SSnode m i j 0 b len ts+ reset (SSnode m i j l b len ts) = SSnode m i j l b len (map r ts)+ in (getSS xs $! nc) $! (reset (SSnode m' i' j' l' b' len' as):(SSnode m i j l b len ts):rs)+getSS ((EndEvent n):xs) count (t:(SSnode m i j l b len ns):rs)+ = let s (SSnode m i j l b len ts) = SSnode m i (max j l) 0 b len ts+ set (SSnode m i j l b len ts) = SSnode m i j l b len (map s ts)+ in (getSS xs $! count) $! ((SSnode m i j l b len (set t:ns):rs))+getSS ((TextEvent t):xs) count ((SSnode m i j l _ len ns):rs) | any (not . isSpace) t- = getSS xs ((SSnode m i j l True ns):rs)-getSS (_:xs) rs = getSS xs rs-getSS [] rs = return rs+ = (getSS xs $! count) $! ((SSnode m i j l True (max len (length t)) ns):rs)+getSS (_:xs) count rs = (getSS xs $! count) $! rs+getSS [] _ rs = rs {---------------------------------------------------------------------------------------@@ -128,7 +134,7 @@ data Table = Table String Path Bool [Table]- | Column String Path+ | Column String Path Int deriving (Show,Read) @@ -142,48 +148,47 @@ schema :: SSnode -> String -> [String] -> [Table]-schema (SSnode n i _ (-1) _ ts) prefix path+schema (SSnode n i _ (-1) _ len ts) prefix path = [ Table (prefix++show i) (pathCons n path) True ((reverse (concatMap (\t -> schema t prefix []) ts))- ++[ Column "value" [] ]) ]-schema (SSnode n i j _ _ []) prefix path+ ++[ Column "value" [] len ]) ]+schema (SSnode n i j _ _ len []) prefix path | j == 1 || head n == '@'- = [ Column (prefix++show i) (pathCons n path) ]-schema (SSnode n i 1 _ _ ts) prefix path+ = [ Column (prefix++show i) (pathCons n path) len ]+schema (SSnode n i 1 _ _ _ ts) prefix path = concatMap (\t -> schema t prefix (pathCons n path)) ts-schema (SSnode n i _ _ b ts) prefix path+schema (SSnode n i _ _ b len ts) prefix path = [ Table (prefix++show i) (pathCons n path) False ((reverse (concatMap (\t -> schema t prefix []) ts))- ++(if b && all (\(SSnode x _ _ _ _ _)-> head x == '@') ts- then [ Column "value" [] ] else [])) ]+ ++(if b && all (\(SSnode x _ _ _ _ _ _)-> head x == '@') ts+ then [ Column "value" [] len ] else [])) ] fixSS :: SSnode -> SSnode-fixSS (SSnode n i j l True ts)- | any (\(SSnode x _ _ _ _ _)-> head x /= '@') ts- = SSnode n i j (-1) True (filter (\(SSnode x _ _ _ _ _)-> head x == '@') ts)-fixSS (SSnode n i j l b ts)- = SSnode n i j l b (map fixSS ts)+fixSS (SSnode n i j l True len ts)+ | any (\(SSnode x _ _ _ _ _ _)-> head x /= '@') ts+ = SSnode n i j (-1) True len (filter (\(SSnode x _ _ _ _ _ _)-> head x == '@') ts)+fixSS (SSnode n i j l b len ts)+ = SSnode n i j l b len (map fixSS ts) deriveSchema :: String -> String -> IO Table deriveSchema file prefix = do doc <- readFile file let ts = parseDocument doc- d = getSS ts [SSnode "root" 1 1 1 False []]- [SSnode _ _ _ _ _ [t]] = evalState d 1- nt@(SSnode m i j l b s) = fixSS t- return (Table prefix [] False (reverse (schema (SSnode m i 2 l b s) prefix [])))+ [SSnode _ _ _ _ _ _ [t]] = getSS ts 0 [SSnode "root" 1 1 1 False 0 []]+ nt@(SSnode m i j l b len s) = fixSS t+ return $! (Table prefix [] False (reverse (schema (SSnode m i 2 l b len s) prefix []))) relationalSchema :: Table -> String -> [String] relationalSchema (Table n path b ts) parent = ("create table "++n++" ( /* "++printPath path ++(if b then " (mixed content)" else "")++" */\n"- ++n++"_id int,\n"- ++(if parent /= "" then (n++"_parent int references "++parent++"("++parent++"_id),\n") else "")- ++(concat [ m++" varchar, /* "++printPath p++" */\n" | Column m p <- ts ])- ++"primary key ("++n++"_id))\n")+ ++n++"_id integer primary key not null"+ ++(if parent /= "" then (",\n"++n++"_parent integer references "++parent++"("++parent++"_id)") else "")+ ++(concat [ ",\n"++m++" varchar("++show size++") /* "++printPath p++" */" | Column m p size <- ts ])+ ++")\n") :[ s | t@(Table _ _ _ _) <- ts, s <- relationalSchema t n ] @@ -194,13 +199,17 @@ initializeDB :: (IConnection conn) => conn -> IO () initializeDB db- = do tables <- getTables db- if elem "HXQCatalog" tables- then return ()- else do let s = "create table HXQCatalog ( name varchar primary key,"- ++" path varchar, summary varchar, relational_schema varchar )"+ = do tbs <- getTables db -- mySql always returns []+ desc <- if null tbs && connectionDriver /= "sqlite"+ then describeTable db "HXQCatalog" -- sqlite3 doesn't support this+ else return []+ if null desc && not(elem "HXQCatalog" tbs)+ then do let s = "create table HXQCatalog ( name varchar(20) primary key not null,"+ ++" next_id integer, path varchar(100),"+ ++" summary varchar(100000), relational_schema varchar(10000) )" handleSqlError (run db s []) commit db+ else return () createSchema :: (IConnection conn) => conn -> String -> String -> IO Table@@ -213,18 +222,19 @@ then do let [[(_,SqlString s)]] = result summary = (read s)::Table tables = getTableNames summary- _ <- mapM (\t -> handleSqlError (run db ("drop table if exists "++t) [])) tables+ _ <- mapM (\t -> handleSqlError (run db ("drop table if exists "++t) []))+ (reverse tables) _ <- handleSqlError (run db "delete from HXQCatalog where name = ?" [SqlString name]) commit db else return () t <- deriveSchema file name let schema = relationalSchema t ""- _ <- handleSqlError (run db "insert into HXQCatalog values (?,?,?,?)"- [SqlString name, SqlString file,+ _ <- handleSqlError (run db "insert into HXQCatalog values (?,?,?,?,?)"+ [SqlString name, SqlInteger 0, SqlString file, SqlString (show t), SqlString (concat schema)]) _ <- mapM (\s -> handleSqlError (run db s [])) schema commit db- return t+ return $! t findSchema :: (IConnection conn) => conn -> String -> IO Table@@ -235,7 +245,7 @@ result <- handleSqlError (fetchAllRowsAL stmt) if length result == 1 then let [[(_,SqlString s)]] = result- in return ((read s)::Table)+ in return $! ((read s)::Table) else error ("Schema "++name++" doesn't exist") @@ -259,7 +269,7 @@ findPath :: [Table] -> [String] -> Int -> Maybe (Int,Table) findPath (t@(Table _ p _ s):ts) path _ | p == path = Just ((length s)-1,t)-findPath (t@(Column _ p):ts) path n | p == path = Just (n,t)+findPath (t@(Column _ p _):ts) path n | p == path = Just (n,t) findPath ((Table _ _ _ _):ts) path n = findPath ts path n findPath (_:ts) path n = findPath ts path (n+1) findPath [] _ _ = Nothing@@ -292,7 +302,7 @@ popAtts [] _ = [] populate ((EndEvent tag):xs) ((t@(Table n path _ s)):ts) _ ([]:ps) = (-2,n):populate xs ts 0 ps-populate ((EndEvent tag):xs) ((Column m path):ts) n (p:ps)+populate ((EndEvent tag):xs) ((Column m path _):ts) n (p:ps) = populate xs ts 0 (tail p:ps) populate ((EndEvent text):xs) ts _ (p:ps) = populate xs ts 0 (tail p:ps)@@ -304,47 +314,59 @@ populate [] ts n ps = [] -insert :: (IConnection conn) => conn -> [(Int,String)] -> [(String,Int,Statement)] -> IO ()-insert db xs stmts = let (s,_,_,_) = m xs 0 0 in s+insert :: (IConnection conn) => conn -> [(Int,String)] -> Integer -> [(String,Int,Statement)] -> IO Integer+insert db xs id stmts = let (s,_,_,_) = m xs id 0 in s where m ((-1,m):xs) i p = let (s,el,xs',i') = ml xs (i+1) i- in (s >> insertTuple m el i p,[],xs',i')- m ((k,m):xs) i p = (return (),[(k,m)],xs,i)- ml [] i p = (return (),[],[],i)- ml ((-2,m):xs) i p = (return (),[],xs,i)+ in ((insertTuple m el i p) >> s,[],xs',i')+ m ((k,m):xs) i p = (return i,[(k,m)],xs,i)+ ml [] i p = (return i,[],[],i)+ ml ((-2,m):xs) i p = (return i,[],xs,i) ml xs i p = let (s,el,xs',i') = m xs i p (s',el',xs'',i'') = ml xs' i' p in (s >> s',el++el',xs'',i'')- find x xs = foldr (\(a,v) r -> if x==a then v else r) "\NUL" xs+ find x xs = foldl' (\r (a,v) -> if x==a then v else r) "\NUL" xs insertTuple m e i p- = let (len,stmt) = foldr (\(a,l,s) r -> if m==a then (l,s) else r) (error "") stmts+ = let (len,stmt) = foldr (\(a,l,s) r -> if m==a then (l,s) else r) (error "*** sql stmt not found") stmts tuple = map (\c -> find c e) [0..len] lift x = if x=="\NUL" then SqlNull else SqlString x in do _ <- handleSqlError (execute stmt- (if i==0+ (if i==id then SqlInteger i:(map lift tuple) else SqlInteger i:SqlInteger p:(map lift tuple)))- if mod i 100 == 99 then commit db else return ()- return ()+ return i +-- | Create a schema for an XML document into the database under the given name.+genSchema :: (IConnection conn) => conn -> String -> String -> IO Table+genSchema db file name+ = createSchema db file (map toLower name)++ -- | Store an XML document into the database under the given name. shred :: (IConnection conn) => conn -> String -> String -> IO () shred db file name = do let prefix = map toLower name+ t <- findSchema db prefix+ --putStrLn (show t) let tableStmt (Table n _ _ ts)- = do let len = length[ 1 | Column _ _ <- ts]-1+ = do let len = length[ 1 | Column _ _ _ <- ts ]-1 stmt <- handleSqlError (prepare db ("insert into "++n++" values (" ++(if n==prefix then "" else "?,")++"?" ++(concatMap (\_ -> ",?") [0..len])++")")) l <- mapM tableStmt ts- return ((n,len,stmt):(concat l))+ return $! ((n,len,stmt):(concat l)) tableStmt _ = return []- t <- createSchema db file prefix stmts <- tableStmt t+ stmt1 <- prepare db "select next_id from HXQCatalog where name = ?"+ _ <- execute stmt1 [SqlString prefix]+ [[(_,SqlString ids)]] <- fetchAllRowsAL stmt1 doc <- readFile file- let ts = parseDocument doc- let ic = (-1,prefix):(populate ts [t] 0 [[]] ++ [(-2,prefix)])- insert db ic stmts+ let id = read ids+ ts = parseDocument doc+ ic = (-1,prefix):(populate ts [t] 0 [[]] ++ [(-2,prefix)])+ new_id <- insert db ic id stmts+ stmt2 <- prepare db "update HXQCatalog set next_id = ? where name = ?"+ execute stmt2 [SqlInteger new_id,SqlString prefix] commit db return () @@ -357,52 +379,228 @@ let indexes = getIndexes "" table _ <- if null indexes then error ("there is no tagname: "++tagname)- else mapM (\(t,c) -> do stmt <- handleSqlError (prepare db ("create index "++t++"_"++c++" on "++t++" ("++c++")"))+ else mapM (\(t,c) -> do -- putStrLn (t++" "++c)+ stmt <- handleSqlError (prepare db ("create index "++t++"_"++c++" on "++t++" ("++c++")")) handleSqlError (execute stmt [])) indexes commit db return ()- where getIndexes _ (Table n _ _ ts) = concatMap (getIndexes n) ts- getIndexes table (Column n path) | (head path)==tagname = [(table,n)]+ where getIndexes _ (Table n (p:_) _ _) | p==tagname = [(n,"value")]+ getIndexes _ (Table n _ _ ts) = concatMap (getIndexes n) ts+ getIndexes table (Column n (p:_) _) | p==tagname = [(table,n)] getIndexes _ _ = [] -{------------------------------------------------------------------------------------------------------- Export (publish) a shredded XML document-----------------------------------------------------------------------------------------------------}+{---------------------------------------------------------------------------------------+-- Generate Haskell code to populate the database from an XML file+----------------------------------------------------------------------------------------} -publishES :: [String] -> [String] -> String-publishES (p:ps) xs- | head p == '@'- = "attribute "++(tail p)++" {"++publishES ps xs++"}"-publishES (p:ps) xs- = "<"++p++">{"++publishES ps xs++"}</"++p++">"-publishES [] [x] = x-publishES [] (x:xs) = x++","++publishES [] xs+{-# NOINLINE insertTuple #-}+insertTuple :: (IConnection conn) => conn -> Statement -> String -> Int+ -> [Integer] -> [[(Int,String)]] -> [[(Int,String)]]+insertTuple db stmt nm len (id:parent:_) (c:cs)+ = let find x xs = foldr (\(a,v) r -> if x==a then v else r) "\NUL" xs+ tuple = map (\a -> find a c) [2..len]+ lift x = if x=="\NUL" then SqlNull else SqlString x+ i = toInteger id+ p = toInteger parent+ query = unsafePerformIO+ (do -- putStrLn (nm++show(show i:show p:tuple))+ catchSql (do execute stmt (if id==0+ then SqlInteger i:(map lift tuple)+ else SqlInteger i:SqlInteger p:(map lift tuple))+ return ())+ (\ e -> putStrLn (show e++show cs))+ if mod id 10000 == 9999+ then do putStrLn (show (id+1)++" tuples")+ commit db+ else return ())+ in query `seq` cs --- for each relational table, synthesize the XQuery that reconstructs the XML from table-publishS :: Table -> String -> String-publishS (Table n path b ts) "error"- = "for $"++n++" in SQL(select(),from($"++n++"),true()) return "- ++publishES (reverse path) (map (\t -> publishS t n) ts)-publishS (Table n path b ts) parent- = "for $"++n++" in SQL(select(),from($"++n++"),$"++n++"/"++n++"_parent eq $"- ++parent++"/"++parent++"_id) return "- ++publishES (reverse path) (map (\t -> publishS t n) ts)-publishS (Column n path) parent- = publishES (reverse path) ["$"++parent++"/"++n++"/text()"]+pushTuple :: (Int,String) -> [[(Int,String)]] -> [[(Int,String)]]+pushTuple a (x:xs) = (a:x):xs +pushAttributes :: [(String,String)] -> [(Int,String)] -> [[(Int,String)]] -> [[(Int,String)]]+pushAttributes atts ps (x:xs)+ = ((map (\(a,v) -> findColumn a v ps) atts)++x):xs+ where findColumn name value ps+ = foldr (\(i,a) r -> if a==name then (i,value) else r) (error ("column "++name++" not found")) ps+++dfa state stream values i ancs c+ = let (n,vs,ni,nancs,s) = ((c (state,stream) $! i) $! ancs) $! values+ in if n == 0+ then i+1+ else dfa n s vs ni nancs c+++{-# NOINLINE shredC #-}+-- | Store an XML document into the database under the given name. Generates Haskell code.+shredC :: String -> String -> String -> Q Exp+shredC dbname file name+ = unsafePerformIO (+ do let prefix = map toLower name+ dbc <- connect dbname+ table <- findSchema dbc prefix+ let intE = litE . integerL . toInteger+ intP = litP . integerL . toInteger+ genCase table cols state pats c+ = case table of+ Column _ ['@':_] _+ -> c state pats+ Column nm path _+ -> let col = findTag nm cols+ in genPath (reverse path) state pats+ (\m ps -> (match (tupP [intP m,infixP (conP (mkName "TextEvent") [dp]) (mkName ":") rp])+ (normalB [| ($(intE m),pushTuple ($(intE col),$d) $cs,+ $current,$ancestors,$r) |]) []):(c m ps))+ Table nm path mixed ts+ -> let cols = zip [2..] [ a | Column a _ _ <- ts ]+ atts = [ (i,a) | (i,['@':a]) <- zip [2..] [ p | Column _ p _ <- ts ] ]+ in genTuple (reverse path) nm atts state pats cols+ (\m -> foldr (\t r _ ps -> genCase t cols m ps r) c ts m)+ findTag tag = foldr (\(n,t) r -> if t==tag then n else r) (error "tag not found")+ findState state tag = foldr (\(b,t,a) r -> if t==tag && b==state then a else r) (-1)+ genTuple [] _ _ state pats _ c = c state pats+ genTuple (p:path) nm atts state pats cols c+ = let after = findState state p pats+ in if after >= 0+ then genPath path after pats c+ else let next = (length pats)+2+ ncs = [| [] : $cs |]+ ae xs = if null atts+ then [| $xs |]+ else [| pushAttributes $al $(listE (map (\(i,a) -> tupE [intE i,litE (stringL a)]) atts)) $xs |]+ in [match (tupP [intP state,infixP (conP (mkName "StartEvent") [litP (stringL p),alp]) (mkName ":") rp])+ (normalB [| ($(intE next),$(ae ncs),$current+1,($current+1) : $ancestors,$r) |]) [],+ match (tupP [intP next,infixP (conP (mkName "EndEvent") [litP (stringL p)]) (mkName ":") rp])+ (normalB [| ($(intE state),+ insertTuple $db $(varE (mkName (nm++"_stmt"))) $(litE (stringL p))+ $(intE ((length cols)+1)) $ancestors $cs,+ $current,tail $ancestors,$r) |]) [],+ match (tupP [intP state,infixP (conP (mkName "EmptyEvent") [litP (stringL p),alp]) (mkName ":") rp])+ (normalB [| ($(intE state),+ insertTuple $db $(varE (mkName (nm++"_stmt"))) $(litE (stringL p))+ $(intE ((length cols)+1)) (($current+1) : $ancestors) $(ae ncs),+ $current+1,$ancestors,$r) |]) []]+ ++(genPath path next ((state,p,next):pats) c)+ genPath [] state pats c = c state pats+ genPath (p:path) state pats c+ = let after = findState state p pats+ in if after >= 0+ then genPath path after pats c+ else let next = (length pats)+2+ in [match (tupP [intP state,infixP (conP (mkName "StartEvent") [litP (stringL p),alp]) (mkName ":") rp])+ (normalB [| ($(intE next),$cs,$current,$ancestors,$r) |]) [],+ match (tupP [intP next,infixP (conP (mkName "EndEvent") [litP (stringL p)]) (mkName ":") rp])+ (normalB [| ($(intE state),$cs,$current,$ancestors,$r) |]) [],+ match (tupP [intP state,infixP (conP (mkName "EmptyEvent") [litP (stringL p),alp]) (mkName ":") rp])+ (normalB [| ($(intE state),$cs,$current,$ancestors,$r) |]) []]+ ++(genPath path next ((state,p,next):pats) c)+ s = varE (mkName "s")+ r = varE (mkName "r")+ current = varE (mkName "i")+ ancestors = varE (mkName "ancs")+ d = varE (mkName "d")+ id = varE (mkName "id")+ al = varE (mkName "al")+ cs = varE (mkName "cs")+ db = varE (mkName "db")+ sp = varP (mkName "s")+ rp = varP (mkName "r")+ dp = varP (mkName "d")+ alp = varP (mkName "al")+ code = lamE [sp,varP (mkName "i"),varP (mkName "ancs"),varP (mkName "cs")]+ (caseE (varE (mkName "s"))+ ((genCase table [] 1 [] (\_ _ -> []))+ ++[match (tupP [sp,infixP wildP (mkName ":") rp])+ (normalB [| ($s,$cs,$current,$ancestors,$r) |]) [],+ match wildP (normalB [| (0,[],1,[],[]) |]) []]))+ tableStmt (Table n _ _ ts)+ = let len = length[ 1 | Column _ _ _ <- ts ]-1+ ins = "insert into "++n++" values ("+ ++(if n==prefix then "" else "?,")++"?"+ ++(concatMap (\_ -> ",?") [0..len])++")"+ stmt = [| handleSqlError (prepare $db $(litE (stringL ins))) |]+ in (n++"_stmt",stmt):concatMap tableStmt ts+ tableStmt _ = []+ mseq a v b = infixE (Just a) (varE (mkName ">>=")) (Just (lamE [varP (mkName v)] b))+ ret = foldr (\(n,s) r -> mseq s n r)+ [| do execute $(varE (mkName (prefix++"_stmt"))) [SqlInteger $id]+ return $! dfa 1 $(varE (mkName "doc")) [[]] $id [0] $code |]+ (tableStmt table)+ -- runQ ret >>= putStrLn.pprint+ return $! [| do d <- readFile $(litE (stringL file))+ let doc = parseDocument d+ db <- connect $(litE (stringL dbname))+ stmt <- prepare db "select next_id from HXQCatalog where name = ?"+ _ <- handleSqlError (execute stmt [SqlString prefix])+ [[(_,SqlString ids)]] <- fetchAllRowsAL stmt+ let id = read ids+ new_id <- handleSqlError ($(lamE [varP (mkName "db"),varP (mkName "doc"),varP (mkName "id")] ret)+ db doc id)+ stmt2 <- prepare db "update HXQCatalog set next_id = ? where name = ?"+ handleSqlError (execute stmt2 [SqlInteger new_id,SqlString prefix])+ commit db+ |])+++{----------------------------------------------------------------------------------------------------+-- Export (publish) a shredded XML document+----------------------------------------------------------------------------------------------------}++ -- construct an XQuery (in string form) that extracts a shredded XML document-publishTable :: Table -> String-publishTable table = "<root>{" ++ publishS table "error" ++ "}</root>"+publishTable :: Table -> Bool -> String+publishTable table needsParent+ = "<root>{" ++ pubS (rev table) "()" id ++ "}</root>"+ where rev (Table n path b ts) = Table n (reverse path) b (map rev ts)+ rev (Column tag path len) = Column tag (reverse path) len+ pubS (Table n [] _ ts) _ _+ = "for $"++n++" in SQL(select(),from($"++n++"),true()) return " ++ pubLS ts n "()" id+ pubS (Table n (p:_) _ ts) parent c+ = c ("{for $"++n++" in SQL(select(),from($"++n++"),$"++n++"/"++n++"_parent eq $"+ ++parent++"/"++parent++"_id) return "+ ++"<"++p++">"+ -- "{attribute {'_id'} {$"++n++"/"++n++"_id/text()}}"+ -- ++",attribute {'_parent'} {"++(if needsParent then "$"++parent else "()")++"}}"+ ++ pubLS ts n parent id ++ "</"++p++">}")+ pubS (Column tag (('@':p):_) _) parent c+ = c ("attribute "++p++" {$"++parent++"/"++tag++"/text()}")+ pubS (Column tag (p:_) _) parent c+ = c ("<"++p++">{$"++parent++"/"++tag++"/text()}</"++p++">")+ pubS (Column "value" [] _) parent c+ = c ("{$"++parent++"/value/text()}")+ pubLS [] _ _ c = c ""+ pubLS (x@(t:ts)) n parent c+ = case head t of+ Nothing -> (pubS t n c)++(pubLS ts n parent c)+ Just tag -> let (s1,s2) = filter tag (reverse x)+ in (mkE tag s1 c)++(if null s2 then "" else (","++pubLS s2 n parent id))+ where mkE tag s c = "<"++tag++">"++pubLS s n parent c++"</"++tag++">"+ head (Table _ (p:_:_) _ _) = Just p+ head (Column _ (p:_:_) _) = Just p+ head _ = Nothing+ filter _ [] = ([],[])+ filter tag ((Table n (p:ps) b s):ts)+ | p == tag+ = let (s1,s2) = filter tag ts+ in ((Table n ps b s):s1,s2)+ filter tag ((Column n (p:ps) len):ts)+ | p == tag+ = let (s1,s2) = filter tag ts+ in ((Column n ps len):s1,s2)+ filter tag (t:ts)+ = let (s1,s2) = filter tag ts+ in (s1,t:s2) {-# NOINLINE publishXmlDoc #-} -- construct the Ast of an XQuery that extracts a shredded XML document-publishXmlDoc :: FilePath -> String -> Ast-publishXmlDoc filepath name+publishXmlDoc :: FilePath -> String -> Bool -> Ast+publishXmlDoc filepath name needsParent = let query = unsafePerformIO (publishWrapper filepath name) [ast] = parse (scan query) in ast@@ -410,5 +608,7 @@ = do let prefix = map toLower name db <- connect filepath table <- findSchema db prefix- let query = publishTable table- return query+ -- putStrLn (show table)+ let query = publishTable table needsParent+ -- putStrLn query+ return $! query
− src/withDB/Text/XML/HXQ/DBConnect.hs
@@ -1,26 +0,0 @@-{----------------------------------------------------------------------------------------- HDBC driver. Currently, Sqlite3.-- Programmer: Leonidas Fegaras-- Email: fegaras@cse.uta.edu-- Web: http://lambda.uta.edu/-- Creation: 05/30/08, last update: 07/24/08-- -- Copyright (c) 2008 by Leonidas Fegaras, the University of Texas at Arlington. All rights reserved.-- This material is provided as is, with absolutely no warranty expressed or implied.-- Any use is at your own risk. Permission is hereby granted to use or copy this program-- for any purpose, provided the above notices are retained on all copies.-----------------------------------------------------------------------------------------}---module Text.XML.HXQ.DBConnect where---import Database.HDBC.Sqlite3------ | Connect to the relational database in filepath using the HDBC Sqlite3 driver-connect :: FilePath -> IO Connection-connect filepath = connectSqlite3 filepath
src/withDB/Text/XML/HXQ/OptionalDB.hs view
@@ -15,10 +15,11 @@ module Text.XML.HXQ.OptionalDB- ( IConnection, Statement, publishXmlDoc, executeSQL, prepareSQL, connect, disconnect, shred, printSchema, createIndex+ ( IConnection, Statement, publishXmlDoc, executeSQL, prepareSQL, connect, disconnect,+ genSchema, shred, shredC, printSchema, createIndex ) where import Database.HDBC import Text.XML.HXQ.DB-import Text.XML.HXQ.DBConnect+import Connect