aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorstuebinm2022-06-06 00:21:19 +0200
committerstuebinm2022-06-06 00:21:19 +0200
commit47ec9303325e66dde548493f0319eaece707aff4 (patch)
tree3cf9fdbfec704128f1c97ee4014b1b57823d8edb
parentc30759d9878127d98c451e62f052c6b30fd3a1ec (diff)
better aeson generics
(template haskell doesn't work well with type families, unfortunately)
Diffstat (limited to '')
-rw-r--r--hie.yaml3
-rw-r--r--lib/GTFS.hs52
-rw-r--r--lib/Server.hs9
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])