diff --git a/lib/GEODE/Metadata/ArticleRecord.hs b/lib/GEODE/Metadata/ArticleRecord.hs index 1337b74ece632b2a5565afa1e7deb7ac0aebfd22..023c45b48c6fc777dc7cefbb8af218bbf1d519ca 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 094fc1065700778e9eb007a2fb9db8229e16c4d8..abf55ab20bcea049dc8a343cec9f820193ff8c37 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 68e4117f93e5a355a30cebbf7894a02601f01e33..e1e7660d8dfa99d483ca588dd08b7971d6f6ed65 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