better aeson generics

(template haskell doesn't work well with type families, unfortunately)

3 files changed, 54 insertions, 10 deletions

diff --git a/hie.yaml b/hie.yaml
index 7cca5eb..03e99e3 100644
--- a/hie.yaml
+++ b/hie.yaml
@@ -2,3 +2,6 @@ cradle:
   cabal:
     - path: "app/Main.hs"
       component: "haskell-gtfs:exe:haskell-gtfs"
+
+    - path: "lib"
+      component: "lib:haskell-gtfs"
diff --git a/lib/GTFS.hs b/lib/GTFS.hs
index cadc930..35a85ea 100644
--- a/lib/GTFS.hs
+++ b/lib/GTFS.hs
@@ -11,6 +11,8 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 
 module GTFS where
@@ -33,11 +35,26 @@ import qualified Data.Time.Calendar.OrdinalDate as Day
 import Data.Time.Calendar (Day, DayOfWeek(..))
 import Data.Time.Calendar.MonthDay (monthAndDayToDayOfYearValid)
 import Data.Time (getCurrentTime, UTCTime (utctDay), dayOfWeek)
-import Data.Aeson (ToJSON, FromJSON)
+import Data.Aeson
+    ( ToJSON,
+      FromJSON,
+      Options(fieldLabelModifier),
+      genericParseJSON,
+      genericToJSON,
+      defaultOptions )
 import qualified Data.Aeson as A
 import GHC.Generics (Generic)
+-- import Data.Aeson.Generic (Options(fieldLabelModifier), deriveJSON, defaultOptions)
+import qualified Data.Text as T
+import Data.Char (toLower)
 
 
+aesonOptions prefix =
+  defaultOptions { fieldLabelModifier = fieldModifier (T.length prefix) }
+  where fieldModifier n label = case drop n label of
+         c:rest -> toLower c : rest
+         "" -> ""
+
 newtype Time = Time { toSeconds :: Int }
   deriving newtype (ToJSON, FromJSON)
 
@@ -89,7 +106,13 @@ data Station = Station
   , stationName :: Text
   , stationLat :: Float
   , stationLon :: Float
-  } deriving (Show, Generic, ToJSON)
+  } deriving (Show, Generic)
+
+instance FromJSON Station where
+  parseJSON = genericParseJSON (aesonOptions "station")
+instance ToJSON Station where
+  toJSON = genericToJSON (aesonOptions "station")
+
 
 -- | This is what's called a stop time in GTFS
 data Stop (deep :: Depth) = Stop
@@ -102,8 +125,10 @@ data Stop (deep :: Depth) = Stop
 
 deriving instance Show (Stop 'Shallow)
 deriving instance Show (Stop 'Deep)
-deriving instance ToJSON (Stop 'Deep)
-
+instance FromJSON (Switch a Station StationID) => FromJSON (Stop a) where
+  parseJSON = genericParseJSON (aesonOptions "stop")
+instance ToJSON (Switch a Station StationID) => ToJSON (Stop a) where
+  toJSON = genericToJSON (aesonOptions "stop")
 
 data Calendar = Calendar
   { calServiceId :: Text
@@ -116,16 +141,23 @@ data Calendar = Calendar
   , calSunday :: Bool
   , calStartDate :: Day
   , calEndDate :: Day
-  } deriving (Show, Generic, ToJSON)
+  } deriving (Show, Generic)
+
+
 
 data CalendarExceptionType = ServiceAdded | ServiceRemoved
-  deriving (Show, Eq, Generic, ToJSON)
+  deriving (Show, Eq, Generic, ToJSON, FromJSON)
 
 data CalendarDate = CalendarDate
   { caldateServiceId :: Text
   , caldateDate :: Day
   , caldateExceptionType :: CalendarExceptionType
-  } deriving (Show, Generic, ToJSON)
+  } deriving (Show, Generic)
+
+instance FromJSON CalendarDate where
+  parseJSON = genericParseJSON (aesonOptions "caldate")
+instance ToJSON CalendarDate where
+  toJSON = genericToJSON (aesonOptions "caldate")
 
 data Trip (deep :: Depth) = Trip
   { tripRoute :: Text
@@ -141,9 +173,13 @@ data Trip (deep :: Depth) = Trip
   , tripStops :: Optional deep (Vector (Stop deep))
   } deriving Generic
 
+
 deriving instance Show (Trip Shallow)
 deriving instance Show (Trip Deep)
-deriving instance ToJSON (Trip Deep)
+instance FromJSON (Optional d (Vector (Stop d))) => FromJSON (Trip d) where
+  parseJSON = genericParseJSON (aesonOptions "trip")
+instance ToJSON (Optional d (Vector (Stop d))) => ToJSON (Trip d) where
+  toJSON = genericToJSON (aesonOptions "trip")
 
 -- | helper function to find things in Vectors of things
 tableLookup :: Eq key => (a -> key) -> key -> Vector a -> Maybe a
diff --git a/lib/Server.hs b/lib/Server.hs
index 0ad451d..7a79aa8 100644
--- a/lib/Server.hs
+++ b/lib/Server.hs
@@ -26,7 +26,7 @@ import qualified Data.UUID.V4 as UUID
 import qualified Data.UUID as UUID
 import Data.UUID (UUID)
 import Control.Concurrent.STM
-import Data.Aeson (ToJSON, FromJSON, ToJSONKey)
+import Data.Aeson (ToJSON (toJSON), FromJSON (parseJSON), ToJSONKey, genericToJSON, genericParseJSON)
 import Servant.Server (Handler)
 import GHC.Generics (Generic)
 import GHC.Foreign (withCStringsLen)
@@ -40,7 +40,12 @@ data TrainPing = TrainPing
   , pingLong :: Float
   , pingDelay :: Int
   , pingTimestamp :: Time
-  } deriving (Generic, FromJSON, ToJSON)
+  } deriving (Generic)
+
+instance FromJSON TrainPing where
+  parseJSON = genericParseJSON (aesonOptions "ping")
+instance ToJSON TrainPing where
+  toJSON = genericToJSON (aesonOptions "ping")
 
 
 type KnownTrips = TVar (Map Token [TrainPing])