Implement new features to merge script

scripts/merge.hs

 #!/usr/bin/env -S runhaskell --ghc-arg="-Wall" --ghc-arg="-i lib"
-{-# LANGUAGE DeriveGeneric, ExplicitNamespaces, OverloadedStrings #-}
+{-# LANGUAGE DeriveGeneric, ExplicitNamespaces, OverloadedStrings, ScopedTypeVariables #-}
 
 import Control.Monad.Except (ExceptT(..), runExceptT)
-import Data.Map ((!?))
+import Data.Foldable (toList)
+import Data.Map (Map, (!?))
 import Data.Maybe (catMaybes)
-import Data.Vector (Vector, toList)
-import GEODE.Metadata (Contrastive, Entry, Has(..), PrimaryKey, type(@)(..), indexBy, readNamedTsv, tsvFile)
+import Data.Text (Text, pack)
+import GEODE.Metadata (Contrastive(..), Entry, Has(..), MultiText(..), PrimaryKey, type(@)(..), indexBy, readNamedTsv, tsvFile)
 import System.Environment (getArgs)
 import System.Exit (die)
 import System.Script (syntax)
 
-merge :: Vector (PrimaryKey @ Entry) -> Vector (PrimaryKey @ Contrastive) -> [PrimaryKey @ Entry @ Contrastive]
-merge left right = catMaybes (mergeRow <$> toList right)
+leftJoin :: forall a b c t. (Foldable t, Functor t, Has PrimaryKey a, Has PrimaryKey b) =>
+  (a -> Maybe b -> c) -> t a -> t b -> t c
+leftJoin f left right = outputRow <$> left
   where
-    indexed = get <$> indexBy get left
-    mergeRow (pK :@: contrastive) =
-      (\entry -> (pK :@: entry :@: contrastive)) <$> (indexed !? pK)
+    indexed :: Map PrimaryKey b
+    indexed = indexBy get right
+    outputRow leftLine =
+      f leftLine (indexed !? get leftLine)
+
+rightJoin :: (Foldable t, Functor t, Has PrimaryKey a, Has PrimaryKey b) =>
+  (Maybe a -> b -> c) -> t a -> t b -> t c
+rightJoin f left right = leftJoin (flip f) right left
+
+join :: forall a b c t. (Foldable t, Functor t, Has PrimaryKey a, Has PrimaryKey b) =>
+  (a -> b -> c) -> t a -> t b -> [c]
+join f left right = catMaybes . toList $ outputRow <$> left
+  where
+    indexed :: Map PrimaryKey b
+    indexed = indexBy get right
+    outputRow leftLine =
+      f leftLine <$> (indexed !? get leftLine)
+
+merge :: (PrimaryKey @ Entry) -> (PrimaryKey @ Contrastive) -> (PrimaryKey @ Entry @ Contrastive)
+merge (pK :@: e) (_ :@: c) = pK :@: e :@: c
+
+tag :: Text -> Maybe PrimaryKey -> (PrimaryKey @ Entry @ Contrastive) -> (PrimaryKey @ Entry @ Contrastive)
+tag _ Nothing l = l
+tag name (Just _) (pK :@: e :@: contr) =
+  pK :@: e :@: contr { subCorpus = MultiText (name : subCorpora) }
+  where
+    MultiText subCorpora = subCorpus contr
 
 main :: IO ()
 main = getArgs >>= run
   where
     run [left, right, output] =
-      runExceptT (merge
+      runExceptT ((join merge)
+                    <$> ExceptT (readNamedTsv left)
+                    <*> ExceptT (readNamedTsv right) )
+      >>= either die (tsvFile output)
+    run [name, left, right, output] =
+      runExceptT ((rightJoin (tag $ pack name))
                     <$> ExceptT (readNamedTsv left)
                     <*> ExceptT (readNamedTsv right) )
       >>= either die (tsvFile output)