Add parsing UIDs as a requirement for Record, explain how they propagate along...

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

 {-# 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

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

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