{------------------------------------------------------------------------------------- - - Database connectivity using HDBC - Programmer: Leonidas Fegaras - Email: fegaras@cse.uta.edu - Web: http://lambda.uta.edu/ - 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. - 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. - --------------------------------------------------------------------------------------} {-# OPTIONS_GHC -fth -funbox-strict-fields #-} module Text.XML.HXQ.DB where import System.IO.Unsafe import Char(isSpace,toLower) 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 Connect sql2xml :: SqlValue -> XTree sql2xml value = case value of SqlString s -> XText s SqlByteString bs -> XText (show bs) SqlWord32 n -> XInt (fromEnum n) SqlWord64 n -> XInt (fromEnum n) SqlInt32 n -> XText (show n) SqlInt64 n -> XText (show n) SqlInteger n -> XInt (fromEnum n) SqlChar c -> XText [c] SqlBool b -> XBool b SqlDouble n -> XText (show n) SqlRational n -> XText (show n) SqlEpochTime n -> XText (show n) SqlTimeDiff n -> XText (show n) SqlNull -> XText "" xml2sql :: XTree -> SqlValue xml2sql e = case e of XText s -> SqlString s XInt n -> SqlInteger (toInteger n) XFloat n -> SqlString (show n) XBool n -> SqlBool n XElem n _ _ _ [x] -> xml2sql x _ -> error ("Cannot convert "++show e++" into sql") perror = error "constructed elements have no parent" executeSQL :: Statement -> XSeq -> IO XSeq 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 (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 prepareSQL db sql = handleSqlError (prepare db sql) {--------------------------------------------------------------------------------------- -- extract the structural summary and statistics from an XML file ----------------------------------------------------------------------------------------} -- structural summary: tag id max# hasText size children data SSnode = SSnode String !Int !Int !Int !Bool !Int [SSnode] deriving (Eq,Show) insertSS :: String -> Int -> Int -> [SSnode] -> (Int,SSnode,[SSnode]) insertSS tag count size ((SSnode n i j l b len ts):s) | n == tag = (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 -> 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] -> 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 $! count) $! ((SSnode m i j l True (max len (length t)) ns):rs) getSS (_:xs) count rs = (getSS xs $! count) $! rs getSS [] _ rs = rs {--------------------------------------------------------------------------------------- -- Derive a good relational schema based on the structural summary (using hybrid inlining) ----------------------------------------------------------------------------------------} type Path = [Tag] data Table = Table String Path Bool [Table] | Column String Path Int deriving (Show,Read) printPath :: Path -> String printPath [] = "" printPath [p] = p printPath (p:ps) = printPath ps++"/"++p pathCons p ps = if p=="root" then ps else p:ps schema :: SSnode -> String -> [String] -> [Table] 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" [] len ]) ] schema (SSnode n i j _ _ len []) prefix path | j == 1 || head n == '@' = [ 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 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" [] len ] else [])) ] fixSS :: SSnode -> SSnode 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 [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 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 ] getTableNames :: Table -> [String] getTableNames (Table n _ _ ts) = n:(concatMap getTableNames ts) getTableNames _ = [] initializeDB :: (IConnection conn) => conn -> IO () initializeDB db = 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 createSchema db file name = do initializeDB db stmt <- handleSqlError (prepare db "select summary from HXQCatalog where name = ?") _ <- handleSqlError (execute stmt [SqlString name]) result <- handleSqlError (fetchAllRowsAL stmt) if length result > 0 then do let [[(_,SqlString s)]] = result summary = (read s)::Table tables = getTableNames summary _ <- 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, SqlInteger 0, SqlString file, SqlString (show t), SqlString (concat schema)]) _ <- mapM (\s -> handleSqlError (run db s [])) schema commit db return $! t findSchema :: (IConnection conn) => conn -> String -> IO Table findSchema db name = do initializeDB db stmt <- handleSqlError (prepare db "select summary from HXQCatalog where name = ?") _ <- handleSqlError (execute stmt [SqlString name]) result <- handleSqlError (fetchAllRowsAL stmt) if length result == 1 then let [[(_,SqlString s)]] = result in return $! ((read s)::Table) else error ("Schema "++name++" doesn't exist") -- | Print the relational schema of the XML document stored in the database under the given name printSchema :: (IConnection conn) => conn -> String -> IO () printSchema db name = do initializeDB db stmt <- handleSqlError (prepare db "select relational_schema from HXQCatalog where name = ?") _ <- handleSqlError (execute stmt [SqlString name]) result <- handleSqlError (fetchAllRowsAL stmt) if length result == 1 then let [[(_,SqlString s)]] = result in putStrLn s else error ("Schema "++name++" doesn't exist") {--------------------------------------------------------------------------------------- -- Populate the database from the XML file and its derived structural summary ----------------------------------------------------------------------------------------} 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 ((Table _ _ _ _):ts) path n = findPath ts path n findPath (_:ts) path n = findPath ts path (n+1) findPath [] _ _ = Nothing populate :: [XMLEvent] -> [Table] -> Int -> [[String]] -> [(Int,String)] populate ((EmptyEvent tag atts):xs) ts n ps = populate ((StartEvent tag atts):(EndEvent tag):xs) ts n ps populate (x@(StartEvent tag atts):xs) ((t@(Table n path _ s)):ts) _ (p:ps) = case findPath s (tag:p) 0 of Just (n,nt@(Table m _ True as)) -> (-1,m):(popAtts atts as ++ showXTree xs 1 "") where showXTree ((EmptyEvent tag atts):xs) i s = showXTree xs i (s++"<"++tag++showAL atts++"/>") showXTree ((StartEvent tag atts):xs) i s = showXTree xs (i+1) (s++"<"++tag++showAL atts++">") showXTree ((EndEvent tag):xs) i s = if i==1 then (n,s):(-2,m):(populate xs (t:ts) n (p:ps)) else showXTree xs (i-1) (s++"") showXTree ((TextEvent text):xs) i s = showXTree xs i (s++text) showXTree (_:xs) i s = showXTree xs i s Just (n,nt@(Table m _ _ as)) -> (-1,m):((popAtts atts as)++(populate xs (nt:t:ts) n ([]:p:ps))) Just (n,nt) -> populate xs (nt:t:ts) n ((tag:p):ps) Nothing -> populate xs (t:ts) 0 ((tag:p):ps) where popAtts ((a,v):as) ks = let Just(m,_) = findPath ks ['@':a] 0 in (m,v):(popAtts as ks) 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 xs ts 0 (tail p:ps) populate ((EndEvent text):xs) ts _ (p:ps) = populate xs ts 0 (tail p:ps) populate ((TextEvent text):xs) ts n ps | any (not . isSpace) text = (n,text):populate xs ts n ps populate (x:xs) ts n ps = populate xs ts n ps populate [] ts n ps = [] 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 ((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 = 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 "*** 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==id then SqlInteger i:(map lift tuple) else SqlInteger i:SqlInteger p:(map lift tuple))) 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 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)) tableStmt _ = return [] 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 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 () -- | Create a secondary index on tagname for the shredded document under the given name.. createIndex :: (IConnection conn) => conn -> String -> String -> IO () createIndex db name tagname = do let prefix = map toLower name table <- findSchema db name let indexes = getIndexes "" table _ <- if null indexes then error ("there is no tagname: "++tagname) 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 (p:_) _ _) | p==tagname = [(n,"value")] getIndexes _ (Table n _ _ ts) = concatMap (getIndexes n) ts getIndexes table (Column n (p:_) _) | p==tagname = [(table,n)] getIndexes _ _ = [] {--------------------------------------------------------------------------------------- -- Generate Haskell code to populate the database from an XML file ----------------------------------------------------------------------------------------} {-# 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 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 -> Bool -> String publishTable table needsParent = "{" ++ pubS (rev table) "()" id ++ "}" 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 ++ "}") pubS (Column tag (('@':p):_) _) parent c = c ("attribute "++p++" {$"++parent++"/"++tag++"/text()}") pubS (Column tag (p:_) _) parent c = c ("<"++p++">{$"++parent++"/"++tag++"/text()}") 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++"" 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 -> Bool -> Ast publishXmlDoc filepath name needsParent = let query = unsafePerformIO (publishWrapper filepath name) [ast] = parse (scan query) in ast where publishWrapper filepath name = do let prefix = map toLower name db <- connect filepath table <- findSchema db prefix -- putStrLn (show table) let query = publishTable table needsParent -- putStrLn query return $! query