From 69257ba5a0ff4eab26b20dffa1a22361a9bcb80c Mon Sep 17 00:00:00 2001
From: Alice BRENON <alice.brenon@ens-lyon.fr>
Date: Fri, 9 Jun 2023 19:14:46 +0200
Subject: [PATCH] Trimming the types apparatus that allows glueing TSV columns
---
lib/GEODE/Metadata.hs | 3 +--
lib/GEODE/Metadata/TSV/Header.hs | 30 +++++++++---------------------
2 files changed, 10 insertions(+), 23 deletions(-)
diff --git a/lib/GEODE/Metadata.hs b/lib/GEODE/Metadata.hs
index 529a50e..964e1aa 100644
--- a/lib/GEODE/Metadata.hs
+++ b/lib/GEODE/Metadata.hs
@@ -23,8 +23,7 @@ import GEODE.Metadata.Projector as Projector
import GEODE.Metadata.SplitContext as SplitContext hiding (page, rank)
import GEODE.Metadata.TSV as TSV
import GEODE.Metadata.TSV.Header as TSV_Header
- ( Concat(..), DefaultFields(..), Glue(..), HasDefaultHeader(..)
- , WithDefaultHeader(..) )
+ ( DefaultFields(..), HasDefaultHeader(..), WithDefaultHeader(..), glue )
import GEODE.Metadata.Types as Types
list :: [Text] -> String
diff --git a/lib/GEODE/Metadata/TSV/Header.hs b/lib/GEODE/Metadata/TSV/Header.hs
index bfb43c7..0defa5e 100644
--- a/lib/GEODE/Metadata/TSV/Header.hs
+++ b/lib/GEODE/Metadata/TSV/Header.hs
@@ -1,12 +1,11 @@
{-# LANGUAGE FlexibleInstances, ScopedTypeVariables, UndecidableInstances #-}
module GEODE.Metadata.TSV.Header
( DefaultFields(..)
- , Glue(..)
, HasDefaultHeader(..)
- , Concat(..)
, WithDefaultHeader(..)
, for
- , getHeader ) where
+ , getHeader
+ , glue ) where
import Data.ByteString.Char8 as StrictByteString (pack)
import Data.Csv (FromNamedRecord(..), Header, ToNamedRecord(..), ToRecord(..))
@@ -18,15 +17,7 @@ newtype DefaultFields a = DefaultFields [String]
class HasDefaultHeader a where
defaultFields :: DefaultFields a
-instance (HasDefaultHeader a, HasDefaultHeader b) =>
- HasDefaultHeader (Glue a b) where
- defaultFields = DefaultFields (a ++ b)
- where
- DefaultFields a = (defaultFields :: DefaultFields a)
- DefaultFields b = (defaultFields :: DefaultFields b)
-
-instance (HasDefaultHeader a, HasDefaultHeader b) =>
- HasDefaultHeader (Concat (a, b)) where
+instance (HasDefaultHeader a, HasDefaultHeader b) => HasDefaultHeader (a, b) where
defaultFields = DefaultFields (a ++ b)
where
DefaultFields a = (defaultFields :: DefaultFields a)
@@ -40,17 +31,14 @@ getHeader _ = StrictByteString.pack <$> fromList fields
for :: HasDefaultHeader a => a
for = undefined
-data Glue a b = Glue a b
-newtype Concat a = Concat a
-
-instance (ToNamedRecord a, ToNamedRecord b) => ToNamedRecord (Glue a b) where
- toNamedRecord (Glue a b) = union (toNamedRecord a) (toNamedRecord b)
+glue :: a -> b -> WithDefaultHeader (a, b)
+glue a b = WithDefaultHeader (a, b)
-instance (ToNamedRecord a, ToNamedRecord b) => ToNamedRecord (Concat (a, b)) where
- toNamedRecord (Concat (a, b)) = union (toNamedRecord a) (toNamedRecord b)
+instance (ToNamedRecord a, ToNamedRecord b) => ToNamedRecord (a, b) where
+ toNamedRecord (a, b) = union (toNamedRecord a) (toNamedRecord b)
-instance (FromNamedRecord a, FromNamedRecord b) => FromNamedRecord (Glue a b) where
- parseNamedRecord nr = Glue <$> parseNamedRecord nr <*> parseNamedRecord nr
+instance (FromNamedRecord a, FromNamedRecord b) => FromNamedRecord (a, b) where
+ parseNamedRecord nr = (,) <$> parseNamedRecord nr <*> parseNamedRecord nr
instance (HasDefaultHeader a, ToNamedRecord a) => ToRecord (WithDefaultHeader a) where
toRecord (WithDefaultHeader a) = (toNamedRecord a !) <$> getHeader a
--
GitLab