aboutsummaryrefslogtreecommitdiff
path: root/lib/GTFS.hs
blob: b83db0f28cb132bf85f244a47ba88bc612e4846c (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DeriveAnyClass             #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE NamedFieldPuns             #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE StandaloneKindSignatures   #-}
{-# LANGUAGE TupleSections              #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE UndecidableInstances       #-}

-- | All kinds of stuff that has to deal with GTFS directly
-- (i.e. parsing, querying, Aeson instances, etc.)
module GTFS where

import qualified Codec.Archive.Zip                   as Zip
import           Control.Monad.ST                    (runST)
import           Data.Aeson                          (FromJSON,
                                                      Options (fieldLabelModifier),
                                                      ToJSON, defaultOptions,
                                                      genericParseJSON,
                                                      genericToJSON)
import qualified Data.Aeson                          as A
import qualified Data.ByteString                     as BS
import qualified Data.ByteString.Lazy                as LB
import           Data.Csv                            ((.:))
import qualified Data.Csv                            as CSV
import           Data.Function                       (on)
import           Data.Functor                        ((<&>))
import           Data.Kind                           (Type)
import           Data.Maybe                          (fromJust, fromMaybe)
import           Data.Text                           (Text)
import           Data.Time                           (TimeZone (timeZoneMinutes),
                                                      UTCTime (..), dayOfWeek,
                                                      getCurrentTime)
import           Data.Time.Calendar                  (Day, DayOfWeek (..))
import           Data.Time.Calendar.MonthDay         (monthAndDayToDayOfYearValid)
import qualified Data.Time.Calendar.OrdinalDate      as Day
import           Data.Vector                         (Vector)
import qualified Data.Vector                         as V
import qualified Data.Vector.Algorithms.Intro        as V
import           Fmt                                 ((+|), (|+))
import           GHC.Generics                        (Generic)
import           Text.Regex.TDFA                     ((=~))
import           Web.Internal.FormUrlEncoded         (FromForm (..))
import           Web.Internal.HttpApiData            (FromHttpApiData (..))
-- import Data.Aeson.Generic (Options(fieldLabelModifier), deriveJSON, defaultOptions)
import           Control.Applicative                 ((<|>))
import           Control.Lens
import           Control.Monad                       (when)
import           Control.Monad.IO.Class              (MonadIO (liftIO))
import           Data.ByteString                     (ByteString)
import           Data.Char                           (toLower)
import           Data.Foldable                       (Foldable (fold))
import           Data.Map                            (Map)
import qualified Data.Map                            as M
import           Data.Proxy                          (Proxy (Proxy))
import           Data.Swagger                        (ParamSchema (..),
                                                      SchemaOptions,
                                                      ToSchema (declareNamedSchema),
                                                      defaultSchemaOptions,
                                                      genericDeclareNamedSchema)
import qualified Data.Swagger                        as S
import qualified Data.Text                           as T
import           Data.Time.LocalTime.TimeZone.Olson  (getTimeZoneSeriesFromOlsonFile)
import           Data.Time.LocalTime.TimeZone.Series (TimeZoneSeries,
                                                      timeZoneFromSeries)
import           GHC.Float                           (int2Double)


-- | for some reason this doesn't exist already in cassava
(.:?) :: forall a. (CSV.FromField (Maybe a)) => CSV.NamedRecord -> ByteString -> CSV.Parser (Maybe a)
(.:?) r field = r .: field <|> pure Nothing

aesonOptions prefix =
  defaultOptions { fieldLabelModifier = fieldModifier (T.length prefix) }
  where fieldModifier n label = case drop n label of
         c:rest -> toLower c : rest
         ""     -> ""

swaggerOptions :: Text -> SchemaOptions
swaggerOptions prefix =
  defaultSchemaOptions { S.fieldLabelModifier = fieldModifier (T.length prefix) }
  where fieldModifier n label = case drop n label of
         c:rest -> toLower c : rest
         ""     -> ""

-- | Times in GTFS are a weird beast, lacking any kinda of timezone information
-- whatsoever, but are given in the timezone of the transport agency, and
-- potentially displayed in a different timezone depending on the station they
-- apply to.
data Time = Time { timeSeconds :: Int, timeTZseries :: TimeZoneSeries, timeTZname :: Text }
  deriving (Generic)

instance ToJSON Time where
  toJSON (Time seconds _ tzname) =
    A.object [ "seconds" A..= seconds, "timezone" A..= tzname ]

-- | a type for all timetable values lacking context
-- confusingly, usually displayed as minutes
newtype Seconds = Seconds { unSeconds :: Int }
  deriving newtype
   ( Num, ToJSON, FromJSON, Eq, Ord, FromHttpApiData
   , Read, ToSchema )

instance Show Seconds where
  show (Seconds s) =
    if s > 0 then "+"+|s `div` 60|+""
    else show (s `div` 60)

seconds2Double :: Seconds -> Double
seconds2Double = int2Double . unSeconds

-- | converts a value of Time to seconds since midnight in UTC, using the
-- timezone that was valid in the timezone series on the given reference day
-- at the given number of seconds since midnight (note that this may lead to
-- strange effects for timezone changes not taking place at midnight)
toSeconds :: Time -> TimeZoneSeries -> Day -> Seconds
toSeconds (Time seconds _ _) tzseries refday =
  Seconds $ seconds - timeZoneMinutes timezone * 60
  where timezone = timeZoneFromSeries tzseries reftime
        reftime = UTCTime refday (fromInteger $ toInteger seconds)

-- | convert a time to a UTCTime, using the timezone valid on the refday.
-- Note that this will may fail to be correct in case of trips going across midnight
toUTC :: Time -> TimeZoneSeries -> Day -> UTCTime
toUTC time tzseries refday =
  UTCTime refday (fromInteger $ toInteger $ unSeconds $ toSeconds time tzseries refday)


-- | Times in GTFS are given without timezone info, which is handled
-- seperately (as an attribute of the stop / the agency). We attach that information
-- back to the Time, this is just an intermediate step during parsing.
newtype RawTime = RawTime { unRawTime :: TimeZoneSeries -> Text -> Time }
  deriving (Generic)

instance CSV.FromField RawTime where
  parseField f = do
    text :: String <- CSV.parseField f
    let (_,_,_,subs) = text =~ ("([0-9][0-9]?):([0-9][0-9]?):([0-9][0-9]?)" :: Text)
          :: (String, String, String, [String])
    case subs of
      [hh,mm,ss] -> pure $ RawTime $ Time (read hh * 3600 + read mm * 60 + read ss)
      _          -> fail $ "encountered an invalid date: " <> text

instance Show Time where
  show (Time seconds _ _) = ""
    +|pad (seconds `div` 3600)|+":"
    +|pad ((seconds `mod` 3600) `div` 60)|+
    {- if seconds `mod` 60 /= 0 then -}":"+|pad (seconds `mod` 60)|+""
    -- else ""
    where
      pad num =
            if length str < 2 then "0"<>str else str
            where str = show num

instance Show RawTime where
  show raw = "[raw time value]" -- show (unRawTime raw 0)

instance CSV.FromField Day where
  parseField f = do
    text :: String <- CSV.parseField f
    let (_,_,_,subs) = text =~ ("([0-9][0-9][0-9][0-9])([0-9][0-9])([0-9][0-9])" :: Text)
          :: (String, String, String, [String])
    case subs of
      [yyyy,mm,dd] -> do
        let Just dayOfYear = monthAndDayToDayOfYearValid (Day.isLeapYear (read yyyy)) (read mm) (read dd)
        pure $ Day.fromOrdinalDate (read yyyy) dayOfYear
      _ -> fail $ "invalid date encountered: " <> show f

instance ToSchema Time where
  declareNamedSchema _ = do
    dings <- declareNamedSchema (Proxy @Int)
    pure (set (S.schema . S.description) (Just "Zeit in Sekunden seit Tagesanfang") dings)


data Depth = Shallow | Deep
type Switch :: Depth -> Type -> Type -> Type
type family Switch c a b where
  Switch Deep a b = a
  Switch Shallow a b = b
type family Optional c a where
  Optional Deep a = a
  Optional Shallow _ = ()

type StationID = Text
type TripID = Text
type ServiceID = Text


-- | This is what's called a Stop in GTFS
data Station = Station
  { stationId       :: StationID
  , stationName     :: Text
  , stationLat      :: Double
  , stationLon      :: Double
  , stationTimezone :: Maybe Text
  } deriving (Show, Generic)

instance ToSchema Station where
  declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "station")
instance FromJSON Station where
  parseJSON = genericParseJSON (aesonOptions "station")
instance ToJSON Station where
  toJSON = genericToJSON (aesonOptions "station")

stationGeopos :: Station -> (Double, Double)
stationGeopos Station{..} = (stationLat, stationLon)

-- | This is what's called a stop time in GTFS
data Stop (deep :: Depth) = Stop
  { stopTrip      :: TripID
  , stopArrival   :: Switch deep Time RawTime
  , stopDeparture :: Switch deep Time RawTime
  , stopStation   :: Switch deep Station StationID
  , stopSequence  :: Int
  } deriving Generic

-- deriving instance Show (Stop 'Shallow)
deriving instance Show (Stop 'Deep)
-- instance FromJSON (Switch a Station StationID) => FromJSON (Stop a) where
--   parseJSON = genericParseJSON (aesonOptions "stop")
instance (ToJSON (Switch a Station StationID)
         , ToJSON (Switch a Time RawTime))
       => ToJSON (Stop a) where
  toJSON = genericToJSON (aesonOptions "stop")
instance ToSchema (Stop Deep)where
  declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "stop")

data Calendar = Calendar
  { calServiceId :: Text
  , calMonday    :: Bool
  , calTuesday   :: Bool
  , calWednesday :: Bool
  , calThursday  :: Bool
  , calFriday    :: Bool
  , calSaturday  :: Bool
  , calSunday    :: Bool
  , calStartDate :: Day
  , calEndDate   :: Day
  } deriving (Show, Generic)



data CalendarExceptionType = ServiceAdded | ServiceRemoved
  deriving (Show, Eq, Generic, ToJSON, FromJSON)

instance FromHttpApiData CalendarExceptionType where
  parseUrlPiece = \case
    "added"   -> Right ServiceAdded
    "removed" -> Right ServiceRemoved
    unknown   -> Left ("unknown CalendarExceptionType: "<>unknown)

data CalendarDate = CalendarDate
  { caldateServiceId     :: Text
  , caldateDate          :: Day
  , caldateExceptionType :: CalendarExceptionType
  } deriving (Show, Generic)

instance FromJSON CalendarDate where
  parseJSON = genericParseJSON (aesonOptions "caldate")
instance ToJSON CalendarDate where
  toJSON = genericToJSON (aesonOptions "caldate")
instance FromForm CalendarDate

data Trip (deep :: Depth) (shape :: Depth)= Trip
  { tripRoute     :: Switch deep (Route Deep) Text
  , tripTripID    :: TripID
  , tripHeadsign  :: Maybe Text
  , tripShortName :: Maybe Text
  , tripDirection :: Maybe Bool
  -- NOTE: there's also block_id, which we're unlikely to ever need
  , tripServiceId :: Text
  -- , tripWheelchairAccessible :: Bool
  -- , tripBikesAllowed :: Bool
  , tripShape     :: Switch shape Shape Text
  , tripStops     :: Optional deep (Vector (Stop deep))
  } deriving Generic

tripForgetShape :: Trip Deep Deep -> Trip Deep Shallow
tripForgetShape trip = trip { tripShape = shapeId (tripShape trip) }

deriving instance Show (Trip Shallow Shallow)
deriving instance Show (Trip Deep Deep)
deriving instance Show (Trip Deep Shallow)
-- instance (FromJSON (Switch d Shape Text), FromJSON (Optional d (Vector (Stop d))), FromJSON (Switch s Shape Text), FromJSON (Switch d (Route 'Deep) Text)) => FromJSON (Trip d s) where
--   parseJSON = genericParseJSON (aesonOptions "trip")
instance (ToJSON (Switch d Shape Text), ToJSON (Optional d (Vector (Stop d))), ToJSON (Switch s Shape Text), ToJSON (Switch d (Route 'Deep) Text)) => ToJSON (Trip d s) where
  toJSON = genericToJSON (aesonOptions "trip")
instance ToSchema (Trip Deep Deep) where
  declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "trip")
instance ToSchema (Trip Deep Shallow) where
  declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "trip")

-- | helper function to find things in Vectors of things
tableLookup :: Eq key => (a -> key) -> key -> Vector a -> Maybe a
tableLookup proj key = V.find (\a -> proj a == key)

data ShapePoint = ShapePoint
  { shapePtId       :: Text
  , shapePtLat      :: Double
  , shapePtLong     :: Double
  , shapePtSequence :: Int
  } deriving Generic

data Shape = Shape
  { shapeId     :: Text
  , shapePoints :: Vector (Double,Double)
  } deriving (Generic, Show)

instance FromJSON Shape where
  parseJSON = genericParseJSON (aesonOptions "shape")
instance ToJSON Shape where
  toJSON = genericToJSON (aesonOptions "shape")
instance ToSchema Shape where
  declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "shape")

data Agency depth = Agency
  { agencyId       :: Maybe Text
  , agencyName     :: Text
  , agencyUrl      ::  Text
  , agencyTimezone :: Switch depth TimeZoneSeries Text
  , agencyLang     :: Maybe Text
  , agencyPhone    :: Maybe Text
  , agencyFareUrl  :: Maybe Text
  , agencyEmail    :: Maybe Text
  } deriving (Generic)

deriving instance Show (Switch depth TimeZoneSeries Text) => Show (Agency depth)
instance ToJSON (Agency Deep) where
  toJSON = genericToJSON (aesonOptions "agency")
instance ToSchema (Agency Deep) where
  declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "agency")
instance ToJSON TimeZoneSeries where
  toJSON tz = "[timezoneseries thingie]"
instance ToSchema TimeZoneSeries where
  declareNamedSchema _ = declareNamedSchema (Proxy @String)

data Route depth = Route
  { routeId          :: Text
  , routeAgency      :: Switch depth (Agency Deep) (Maybe Text)
  , routeShortName   :: Maybe Text
  , routeLongName    :: Maybe Text
  , routeDescription :: Maybe Text
  , routeType        :: Int
  , routeUrl         :: Maybe Text
  , routeColor       :: Maybe Text
  , routeTextColor   :: Maybe Text
  , routeSortOrder   :: Maybe Int
  , routeNetworkId   :: Maybe Text
  } deriving (Generic)

deriving instance Show (Switch depth (Agency Deep) (Maybe Text)) => Show (Route depth)
instance ToJSON (Route Deep) where
  toJSON = genericToJSON (aesonOptions "route")
instance ToSchema (Route Deep) where
  declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "route")

instance CSV.FromNamedRecord Station where
  parseNamedRecord r = Station
    <$> r .: "stop_id"
    <*> r .: "stop_name"
    <*> r .: "stop_lat"
    <*> r .: "stop_lon"
    <*> r .:? "stop_timezone"

instance CSV.FromNamedRecord (Stop 'Shallow) where
  parseNamedRecord r = Stop
    <$> r .: "trip_id"
    <*> r .: "arrival_time"
    <*> r .: "departure_time"
    <*> r .: "stop_id"
    <*> r .: "stop_sequence"

instance CSV.FromNamedRecord Calendar where
  parseNamedRecord r = Calendar
    <$> r .: "service_id"
    <*> intAsBool' r "monday"
    <*> intAsBool' r "tuesday"
    <*> intAsBool' r "wednesday"
    <*> intAsBool' r "thursday"
    <*> intAsBool' r "friday"
    <*> intAsBool' r "saturday"
    <*> intAsBool' r "sunday"
    <*> r .: "start_date"
    <*> r .: "end_date"

instance CSV.FromNamedRecord ShapePoint where
  parseNamedRecord r = ShapePoint
    <$> r .: "shape_id"
    <*> r .: "shape_pt_lat"
    <*> r .: "shape_pt_lon"
    <*> r .: "shape_pt_sequence"

intAsBool :: CSV.NamedRecord -> BS.ByteString -> CSV.Parser (Maybe Bool)
intAsBool r field = do
  int <- r .: field
  pure $ case int :: Int of
    1 -> Just True
    0 -> Just False
    _ -> Nothing

intAsBool' :: CSV.NamedRecord -> BS.ByteString -> CSV.Parser Bool
intAsBool' r field = intAsBool r field >>= maybe
  (fail "unexpected value for a boolean.")
  pure


instance CSV.FromNamedRecord CalendarDate where
  parseNamedRecord r = CalendarDate
    <$> r .: "service_id"
    <*> r .: "date"
    <*> do
      int <- r .: "exception_type"
      case int :: Int of
        1 -> pure ServiceAdded
        2 -> pure ServiceRemoved
        _ -> fail $ "unexpected value in exception_type: "+|int|+"."


instance CSV.FromNamedRecord (Trip Shallow Shallow) where
  parseNamedRecord r = Trip
    <$> r .: "route_id"
    <*> r .: "trip_id"
    <*> r .: "trip_headsign"
    <*> r .: "trip_short_name"
    <*> intAsBool r "direction_id"
    <*> r .: "service_id"
    -- NOTE: these aren't booleans but triple-values
    -- <*> intAsBool r "wheelchair_accessible"
    -- <*> intAsBool r "bikes_allowed"
    <*> r .: "shape_id"
    <*> pure ()

instance CSV.FromNamedRecord (Agency Shallow) where
  parseNamedRecord r = Agency
    <$> r .:? "agency_id"
    <*> r .: "agency_name"
    <*> r .: "agency_url"
    <*> r .: "agency_timezone"
    <*> r .:? "agency_lang"
    <*> r .:? "agency_phone"
    <*> r .:? "agency_fare_url"
    <*> r .:? "agency_email"

instance CSV.FromNamedRecord (Route Shallow) where
  parseNamedRecord r = Route
    <$> r .: "route_id"
    <*> r .:? "agency_id"
    <*> r .:? "route_short_name"
    <*> r .:? "route_long_name"
    <*> r .:? "route_desc"
    <*> r .: "route_type"
    <*> r .:? "route_url"
    <*> r .:? "route_color"
    <*> r .:? "route_text_color"
    <*> r .:? "route_sort_order"
    <*> r .:? "network_id"



data RawGTFS = RawGTFS
  { rawStations      :: Vector Station
  , rawStops         :: Vector (Stop Shallow)
  , rawTrips         :: Vector (Trip Shallow Shallow)
  , rawCalendar      :: Maybe (Vector Calendar)
  , rawCalendarDates :: Maybe (Vector CalendarDate)
  , rawShapePoints   :: Maybe (Vector ShapePoint)
  , rawAgencies      :: Vector (Agency Shallow)
  , rawRoutes        :: Vector (Route Shallow)
  }


data GTFS = GTFS
  { stations      :: Map StationID Station
  , trips         :: Map TripID (Trip Deep Deep)
  , calendar      :: Map DayOfWeek (Vector Calendar)
  , calendarDates :: Map Day (Vector CalendarDate)
  , shapes        :: Map Text Shape
  , agencies      :: Vector (Agency Deep)
  -- ^ not a Map AgencyID Agency since if there's only one agency, it may lack an ID
  , routes        :: Map Text (Route Deep)
  , tzseries      :: TimeZoneSeries
  }


loadRawGtfs :: FilePath -> IO RawGTFS
loadRawGtfs path = do
    zip <- Zip.toArchive <$> LB.readFile path
    RawGTFS
      <$> decodeTable' "stops.txt" zip
      <*> decodeTable' "stop_times.txt" zip
      <*> decodeTable' "trips.txt" zip
      <*> decodeTable "calendar.txt" zip
      <*> decodeTable "calendar_dates.txt" zip
      <*> decodeTable "shapes.txt" zip
      <*> decodeTable' "agency.txt" zip
      <*> decodeTable' "routes.txt" zip
    where
      decodeTable :: CSV.FromNamedRecord a => FilePath -> Zip.Archive -> IO (Maybe (Vector a))
      decodeTable path zip =
        case Zip.findEntryByPath path zip of
          Nothing -> pure Nothing
          Just csv -> case CSV.decodeByName (Zip.fromEntry csv) of
            Left err -> error $ "could not decode file "+|path|+": "+|err|+"."
            Right (_,v :: a) -> pure (Just v)
      decodeTable' path zip =
        decodeTable path zip >>= \case
          Nothing -> fail $ "required file "+|path|+" not found in gtfs.zip"
          Just a  -> pure a

-- | load a gtfs file "the complicated way", creating data structures much nicer
-- to work with than the raw representation of GTFS.
--
-- Note that this additionally needs a path to the machine's timezone info
-- (usually /etc/zoneinfo or /usr/shared/zoneinfo)
loadGtfs :: FilePath -> FilePath -> IO GTFS
loadGtfs path zoneinforoot = do
    shallow@RawGTFS{..} <- loadRawGtfs path
    -- TODO: sort these according to sequence numbers
    let shapes =
          V.foldr' sortShapePoint mempty
          $ V.modify (V.sortBy (compare `on` shapePtSequence))
          (fromMaybe mempty rawShapePoints)
    -- all agencies must have the same timezone, so just take the first's
    let tzname = agencyTimezone $ V.head rawAgencies
    tzseries <- getTimeZoneSeriesFromOlsonFile (zoneinforoot<>T.unpack tzname)
    let agencies' = fmap (\a -> a { agencyTimezone = tzseries }) rawAgencies
    routes' <- V.mapM (pushRoute agencies') rawRoutes
      <&> mapFromVector routeId
    stops' <- V.mapM (pushStop tzseries tzname rawStations) rawStops
    trips' <- V.mapM (pushTrip routes' stops' shapes) rawTrips
    pure $ GTFS
      { stations = mapFromVector stationId rawStations
      , trips = mapFromVector tripTripID trips'
      , calendar =
        fmap V.fromList
        $ M.fromListWith (<>)
        $ concatMap (\cal -> (, [cal]) <$> weekdays cal)
        $ V.toList (fromMaybe mempty rawCalendar)
      , calendarDates =
        fmap V.fromList
        $ M.fromListWith (<>) $ (\cd -> (caldateDate cd, [cd]))
        <$> V.toList (fromMaybe mempty rawCalendarDates)
      , shapes
      , agencies = agencies'
      , routes = routes'
      , tzseries
      }
    where
      mapFromVector :: Ord k => (a -> k) -> Vector a  -> Map k a
      mapFromVector by v = M.fromList $ fmap (\a -> (by a,a)) $ V.toList v
      weekdays Calendar{..} =
        [Monday | calMonday]
        <> [Tuesday | calTuesday]
        <> [Wednesday | calWednesday]
        <> [Thursday | calThursday]
        <> [Friday | calFriday]
        <> [Saturday | calSaturday]
        <> [Sunday | calSunday]
      pushStop :: TimeZoneSeries -> Text -> Vector Station -> Stop Shallow -> IO (Stop Deep)
      pushStop tzseries tzname stations stop = do
        station <- case tableLookup stationId (stopStation stop) stations of
          Just a -> pure a
          Nothing -> fail $ "station with id "+|stopStation stop|+" is mentioned but not defined."
        (tzseries', tzname') <- case stationTimezone station of
          Nothing -> pure (tzseries, tzname)
          Just tzname -> do
            tzseries <- getTimeZoneSeriesFromOlsonFile (T.unpack $ "/etc/zoneinfo/"<>tzname)
            pure (tzseries, tzname)
        pure $ stop { stopStation = station
                    , stopDeparture = unRawTime (stopDeparture stop) tzseries tzname
                    , stopArrival = unRawTime (stopArrival stop) tzseries tzname }
      pushTrip :: Map Text (Route Deep) -> Vector (Stop Deep) -> Map Text Shape -> Trip Shallow Shallow -> IO (Trip Deep Deep)
      pushTrip routes stops shapes trip = if V.length alongRoute < 2
          then fail $ "trip with id "+|tripTripID trip|+" has no stops"
          else do
            shape <- case M.lookup (tripShape trip) shapes of
              Nothing -> fail $ "trip with id "+|tripTripID trip|+" mentions a shape that does not exist."
              Just shape -> pure shape
            route <- case M.lookup (tripRoute trip) routes of
              Nothing -> fail $ "trip with id "+|tripTripID trip|+" specifies a route_id which does not exist."
              Just route -> pure route
            pure $ trip { tripStops = alongRoute, tripShape = shape, tripRoute = route}
        where alongRoute =
                V.modify (V.sortBy (compare `on` stopSequence))
                $ V.filter (\s -> stopTrip s == tripTripID trip) stops
      pushRoute :: Vector (Agency Deep) -> Route Shallow -> IO (Route Deep)
      pushRoute agencies route = case routeAgency route of
        Nothing -> do
          when (V.length agencies /= 1)
            $ fail $ "route "+|routeId route|+" has no agency_id specified, but there are multiple agencies specified in agency.txt"
          pure $ route {routeAgency = V.head agencies}
        Just specifiedId -> case V.headM $ V.filter (\a -> agencyId a == Just specifiedId) agencies of
          Nothing -> fail $ "route "+|routeId route|+" specifies an agency_id which does not exist."
          Just agency -> pure $ route { routeAgency = agency }


      sortShapePoint :: ShapePoint -> Map Text Shape -> Map Text Shape
      sortShapePoint ShapePoint{..} = M.alter appendPoint shapePtId
        where
          point = (shapePtLat, shapePtLong)
          appendPoint = \case
            Just shape -> Just $ shape { shapePoints = V.cons point (shapePoints shape) }
            Nothing -> Just $ Shape { shapeId = shapePtId, shapePoints = V.singleton point }


servicesOnDay :: GTFS -> Day -> Vector ServiceID
servicesOnDay GTFS{..} day =
  fmap caldateServiceId added <> V.filter notCancelled regular
  where (added,removed) =
          V.partition (\cd -> caldateExceptionType cd == ServiceAdded)
          . fromMaybe mempty $ M.lookup day calendarDates
        regular = fmap calServiceId
          $ V.filter (\Calendar{..} -> day >= calStartDate && day <= calEndDate)
          $ maybe mempty id
          $ M.lookup (dayOfWeek day) calendar
        notCancelled serviceID =
          null (tableLookup caldateServiceId serviceID removed)

tripsOfService :: GTFS -> ServiceID -> Map TripID (Trip Deep Deep)
tripsOfService GTFS{..} serviceId =
  M.filter (\trip -> tripServiceId trip == serviceId ) trips

-- TODO: this should filter out trips ending there
tripsAtStation :: GTFS -> StationID -> Vector TripID
tripsAtStation GTFS{..} at = fmap stopTrip stops
  where
    stops = V.filter (\(stop :: Stop Deep) -> stationId (stopStation stop) == at) stops

tripsOnDay :: GTFS -> Day -> Map TripID (Trip Deep Deep)
tripsOnDay gtfs today = foldMap (tripsOfService gtfs) (servicesOnDay gtfs today)

runsOnDay :: GTFS -> TripID -> Day -> Bool
runsOnDay gtfs trip day = not . null . M.filter same $ tripsOnDay gtfs day
  where same Trip{..} = tripTripID == trip

runsToday :: MonadIO m => GTFS -> TripID -> m Bool
runsToday gtfs trip = do
  today <- liftIO getCurrentTime <&> utctDay
  pure (runsOnDay gtfs trip today)

tripName :: Trip a b -> Text
tripName Trip{..} = case tripShortName of
  Just name -> name
  Nothing -> tripTripID