path: root/lib/GTFS.hs

{-# 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