From 69e07588741f4ceba9e12c1d1d236c266ad5f0ca Mon Sep 17 00:00:00 2001
From: Alice BRENON <alice.brenon@ens-lyon.fr>
Date: Fri, 26 Jan 2024 15:17:23 +0100
Subject: [PATCH] Add parsing UIDs as a requirement for Record, explain how
they propagate along @-chains and make a case-insensitive instance for Work
---
lib/GEODE/Metadata/ArticleRecord.hs | 13 +++++++++----
lib/GEODE/Metadata/Record.hs | 10 ++++++++--
lib/GEODE/Metadata/Work.hs | 15 ++++++++++-----
3 files changed, 27 insertions(+), 11 deletions(-)
diff --git a/lib/GEODE/Metadata/ArticleRecord.hs b/lib/GEODE/Metadata/ArticleRecord.hs
index 1337b74..023c45b 100644
--- a/lib/GEODE/Metadata/ArticleRecord.hs
+++ b/lib/GEODE/Metadata/ArticleRecord.hs
@@ -1,10 +1,9 @@
{-# LANGUAGE DeriveGeneric, FlexibleContexts, FlexibleInstances, NamedFieldPuns, OverloadedStrings #-}
module GEODE.Metadata.ArticleRecord
( Work(..)
- , ArticleRecord(..)
- , relativePath
- , uid ) where
+ , ArticleRecord(..) ) where
+import Control.Monad.State (MonadState(..), StateT(..), evalStateT, lift)
import Data.Aeson ((.=), FromJSON(..), ToJSON(..))
import Data.Aeson.KeyMap as KeyMap (fromList)
import Data.Csv (DefaultOrdered(..), FromNamedRecord(..), ToNamedRecord(..))
@@ -14,6 +13,7 @@ import GEODE.Metadata.Work (Work(..))
import GHC.Generics (Generic)
import System.FilePath ((</>), (<.>))
import Text.Printf (printf)
+import Text.Read (readEither)
data ArticleRecord = ArticleRecord
{ work :: Work
@@ -37,8 +37,13 @@ instance ToJSONObject ArticleRecord where
instance FromJSON ArticleRecord
instance Record ArticleRecord where
- uid (ArticleRecord {work, volume, article}) =
+ toUID (ArticleRecord {work, volume, article}) =
printf "%s_%d_%d" (show $ work) volume article
+ fromUID = evalStateT $ ArticleRecord <$> nextBlock <*> nextBlock <*> nextBlock
+ where
+ nextBlock :: Read a => StateT String (Either String) a
+ nextBlock = state (fmap (drop 1) . break (== '_')) >>= lift . readEither
+
relativePath (ArticleRecord {work, volume, article}) extension =
(show work) </> ("T" <> show volume) </> (show article) <.> extension
diff --git a/lib/GEODE/Metadata/Record.hs b/lib/GEODE/Metadata/Record.hs
index 094fc10..abf55ab 100644
--- a/lib/GEODE/Metadata/Record.hs
+++ b/lib/GEODE/Metadata/Record.hs
@@ -7,10 +7,16 @@ import System.FilePath ((</>))
import Text.Printf (printf)
class Record a where
- uid :: a -> String
+ toUID :: a -> String
+ fromUID :: String -> Either String a
relativePath :: a -> String -> FilePath
instance (Record a, Record b) => Record (a @ b) where
- uid (a :@: b) = printf "%s_%s" (uid a) (uid b)
+ toUID (a :@: b) = printf "%s_%s" (toUID a) (toUID b)
+
+ fromUID s = do
+ prefix <- fromUID s
+ (prefix :@:) <$> fromUID (drop (length (toUID prefix) + 1) s)
+
relativePath (a :@: b) extension =
relativePath a "" </> relativePath b extension
diff --git a/lib/GEODE/Metadata/Work.hs b/lib/GEODE/Metadata/Work.hs
index 68e4117..e1e7660 100644
--- a/lib/GEODE/Metadata/Work.hs
+++ b/lib/GEODE/Metadata/Work.hs
@@ -2,29 +2,34 @@
module GEODE.Metadata.Work
( Work(..) ) where
+import Control.Applicative (Alternative(..))
import Data.Aeson (FromJSON(..), ToJSON(..), withText)
import Data.ByteString.Char8 as ByteString (unpack)
import Data.Csv (FromField(..), ToField(..))
import Data.Char (toLower)
import Data.Text as Text (unpack)
import GHC.Generics (Generic)
+import Text.Read (Read(..), get)
data Work = EDdA | LGE | Wikipedia deriving (Eq, Generic, Ord, Show)
-tolerantParser :: (Applicative m, Monoid (m Work)) => String -> m Work
-tolerantParser = recognize . fmap toLower
+readCaseInsensitive :: Alternative m => String -> m Work
+readCaseInsensitive = recognize . fmap toLower
where
recognize "edda" = pure EDdA
recognize "lge" = pure LGE
recognize "wikipedia" = pure Wikipedia
- recognize _ = mempty
+ recognize _ = empty
+
+instance Read Work where
+ readPrec = many get >>= readCaseInsensitive
instance FromField Work where
- parseField = tolerantParser . ByteString.unpack
+ parseField = readCaseInsensitive . ByteString.unpack
instance ToField Work where
toField = toField . show
instance ToJSON Work
instance FromJSON Work where
- parseJSON = withText "Work" $ tolerantParser . Text.unpack
+ parseJSON = withText "Work" $ readCaseInsensitive . Text.unpack
--
GitLab