diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +import Distribution.Simple + +main = defaultMain + diff --git a/TableAlgebra.cabal b/TableAlgebra.cabal new file mode 100644 --- /dev/null +++ b/TableAlgebra.cabal @@ -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. + . + 2. + . + 3. + . + 4. +License: BSD3 +License-file: LICENSE +Author: Jeroen Weijers Tom Schreiber +Maintainer: Jeroen Weijers +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 diff --git a/src/Database/Ferry/Algebra.hs b/src/Database/Ferry/Algebra.hs new file mode 100644 --- /dev/null +++ b/src/Database/Ferry/Algebra.hs @@ -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 diff --git a/src/Database/Ferry/Algebra/Data/Algebra.hs b/src/Database/Ferry/Algebra/Data/Algebra.hs new file mode 100644 --- /dev/null +++ b/src/Database/Ferry/Algebra/Data/Algebra.hs @@ -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) diff --git a/src/Database/Ferry/Algebra/Data/Create.hs b/src/Database/Ferry/Algebra/Data/Create.hs new file mode 100644 --- /dev/null +++ b/src/Database/Ferry/Algebra/Data/Create.hs @@ -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)] diff --git a/src/Database/Ferry/Algebra/Data/GraphBuilder.hs b/src/Database/Ferry/Algebra/Data/GraphBuilder.hs new file mode 100644 --- /dev/null +++ b/src/Database/Ferry/Algebra/Data/GraphBuilder.hs @@ -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!" + diff --git a/src/Database/Ferry/Algebra/Render/XML.hs b/src/Database/Ferry/Algebra/Render/XML.hs new file mode 100644 --- /dev/null +++ b/src/Database/Ferry/Algebra/Render/XML.hs @@ -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" diff --git a/src/Database/Ferry/Algebra/Render/XMLUtils.hs b/src/Database/Ferry/Algebra/Render/XMLUtils.hs new file mode 100644 --- /dev/null +++ b/src/Database/Ferry/Algebra/Render/XMLUtils.hs @@ -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 diff --git a/src/Database/Ferry/Impossible.hs b/src/Database/Ferry/Impossible.hs new file mode 100644 --- /dev/null +++ b/src/Database/Ferry/Impossible.hs @@ -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)))