added support for outer join

Database/TxtSushi/Relational.hs

@@ -31,21 +31,23 @@ joinTables joinOrdFunc1 table1 joinOrdFunc2 table2 =
         sortedTable1 = sortBy (compare `on` joinOrdFunc1) table1
         sortedTable2 = sortBy (compare `on` joinOrdFunc2) table2
     in
-        joinPresortedTables joinOrdFunc1 sortedTable1 joinOrdFunc2 sortedTable2
+        joinPresortedTables joinOrdFunc1 sortedTable1 Nothing joinOrdFunc2 sortedTable2 Nothing
 
 -- | join together two tables that are presorted on the given column index pairs
 joinPresortedTables :: (Ord o) =>
     (a -> o)
     -> [a]
+    -> Maybe a
     -> (b -> o)
     -> [b]
+    -> Maybe b
     -> [(a, b)]
-joinPresortedTables joinOrdFunc1 sortedTable1 joinOrdFunc2 sortedTable2 =
+joinPresortedTables joinOrdFunc1 sortedTable1 maybeNull1 joinOrdFunc2 sortedTable2 maybeNull2 =
     let
         tableGroups1 = groupBy rowEq1 sortedTable1
         tableGroups2 = groupBy rowEq2 sortedTable2
     in
-        joinGroupedTables joinOrdFunc1 tableGroups1 joinOrdFunc2 tableGroups2
+        joinGroupedTables joinOrdFunc1 tableGroups1 maybeNull1 joinOrdFunc2 tableGroups2 maybeNull2
     where
         rowEq1 x y = (compare `on` joinOrdFunc1) x y == EQ
         rowEq2 x y = (compare `on` joinOrdFunc2) x y == EQ
@@ -59,28 +61,54 @@ crossJoinTables (table1Head:table1Tail) table2 =
 joinGroupedTables :: (Ord o) =>
     (a -> o)
     -> [[a]]
+    -> Maybe a
     -> (b -> o)
     -> [[b]]
+    -> Maybe b
     -> [(a, b)]
-joinGroupedTables _ [] _ _  = []
-joinGroupedTables _ _  _ [] = []
+joinGroupedTables _ [] Nothing      _ _  _       = []
+joinGroupedTables _ _  _            _ [] Nothing = []
+
+joinGroupedTables _ [] (Just null1) _ tableGroups2 _ = zip (repeat null1) (concat tableGroups2)
+joinGroupedTables _ tableGroups1 _ _ [] (Just null2) = zip (concat tableGroups1) (repeat null2)
+
 joinGroupedTables
     joinOrdFunc1
     tableGroups1@(headTableGroup1:tableGroupsTail1)
+    maybeNull1
+
     joinOrdFunc2
-    tableGroups2@(headTableGroup2:tableGroupsTail2) =
+    tableGroups2@(headTableGroup2:tableGroupsTail2)
+    maybeNull2 =
     let
         headRow1 = head headTableGroup1
         headRow2 = head headTableGroup2
     in
         case joinOrdFunc1 headRow1 `compare` joinOrdFunc2 headRow2 of
             -- drop the 1st group if its smaller
-            LT -> joinGroupedTables joinOrdFunc1 tableGroupsTail1 joinOrdFunc2 tableGroups2
+            LT ->
+                let joinRemainder =
+                        joinGroupedTables
+                            joinOrdFunc1 tableGroupsTail1 maybeNull1
+                            joinOrdFunc2 tableGroups2 maybeNull2 in
+                case maybeNull2 of
+                    Nothing    -> joinRemainder
+                    Just null2 -> zip headTableGroup1 (repeat null2) ++ joinRemainder
 
             -- drop the 2nd group if its smaller
-            GT -> joinGroupedTables joinOrdFunc1 tableGroups1 joinOrdFunc2 tableGroupsTail2
+            GT ->
+                let joinRemainder =
+                        joinGroupedTables
+                            joinOrdFunc1 tableGroups1 maybeNull1
+                            joinOrdFunc2 tableGroupsTail2 maybeNull2 in
+                case maybeNull1 of
+                    Nothing    -> joinRemainder
+                    Just null1 -> zip (repeat null1) headTableGroup2 ++ joinRemainder
 
             -- the two groups are equal so permute
             _  ->
-                (crossJoinTables headTableGroup1 headTableGroup2) ++
-                (joinGroupedTables joinOrdFunc1 tableGroupsTail1 joinOrdFunc2 tableGroupsTail2)
+                let joinRemainder =
+                        joinGroupedTables
+                            joinOrdFunc1 tableGroupsTail1 maybeNull1
+                            joinOrdFunc2 tableGroupsTail2 maybeNull2 in
+                crossJoinTables headTableGroup1 headTableGroup2 ++ joinRemainder

Database/TxtSushi/SQLExecution.hs

@@ -48,7 +48,8 @@ textTableToDatabaseTable tblName (headerNames:tblRows) =
         qualifiedColumnsWithContext = M.empty,
         evaluationContext = evalCtxt,
         tableData = tblRows,
-        isInScope = idInHeader}
+        isInScope = idInHeader,
+        nullRow = replicate (length headerNames) ""}
     where
         makeColExpr colName = ColumnExpression (ColumnIdentifier Nothing colName) colName
 
@@ -84,7 +85,8 @@ emptyTable =
         qualifiedColumnsWithContext = M.empty,
         evaluationContext = eval,
         tableData = [shouldNeverOccurError] :: [String],
-        isInScope = const False}
+        isInScope = const False,
+        nullRow = []}
     where
         eval (ColumnExpression _ colStr)    = columnNotInScopeError colStr
         eval expr                           = evalWithContext eval expr
@@ -155,13 +157,21 @@ evalTableExpression sortCfg tblExpr tableMap =
             let table = M.findWithDefault (tableNotInScopeError tblName) tblName tableMap
             in  maybeRename maybeTblAlias table
 
-        -- TODO inner join should allow joining on expressions too!!
         InnerJoin leftJoinTblExpr rightJoinTblExpr onConditionExpr maybeTblAlias ->
             let
                 leftJoinTbl = evalTableExpression sortCfg leftJoinTblExpr tableMap
                 rightJoinTbl = evalTableExpression sortCfg rightJoinTblExpr tableMap
                 joinExprs = extractJoinExprs leftJoinTbl rightJoinTbl onConditionExpr
-                joinedTbl = innerJoinDbTables sortCfg joinExprs leftJoinTbl rightJoinTbl
+                joinedTbl = sortAndJoinDbTables False sortCfg joinExprs leftJoinTbl rightJoinTbl
+            in
+                maybeRename maybeTblAlias joinedTbl
+
+        OuterJoin leftJoinTblExpr rightJoinTblExpr onConditionExpr maybeTblAlias ->
+            let
+                leftJoinTbl = evalTableExpression sortCfg leftJoinTblExpr tableMap
+                rightJoinTbl = evalTableExpression sortCfg rightJoinTblExpr tableMap
+                joinExprs = extractJoinExprs leftJoinTbl rightJoinTbl onConditionExpr
+                joinedTbl = sortAndJoinDbTables True sortCfg joinExprs leftJoinTbl rightJoinTbl
             in
                 maybeRename maybeTblAlias joinedTbl
 
@@ -328,7 +338,10 @@ data DatabaseTable a = DatabaseTable {
     tableData :: [a],
 
     -- | is the given identifier in scope for this table
-    isInScope :: ColumnIdentifier -> Bool}
+    isInScope :: ColumnIdentifier -> Bool,
+
+    -- | we can only do an outer join if the concept of a NULL row exists
+    nullRow :: a}
 
 allIdentifiers :: Expression -> [ColumnIdentifier]
 allIdentifiers (FunctionExpression _ args _) = concatMap allIdentifiers args
@@ -431,7 +444,8 @@ groupDbTable sortCfg grpExprs (BoxedTable tbl) =
         columnsWithContext = mapSnd toGroupContext (columnsWithContext tbl),
         qualifiedColumnsWithContext = M.map (mapSnd toGroupContext) (qualifiedColumnsWithContext tbl),
         evaluationContext = toGroupContext $ evaluationContext tbl,
-        tableData = groupedData}
+        tableData = groupedData,
+        nullRow = [nullRow tbl]}
     where
         eval = evaluationContext tbl
         rowOrd row = [eval expr row | expr <- grpExprs]
@@ -446,7 +460,8 @@ singleGroupDbTable (BoxedTable tbl) =
         columnsWithContext = mapSnd toGroupContext (columnsWithContext tbl),
         qualifiedColumnsWithContext = M.map (mapSnd toGroupContext) (qualifiedColumnsWithContext tbl),
         evaluationContext = toGroupContext $ evaluationContext tbl,
-        tableData = [tableData tbl]}
+        tableData = [tableData tbl],
+        nullRow = [nullRow tbl]}
 
 compareWithDirection :: (Ord a) => [Bool] -> [a] -> [a] -> Ordering
 compareWithDirection (asc:ascTail) (x:xt) (y:yt) = case x `compare` y of
@@ -456,13 +471,14 @@ compareWithDirection (asc:ascTail) (x:xt) (y:yt) = case x `compare` y of
 compareWithDirection [] [] [] = EQ
 compareWithDirection _ _ _ = error "Internal Error: List sizes should match"
 
-innerJoinDbTables ::
-    SortConfiguration
+sortAndJoinDbTables ::
+    Bool
+    -> SortConfiguration
     -> [(Expression, Expression)]
     -> BoxedTable
     -> BoxedTable
     -> BoxedTable
-innerJoinDbTables sortCfg joinExprs (BoxedTable fstTable) (BoxedTable sndTable) =
+sortAndJoinDbTables outerJoin sortCfg joinExprs (BoxedTable fstTable) (BoxedTable sndTable) =
     BoxedTable $ zipDbTables joinedData fstTable sndTable
     where
         fstEval = evaluationContext fstTable
@@ -474,7 +490,10 @@ innerJoinDbTables sortCfg joinExprs (BoxedTable fstTable) (BoxedTable sndTable)
         sortedFstData = sortByCfg sortCfg (compare `on` fstRowOrd) (tableData fstTable)
         sortedSndData = sortByCfg sortCfg (compare `on` sndRowOrd) (tableData sndTable)
 
-        joinedData = joinPresortedTables fstRowOrd sortedFstData sndRowOrd sortedSndData
+        fstNull = if outerJoin then Just (nullRow fstTable) else Nothing
+        sndNull = if outerJoin then Just (nullRow sndTable) else Nothing
+
+        joinedData = joinPresortedTables fstRowOrd sortedFstData fstNull sndRowOrd sortedSndData sndNull
 
 crossJoinDbTables ::
     BoxedTable
@@ -491,7 +510,8 @@ zipDbTables zippedData fstTable sndTable = DatabaseTable {
     qualifiedColumnsWithContext = M.unionWithKey ambiguousTableError fstQualCols sndQualCols,
     evaluationContext = evalCtxt,
     tableData = zippedData,
-    isInScope = isInFstOrSndScope}
+    isInScope = isInFstOrSndScope,
+    nullRow = (nullRow fstTable, nullRow sndTable)}
 
     where
         isInFstScope = isInScope fstTable

Database/TxtSushi/SQLExpression.hs

@@ -50,6 +50,11 @@ data TableExpression =
         rightJoinTable :: TableExpression,
         onCondition :: Expression,
         maybeTableAlias :: Maybe String} |
+    OuterJoin {
+        leftJoinTable :: TableExpression,
+        rightJoinTable :: TableExpression,
+        onCondition :: Expression,
+        maybeTableAlias :: Maybe String} |
     CrossJoin {
         leftJoinTable :: TableExpression,
         rightJoinTable :: TableExpression,
@@ -68,6 +73,8 @@ allTableNames :: TableExpression -> [String]
 allTableNames (TableIdentifier tblName _) = [tblName]
 allTableNames (InnerJoin lftTbl rtTbl _ _) =
     (allTableNames lftTbl) ++ (allTableNames rtTbl)
+allTableNames (OuterJoin lftTbl rtTbl _ _) =
+    (allTableNames lftTbl) ++ (allTableNames rtTbl)
 allTableNames (CrossJoin lftTbl rtTbl _) =
     (allTableNames lftTbl) ++ (allTableNames rtTbl)
 allTableNames (SelectExpression selectStmt _) =

Database/TxtSushi/SQLParser.hs

@@ -197,6 +197,14 @@ parseTableIdentifierOrJoin = do
     nextTblId <- parseTableIdentifier
 
     let
+        ifJoinParse = ifParseThenElse
+            -- if
+            outerJoinSep -- TODO commit to join
+            -- then
+            (parseOuterJoinRemainder nextTblId)
+            --else
+            ifCrossOrInnerJoinParse
+
         ifCrossOrInnerJoinParse = ifParseThenElse
             -- if
             crossJoinSep -- TODO commit to join
@@ -213,9 +221,10 @@ parseTableIdentifierOrJoin = do
             -- else
             (return nextTblId)
 
-    ifCrossOrInnerJoinParse
+    ifJoinParse
 
     where
+        outerJoinSep = parseToken "OUTER" >> parseToken "JOIN"
         crossJoinSep = (commaSeparator >> return "") <|> (parseToken "CROSS" >> parseToken "JOIN")
         innerJoinSep = ((maybeParse $ parseToken "INNER") >> parseToken "JOIN")
 
@@ -234,6 +243,21 @@ parseInnerJoinRemainder leftTblExpr = do
             onCondition=onPart,
             maybeTableAlias=maybeAlias}
 
+parseOuterJoinRemainder :: TableExpression -> GenParser Char a TableExpression
+parseOuterJoinRemainder leftTblExpr = do
+    rightTblExpr <- parseTableExpression
+
+    _ <- parseToken "ON"
+    onPart <- parseExpression
+
+    maybeAlias <- maybeParseAlias
+
+    return OuterJoin {
+            leftJoinTable=leftTblExpr,
+            rightJoinTable=rightTblExpr,
+            onCondition=onPart,
+            maybeTableAlias=maybeAlias}
+
 parseCrossJoinRemainder :: TableExpression -> GenParser Char a TableExpression
 parseCrossJoinRemainder leftTblExpr = do
     rightTblExpr <- parseTableExpression
@@ -441,8 +465,8 @@ reservedWords =
     map functionName normalSyntaxFunctions ++
     map functionName (concat infixFunctions) ++
     map functionName specialFunctions ++
-    ["BY","CROSS", "FROM", "FOR", "GROUP", "HAVING", "IN", "INNER", "JOIN", "ON",
-     "ORDER", "SELECT", "WHERE", "TRUE", "FALSE", "YIELD"]
+    ["BY", "CROSS", "FROM", "FOR", "GROUP", "HAVING", "IN", "INNER", "JOIN", "ON",
+     "ORDER", "OUTER", "SELECT", "WHERE", "TRUE", "FALSE", "YIELD"]
 
 -- | tries parsing both the upper and lower case versions of the given string
 upperOrLower :: String -> GenParser Char st String