souplesse

Unnamed repository; edit this file 'description' to name the repository.
Log | Files | Refs | README | LICENSE

Track.hs (3012B)

      1 {-# LANGUAGE OverloadedStrings #-}
      2 
      3 module Track
      4   ( Track,
      5     module Point,
      6     BadFile,
      7     parse,
      8     parseFile,
      9     parseBS,
     10     Track.length,
     11   )
     12 where
     13 
     14 import Control.Exception
     15 import Data.Aeson
     16 import Data.ByteString.Lazy.Char8 qualified as L
     17 import Data.Either
     18 import Data.Functor ((<&>))
     19 import Data.List as List
     20 import Data.List qualified
     21 import Data.Map as Map
     22 import Data.Maybe
     23 import Data.Text qualified
     24 import Data.Text.Lazy as T
     25 import Data.Time
     26 import Data.Time.ISO8601 qualified
     27 import Debug.Trace (trace, traceShow)
     28 import Point
     29 import Text.Read (readMaybe)
     30 import Text.XML
     31 import Text.XML.Cursor as Cursor
     32 
     33 -- TODO do we even need this type?
     34 type Track = [Point]
     35 
     36 gpxNS localName =
     37   Name localName (Just "http://www.topografix.com/GPX/1/1") Nothing
     38 
     39 tpxNS localName =
     40   Name localName (Just "http://www.garmin.com/xmlschemas/TrackPointExtension/v2") Nothing
     41 
     42 data BadFile = BadFile String deriving (Show)
     43 
     44 instance Exception BadFile
     45 
     46 elToPoint :: Cursor -> Either SomeException Point
     47 elToPoint c =
     48   let lat = listToMaybe (attribute "lat" c) >>= asDouble
     49       lon = listToMaybe (attribute "lon" c) >>= asDouble
     50       ts =
     51         listToMaybe (child c >>= element (gpxNS "time") >>= child >>= content)
     52           >>= (Data.Time.ISO8601.parseISO8601 . Data.Text.unpack)
     53       ele = listToMaybe (child c >>= element (gpxNS "ele") >>= child >>= content) >>= asDouble
     54       gpxtpx =
     55         child c
     56           >>= element (gpxNS "extensions")
     57           >>= child
     58           >>= element (tpxNS "TrackPointExtension")
     59           >>= child
     60       extn n =
     61         gpxtpx >>= element n >>= child >>= content
     62 
     63       cadence = extn (tpxNS "cad")
     64       hr = extn (tpxNS "hr")
     65       power = extn "{http://www.garmin.com/xmlschemas/PowerExtension/v1}PowerInWatts"
     66    in if isJust lat && isJust lon && isJust ts
     67         then
     68           Right $
     69             Point
     70               (Pos (fromJust lat) (fromJust lon) ele)
     71               (fromJust ts)
     72               (listToMaybe cadence >>= asInt)
     73               (listToMaybe power >>= asInt)
     74               (listToMaybe hr >>= asInt)
     75         else Left (toException (BadFile "missing a required attribute"))
     76   where
     77     asDouble v = (readMaybe :: String -> Maybe Double) (Data.Text.unpack v)
     78     asInt v = (readMaybe :: String -> Maybe Int) (Data.Text.unpack v)
     79 
     80 getPoints :: Cursor -> Either SomeException [Point]
     81 getPoints c =
     82   let trkpts =
     83         element (gpxNS "gpx") c
     84           >>= child
     85           >>= element (gpxNS "trk")
     86           >>= descendant
     87           >>= element (gpxNS "trkpt")
     88    in traverse elToPoint trkpts
     89 
     90 parse :: String -> Either SomeException [Point]
     91 parse str = do
     92   gpx <- parseText def (T.pack str)
     93   getPoints (fromDocument gpx)
     94 
     95 length :: Track -> Int
     96 length = Data.List.length
     97 
     98 -- parseFile :: FilePath -> IO [Point]
     99 parseFile name = do
    100   gpx <- Text.XML.readFile def name
    101   return $ case getPoints (fromDocument gpx) of
    102     Left err -> []
    103     Right points -> points
    104 
    105 parseBS bs = do
    106   gpx <- parseLBS def bs
    107   getPoints (fromDocument gpx)