lib/GEODE/Metadata/Types.hs

@@ -9,8 +9,8 @@ import Data.Aeson.KeyMap as Object (union)
 import Data.Csv (FromNamedRecord(..), ToNamedRecord(..))
 import Data.HashMap.Strict as Hash (union)
 
-infixr 9 @
-infixr 9 :@:
+infixl 9 @
+infixl 9 :@:
 data a @ b = a :@: b
 
 class Has a b where
@@ -19,11 +19,11 @@ class Has a b where
 instance Has a a where
   get = id
 
-instance Has a c => Has a (b @ c) where
-  get (_ :@: c) = get c
+instance Has a b => Has a (b @ c) where
+  get (b :@: _) = get b
 
-instance {-# OVERLAPS #-} Has a (a @ b) where
-  get (a :@: _) = a
+instance {-# OVERLAPS #-} Has b (a @ b) where
+  get (_ :@: b) = b
 
 instance (ToNamedRecord a, ToNamedRecord b) => ToNamedRecord (a @ b) where
   toNamedRecord (a :@: b) = Hash.union (toNamedRecord a) (toNamedRecord b)

lib/GEODE/Metadata/Work.hs

-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveGeneric, OverloadedStrings #-}
 module GEODE.Metadata.Work
   ( Work(..) ) where
 
-import Data.Aeson (ToJSON(..))
+import Data.Aeson (FromJSON(..), ToJSON(..), withText)
+import Data.ByteString.Char8 as ByteString (unpack)
 import Data.Csv (FromField(..), ToField(..))
 import Data.Char (toLower)
-import Data.ByteString.Char8 as ByteString (map)
+import Data.Text as Text (unpack)
+import GHC.Generics (Generic)
 
-data Work = EDdA | LGE | Wikipedia deriving (Eq, Ord, Read, Show)
+data Work = EDdA | LGE | Wikipedia deriving (Eq, Generic, Ord, Show)
+
+tolerantParser :: (Applicative m, Monoid (m Work)) => String -> m Work
+tolerantParser = recognize . fmap toLower
+  where
+    recognize "edda" = pure EDdA
+    recognize "lge" = pure LGE
+    recognize "wikipedia" = pure Wikipedia
+    recognize _ = mempty
 
 instance FromField Work where
-  parseField = recognize . ByteString.map toLower
-    where
-      recognize "EDdA" = pure EDdA
-      recognize "LGE" = pure LGE
-      recognize "Wikipedia" = pure Wikipedia
-      recognize _ = mempty
+  parseField = tolerantParser . ByteString.unpack
 
 instance ToField Work where
   toField = toField . show
 
-instance ToJSON Work where
-  toJSON = toJSON . show
-
+instance ToJSON Work
+instance FromJSON Work where
+  parseJSON = withText "Work" $ tolerantParser . Text.unpack