refactor `Query`

1 files changed, 137 insertions, 0 deletions

diff --git a/app/Query.hs b/app/Query.hs
new file mode 100644
index 0000000..8f0eda6
--- /dev/null
+++ b/app/Query.hs
@@ -0,0 +1,137 @@
+module Query
+  ( module Query.Type,
+    query,
+  )
+where
+
+import Control.Exception (throw)
+import Data.Aeson qualified as J
+import Data.Aeson.Key qualified as JK
+import Data.Aeson.KeyMap qualified as JM
+import Data.List (isSuffixOf)
+import Data.List.NonEmpty qualified as N
+import Data.Maybe (fromMaybe)
+import Data.Vector qualified as V
+import Exception (DecodeException (DecodeException))
+import Query.Parser ()
+import Query.Printer ()
+import Query.Record
+import Query.Type
+import Store qualified as S
+import System.FilePath ((</>))
+
+query :: Query -> IO [J.Value]
+query (Select fs c js es w) = do
+  c' <-
+    mapM (fmap (fromValue c) . decodeFile . (c </>)) =<< ls c
+  js' <-
+    mapM
+      ( \(JoinClause t c w) ->
+          fmap (\j' -> JoinClause t (map (fromValue c) j') w) . mapM (decodeFile . (c </>))
+            =<< ls c
+      )
+      js
+  es' <-
+    mapM
+      ( \(EmbedClause c w) ->
+          fmap (\e' -> EmbedClause (fromValue c e') w) . mapM (decodeFile . (c </>))
+            =<< ls c
+      )
+      es
+  pure $ map (Query.select fs) $ where_ w $ embed es' $ join c' js'
+  where
+    ls c =
+      filter (not . (isSuffixOf "/"))
+        <$> S.withStore "." "HEAD" do
+          S.listDirectory c
+
+-- TODO use fold
+embed ::
+  EmbedClauses (Record [J.Value]) ->
+  [Records J.Value] ->
+  [Records J.Value]
+embed es vss = embed' vss es
+  where
+    embed' vss [] = vss
+    embed' vss (EmbedClause (Record c es) w : ess) =
+      embed'
+        ( map
+            ( \vs ->
+                let es' :: [J.Value]
+                    es' = filter (\e -> satisfies w (vs ++ [Record c e])) es
+                 in vs
+                      ++ [ Record
+                             c
+                             ( J.Object
+                                 ( JM.singleton
+                                     (JK.fromString c)
+                                     (J.Array (V.fromList es'))
+                                 )
+                             )
+                         ]
+            )
+            vss
+        )
+        ess
+
+-- TODO use fold
+join ::
+  Records J.Value ->
+  JoinClauses (Records J.Value) ->
+  [Records J.Value]
+join vs js = join' (map (: []) vs) js
+  where
+    join' vss [] = vss
+    join' vss (JoinClause JoinLeft js w : jss) =
+      join'
+        ( concatMap
+            ( \vs -> case filter (satisfies w) $ map (\j -> vs ++ [j]) js of
+                [] -> [vs]
+                vs' -> vs'
+            )
+            vss
+        )
+        jss
+    join' vss (JoinClause JoinRight js w : jss) =
+      join'
+        ( concatMap
+            ( \j -> case filter (satisfies w) $ map (\vs -> vs ++ [j]) vss of
+                [] -> [[j]]
+                vs' -> vs'
+            )
+            js
+        )
+        jss
+    join' vss (JoinClause JoinFull js w : jss) =
+      join'
+        ( concatMap
+            ( \vs -> case filter (satisfies w) $ map (\j -> vs ++ [j]) js of
+                [] -> [vs]
+                vs' -> vs'
+            )
+            vss
+            ++ concatMap
+              ( \j -> case filter (satisfies w) $ map (\vs -> vs ++ [j]) vss of
+                  [] -> [[j]]
+                  _ -> []
+              )
+              js
+        )
+        jss
+
+select :: FieldSelector -> Records J.Value -> J.Value
+select All vs = disjointUnions (map toValue vs)
+select (Only fs) vs = Query.Record.select (N.toList fs) vs
+
+where_ :: Maybe WhereClause -> [Records J.Value] -> [Records J.Value]
+where_ w = filter (satisfies w)
+
+satisfies :: Maybe WhereClause -> Records J.Value -> Bool
+satisfies Nothing _ = True
+satisfies (Just (And ws)) vs = all (\w -> satisfies (Just w) vs) ws
+satisfies (Just (Or ws)) vs = any (\w -> satisfies (Just w) vs) ws
+satisfies (Just (Where (Eq f g))) vs = lookups f vs == lookups g vs
+
+decodeFile :: J.FromJSON a => Collection -> IO a
+decodeFile fp = S.withStore "." "HEAD" do
+  fromMaybe (throw DecodeException) . J.decode <$> S.readFile fp