refactor `Record`

5 files changed, 169 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)
diff --git a/json2sql.cabal b/json2sql.cabal
index 5851d0e..aab906b 100644
--- a/json2sql.cabal
+++ b/json2sql.cabal
@@ -20,6 +20,9 @@ executable json2sql
     main-is:          Main.hs
     other-modules:
       Debug
+      Exception
+      Field
+      Record
       Store
     -- other-extensions:
     build-depends:    base ^>=4.16.4.0,