TableAlgebra (empty) → 0.1.5
raw patch · 10 files changed
+1122/−0 lines, 10 filesdep +HaXmldep +basedep +containerssetup-changed
Dependencies added: HaXml, base, containers, haskell98, mtl, pretty, template-haskell
Files
- LICENSE +27/−0
- Setup.hs +4/−0
- TableAlgebra.cabal +41/−0
- src/Database/Ferry/Algebra.hs +28/−0
- src/Database/Ferry/Algebra/Data/Algebra.hs +233/−0
- src/Database/Ferry/Algebra/Data/Create.hs +151/−0
- src/Database/Ferry/Algebra/Data/GraphBuilder.hs +109/−0
- src/Database/Ferry/Algebra/Render/XML.hs +410/−0
- src/Database/Ferry/Algebra/Render/XMLUtils.hs +109/−0
- src/Database/Ferry/Impossible.hs +10/−0
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) Eberhard Karls Universität Tübingen 2010++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,4 @@+import Distribution.Simple++main = defaultMain+
+ TableAlgebra.cabal view
@@ -0,0 +1,41 @@+cabal-version: >=1.8+Name: TableAlgebra+synopsis: Ferry Table Algebra+Category: Database+Version: 0.1.5+Description: The Ferry 2.0 Table Algebra library+ .+ The table algebra [2] is an intermediate language used by Ferry 2.0 [3] and DSH [4].+ It forms the input for the pathfinder [1] optimiser that can translate it into SQL.+ The library exposes a monadic interface to construct algebraic plans, it + automatically performs common sub-tree elimination so that the resulting plan+ is as small as possible and the optimiser can do it's work better. + XML rendering is present and needed for interfacing with DSH-Pathfinder, and + for debugging plans with the standalone Pathfinder.+ .+ .+ 1. <http://www-db.informatik.uni-tuebingen.de/research/pathfinder>+ .+ 2. <http://dbworld.informatik.uni-tuebingen.de/projects/pathfinder/wiki/Logical_Algebra>+ .+ 3. <http://www-db.informatik.uni-tuebingen.de/research/ferry>+ .+ 4. <http://www-db.informatik.uni-tuebingen.de/files/publications/ferryhaskell.pdf>+License: BSD3+License-file: LICENSE+Author: Jeroen Weijers <jeroen.weijers@uni-tuebingen.de> Tom Schreiber <tom.schreiber@uni-tuebingen.de>+Maintainer: Jeroen Weijers <jeroen.weijers@uni-tuebingen.de>+Build-Type: Simple+library+ buildable: True+ build-depends: base >= 4.2 && < 5, HaXml >= 1.20.2, mtl >= 2.0.1.0, containers >= 0.3.0.0, haskell98 >= 1.0.1.1, template-haskell >= 2.4.0.0, pretty >= 1.0.1.1+ exposed-modules: Database.Ferry.Algebra+ hs-source-dirs: src+ GHC-Options: -Wall -fno-warn-orphans -fno-warn-type-defaults -fno-warn-unused-do-bind + other-modules:+ Database.Ferry.Algebra.Data.Algebra + Database.Ferry.Algebra.Data.Create + Database.Ferry.Algebra.Data.GraphBuilder + Database.Ferry.Algebra.Render.XML + Database.Ferry.Algebra.Render.XMLUtils+ Database.Ferry.Impossible
+ src/Database/Ferry/Algebra.hs view
@@ -0,0 +1,28 @@+{-| +This package provides a convenient interface to construct Table Algebra+plans that can be dealt with by Pathfinder+(http://www-db.informatik.uni-tuebingen.de/research/pathfinder). +A describtion of the algebra can be found at: +http://dbworld.informatik.uni-tuebingen.de/projects/pathfinder/wiki/Logical_Algebra+This module only provides a subset of the complete algebra.+-}++module Database.Ferry.Algebra (+ AlgPlan,+ transform,+ union, emptyPlan, attach, proj, getLoop, subPlan, rownum, rownum', eqJoin, rank, eqTJoin, distinct, rowrank, cast, difference, aggr,+ select, posSelect, dbTable, notC, cross, oper, emptyTable,+ withBinding, withContext, getGamma, getPlan, fromGam, + nat, int, bool, double, string,+ natT, intT, surT, boolT, doubleT, stringT,+ SortDir(..), AggrType(..),+ SubPlan(..), AlgRes,+ Column(..), Columns, + ATy(..),+ SchemaInfos, KeyInfos, AlgNode, GraphM, Gam,+ initLoop, runGraph)where++import Database.Ferry.Algebra.Data.Algebra+import Database.Ferry.Algebra.Data.Create+import Database.Ferry.Algebra.Data.GraphBuilder+import Database.Ferry.Algebra.Render.XML
+ src/Database/Ferry/Algebra/Data/Algebra.hs view
@@ -0,0 +1,233 @@+{-# LANGUAGE GADTs #-}+{-| +The Algebra module provides the internal datatypes used for +constructing algebaric plans. It is not recommended to use these+datatypes directly instead it is adviced the to use the functions+provided by the module Ferry.Algebra.Data.Create+-}+module Database.Ferry.Algebra.Data.Algebra where++import Numeric (showFFloat)++-- | The column data type is used to represent the table structure while+-- compiling ferry core into an algebraic plan+-- The col column contains the column number and the type of its contents+-- The NCol column is used to group columns that together form an element of a record+-- , its string argument is used to represent the field name.+data Column where+ Col :: Int -> ATy -> Column+ NCol :: String -> Columns -> Column+ deriving (Show)++-- | One table can have multiple columns +type Columns = [Column]++-- | Sorting rows in a direction+data SortDir = Asc+ | Desc+ deriving (Eq, Ord)+ +data AggrType = Avg + | Max + | Min + | Sum + | Count + | All + | Prod + | Dist+ deriving (Eq, Ord)++instance Show AggrType where+ show Avg = "avg"+ show Max = "max"+ show Min = "min"+ show Sum = "sum"+ show Count = "count"+ show All = "all"+ show Prod = "prod"+ show Dist = "distinct"++-- | The show instance results in values that are accepted in the xml plan.+instance Show SortDir where+ show Asc = "ascending"+ show Desc = "descending"+ +-- | Algebraic types+-- At this level we do not have any structural types anymore+-- those are represented by columns. ASur is used for surrogate+-- values that occur for nested lists.+data ATy where+ AInt :: ATy + AStr :: ATy + ABool :: ATy+ ADec :: ATy + ADouble :: ATy + ANat :: ATy + ASur :: ATy+ deriving (Eq, Ord)+ +-- | Show the algebraic types in a way that is compatible with +-- the xml plan.+instance Show ATy where+ show AInt = "int"+ show AStr = "str"+ show ABool = "bool"+ show ADec = "dec"+ show ADouble = "dbl"+ show ANat = "nat"+ show ASur = "nat"++-- | Wrapper around values that can occur in an algebraic plan +data AVal where+ VInt :: Integer -> AVal+ VStr :: String -> AVal+ VBool :: Bool -> AVal+ VDouble :: Double -> AVal+ VDec :: Float -> AVal + VNat :: Integer -> AVal+ deriving (Eq, Ord)++-- | Show the values in the way compatible with the xml plan.+instance Show AVal where+ show (VInt x) = show x+ show (VStr x) = x + show (VBool True) = "true"+ show (VBool False) = "false"+ show (VDouble x) = show x+ show (VDec x) = showFFloat (Just 2) x ""+ show (VNat x) = show x++-- | Pair of a type and a value+type ATyVal = (ATy, AVal)++-- | Attribute name or column name+type AttrName = String++-- | Result attribute name, used as type synonym where the name for a result column of a computation is needed +type ResAttrName = AttrName++-- | Sort attribute name, used as type synonym where a column for sorting is needed+type SortAttrName = AttrName++-- | Partition attribute name, used as a synonym where the name for the partitioning column is expected by the rownum operator+type PartAttrName = AttrName++-- | New attribute name, used to represent the new column name when renaming columns+type NewAttrName = AttrName++-- | Old attribute name, used to represent the old column name when renaming columns+type OldAttrName = AttrName++-- | Selection attribute name, used to represent the column containing the selection boolean+type SelAttrName = AttrName++-- | Left attribute name, used to represent the left argument when applying binary operators+type LeftAttrName = AttrName++-- | Right attribute name, used to represent the right argument when applying binary operators+type RightAttrName = AttrName+--+-- | Name of a database table+type TableName = String ++-- | List of table attribute information consisting of (column name, new column name, type of column)+type TableAttrInf = [(AttrName, AttrName, ATy)]++-- | Key of a database table, a key consists of multiple column names+type KeyInfo = [AttrName]++-- | Multiple keys+type KeyInfos = [KeyInfo]++-- | Sort information, a list (ordered in sorting priority), of pair of columns and their sort direction--+type SortInf = [(SortAttrName, SortDir)]++-- | Projection information, a list of new attribute names, and their old names.+type ProjInf = [(NewAttrName, OldAttrName)] ++-- | A tuple is a list of values+type Tuple = [AVal]++-- | Schema information, represents a table structure, the first element of the tuple is the column name the second its type.+type SchemaInfos = [(AttrName, ATy)] ++type SemInfRowNum = (ResAttrName, SortInf, Maybe PartAttrName) ++-- | Information that specifies how to perform the rank operation.+-- its first element is the column where the output of the operation is inserted+-- the second element represents the sorting criteria that determine the ranking.+type SemInfRank = (ResAttrName, SortInf)++-- | Information that specifies a projection+type SemInfProj = ProjInf+++-- | Information that specifies which column contains the conditional+type SemInfSel = SelAttrName++-- | Information that specifies how to select element at a certain position+type SemInfPosSel = (Int, SortInf, Maybe PartAttrName) +++-- | Information on how to perform an eq-join. The first element represents the column from the+-- first table that has to be equal to the column in the second table represented by the second+-- element in the pair.+type SemInfEqJoin = (LeftAttrName,RightAttrName)++-- | Information what to put in a literate table+type SemInfLitTable = [Tuple]++-- | Information for accessing a database table+type SemInfTableRef = (TableName, TableAttrInf, KeyInfos)++-- | Information what column, the first element, to attach to a table and what its content would be, the second element.+type SemInfAttach = (ResAttrName, ATyVal)++type SemInfCast = (ResAttrName, AttrName, ATy)++-- | Information on how to perform a binary operation+-- The first element is the function that is to be performed+-- The second element the column name for its result+-- The third element is the left argument for the operator+-- The fourth element is the right argument for the operator+type SemBinOp = (String, ResAttrName, LeftAttrName, RightAttrName)++type SemUnOp = (ResAttrName, AttrName)++type SemInfAggr = ([(AggrType, ResAttrName, Maybe AttrName)], Maybe PartAttrName)++type AlgNode = Int++-- | Algebraic operations. These operation do not reference their own children directly+-- they only contain the information that is needed to perform the operation.+data Algebra where+ RowNum :: SemInfRowNum -> AlgNode -> Algebra -- Should have one child+-- RowId :: SemInfRowId -> Algebra -- should have one child+ RowRank :: SemInfRank -> AlgNode -> Algebra -- should have one child+ Rank :: SemInfRank -> AlgNode -> Algebra -- should have one child+ Proj :: SemInfProj -> AlgNode -> Algebra -- should have one child + Sel :: SemInfSel -> AlgNode -> Algebra -- should have one child + PosSel :: SemInfPosSel -> AlgNode -> Algebra -- should have one child+ Cross :: AlgNode -> AlgNode -> Algebra -- should have two children+ EqJoin :: SemInfEqJoin -> AlgNode -> AlgNode -> Algebra -- should have two children +-- SemiJoin :: SemInfEqJoin -> Algebra -- should have two children +-- ThetaJoin :: SemInfThetaJoin -> Algebra -- should have two children+ DisjUnion :: AlgNode -> AlgNode -> Algebra -- should have two children+ Difference :: AlgNode -> AlgNode -> Algebra -- should have two children+ Distinct :: AlgNode -> Algebra -- should have one child+ LitTable :: SemInfLitTable -> SchemaInfos -> Algebra+ EmptyTable :: SchemaInfos -> Algebra+ TableRef :: SemInfTableRef -> Algebra+ Attach :: SemInfAttach -> AlgNode -> Algebra -- should have one child+ FunBinOp :: SemBinOp -> AlgNode -> Algebra -- should have one child+ Cast :: SemInfCast -> AlgNode -> Algebra -- should have one child+-- FunNumEq :: SemInfBinOp -> Algebra -- should have one child+-- FunNumGt :: SemInfBinOp -> Algebra -- should have one child+-- Fun1To1 :: SemInfFun1To1 -> Algebra -- should have one child+-- FunBoolAnd :: SemInfBinOp -> Algebra -- should have one child +-- FunBoolOr :: SemInfBinOp -> Algebra -- should have one child+ FunBoolNot :: SemUnOp -> AlgNode -> Algebra -- should have one child+ Aggr :: SemInfAggr -> AlgNode -> Algebra -- should have one child+-- FunAggrCnt :: SemInfFunAggrCnt -> Algebra -- should have one child+-- SerializeRel :: SemInfSerRel -> Algebra -- should have two children+ deriving (Show, Eq, Ord)
+ src/Database/Ferry/Algebra/Data/Create.hs view
@@ -0,0 +1,151 @@+{-|+This module contains helper functions for constructing algebraic plans.+-}+module Database.Ferry.Algebra.Data.Create where+ +import Database.Ferry.Algebra.Data.Algebra+import Database.Ferry.Algebra.Data.GraphBuilder++-- * Value constructors++-- | Create an algebraic int value+int :: Integer -> AVal+int = VInt++-- | Create an algebraic string value+string :: String -> AVal+string = VStr++-- | Create an algebraic boolean value+bool :: Bool -> AVal+bool = VBool++-- | Create an algebraic double value+double :: Double -> AVal+double = VDouble++-- | Create an algebraic decimal value+dec :: Float -> AVal+dec = VDec++-- | Create an algebraic nat value+nat :: Integer -> AVal+nat = VNat++-- | Types of algebraic values+intT, stringT, boolT, decT, doubleT, natT, surT :: ATy+intT = AInt+stringT = AStr+boolT = ABool+decT = ADec+doubleT = ADouble+natT = ANat+surT = ASur++-- * Graph construction combinators for table algebra++-- | Construct an empty table node with +emptyTable :: SchemaInfos -> GraphM AlgNode+emptyTable = insertNode . EmptyTable++-- | Construct a database table node+-- The first argument is the \emph{qualified} name of the database+-- table. The second describes the columns in alphabetical order.+-- The third argument describes the database keys (one table key can+-- span over multiple columns).+dbTable :: String -> Columns -> KeyInfos -> GraphM AlgNode+dbTable n cs ks = insertNode $ TableRef (n, attr, ks) + where+ attr = map (\c -> case c of+ (NCol n' [Col i t]) -> (n', "item" ++ show i, t)+ _ -> error "Not a named column") cs++-- | Construct a table with one value+litTable :: AVal -> String -> ATy -> GraphM AlgNode+litTable v s t = insertNode $ LitTable [[v]] [(s, t)]++-- | Attach a column 'ResAttrName' of type `ATy' with value+-- `AVal' in all rows to table `AlgNode'+attach :: ResAttrName -> ATy -> AVal -> AlgNode -> GraphM AlgNode+attach n t v c = insertNode $ Attach (n, (t, v)) c++-- | Cast column `AttrName' to type `ATy' and give it the name +-- `ResAttrName' afterwards.+cast :: AttrName -> ResAttrName -> ATy -> AlgNode -> GraphM AlgNode+cast n r t c = insertNode $ Cast (r, n, t) c++-- | Join two plans where the columns n1 of table 1 and columns n2 of table+-- 2 are equal.+eqJoin :: String -> String -> AlgNode -> AlgNode -> GraphM AlgNode+eqJoin n1 n2 c1 c2 = insertNode $ EqJoin (n1, n2) c1 c2++-- | The same as eqJoin but with multiple columns.+eqTJoin :: [(String, String)] -> ProjInf -> AlgNode -> AlgNode -> GraphM AlgNode+eqTJoin eqs projI q1 q2 = let (a, b) = head eqs+ in foldr filterEqs (eqJoin a b q1 q2) $ tail eqs+ where resCol = "item99999002"+ filterEqs :: (String, String) -> GraphM AlgNode -> GraphM AlgNode+ filterEqs (l, r) res = proj projI =<< select resCol =<< oper "==" resCol l r =<< res++-- | Assign a number to each row in column 'ResAttrName' incrementing+-- sorted by `SortInf'. The numbering is not dense!+rank :: ResAttrName -> SortInf -> AlgNode -> GraphM AlgNode+rank res sort c1 = insertNode $ Rank (res, sort) c1++-- | Compute the difference between two plans.+difference :: AlgNode -> AlgNode -> GraphM AlgNode+difference q1 q2 = insertNode $ Difference q1 q2++-- | Same as rank but provides a dense numbering.+rowrank :: ResAttrName -> SortInf -> AlgNode -> GraphM AlgNode+rowrank res sort c1 = insertNode $ RowRank (res, sort) c1++-- | Get's the nth element(s) of a (partitioned) table.+posSelect :: Int -> SortInf -> Maybe AttrName -> AlgNode -> GraphM AlgNode+posSelect n sort part c1 = insertNode $ PosSel (n, sort, part) c1++-- | Select rows where the column `SelAttrName' contains True.+select :: SelAttrName -> AlgNode -> GraphM AlgNode+select sel c1 = insertNode $ Sel sel c1++-- | Remove duplicate rows+distinct :: AlgNode -> GraphM AlgNode+distinct c1 = insertNode $ Distinct c1++-- | Make cross product from two plans+cross :: AlgNode -> AlgNode -> GraphM AlgNode+cross c1 c2 = insertNode $ Cross c1 c2++-- | Negate the boolen value in column n and store it in column r+notC :: AttrName -> AttrName -> AlgNode -> GraphM AlgNode+notC r n c1 = insertNode $ FunBoolNot (r, n) c1++-- | Union between two plans+union :: AlgNode -> AlgNode -> GraphM AlgNode+union c1 c2 = insertNode $ DisjUnion c1 c2++-- | Project/rename certain column out of a plan+proj :: ProjInf -> AlgNode -> GraphM AlgNode+proj cols c = insertNode $ Proj cols c++-- | Apply aggregate functions to a plan+aggr :: [(AggrType, ResAttrName, Maybe AttrName)] -> Maybe PartAttrName -> AlgNode -> GraphM AlgNode+aggr aggrs part c1 = insertNode $ Aggr (aggrs, part) c1++-- | Similar to rowrank but this will assign a \emph{unique} number to every row+-- (even if two rows are equal)+rownum :: AttrName -> [AttrName] -> Maybe AttrName -> AlgNode -> GraphM AlgNode+rownum res sort part c1 = insertNode $ RowNum (res, zip sort $ repeat Asc, part) c1++-- | Same as rownum but columns can be assigned an ordering direction+rownum' :: AttrName -> [(AttrName, SortDir)] -> Maybe AttrName -> AlgNode -> GraphM AlgNode+rownum' res sort part c1 = insertNode $ RowNum (res, sort, part) c1++-- | Apply an operator to the element in `LeftAttrName' and `RightAttrName',+-- store the result in `ResAttrName'+oper :: String -> ResAttrName -> LeftAttrName -> RightAttrName -> AlgNode -> GraphM AlgNode+oper o r la ra c = insertNode $ FunBinOp (o, r, la, ra) c++-- | Shorthand for the initial loop condition used by Ferry.+initLoop :: Algebra+initLoop = LitTable [[(nat 1)]] [("iter", natT)]
+ src/Database/Ferry/Algebra/Data/GraphBuilder.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE GADTs #-}+module Database.Ferry.Algebra.Data.GraphBuilder where+ +import Database.Ferry.Algebra.Data.Algebra++import qualified Data.Map as M+import Control.Monad.State+import Control.Monad.Reader++-- | Graphs are constructed in a monadic environment.+-- | The graph constructed has to be a DAG.+-- | The reader monad provides access to the variable environment Gamma and the loop table+-- | The variable environment is a mapping from variable names to graphnodes that represent+-- | their compiled form.+-- | The state monad gives access to a supply of fresh variables, and maintains a map from+-- | nodes to node ids. When a node is inserted and an equal node (equal means, equal node +-- | and equal child nodes) already exists in the map the node id for that already existing+-- | node is returned. This allows maximal sharing.+type GraphM = ReaderT (Gam, AlgNode) (State (Int, M.Map Algebra AlgNode))++-- | Variable environemtn mapping from variables to compiled nodes.+type Gam = [(String, AlgRes)]++newtype SubPlan = SubPlan (M.Map Int AlgRes)++instance Show SubPlan where+ show (SubPlan p) = "SubPlans " ++ (show $ map (\(_,y,z) -> show (y, z)) $ M.elems p)+ +emptyPlan :: SubPlan+emptyPlan = SubPlan M.empty++subPlan :: Int -> AlgRes -> SubPlan+subPlan i p = SubPlan $ M.singleton i p++getPlan :: Int -> SubPlan -> AlgRes+getPlan i (SubPlan p) = p M.! i+-- | An algebraic solution is a triple consisting of the node id, a description of the database columns and all subplans+type AlgRes = (AlgNode, Columns, SubPlan)++-- | An algebraic plan is the result of constructing a graph.+-- | The pair consists of the mapping from nodes to their respective ids+-- | and the algres from the top node.+type AlgPlan = (M.Map Algebra AlgNode, AlgRes)++-- | Evaluate the monadic graph into an algebraic plan, given a loop relation.+runGraph :: Algebra -> GraphM AlgRes -> AlgPlan+runGraph l = (\(r, (_,m)) -> (m, r) ) . flip runState (2, M.singleton l 1) . flip runReaderT ([], 1)++-- | Get the current loop table+getLoop :: GraphM AlgNode+getLoop = do + (_, l) <- ask+ return l++-- | Get the current variable environment +getGamma :: GraphM Gam+getGamma = do+ (g, _) <- ask+ return g++-- | Get a fresh node id+getFreshId :: GraphM Int+getFreshId = do+ (n, t) <- get+ put $ (n + 1, t)+ return n++-- | Check if a node already exists in the graph construction environment, if so return its id.+findNode :: Algebra -> GraphM (Maybe AlgNode)+findNode n = do+ (_, t) <- get+ return $ M.lookup n t++-- | Insert a node into the graph construction environment, first check if the node already exists+-- | if so return its id, otherwise insert it and return its id. +insertNode :: Algebra -> GraphM AlgNode+insertNode n = do+ v <- findNode n + case v of+ (Just n') -> return n'+ Nothing -> insertNode' n++-- | Blindly insert a node, get a fresh id and return that +insertNode' :: Algebra -> GraphM AlgNode+insertNode' n = do + i <- getFreshId + (sup, t) <- get+ let t' = M.insert n i t+ put $ (sup, t')+ return i++-- | Evaluate the graph construction computation with the current environment extended with a binding n to v.+withBinding :: String -> AlgRes -> GraphM a -> GraphM a+withBinding n v a = do+ local (\(g, alg) -> ((n, v):g, alg)) a++-- | Evaluate the graph construction computation with a differnt gamma, +-- | and loop table. Return within he current computational context. +withContext :: Gam -> AlgNode -> GraphM a -> GraphM a+withContext gam loop = local (\_ -> (gam, loop))++-- | Lookup a variable in the environment +fromGam :: String -> GraphM AlgRes+fromGam n = do+ (m, _) <- ask+ case lookup n m of+ Just r -> return r+ Nothing -> error $ "Variable: " ++ n ++ " could not be found, should not be possible!"+
+ src/Database/Ferry/Algebra/Render/XML.hs view
@@ -0,0 +1,410 @@+{-# LANGUAGE TemplateHaskell #-}+module Database.Ferry.Algebra.Render.XML where+{-+Transform a query plan DAG into an XML representation.+-} +import Database.Ferry.Impossible+import Database.Ferry.Algebra.Data.Algebra+import Database.Ferry.Algebra.Data.GraphBuilder+import Database.Ferry.Algebra.Render.XMLUtils+import Control.Monad.Writer++import Text.XML.HaXml.Types+import Text.XML.HaXml.Pretty (document)+import Text.XML.HaXml.Escape (xmlEscape, stdXmlEscaper)++import Text.PrettyPrint.HughesPJ++import qualified Data.Map as M++-- Transform a query plan with result type into a pretty doc.+-- The type is used to add meta information to the XML that is used for pretty printing by ferryDB+transform :: (Bool, AlgPlan) -> Doc+transform (isList, p) = let plans = runXML M.empty $ planBuilder (mkProperty isList) p+ planBundle = mkPlanBundle plans+ in (document $ mkXMLDocument planBundle)++-- Transform a potentially nested algebraic plan into xml.+-- The first argument is the overall result type property of the query.+planBuilder :: Element () -> AlgPlan -> XML ()+planBuilder prop (nodes, (top, cols, subs)) = buildPlan Nothing (Just prop) (top, cols, subs)+ where+ buildPlan :: Maybe (Int, Int) -> Maybe (Element ()) -> AlgRes -> XML ()+ buildPlan parent props (top', cols', subs') = + do+ let colProp = cssToProp cols'+ let planProp = case props of+ Nothing -> [colProp] `childsOf` xmlElem "properties"+ Just p -> [colProp, p] `childsOf` xmlElem "properties"+ let plan = runXML nodeTable $ serializeAlgebra top' cols'+ pId <- mkQueryPlan parent planProp plan+ buildSubPlans pId subs'+ buildSubPlans :: Int -> SubPlan -> XML ()+ buildSubPlans parent (SubPlan m) = let subPlans = M.toList m+ in mapM_ (\(cId, res) -> buildPlan (Just (parent, cId)) Nothing res) subPlans+ + nodeTable = M.fromList $ map (\(a, b) -> (b, a)) $ M.toList nodes+++-- Convert columns structure to xml properties for rendering by ferry DB +cssToProp :: Columns -> Element ()+cssToProp cols = map csToProp cols `childsOf` [attr "name" "cs"] `attrsOf` xmlElem "property"++csToProp :: Column -> Element ()+csToProp (Col i ty) = [[attr "name" "type", attr "value" $ show ty] `attrsOf` xmlElem "property"] `childsOf` [attr "name" "offset", attr "value" $ show i] `attrsOf` xmlElem "property" +csToProp (NCol x css) = [cssToProp css] `childsOf` [attr "name" "mapping", attr "value" x] `attrsOf` xmlElem "property" ++-- Serialize algebra+serializeAlgebra :: GraphNode -> Columns -> XML XMLNode+serializeAlgebra qGId cols = do+ qId <- alg2XML qGId+ nilId <- nilNode+ xId <- freshId+ let contentN = ((:) iterCol $ (:) posCol $ fst $ colsToNodes 1 cols) `childsOf` contentNode+ let edgeNil = mkEdge nilId+ let edgeQ = mkEdge qId+ tell [[contentN, edgeNil, edgeQ] `childsOf` node xId "serialize relation"]+ return xId++-- XML defintion of iter column+iterCol :: Element ()+iterCol = [attr "name" "iter", attr "new" "false", attr "function" "iter"] `attrsOf` xmlElem "column"++-- XML defintion of position column+posCol :: Element ()+posCol = [attr "name" "pos", attr "new" "false", attr "function" "pos"] `attrsOf` xmlElem "column"++-- Transform cs structure into xml columns+colsToNodes :: Int -> Columns -> ([Element ()], Int)+colsToNodes i ((Col n _):cs) = let col = [attr "name" $ "item" ++ (show n), attr "new" "false", attr "function" "item", attr "position" $ show i] `attrsOf` xmlElem "column"+ (els, i') = colsToNodes (i+1) cs+ in (col:els, i') +colsToNodes i ((NCol _ cs):cs') = let (els, i') = colsToNodes i cs + (els', i'') = colsToNodes i' cs'+ in (els ++ els', i'')+colsToNodes i [] = ([], i)++-- XML defintion of nil node +nilNode :: XML XMLNode+nilNode = do+ xId <- freshId+ tell [node xId "nil"]+ return xId+ +-- Transform algebra into XML+-- The outer function determines whether the node was already translated into xml, if so it returns the xml id of that node.+-- if the node was not translated yet the inner function alg2XML' will translated the plan and return the xml id+alg2XML :: GraphNode -> XML XMLNode +alg2XML gId = do+ def <- isDefined gId+ case def of+ Just x -> return x+ Nothing -> do+ nd <- getNode gId+ xId <- alg2XML' nd+ addNodeTrans gId xId+ return xId+ + + where+ alg2XML' :: Algebra -> XML XMLNode + alg2XML' (LitTable [[v]] [(n, ty)]) = do+ xId <- freshId+ tell [mkTableNode xId n v ty]+ return xId + alg2XML' (Attach (n, (ty, val)) cId1) = do+ cxId1 <- alg2XML cId1+ xId <- freshId+ tell [mkAttachNode xId n val ty cxId1]+ return xId+ alg2XML' (Proj proj cId1) = do+ cxId1 <- alg2XML cId1+ xId <- freshId+ tell [mkProjNode xId proj cxId1]+ return xId+ alg2XML' (EqJoin jc cId1 cId2) = do+ cxId1 <- alg2XML cId1+ cxId2 <- alg2XML cId2+ xId <- freshId+ tell [mkEqJoinNode xId jc cxId1 cxId2]+ return xId+ alg2XML' (FunBinOp (op, res, lArg, rArg) cId) = do+ cxId1 <- alg2XML cId+ xId <- freshId+ tell [mkBinOpNode xId op res lArg rArg cxId1]+ return xId+ alg2XML' (EmptyTable schema) = do+ xId <- freshId+ tell [mkEmptyTable xId schema]+ return xId+ alg2XML' (DisjUnion cId1 cId2) = do+ cxId1 <- alg2XML cId1+ cxId2 <- alg2XML cId2+ xId <- freshId+ tell [mkUnion xId cxId1 cxId2]+ return xId+ alg2XML' (Rank (res, sort) cId1) = do+ cxId1 <- alg2XML cId1+ xId <- freshId+ tell [mkRank xId res sort cxId1]+ return xId+ alg2XML' (Cross cId1 cId2) = do+ cxId1 <- alg2XML cId1+ cxId2 <- alg2XML cId2+ xId <- freshId+ tell [mkCross xId cxId1 cxId2]+ return xId+ alg2XML' (TableRef (n, cs, ks)) = do+ xId <- freshId+ tell [mkTable xId n cs ks]+ return xId+ alg2XML' (Sel n cId1) = do+ cxId <- alg2XML cId1+ xId <- freshId+ tell [mkSelect xId n cxId]+ return xId+ alg2XML' (PosSel (n, sort, part) cId1) = do+ cxId1 <- alg2XML cId1+ xId <- freshId+ tell [mkPosSel xId n sort part cxId1]+ return xId+ alg2XML' (FunBoolNot (res, col) cId1) = do+ cxId1 <- alg2XML cId1+ xId <- freshId+ tell [mkBoolNot xId res col cxId1]+ return xId+ alg2XML' (RowNum (res, sort, part) cId1) = do+ cxId1 <- alg2XML cId1+ xId <- freshId+ tell [mkRowNum xId res sort part cxId1]+ return xId+ alg2XML' (Distinct cId1) = do+ cxId <- alg2XML cId1+ xId <- freshId+ tell [mkDistinct xId cxId]+ return xId+ alg2XML' (RowRank (res, sort) cId1) = do+ cxId1 <- alg2XML cId1+ xId <- freshId+ tell [mkRowRank xId res sort cxId1]+ return xId+ alg2XML' (Aggr (aggrs, part) cId1)+ = do+ cxId1 <- alg2XML cId1+ xId <- freshId+ tell [mkAggrs xId aggrs part cxId1]+ return xId+ alg2XML' (Cast (r, o, t) cId1) = do+ cxId1 <- alg2XML cId1+ xId <- freshId+ tell [mkCast xId o r t cxId1]+ return xId+ alg2XML' (Difference cId1 cId2) = do+ cxId1 <- alg2XML cId1+ cxId2 <- alg2XML cId2+ xId <- freshId+ tell [mkDifference xId cxId1 cxId2]+ return xId+ alg2XML' _ = $impossible++mkDifference :: XMLNode -> XMLNode -> XMLNode -> Element ()+mkDifference xId cxId1 cxId2 = [mkEdge cxId1, mkEdge cxId2]`childsOf` node xId "difference" ++mkCast :: XMLNode -> AttrName -> AttrName -> ATy -> XMLNode -> Element ()+mkCast xId o r t c = [[column r True, column o False, typeN t] `childsOf` contentNode, mkEdge c] `childsOf` node xId "cast"++mkAggrs :: XMLNode -> [(AggrType, ResAttrName, Maybe AttrName)] -> Maybe PartAttrName -> XMLNode -> Element ()+mkAggrs xId aggrs part cId = let partCol = case part of+ Nothing -> []+ Just x -> [[attr "function" "partition"] `attrsOf` column x False]+ aggr = map mkAggr aggrs + in [(partCol ++ aggr) `childsOf` contentNode, mkEdge cId] `childsOf` node xId "aggr" + where+ mkAggr :: (AggrType, ResAttrName, Maybe AttrName) -> Element ()+ mkAggr (aggr, res, arg) = let argCol = case arg of+ Just arg' -> [[attr "function" "item"] `attrsOf` column arg' False]+ Nothing -> [] + in ((column res True):argCol) `childsOf` [attr "kind" $ show aggr] `attrsOf` xmlElem "aggregate"++mkPosSel :: XMLNode -> Int -> SortInf -> Maybe PartAttrName -> XMLNode -> Element ()+mkPosSel xId n sort part cId = let sortCols = map mkSortColumn $ zip sort [1..]+ partCol = case part of+ Nothing -> []+ Just x -> [[attr "function" "partition"] `attrsOf` column x False]+ posNode = n `dataChildOf` xmlElem "position" + in [((posNode:sortCols) ++ partCol) `childsOf` contentNode, mkEdge cId] `childsOf` node xId "pos_select" ++-- Create an xml rank element node. +mkRowRank :: XMLNode -> ResAttrName -> SortInf -> XMLNode -> Element ()+mkRowRank xId res sort cId = let sortCols = map mkSortColumn $ zip sort [1..]+ in [(column res True : sortCols) `childsOf` contentNode, mkEdge cId] `childsOf` node xId "rowrank"++-- | Create an xml distinct node+mkDistinct :: XMLNode -> XMLNode -> Element ()+mkDistinct xId cxId = [mkEdge cxId] `childsOf` node xId "distinct" ++-- | Create an xml rownum node +mkRowNum :: XMLNode -> ResAttrName -> SortInf -> Maybe PartAttrName -> XMLNode -> Element ()+mkRowNum xId res sort part cxId = let sortCols = map mkSortColumn $ zip sort [1..]+ partCol = case part of+ Nothing -> []+ Just x -> [[attr "function" "partition"] `attrsOf` column x False]+ in [(column res True:(sortCols ++ partCol)) `childsOf` contentNode , mkEdge cxId] `childsOf` node xId "rownum"++-- | Create an xml boolean not node +mkBoolNot :: XMLNode -> String -> String -> XMLNode -> Element ()+mkBoolNot xId res arg cxId = [[column res True, column arg False] `childsOf` contentNode, mkEdge cxId] `childsOf` node xId "not"++-- | Create an xml select node+mkSelect :: XMLNode -> String -> XMLNode -> Element ()+mkSelect xId n cxId = [[column n False] `childsOf` contentNode, mkEdge cxId] `childsOf` node xId "select"++-- | Create an xml table binding node+mkTable :: XMLNode -> String -> TableAttrInf -> KeyInfos -> Element ()+mkTable xId n descr keys = [[mkKeys keys] `childsOf` xmlElem "properties", [mkTableDescr n descr] `childsOf` contentNode] `childsOf` node xId "ref_tbl"+ +-- | Create an xml table description node+mkTableDescr :: String -> TableAttrInf -> Element ()+mkTableDescr n descr = map (\d -> toTableCol d ) descr `childsOf` [attr "name" n] `attrsOf` xmlElem "table"+ where+ toTableCol :: (AttrName, AttrName, ATy) -> Element ()+ toTableCol (cn, xn, t) = [attr "name" xn, attr "tname" cn, attr "type" $ show t] `attrsOf` xmlElem "column"++-- | Create an xml table key node+mkKey :: KeyInfo -> Element ()+mkKey k = let bd = map (\(k', p) -> [attr "name" k', attr "position" $ show p] `attrsOf` xmlElem "column") $ zip k [1..]+ in bd `childsOf` xmlElem "key" ++-- | Create an xml node containing multiple table keys +mkKeys :: KeyInfos -> Element ()+mkKeys ks = map mkKey ks `childsOf` xmlElem "keys"+ +-- Create an xml rank element node. +mkRank :: XMLNode -> ResAttrName -> SortInf -> XMLNode -> Element ()+mkRank xId res sort cId = let sortCols = map mkSortColumn $ zip sort [1..]+ resCol = column res True+ in [resCol:sortCols `childsOf` contentNode, mkEdge cId] `childsOf` node xId "rank" ++-- Create an xml sort column node for use in the rank node. +mkSortColumn :: ((SortAttrName, SortDir), Int) -> Element ()+mkSortColumn ((n, d), p) = [attr "function" "sort", attr "position" $ show p, attr "direction" $ show d] `attrsOf` column n False+++-- Create an xml cross node+mkCross :: XMLNode -> XMLNode -> XMLNode -> Element ()+mkCross xId cxId1 cxId2 = [mkEdge cxId1, mkEdge cxId2]`childsOf` node xId "cross"++-- Create an xml union node +mkUnion :: XMLNode -> XMLNode -> XMLNode -> Element ()+mkUnion xId cxId1 cxId2 = [mkEdge cxId1, mkEdge cxId2]`childsOf` node xId "union" ++-- Create an empty table node, table needs to contain type information+mkEmptyTable :: XMLNode -> SchemaInfos -> Element ()+mkEmptyTable xId schema = [map mkColumn schema `childsOf` contentNode] `childsOf` node xId "empty_tbl"++-- Create an xml column node+mkColumn :: (AttrName, ATy) -> Element ()+mkColumn (n, t) = [attr "type" $ show t] `attrsOf` column n True++-- Create an xml binary operator node.+-- Three sort of binary operators exist:+-- 1. Arithmatic operators, represented in xml as function nodes+-- 2. Relational operators, represented in xml as relational function nodes+-- 3. Operators that can be expressed in terms of other operators +mkBinOpNode :: XMLNode -> String -> ResAttrName -> LeftAttrName -> RightAttrName -> XMLNode -> Element ()+mkBinOpNode xId op res lArg rArg cId | elem op ["+", "-", "*", "%", "/"] = mkFnNode xId (arOptoFn op) res lArg rArg cId+ | elem op [">", "==", "and", "or", "&&", "||"] = mkRelFnNode xId (relOptoFn op) res lArg rArg cId+ | elem op ["<" ] = mkBinOpNode xId ">" res rArg lArg cId+ | otherwise = $impossible+ where+ arOptoFn :: String -> String+ arOptoFn "+" = "add"+ arOptoFn "-" = "subtract"+ arOptoFn "/" = "divide"+ arOptoFn "*" = "multiply"+ arOptoFn "%" = "modulo"+ arOptoFn _ = $impossible+ relOptoFn :: String -> String+ relOptoFn ">" = "gt"+ relOptoFn "==" = "eq"+ relOptoFn "and" = "and"+ relOptoFn "or" = "or"+ relOptoFn "&&" = "and"+ relOptoFn "||" = "or"+ relOptoFn _ = $impossible++-- Create an XML relational function node+mkRelFnNode :: XMLNode -> String -> ResAttrName -> LeftAttrName -> RightAttrName -> XMLNode -> Element ()+mkRelFnNode xId fn res lArg rArg cId = let content = [column res True,+ [attr "position" "1"] `attrsOf` column lArg False,+ [attr "position" "2"] `attrsOf` column rArg False] `childsOf` contentNode+ in [content, mkEdge cId] `childsOf` node xId fn+ ++-- Create an XML function node +mkFnNode :: XMLNode -> String -> ResAttrName -> LeftAttrName -> RightAttrName -> XMLNode -> Element ()+mkFnNode xId fn res lArg rArg cId = let cont = [[attr "name" fn] `attrsOf` xmlElem "kind",+ column res True,+ [attr "position" "1"] `attrsOf` column lArg False, + [attr "position" "2"] `attrsOf` column rArg False] `childsOf` contentNode+ in [cont, mkEdge cId] `childsOf` node xId "fun"++-- Create an XML eq-join node. +mkEqJoinNode :: XMLNode -> (LeftAttrName,RightAttrName) -> XMLNode -> XMLNode -> Element ()+mkEqJoinNode xId (lN, rN) cxId1 cxId2 = let contNode = [[attr "position" "1"] `attrsOf` column lN False,+ [attr "position" "2"] `attrsOf` column rN False] `childsOf` contentNode+ in [contNode, mkEdge cxId1, mkEdge cxId2]`childsOf` node xId "eqjoin"+ +-- Create an XML projection node+mkProjNode :: XMLNode -> [(NewAttrName, OldAttrName)] -> XMLNode -> Element ()+mkProjNode xId mapping cxId = [map mkProjColumn mapping `childsOf` contentNode, mkEdge cxId] `childsOf` node xId "project"+ where+ mkProjColumn :: (NewAttrName, OldAttrName) -> Element ()+ mkProjColumn (n, o) = [attr "old_name" o] `attrsOf` column n True++-- Create an xml attach column node +mkAttachNode :: XMLNode -> ColName -> AVal -> ATy -> XMLNode -> Element ()+mkAttachNode xId n val ty cxId = let valNode = val `dataChildOf` [attr "type" $ show ty] `attrsOf` xmlElem "value" + colNode = [xmlEscape stdXmlEscaper valNode] `childsOf` column n True+ in [[colNode] `childsOf` contentNode, mkEdge cxId]`childsOf` node xId "attach"++-- Create an xml table node with one value in it+mkTableNode :: XMLNode -> ColName -> AVal -> ATy -> Element ()+mkTableNode xId n val ty = let valNode = val `dataChildOf` [attr "type" $ show ty] `attrsOf` xmlElem "value"+ colNode = [xmlEscape stdXmlEscaper valNode] `childsOf` column n True+ conNode = [colNode] `childsOf` contentNode+ in [conNode] `childsOf` node xId "table"++-- Create an xml edge to point to the given xml node id.+mkEdge :: XMLNode -> Element ()+mkEdge n = [attr "to" $ show n] `attrsOf` xmlElem "edge"++-- Transform the given plan nodes into an xml query plan.+-- The first argument can contain additional property node information+mkQueryPlan :: Maybe (Int, Int) -> Element () -> [Element ()] -> XML Int+mkQueryPlan parent props els = let logicalPlan = els `childsOf` [attr "unique_names" "true"] `attrsOf` xmlElem "logical_query_plan"+ in do+ planId <- freshId+ let attrs = case parent of+ Nothing -> [attr "id" $ show planId]+ Just (p, c) -> [attr "id" $ show planId, attr "idref" $ show p, attr "colref" $ show c]+ tell [[props, logicalPlan] `childsOf` attrs `attrsOf` xmlElem "query_plan"]+ return planId+ +-- Create a plan bundle out of the given query plans+mkPlanBundle :: [Element ()] -> Element ()+mkPlanBundle plans = plans `childsOf` xmlElem "query_plan_bundle"++-- Create an xml document out of the given root tag.+mkXMLDocument :: Element () -> Document ()+mkXMLDocument el = let xmlDecl = XMLDecl "1.0" (Just $ EncodingDecl "UTF-8") Nothing+ prol = Prolog (Just xmlDecl) [] Nothing []+ in Document prol emptyST el []++-- Create an xml property node so that ferryDB knows more or less how to print the result+mkProperty :: Bool -> Element ()+mkProperty isList = [attr "name" "overallResultType", attr "value" result] `attrsOf` xmlElem "property"+ where+ result = case isList of+ True -> "LIST"+ False -> "TUPLE"
+ src/Database/Ferry/Algebra/Render/XMLUtils.hs view
@@ -0,0 +1,109 @@+module Database.Ferry.Algebra.Render.XMLUtils where+ +import Text.XML.HaXml.Types++import Database.Ferry.Algebra.Data.Algebra++import qualified Data.Map as M++import Control.Monad.State+import Control.Monad.Writer+import Control.Monad.Reader++-- Convenient alias for column names+type ColName = String++-- The Graph is represented as a tuple of an int, that represents the first node, and+-- a list of algebraic nodes with their node numbers.+type Graph = (AlgNode, [(Algebra, AlgNode)])++-- Alias for GraphNode ids+type GraphNode = Int+-- Alias for xmlNode ids+type XMLNode = Int++-- Mapping from graphnodes to xmlnode ids. This dictionary is used to prevent duplicate xml nodes+type Dictionary = M.Map GraphNode XMLNode++-- XML monad, all elements are printed in bottom up!!! order into the writer monad so+-- that the xml can easily be printed an will be accepted by pfopt.+-- The reader monad contains the map with all the nodes from the algebraic plan, the keys+-- are the node ids from the graph. The state monad keeps track of the supply of fresh ids+-- for xml nodes and the dictionary for looking up whether a certain graphnode already has+-- an xml representation.+type XML = WriterT [Element ()] (ReaderT (M.Map AlgNode Algebra) (State (Int, Dictionary)))++-- Has a graphnode already been translated into an xml node. If yes which node?+isDefined :: GraphNode -> XML (Maybe XMLNode)+isDefined g = do+ (_, d) <- get+ return $ M.lookup g d ++-- Get a fresh xml node id.+freshId :: XML Int+freshId = do+ (n, d) <- get+ put (n + 1, d)+ return n++-- Add a mapping from a graphnode to an xml node id to the dictionary +addNodeTrans :: GraphNode -> XMLNode -> XML ()+addNodeTrans gId xId = do+ (n, d) <- get+ put (n, M.insert gId xId d)++-- Get a node from the algebraic plan with a certain graphNode id number+getNode :: Int -> XML Algebra+getNode i = do+ nodes <- ask+ return $ nodes M.! i+++-- Run the monad and return a list of xml elements from the monad.+runXML :: M.Map AlgNode Algebra -> XML a -> [Element ()]+runXML m = snd . fst . flip runState (0, M.empty) . flip runReaderT m . runWriterT++-- * Helper functions for constructing xml nodes++infixr 0 `childsOf`+infixr 0 `dataChildOf`+infixr 0 `attrsOf`++-- | Childs of takes a list of xml elements, and nests them in the xml element given as a second argument+childsOf :: [Element ()] -> Element () -> Element () +childsOf cs (Elem n attrs cs') = Elem n attrs $ cs' ++ [CElem c () | c <- cs]++-- | Data child of takes some data that can be printed and adds that as child to the xml element given as second argument+dataChildOf :: Show a => a -> Element () -> Element ()+dataChildOf v (Elem n attrs cs) = Elem n attrs $ (CString False (show v) ()) : cs++-- | Construct a column with name n, and new status v+column :: String -> Bool -> Element ()+column n v = let new = case v of+ True -> "true"+ False -> "false"+ in [attr "name" n, attr "new" new] `attrsOf` xmlElem "column"++-- | XML element representing a type +typeN :: ATy -> Element ()+typeN t = [attr "name" $ show t] `attrsOf` xmlElem "type"++-- | Construct an xml tag with name n+xmlElem :: String -> Element ()+xmlElem n = Elem n [] []++-- | Construct an algebraic node with id xId and of kind t+node :: XMLNode -> String -> Element ()+node xId t = [attr "id" $ show xId, attr "kind" t] `attrsOf` xmlElem "node"++-- | Construct a content node+contentNode :: Element ()+contentNode = xmlElem "content"++-- | Construct an attribute for an xml node, attrname = n and its value is v+attr :: String -> String -> Attribute+attr n v = (n, AttValue [Left v])++-- | Attach list of attributes to an xml element+attrsOf :: [Attribute] -> Element () -> Element ()+attrsOf at (Elem n attrs cs) = Elem n (at ++ attrs) cs
+ src/Database/Ferry/Impossible.hs view
@@ -0,0 +1,10 @@+module Database.Ferry.Impossible (impossible) where++import qualified Language.Haskell.TH as TH++impossible :: TH.ExpQ+impossible = do+ loc <- TH.location+ let pos = (TH.loc_filename loc, fst (TH.loc_start loc), snd (TH.loc_start loc))+ let message = "ferry: Impossbile happend at " ++ show pos+ return (TH.AppE (TH.VarE (TH.mkName "error")) (TH.LitE (TH.StringL message)))