Rename poorly named fields, improve type composition

geode.cabal

@@ -29,9 +29,11 @@ library
 
     -- Modules included in this library but not exported.
     other-modules:    GEODE.Metadata.Contrastive
-                    , GEODE.Metadata.PrimaryKey
+                    , GEODE.Metadata.ArticleRecord
+                    , GEODE.Metadata.Record
                     , GEODE.Metadata.TSV
                     , GEODE.Metadata.Types
+                    , GEODE.Metadata.Work
 
     -- LANGUAGE extensions used by modules in this package.
     -- other-extensions:
@@ -55,7 +57,7 @@ test-suite ghc-geode-test
     hs-source-dirs:   test
     main-is:          Main.hs
     other-modules:    GEODE.Metadata.TestEntry
-                    , GEODE.Metadata.TestPrimaryKey
+                    , GEODE.Metadata.TestArticleRecord
                     , Test.HUnit.Extra
     build-depends:    base
                     , bytestring

lib/GEODE/Metadata.hs

 {-# LANGUAGE OverloadedStrings #-}
 module GEODE.Metadata
-  ( module Contrastive
+  ( module ArticleRecord
+  , module Contrastive
   , module Entry
-  , module PrimaryKey
+  , module Record
   , module SplitContext
   , module TSV
   , module TSV_Header
   , module Types
+  , module Work
   , groupBy
   , indexBy
   , sortBy ) where
@@ -16,13 +18,15 @@ import Data.List (sortOn)
 import Data.Map.Strict as Map (Map, alter, empty, insert, toList)
 import GEODE.Metadata.Contrastive as Contrastive
 import GEODE.Metadata.Entry as Entry
-  ( Entry(headWord, name, page), newEntry, normalize )
-import GEODE.Metadata.PrimaryKey as PrimaryKey
+  ( Entry(headword, name, page), newEntry, normalize )
+import GEODE.Metadata.ArticleRecord as ArticleRecord
+import GEODE.Metadata.Record as Record
 import GEODE.Metadata.SplitContext as SplitContext hiding (get, page, rank)
 import GEODE.Metadata.TSV as TSV
 import GEODE.Metadata.TSV.Header as TSV_Header
   ( DefaultFields(..), HasDefaultHeader(..), WithDefaultHeader(..), glue )
 import GEODE.Metadata.Types as Types
+import GEODE.Metadata.Work as Work
 
 sortBy :: (Foldable t, Ord k) => (a -> k) -> t a -> [a]
 sortBy field = sortOn field . Foldable.toList

lib/GEODE/Metadata/ArticleRecord.hs

+{-# LANGUAGE DeriveGeneric, FlexibleContexts, FlexibleInstances, NamedFieldPuns, OverloadedStrings #-}
+module GEODE.Metadata.ArticleRecord
+  ( Work(..)
+  , ArticleRecord(..)
+  , relativePath
+  , uid ) where
+
+import Data.Aeson ((.=), ToJSON(..))
+import Data.Aeson.KeyMap as KeyMap (fromList)
+import Data.Csv (FromField(..), FromNamedRecord(..), ToNamedRecord(..), ToField(..))
+import GEODE.Metadata.Record (Record(..))
+import GEODE.Metadata.Types (Has(..), ToJSONObject(..))
+import GEODE.Metadata.TSV.Header (DefaultFields(..), HasDefaultHeader(..))
+import GEODE.Metadata.Work (Work(..))
+import GHC.Generics (Generic)
+import System.FilePath ((</>), (<.>))
+import Text.Printf (printf)
+
+data ArticleRecord = ArticleRecord
+  { work :: Work
+  , volume :: Int
+  , article :: Int } deriving (Eq, Ord, Generic, Show)
+
+instance FromNamedRecord ArticleRecord
+instance ToNamedRecord ArticleRecord
+
+instance ToJSONObject ArticleRecord where
+  toJSONObject (ArticleRecord {work, volume, article}) = KeyMap.fromList
+    [ ("work", toJSON work)
+    , ("volume", toJSON volume)
+    , ("article", toJSON article) ]
+  toJSONPairs (ArticleRecord {work, volume, article}) =
+      "work" .= work
+    <> "volume" .= volume
+    <> "article" .= article
+
+instance Record ArticleRecord where
+  uid (ArticleRecord {work, volume, article}) =
+    printf "%s_%d_%d" (show $ work) volume article
+
+  relativePath (ArticleRecord {work, volume, article}) extension =
+    (show work) </> ("T" <> show volume) </> (show article) <.> extension
+
+{-
+relativePath :: Has ArticleRecord a => a -> String -> FilePath
+relativePath a extension =
+  (show work) </> ("T" <> show volume) </> (show article) <.> extension
+  where
+    ArticleRecord {work, volume, article} = get a
+-}
+
+instance HasDefaultHeader ArticleRecord where
+  defaultFields = DefaultFields [ "work", "volume", "article" ]

lib/GEODE/Metadata/Entry.hs

@@ -13,7 +13,7 @@ import GEODE.Metadata.TSV.Header
 import GHC.Generics (Generic)
 
 data Entry = Entry
-  { headWord :: Text
+  { headword :: Text
   , name :: Text 
   , page :: Int } deriving (Generic, Show)
 
@@ -21,7 +21,7 @@ instance FromNamedRecord Entry
 instance ToNamedRecord Entry
 
 instance HasDefaultHeader Entry where
-  defaultFields = DefaultFields [ "headWord", "name", "page" ]
+  defaultFields = DefaultFields [ "headword", "name", "page" ]
 
 normalize :: Text -> Text
 normalize = Text.foldl' appendIf mempty
@@ -33,8 +33,8 @@ normalize = Text.foldl' appendIf mempty
       | otherwise = tmpText `snoc` '-'
 
 newEntry :: SplitContext m => Text -> m Entry
-newEntry headWord = do
+newEntry headword = do
   count <- Text.pack . show <$> next (HeadWord prefix)
-  Entry headWord (Text.concat [prefix, "-", count]) <$> get Page
+  Entry headword (Text.concat [prefix, "-", count]) <$> get Page
   where
-    prefix = normalize headWord
+    prefix = normalize headword

lib/GEODE/Metadata/PrimaryKey.hs

-{-# LANGUAGE DeriveGeneric, FlexibleContexts, FlexibleInstances, NamedFieldPuns, OverloadedStrings #-}
-module GEODE.Metadata.PrimaryKey
-  ( Book(..)
-  , PrimaryKey(..)
-  , relativePath
-  , uid ) where
-
-import Data.Aeson (ToJSON(..))
-import Data.Csv (FromField(..), FromNamedRecord(..), ToNamedRecord(..), ToField(..))
-import GEODE.Metadata.Types (Has(..))
-import GEODE.Metadata.TSV.Header (DefaultFields(..), HasDefaultHeader(..))
-import GHC.Generics (Generic)
-import System.FilePath ((</>), (<.>))
-import Text.Printf (printf)
-
-data Book = EDdA | LGE | Wikipedia deriving (Eq, Ord, Read, Show)
-
-instance FromField Book where
-  parseField "EDdA" = pure EDdA
-  parseField "LGE" = pure LGE
-  parseField "Wikipedia" = pure Wikipedia
-  parseField _ = mempty
-
-instance ToField Book where
-  toField = toField . show
-
-instance ToJSON Book where
-  toJSON = toJSON . show
-
-data PrimaryKey = PrimaryKey
-  { book :: Book
-  , tome :: Int
-  , rank :: Int } deriving (Eq, Ord, Generic, Show)
-
-instance FromNamedRecord PrimaryKey
-instance ToNamedRecord PrimaryKey
-
-uid :: Has PrimaryKey a => a -> String
-uid a = printf "%s_%d_%d" (show $ book) tome rank
-  where
-    PrimaryKey {book, tome, rank} = get a
-
-relativePath :: Has PrimaryKey a => a -> String -> FilePath
-relativePath a extension =
-  (show book) </> ("T" <> show tome) </> (show rank) <.> extension
-  where
-    PrimaryKey {book, tome, rank} = get a
-
-instance HasDefaultHeader PrimaryKey where
-  defaultFields = DefaultFields [ "book", "tome", "rank" ]

lib/GEODE/Metadata/Record.hs

+{-# LANGUAGE ExplicitNamespaces, TypeOperators #-}
+module GEODE.Metadata.Record
+  ( Record(..) ) where
+
+import GEODE.Metadata.Types (type (@)(..))
+import System.FilePath ((</>))
+import Text.Printf (printf)
+
+class Record a where
+  uid :: a -> String
+  relativePath :: a -> String -> FilePath
+
+instance (Record a, Record b) => Record (a @ b) where
+  uid (a :@: b) = printf "%s_%s" (uid a) (uid b)
+  relativePath (a :@: b) extension =
+    relativePath a "" </> relativePath b extension

lib/GEODE/Metadata/Types.hs

-{-# LANGUAGE ExplicitNamespaces, FlexibleInstances, MultiParamTypeClasses, TypeOperators #-}
+{-# LANGUAGE ExplicitNamespaces, FlexibleInstances, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
 module GEODE.Metadata.Types
   ( Has(..)
+  , ToJSONObject(..)
   , type (@)(..) ) where
 
+import Data.Aeson (Object, Series, ToJSON(..), Value(..), pairs)
+import Data.Aeson.KeyMap as Object (union)
 import Data.Csv (FromNamedRecord(..), ToNamedRecord(..))
-import Data.HashMap.Strict (union)
+import Data.HashMap.Strict as Hash (union)
 
 infixr 9 @
 infixr 9 :@:
@@ -23,7 +26,19 @@ instance {-# OVERLAPS #-} Has a (a @ b) where
   get (a :@: _) = a
 
 instance (ToNamedRecord a, ToNamedRecord b) => ToNamedRecord (a @ b) where
-  toNamedRecord (a :@: b) = union (toNamedRecord a) (toNamedRecord b)
+  toNamedRecord (a :@: b) = Hash.union (toNamedRecord a) (toNamedRecord b)
 
 instance (FromNamedRecord a, FromNamedRecord b) => FromNamedRecord (a @ b) where
   parseNamedRecord nr = (:@:) <$> parseNamedRecord nr <*> parseNamedRecord nr
+
+class ToJSONObject a where
+  toJSONObject :: a -> Object
+  toJSONPairs :: a -> Series
+
+instance {-# OVERLAPPABLE #-} ToJSONObject a => ToJSON a where
+  toJSON = Object . toJSONObject
+  toEncoding = pairs . toJSONPairs
+
+instance (ToJSONObject a, ToJSONObject b) => ToJSONObject (a @ b) where
+  toJSONObject (a :@: b) = toJSONObject a `Object.union` toJSONObject b
+  toJSONPairs (a :@: b) = toJSONPairs a <> toJSONPairs b

lib/GEODE/Metadata/Work.hs

+{-# LANGUAGE OverloadedStrings #-}
+module GEODE.Metadata.Work
+  ( Work(..) ) where
+
+import Data.Aeson (ToJSON(..))
+import Data.Csv (FromField(..), ToField(..))
+import Data.Char (toLower)
+import Data.ByteString.Char8 as ByteString (map)
+
+data Work = EDdA | LGE | Wikipedia deriving (Eq, Ord, Read, Show)
+
+instance FromField Work where
+  parseField = recognize . ByteString.map toLower
+    where
+      recognize "EDdA" = pure EDdA
+      recognize "LGE" = pure LGE
+      recognize "Wikipedia" = pure Wikipedia
+      recognize _ = mempty
+
+instance ToField Work where
+  toField = toField . show
+
+instance ToJSON Work where
+  toJSON = toJSON . show
+

test/GEODE/Metadata/TestPrimaryKey.hs → test/GEODE/Metadata/TestArticleRecord.hs

 {-# LANGUAGE OverloadedStrings #-}
-module GEODE.Metadata.TestPrimaryKey (testPrimaryKey) where
+module GEODE.Metadata.TestArticleRecord (testArticleRecord) where
 
 import Data.Csv (ToNamedRecord(..))
 import Data.Foldable (toList)
 import Data.HashMap.Strict ((!?))
-import GEODE.Metadata (Book(..), PrimaryKey(..))
+import GEODE.Metadata (Work(..), ArticleRecord(..))
 import GEODE.Metadata.TSV.Header (getHeader, for)
 import Test.HUnit (Test(..), (~?=))
 import Test.HUnit.Extra (isJust)
 
-testPrimaryKey :: Test
-testPrimaryKey = TestLabel "Testing the PrimaryKey data type" $
+testArticleRecord :: Test
+testArticleRecord = TestLabel "Testing the ArticleRecord data type" $
   TestList [ testToNamedRecord ]
 
 testToNamedRecord :: Test
@@ -19,8 +19,8 @@ testToNamedRecord = TestLabel "Testing ToNamedRecord instance" $
   where
     has3Keys = length aNamedRecord ~?= 3
     validDefaultHeader = TestList . toList $
-      (isJust . (aNamedRecord !?)) <$> getHeader (for :: PrimaryKey)
+      (isJust . (aNamedRecord !?)) <$> getHeader (for :: ArticleRecord)
     aNamedRecord = toNamedRecord aPrimaryKey
 
-aPrimaryKey :: PrimaryKey
-aPrimaryKey = PrimaryKey LGE 1 1212 -- ALCALA DE HÉNARÈS
+aPrimaryKey :: ArticleRecord
+aPrimaryKey = ArticleRecord LGE 1 1212 -- ALCALA DE HÉNARÈS

test/GEODE/Metadata/TestEntry.hs

@@ -28,7 +28,7 @@ testNormalize :: Test
 testNormalize = TestLabel "Testing function normalize" . TestList $
   check <$> [ ("", "")
             , ("é", "é")
-            , (headWord anEntry, dropEnd 2 $ name anEntry) ]
+            , (headword anEntry, dropEnd 2 $ name anEntry) ]
   where
     check (a, b) = normalize a ~?= b
 

test/Main.hs

 module Main (main) where
 
 import Test.HUnit (Test(..), runTestTTAndExit)
-import GEODE.Metadata.TestPrimaryKey (testPrimaryKey)
+import GEODE.Metadata.TestArticleRecord (testArticleRecord)
 import GEODE.Metadata.TestEntry (testEntry)
 
 testMetadata :: Test
 testMetadata = TestLabel "Metadata suite" $
-  TestList [ testPrimaryKey, testEntry ]
+  TestList [ testArticleRecord, testEntry ]
 
 main :: IO ()
 main = runTestTTAndExit testMetadata