diff options
Diffstat (limited to 'app')
| -rw-r--r-- | app/Exception.hs | 11 | ||||
| -rw-r--r-- | app/Field.hs | 32 | ||||
| -rw-r--r-- | app/Main.hs | 145 | ||||
| -rw-r--r-- | app/Record.hs | 78 |
4 files changed, 166 insertions, 100 deletions
diff --git a/app/Exception.hs b/app/Exception.hs new file mode 100644 index 0000000..d67a8bc --- /dev/null +++ b/app/Exception.hs @@ -0,0 +1,11 @@ +module Exception + ( DuplicateField (DuplicateField), + ) +where + +import Control.Exception (Exception) + +data DuplicateField = DuplicateField String + deriving (Show) + +instance Exception DuplicateField diff --git a/app/Field.hs b/app/Field.hs new file mode 100644 index 0000000..68baec7 --- /dev/null +++ b/app/Field.hs @@ -0,0 +1,32 @@ +module Field + ( Field (..), + toString, + prefix, + ) +where + +import Data.Aeson qualified as J +import Data.Aeson.Key qualified as JK +import Data.Aeson.KeyMap qualified as JM +import Data.List (intercalate) +import Data.List.NonEmpty qualified as N +import Data.Text qualified as T + +data Field + = Qualified Collection (N.NonEmpty T.Text) + | Unqualified (N.NonEmpty T.Text) + deriving (Show) + +toString :: Field -> String +toString (Qualified c ks) = intercalate "." (c : map T.unpack (N.toList ks)) +toString (Unqualified ks) = intercalate "." (map T.unpack (N.toList ks)) + +type Collection = FilePath + +prefix :: Field -> J.Value -> J.Value +prefix (Qualified c ks) = prefix' (T.pack c : N.toList ks) +prefix (Unqualified ks) = prefix' (N.toList ks) + +prefix' :: [T.Text] -> J.Value -> J.Value +prefix' ks v = + foldr ((J.Object .) . JM.singleton) v (map JK.fromText ks) diff --git a/app/Main.hs b/app/Main.hs index 3b630ac..c0618ae 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -13,14 +13,15 @@ import Data.Aeson.Key qualified as JK import Data.Aeson.KeyMap qualified as JM import Data.ByteString.Lazy.Char8 qualified as LB import Data.Char (isSpace) -import Data.List (foldl', intercalate, isSuffixOf) +import Data.List (intercalate, isSuffixOf) import Data.List.NonEmpty qualified as N import Data.Maybe (catMaybes, fromMaybe, mapMaybe) -import Data.Set qualified as S import Data.String (IsString (fromString)) import Data.Text qualified as T import Data.Vector qualified as V import Data.Void (Void) +import Field qualified as F +import Record qualified as R import Store qualified as S import System.Directory (setCurrentDirectory) import System.FilePath ((</>)) @@ -70,8 +71,7 @@ instance Show Query where showFieldSelector All = "*" showFieldSelector (Only (N.toList -> fs)) = intercalate ", " (map showField fs) - showField (Qualified c k) = c <> "." <> T.unpack k - showField (Unqualified k) = T.unpack k + showField = F.toString showCollection c = c showJoinClauses js = case map showJoinClause js of [] -> Nothing @@ -108,12 +108,7 @@ instance Show Query where data FieldSelector = All - | Only (N.NonEmpty Field) - deriving (Show) - -data Field - = Qualified Collection T.Text - | Unqualified T.Text + | Only (N.NonEmpty F.Field) deriving (Show) type Collection = FilePath @@ -143,13 +138,9 @@ data WhereClause deriving (Show) data Comparison - = Eq Field Field + = Eq F.Field F.Field deriving (Show) -data Record a - = Record Collection a - deriving (Show, Eq) - data ParseError = ParseError String deriving (Show) @@ -231,18 +222,22 @@ instance IsString Query where Only <$> PN.sepBy1 field comma ] - field :: P.Parsec Void String Field + field :: P.Parsec Void String F.Field field = lexeme . P.choice $ - [ P.try do - Qualified - <$> (P.takeWhile1P Nothing (\c -> not (isSpace c) && c /= ',' && c /= '.')) - <*> (P.string "." >> T.pack <$> P.takeWhile1P Nothing (\c -> not (isSpace c) && c /= ',')), - do - Unqualified - <$> (T.pack <$> P.takeWhile1P Nothing (\c -> not (isSpace c) && c /= ',')) + [ P.try + do + F.Qualified + <$> (fieldPart <* P.string ".") + <*> (N.map T.pack <$> PN.sepBy1 fieldPart (P.string ".")), + do + F.Unqualified + <$> (N.map T.pack <$> PN.sepBy1 fieldPart (P.string ".")) ] + fieldPart :: P.Parsec Void String String + fieldPart = P.takeWhile1P Nothing (\c -> not (isSpace c) && c /= ',' && c /= '.') + joinType :: P.Parsec Void String JoinType joinType = P.choice @@ -263,18 +258,18 @@ instance IsString Query where query :: Query -> IO [J.Value] query (Select fs c js es w) = do c' <- - mapM (fmap (Record c) . decodeFile . (c </>)) =<< ls c + mapM (fmap (R.fromValue c) . decodeFile . (c </>)) =<< ls c js' <- mapM ( \(JoinClause t c w) -> - fmap (\j' -> JoinClause t (map (Record c) j') w) . mapM (decodeFile . (c </>)) + fmap (\j' -> JoinClause t (map (R.fromValue c) j') w) . mapM (decodeFile . (c </>)) =<< ls c ) js es' <- mapM ( \(EmbedClause c w) -> - fmap (\e' -> EmbedClause (Record c e') w) . mapM (decodeFile . (c </>)) + fmap (\e' -> EmbedClause (R.fromValue c e') w) . mapM (decodeFile . (c </>)) =<< ls c ) es @@ -285,18 +280,22 @@ query (Select fs c js es w) = do <$> S.withStore "." "HEAD" do S.listDirectory c -embed :: EmbedClauses (Record [J.Value]) -> [[Record J.Value]] -> [[Record J.Value]] +-- TODO use fold +embed :: + EmbedClauses (R.Record [J.Value]) -> + [R.Records J.Value] -> + [R.Records J.Value] embed es vss = embed' vss es where embed' vss [] = vss - embed' vss (EmbedClause (Record c es) w : ess) = + embed' vss (EmbedClause (R.Record c es) w : ess) = embed' ( map ( \vs -> let es' :: [J.Value] - es' = filter (\e -> satisfies w (vs ++ [Record c e])) es + es' = filter (\e -> satisfies w (vs ++ [R.Record c e])) es in vs - ++ [ Record + ++ [ R.Record c ( J.Object ( JM.singleton @@ -310,7 +309,13 @@ embed es vss = embed' vss es ) ess -combine :: [Record J.Value] -> JoinClauses [Record J.Value] -> [[Record J.Value]] +-- TODO rename `join` + +-- TODO use fold +combine :: + R.Records J.Value -> + JoinClauses (R.Records J.Value) -> + [R.Records J.Value] combine vs js = combine' (map (: []) vs) js where combine' vss [] = vss @@ -360,52 +365,20 @@ decodeFile :: J.FromJSON a => Collection -> IO a decodeFile fp = S.withStore "." "HEAD" do fromMaybe (throw DecodeException) . J.decode <$> S.readFile fp -select :: FieldSelector -> [Record J.Value] -> J.Value -select All vs = - join' (map (\(Record _ v) -> v) vs) -select (Only 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 k -> Just $ J.Object $ JM.singleton (JK.fromText k) J.Null - ) - (N.toList fs) - -select' :: N.NonEmpty Field -> Record J.Value -> Record J.Value -select' (N.toList -> fs) (Record c (J.Object kvs)) = - Record c . J.Object $ - JM.fromList . mapMaybe match . JM.toList $ - kvs - where - match (k, v) = case filter (matches (Record c (JK.toText k))) fs of - (Qualified _ _ : _) -> Just (JK.fromString (c <> "." <> JK.toString k), v) - (Unqualified _ : _) -> Just (k, v) - _ -> Nothing - -matches :: Record T.Text -> Field -> Bool -matches (Record c k) (Qualified c' k') = c == c' && k == k' -matches (Record _ k) (Unqualified k') = k == k' +select :: FieldSelector -> R.Records J.Value -> J.Value +select All vs = R.disjointUnions (map R.toValue vs) +select (Only fs) vs = R.select (N.toList fs) 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_ :: Maybe WhereClause -> [[Record J.Value]] -> [[Record J.Value]] +where_ :: Maybe WhereClause -> [R.Records J.Value] -> [R.Records J.Value] where_ w = filter (satisfies w) -satisfies :: Maybe WhereClause -> [Record J.Value] -> Bool +satisfies :: Maybe WhereClause -> R.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 p)) vs = satisfy p vs -satisfy :: Comparison -> [Record J.Value] -> Bool +satisfy :: Comparison -> R.Records J.Value -> Bool satisfy (Eq f g) vs = unique f vs == unique g vs data DuplicateField' = DuplicateField' @@ -413,38 +386,10 @@ data DuplicateField' = DuplicateField' instance Exception DuplicateField' -unique :: Field -> [Record J.Value] -> J.Value -unique f as = case mapMaybe (get f) as of - [Record _ v] -> v +unique :: F.Field -> R.Records J.Value -> J.Value +unique f as = case mapMaybe (R.lookup f) as of + [v] -> v (_ : _) -> throw DuplicateField' -get :: Field -> Record J.Value -> Maybe (Record J.Value) -get (Unqualified k) (Record c (J.Object kvs)) = - Record c <$> JM.lookup (JK.fromText k) kvs -get (Qualified c' k) (Record c (J.Object kvs)) - | c' == c = Record c <$> JM.lookup (JK.fromText k) kvs - | otherwise = Nothing - -data DuplicateField = DuplicateField - deriving (Show) - -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 v@(J.Object kvs) v'@(J.Object kvs') = - case disjoint kvs kvs' of - True -> mergeUnsafe v v' - False -> throw DuplicateField - -disjoint :: JM.KeyMap v -> JM.KeyMap v -> Bool -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 diff --git a/app/Record.hs b/app/Record.hs new file mode 100644 index 0000000..d23d289 --- /dev/null +++ b/app/Record.hs @@ -0,0 +1,78 @@ +module Record + ( Record (..), + fromValue, + toValue, + lookup, + Records, + select, + disjointUnion, + disjointUnions, + ) +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 (foldl') +import Data.List.NonEmpty qualified as N +import Data.Maybe (mapMaybe) +import Data.Text qualified as T +import Exception (DuplicateField (DuplicateField)) +import Field qualified as F +import Prelude hiding (lookup) + +data Record a + = Record Collection a + deriving (Show, Eq) + +type Collection = FilePath + +fromValue :: Collection -> a -> Record a +fromValue = Record + +toValue :: Record a -> a +toValue (Record _ v) = v + +lookup :: F.Field -> Record J.Value -> Maybe J.Value +lookup (F.Unqualified ks) (Record _ v) = + lookup' (N.toList ks) v +lookup (F.Qualified c' ks) (Record c v) + | c' == c = lookup' (N.toList ks) v + | otherwise = Nothing + +lookup' :: [T.Text] -> J.Value -> Maybe J.Value +lookup' [] v = Just v +lookup' (k : ks) (J.Object kvs) = + lookup' ks =<< JM.lookup (JK.fromText k) kvs + +type Records a = [Record a] + +select :: [F.Field] -> Records J.Value -> J.Value +select fs rs = + foldl' + union + (J.Object JM.empty) + (map (\f -> F.prefix f (select' rs f)) fs) + +select' :: Records J.Value -> F.Field -> J.Value +select' rs f = case mapMaybe (lookup f) rs of + [] -> J.Null + [v] -> v + (_ : _) -> throw (DuplicateField (F.toString f)) + +union :: J.Value -> J.Value -> J.Value +union (J.Object r) (J.Object s) = J.Object (JM.unionWith union r s) + +disjointUnion :: J.Value -> J.Value -> J.Value +disjointUnion (J.Object r) (J.Object s) = + J.Object (JM.unionWithKey disjointUnion' r s) + +disjointUnion' :: JK.Key -> J.Value -> J.Value -> J.Value +disjointUnion' _ (J.Object r) (J.Object s) = + J.Object (JM.unionWithKey disjointUnion' r s) +disjointUnion' k _ _ = + throw (DuplicateField (JK.toString k)) + +disjointUnions :: [J.Value] -> J.Value +disjointUnions = foldl' disjointUnion (J.Object JM.empty) |