support joins

2 files changed, 161 insertions, 22 deletions

diff --git a/README.md b/README.md
new file mode 100644
index 0000000..c9eba83
--- /dev/null
+++ b/README.md
@@ -0,0 +1,33 @@
+```console
+❯ tree data/
+data/
+├── c
+│   ├── 1.json
+│   └── 2.json
+└── j
+    ├── 1.json
+    └── 2.json
+```
+
+```console
+> SELECT . FROM c
+{"id":2,"j_id":3}
+{"foo":"bar","id":1,"j_id":1}
+
+> SELECT id FROM c
+{"c.id":2}
+{"c.id":1}
+
+> SELECT c.id, j.id, is_j FROM c LEFT JOIN j ON j.id == c.j_id
+{"c.id":2,"is_j":null,"j.id":null}
+{"c.id":1,"is_j":true,"j.id":1}
+
+> SELECT c.id, j.id FROM c RIGHT JOIN j ON j.id == c.j_id
+{"c.id":null,"j.id":2}
+{"c.id":1,"j.id":1}
+
+> SELECT c.id, j.id FROM c FULL JOIN j ON j.id == c.j_id
+{"c.id":2,"j.id":null}
+{"c.id":1,"j.id":1}
+{"c.id":null,"j.id":2}
+```
diff --git a/app/Main.hs b/app/Main.hs
index d650a33..c0e6d11 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
 
 module Main where
 
@@ -23,15 +24,16 @@ import Text.Printf (printf)
 debug :: Show a => String -> a -> a
 debug s x = trace (printf "%s: %s" s (show x)) x
 
+main :: IO ()
 main = do
   setCurrentDirectory "./data"
-  -- query "SELECT . FROM c"
+  putStrLn "> SELECT . FROM c"
   query' $ Select [Unqualified "."] "c" [] []
-  putStrLn ""
-  -- query "SELECT id FROM c"
-  query' $ Select [Qualified "c" "id"] "c" [] []
-  putStrLn ""
-  -- query "SELECT c.id, j.id, is_j FROM c JOIN j WHERE j.id == c.j_id"
+
+  putStrLn "\n> SELECT id FROM c"
+  query' $ Select [Unqualified "id"] "c" [] []
+
+  putStrLn "\n> SELECT c.id, j.id, is_j FROM c LEFT JOIN j ON j.id == c.j_id"
   query' $
     Select
       [ Qualified "c" "id",
@@ -39,12 +41,43 @@ main = do
         Unqualified "is_j"
       ]
       "c"
-      ["j"]
-      [ Eq (Qualified "j" "id") (Qualified "c" "j_id")
+      [ LeftJoin
+          "j"
+          [ Eq (Qualified "j" "id") (Qualified "c" "j_id")
+          ]
+      ]
+      []
+
+  putStrLn "\n> SELECT c.id, j.id FROM c RIGHT JOIN j ON j.id == c.j_id"
+  query' $
+    Select
+      [ Qualified "c" "id",
+        Qualified "j" "id"
+      ]
+      "c"
+      [ RightJoin
+          "j"
+          [ Eq (Qualified "j" "id") (Qualified "c" "j_id")
+          ]
       ]
+      []
+
+  putStrLn "\n> SELECT c.id, j.id FROM c FULL JOIN j ON j.id == c.j_id"
+  query' $
+    Select
+      [ Qualified "c" "id",
+        Qualified "j" "id"
+      ]
+      "c"
+      [ FullJoin
+          "j"
+          [ Eq (Qualified "j" "id") (Qualified "c" "j_id")
+          ]
+      ]
+      []
 
 data Query
-  = Select [Field] Collection Join Where
+  = Select [Field] Collection [Join FilePath] Where
   deriving (Show)
 
 data Field
@@ -54,7 +87,11 @@ data Field
 
 type Collection = FilePath
 
-type Join = [FilePath]
+data Join a
+  = LeftJoin a Where
+  | RightJoin a Where
+  | FullJoin a Where
+  deriving (Show)
 
 type Where = [Cmp]
 
@@ -74,13 +111,60 @@ instance IsString Query where
 query :: Query -> IO [J.Value]
 query (Select fs c js ws) = do
   c' <- mapM (fmap (Record c) . decodeFile . (c </>)) =<< ls c
-  js' <- mapM (\j -> mapM (fmap (Record j) . decodeFile . (j </>)) =<< ls j) js
+  js' <-
+    mapM
+      ( \j ->
+          case j of
+            LeftJoin c ws ->
+              fmap (\j' -> LeftJoin (map (Record c) j') ws) . mapM (decodeFile . (c </>)) =<< ls c
+            RightJoin c ws ->
+              fmap (\j' -> RightJoin (map (Record c) j') ws) . mapM (decodeFile . (c </>)) =<< ls c
+            FullJoin c ws ->
+              fmap (\j' -> FullJoin (map (Record c) j') ws) . mapM (decodeFile . (c </>)) =<< ls c
+      )
+      js
   pure $ map (select fs) $ where_ ws $ combine c' js'
 
-combine c = combine' (map (: []) c)
+combine :: [Record J.Value] -> [Join [Record J.Value]] -> [[Record J.Value]]
+combine vs js = combine' (map (: []) vs) js
   where
-    combine' cs [] = cs
-    combine' cs (js : jss) = combine' [c ++ [j] | c <- cs, j <- js] jss
+    combine' vss [] = vss
+    combine' vss (LeftJoin js ws : jss) =
+      combine'
+        ( concatMap
+            ( \vs -> case filter (satisfies ws) $ map (\j -> vs ++ [j]) js of
+                [] -> [vs]
+                vs' -> vs'
+            )
+            vss
+        )
+        jss
+    combine' vss (RightJoin js ws : jss) =
+      combine'
+        ( concatMap
+            ( \j -> case filter (satisfies ws) $ map (\vs -> vs ++ [j]) vss of
+                [] -> [[j]]
+                vs' -> vs'
+            )
+            js
+        )
+        jss
+    combine' vss (FullJoin js ws : jss) =
+      combine'
+        ( concatMap
+            ( \vs -> case filter (satisfies ws) $ map (\j -> vs ++ [j]) js of
+                [] -> [vs]
+                vs' -> vs'
+            )
+            vss
+            ++ concatMap
+              ( \j -> case filter (satisfies ws) $ map (\vs -> vs ++ [j]) vss of
+                  [] -> [[j]]
+                  _ -> []
+              )
+              js
+        )
+        jss
 
 ls :: FilePath -> IO [FilePath]
 ls =
@@ -96,7 +180,18 @@ decodeFile =
   fmap (fromMaybe (throw DecodeException)) . J.decodeFileStrict
 
 select :: [Field] -> [Record J.Value] -> J.Value
-select fs vs = join' $ map (select' fs) vs
+select fs vs =
+  mergeUnsafe (join' (map ((\(Record _ v) -> v) . select' fs) vs)) v0
+  where
+    v0 =
+      joinUnsafe $
+        mapMaybe
+          ( \f -> case f of
+              Qualified c k -> Just $ J.Object $ JM.singleton (JK.fromText (T.pack c <> "." <> k)) J.Null
+              Unqualified "." -> Nothing
+              Unqualified k -> Just $ J.Object $ JM.singleton (JK.fromText k) J.Null
+          )
+          fs
 
 select' :: [Field] -> Record J.Value -> Record J.Value
 select' [Unqualified "."] v = v
@@ -114,13 +209,20 @@ matches :: Record T.Text -> Field -> Bool
 matches (Record c k) (Qualified c' k') = c == c' && k == k'
 matches (Record _ k) (Unqualified k') = k == k'
 
-join' :: [Record J.Value] -> J.Value
-join' vs = foldl' merge (J.Object JM.empty) (map (\(Record _ v) -> v) vs)
+join' :: [J.Value] -> J.Value
+join' = foldl' merge (J.Object JM.empty)
+
+joinUnsafe :: [J.Value] -> J.Value
+joinUnsafe = foldl' mergeUnsafe (J.Object JM.empty)
 
 where_ :: Where -> [[Record J.Value]] -> [[Record J.Value]]
-where_ ws vss = filter (\vs -> all (\w -> satisfy w vs) ws) vss
-  where
-    satisfy (Eq f f') vs = unique f vs == unique f' vs
+where_ ws vss = filter (satisfies ws) vss
+
+satisfies :: [Cmp] -> [Record J.Value] -> Bool
+satisfies ws vs = all (\w -> satisfy w vs) ws
+
+satisfy :: Cmp -> [Record J.Value] -> Bool
+satisfy (Eq f f') vs = unique f vs == unique f' vs
 
 data DuplicateField' = DuplicateField'
   deriving (Show)
@@ -144,10 +246,14 @@ data DuplicateField = DuplicateField
 
 instance Exception DuplicateField
 
+mergeUnsafe :: J.Value -> J.Value -> J.Value
+mergeUnsafe (J.Object kvs) (J.Object kvs') =
+  J.Object (JM.union kvs kvs')
+
 merge :: J.Value -> J.Value -> J.Value
-merge (J.Object kvs) (J.Object kvs') =
+merge v@(J.Object kvs) v'@(J.Object kvs') =
   case disjoint kvs kvs' of
-    True -> J.Object (JM.union kvs kvs')
+    True -> mergeUnsafe v v'
     False -> throw DuplicateField
 
 disjoint :: JM.KeyMap v -> JM.KeyMap v -> Bool