Refactor Aeson instances

src/Lisa/Squeak.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ImpredicativeTypes #-}
 
@@ -6,11 +7,14 @@ module Lisa.Squeak where
 
 import Control.Applicative ((<|>))
 import Control.Monad.IO.Class (MonadIO, liftIO)
-import Data.Aeson (FromJSON(parseJSON), ToJSON(toJSON), Value, (.:), (.:?), (.=), object, withObject)
+import Data.Aeson (FromJSON(parseJSON), FromJSONKey(fromJSONKey), Options(fieldLabelModifier), ToJSON(toJSON), Value, (.:), (.:?), (.=), defaultOptions, genericParseJSON, genericToJSON, object, withObject)
 import Data.Text (Text)
 import Data.Time.Calendar (Day)
+import GHC.Generics (Generic)
 import Network.HTTP.Req (Option, Scheme(..), POST(..), ReqBodyJson(..), Req, Scheme, Url, defaultHttpConfig, http, https, port, jsonResponse, responseBody, req, runReq)
 
+import qualified Data.Char as Char
+
 -- | Dependency Inversion for monads that can run requests.
 -- By requiring 'HasEndpointInfo' and 'MonadIO' for functions that perform requests we don't need to import anything from Scotty.
 class HasEndpointInfo m where
@@ -49,25 +53,23 @@ joinErrors (Left errors) = Left $ GQLErrors errors
 joinErrors (Right (SqueakErrorOr inner)) = inner
 
 -- ^ A GraphQL query with a bunch of variables.
-data GQLQuery v = GQLQuery Text v
-    deriving (Show)
+data GQLQuery v = GQLQuery
+    { gqlQueryQuery     :: Text
+    , gqlQueryVariables :: v
+    }
+    deriving (Generic, Show)
 
 instance ToJSON v => ToJSON (GQLQuery v) where
-    toJSON (GQLQuery query variables) = object
-        [ "query" .= query
-        , "variables" .= variables
-        ]
+    toJSON = genericToJSON $ removePrefixOpts "gqlQuery"
 
 data GQLReply a = GQLReply
     { gqlReplyData :: Maybe a
     , gqlReplyErrors :: Maybe [GQLError]
     }
-    deriving (Show)
+    deriving (Generic, Show)
 
 instance FromJSON a => FromJSON (GQLReply a) where
-    parseJSON = withObject "GQLReply" $ \v -> GQLReply
-        <$> v .: "data"
-        <*> v .:? "errors"
+    parseJSON = genericParseJSON $ removePrefixOpts "gqlReply"
 
 replyToEither :: GQLReply a -> Either [GQLError] a
 replyToEither (GQLReply (Just data') _)  = Right data'
@@ -77,19 +79,38 @@ replyToEither _                          = error "Invalid GQLReply: Neither 'dat
 data GQLError = GQLError
     { gqlErrorMessage :: Text
     }
-    deriving (Show)
+    deriving (Generic, Show)
 
 instance FromJSON GQLError where
-    parseJSON = withObject "GQLError" $ \v -> GQLError
-        <$> v .: "message"
+    parseJSON = genericParseJSON $ removePrefixOpts "gqlError"
 
+-- TODO: doc
 data Documents = Documents { unDocuments :: [Document] }
     deriving (Show)
 
+-- TODO: doc
 instance FromJSON Documents where
     parseJSON = withObject "Documents" $ \v -> Documents
         <$> ((v .: "documents") >>= (.: "results"))
 
+-- | Helper for automatically writing 'FromJSON' instances.
+--
+-- >>> removePrefixModifier "document" "documentId"
+-- "id"
+-- >>> removePrefixModifier "document" "documentPublicComment"
+-- "publicComment"
+removePrefixModifier :: String -> String -> String
+removePrefixModifier prefix = lowercaseFirst . stripPrefix prefix
+    where
+        stripPrefix [] word = word
+        stripPrefix (p:ps) (c:cs)
+            | p == c    = stripPrefix ps cs
+            | otherwise = error $ "Invalid prefix " ++ ps ++ " (" ++ prefix ++ ") for key " ++ cs
+        stripPrefix _ [] = error $ "Prefix " ++ prefix ++ " is too long"
+        lowercaseFirst (c:cs) = Char.toLower c : cs
+
+removePrefixOpts prefix = defaultOptions { fieldLabelModifier = removePrefixModifier prefix }
+
 data Document = Document
     { documentId            :: Text
     , documentDate          :: Day
@@ -99,48 +120,35 @@ data Document = Document
     , documentLectures      :: [Lecture]
     , documentDownloadable  :: Bool
     }
-    deriving (Show)
+    deriving (Show, Generic)
 
 instance FromJSON Document where
-    parseJSON = withObject "Document" $ \v -> Document
-        <$> v .: "id"
-        <*> v .: "date"
-        <*> v .: "semester"
-        <*> v .: "publicComment"
-        <*> v .: "faculty"
-        <*> v .: "lectures"
-        <*> v .: "downloadable"
+    parseJSON = genericParseJSON $ removePrefixOpts "document"
 
 data Faculty = Faculty
     { facultyId          :: Text
     , facultyDisplayName :: Text
     }
-    deriving (Show)
+    deriving (Generic, Show)
 
 instance FromJSON Faculty where
-    parseJSON = withObject "Faculty" $ \v -> Faculty
-        <$> v .: "id"
-        <*> v .: "displayName"
+    parseJSON = genericParseJSON $ removePrefixOpts "faculty"
 
 data Lectures = Lectures { unLectures :: [Lecture] }
-    deriving (Show)
+    deriving (Generic, Show)
 
 instance FromJSON Lectures where
-    parseJSON = withObject "Lectures" $ \v -> Lectures
-        <$> v .: "lectures"
+    parseJSON = genericParseJSON $ removePrefixOpts "un"
 
 data Lecture = Lecture
     { lectureId          :: Text
     , lectureDisplayName :: Text
     , lectureAliases     :: [Text]
     }
-    deriving (Show)
+    deriving (Generic, Show)
 
 instance FromJSON Lecture where
-    parseJSON = withObject "Lecture" $ \v -> Lecture
-        <$> v .: "id"
-        <*> v .: "displayName"
-        <*> v .: "aliases"
+    parseJSON = genericParseJSON $ removePrefixOpts "lecture"
 
 getAllLectures :: (HasEndpointInfo m, MonadIO m) => m (Either SqueakError [Lecture])
 getAllLectures = fmap unLectures <$> joinErrors <$> mkQuery
@@ -168,22 +176,18 @@ instance FromJSON LoginResult where
 data Credentials = Credentials
     { credentialsToken :: Text
     , credentialsUser  :: User
-    } deriving (Show)
+    } deriving (Generic, Show)
 
 instance FromJSON Credentials where
-    parseJSON = withObject "Credentials" $ \v -> Credentials
-        <$> v .: "token"
-        <*> v .: "user"
+    parseJSON = genericParseJSON $ removePrefixOpts "credentials"
 
 data User = User
     { userUsername    :: Text
     , userDisplayName :: Text
-    } deriving (Show)
+    } deriving (Generic, Show)
 
 instance FromJSON User where
-    parseJSON = withObject "User" $ \v -> User
-        <$> v .: "username"
-        <*> v .: "displayName"
+    parseJSON = genericParseJSON $ removePrefixOpts "user"
 
 {-
 login :: Text -> Text -> Req (Either [GQLError] Credentials)
@@ -212,6 +216,7 @@ data SqueakError
     | GQLErrors [GQLError]
     deriving (Show)
 
+-- TODO: doc
 instance FromJSON SqueakError where
     parseJSON = withObject "SqueakError" $ \v -> SqueakError
         <$> v .: "errorCode"
@@ -220,6 +225,7 @@ instance FromJSON SqueakError where
 newtype SqueakErrorOr a = SqueakErrorOr (Either SqueakError a)
     deriving (Show)
 
+-- TODO: doc
 instance FromJSON a => FromJSON (SqueakErrorOr a) where
     -- | Parse 'SqueakError' if @errorCode@ and @msg@ are present; otherwise, parse an 'a'.
     parseJSON v = SqueakErrorOr
@@ -238,13 +244,10 @@ data Order = Order
     , orderTag      :: Text
     , orderNumPages :: Int
     }
-    deriving (Show)
+    deriving (Generic, Show)
 
 instance FromJSON Order where
-    parseJSON = withObject "Order" $ \v -> Order
-        <$> v .: "id"
-        <*> v .: "tag"
-        <*> v .: "numPages"
+    parseJSON = genericParseJSON $ removePrefixOpts "order"
 
 createOrder :: (HasEndpointInfo m, MonadIO m) => Text -> [Text] -> m (Either SqueakError Order)
 createOrder tag documents = joinErrors <$> fmap unCreateOrderResult <$> mkQueryWithVars