init

1 files changed, 125 insertions, 0 deletions

diff --git a/app/Main.hs b/app/Main.hs
new file mode 100644
index 0000000..3747dab
--- /dev/null
+++ b/app/Main.hs
@@ -0,0 +1,125 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main where
+
+import Control.Exception (Exception, throw)
+import Data.Aeson qualified as J
+import Data.Aeson.Key qualified as JK
+import Data.Aeson.KeyMap qualified as JM
+import Data.ByteString.Lazy.Char8 qualified as LB
+import Data.List (foldl')
+import Data.Maybe (fromMaybe, mapMaybe)
+import Data.Set qualified as S
+import Data.String (IsString (fromString))
+import Data.Text qualified as T
+import Debug.Trace (trace)
+import System.Directory (listDirectory)
+import System.FilePath (takeExtension, (</>))
+import Text.Megaparsec qualified as P
+import Text.Megaparsec.Char qualified as P
+import Text.Megaparsec.Char.Lexer qualified as P
+import Text.Printf (printf)
+
+debug :: Show a => String -> a -> a
+debug s x = trace (printf "%s: %s" s (show x)) x
+
+main = do
+  -- query "SELECT . FROM c"
+  query' $ Select ["."] "./data/c" [] []
+  putStrLn ""
+  -- query "SELECT id FROM c"
+  query' $ Select ["id"] "./data/c" [] []
+  putStrLn ""
+  -- query "SELECT c.id, j.id, is_j FROM c JOIN j WHERE j.id == c.j_id"
+  query' $ Select ["c.id", "j.id", "is_j"] "./data/c" ["./data/j"] [Eq "j.id" "c.j_id"]
+
+data Query
+  = Select [Field] Collection Join Where
+
+type Field = T.Text
+
+type Collection = FilePath
+
+type Join = [FilePath]
+
+type Where = [Cmp]
+
+data Cmp
+  = Eq Field Field
+
+{-
+instance IsString Query where
+  fromString =
+    either throw id (P.parse parser "" s)-}
+
+query :: Query -> IO [J.Value]
+query (Select fs c js ws) = do
+  c' <- mapM (decodeFile . (c </>)) =<< ls c
+  js' <- mapM (\j -> mapM (decodeFile . (j </>)) =<< ls j) js
+  pure $ map (select fs) $ where_ ws $ combine c' js'
+
+combine c = combine' (map (: []) c)
+  where
+    combine' cs [] = cs
+    combine' cs (js : jss) = combine' [c ++ [j] | c <- cs, j <- js] jss
+
+ls :: FilePath -> IO [FilePath]
+ls =
+  fmap (filter ((== ".json") . takeExtension)) . listDirectory
+
+data DecodeException = DecodeException
+  deriving (Show)
+
+instance Exception DecodeException
+
+decodeFile :: J.FromJSON a => FilePath -> IO a
+decodeFile =
+  fmap (fromMaybe (throw DecodeException)) . J.decodeFileStrict
+
+select :: [T.Text] -> [J.Value] -> J.Value
+select fs vs = join' $ map (select' fs) vs
+
+select' :: [T.Text] -> J.Value -> J.Value
+select' ["."] (J.Object kvs) = J.Object kvs
+select' fs (J.Object kvs) =
+  J.Object (JM.filterWithKey (\k _ -> JK.toText k `elem` fs) kvs)
+
+join' :: [J.Value] -> J.Value
+join' vs = foldl' merge (J.Object JM.empty) vs
+
+where_ :: Where -> [[J.Value]] -> [[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
+
+data DuplicateField' = DuplicateField'
+  deriving (Show)
+
+instance Exception DuplicateField'
+
+unique :: T.Text -> [J.Value] -> J.Value
+unique f as = case debug "unique" $ mapMaybe (get (debug "f" f)) (debug "as" as) of
+  [x] -> x
+  (_ : _) -> throw DuplicateField'
+
+get :: T.Text -> J.Value -> Maybe J.Value
+get f (J.Object kvs) = JM.lookup (JK.fromText f) kvs
+
+data DuplicateField = DuplicateField
+  deriving (Show)
+
+instance Exception DuplicateField
+
+merge :: J.Value -> J.Value -> J.Value
+merge (J.Object kvs) (J.Object kvs') =
+  case disjoint kvs kvs' of
+    True -> J.Object (JM.union kvs kvs')
+    False -> throw DuplicateField
+
+disjoint kvs kvs' =
+  let ks = S.fromList (JM.keys kvs)
+      ks' = S.fromList (JM.keys kvs')
+   in S.size ks + S.size ks' == S.size (ks `S.union` ks')
+
+query' :: Query -> IO ()
+query' q = mapM_ (LB.putStrLn . J.encode) =<< query q