Compare commits

..

No commits in common. "dd49bc50fa81e7f166e47641840af73a338e0d35" and "3192577d15108c3b322d46f02a76b5eb8099e1c9" have entirely different histories.

5 changed files with 35 additions and 116 deletions

View File

@ -43,12 +43,6 @@ arbitrary functions of properties (e.g. to look at power/cadence
ratio, or ... some other weirdness) ratio, or ... some other weirdness)
# Tech notes
Run tests with `cabal test --test-show-details=always`: if you don't
ask for details it won't tell you about incomplete pattern matches
---- ----
_Do not look below this line_ _Do not look below this line_
@ -58,6 +52,4 @@ _Do not look below this line_
* [done] Pos can't include elevation if it's sometimes unknown * [done] Pos can't include elevation if it's sometimes unknown
* do we even need Track? will it ever be anything more than a collection * do we even need Track? will it ever be anything more than a collection
of Points? of Points?
* [done] need a real gpx file with namespace decls before we can parse power and stuff * need a real gpx file with namespace decls before we can parse power and stuff
* tests seem to pass without <gpx> element?
* stop returning bogus data when missing required elements (e.g. time)

View File

@ -6,7 +6,6 @@ let
pkgs.haskell.lib.addBuildTools drv (with pkgs.haskellPackages; pkgs.haskell.lib.addBuildTools drv (with pkgs.haskellPackages;
[ [
cabal-install cabal-install
hlint
]); ]);
}; };
in haskellEnv.overrideAttrs(o: { in haskellEnv.overrideAttrs(o: {

View File

@ -5,14 +5,10 @@ module Track (
Pos(..), Pos(..),
pos, pos,
elevation, elevation,
cadence,
power,
time,
parse, parse,
Track.length Track.length
) where ) where
import Data.Time import Data.Time
import qualified Data.Time.ISO8601
import qualified Data.List import qualified Data.List
import Text.XML import Text.XML
import Text.XML.Cursor as Cursor import Text.XML.Cursor as Cursor
@ -32,28 +28,22 @@ data Point = Point {
pos :: Pos, pos :: Pos,
elevation :: Maybe Float, elevation :: Maybe Float,
time :: UTCTime, time :: UTCTime,
cadence :: Cadence,
power :: Power, power :: Power,
cadence :: Cadence,
heartRate :: HeartRate heartRate :: HeartRate
} deriving (Show) } deriving (Show)
-- TODO do we even need this type? -- TODO do we even need this type?
type Track = [Point] type Track = [Point]
gpxNS localName =
Name localName (Just "http://www.topografix.com/GPX/1/1") Nothing
tpxNS localName =
Name localName (Just "http://www.garmin.com/xmlschemas/TrackPointExtension/v2") Nothing
mkPoint pos = mkPoint pos =
Point Point
pos pos
Nothing Nothing
(UTCTime (toEnum 60631) 43200) (UTCTime (toEnum 60631) 43200)
Nothing (Just 0)
Nothing (Just 0)
Nothing (Just 0)
elToPoint :: Cursor -> Point elToPoint :: Cursor -> Point
elToPoint c = elToPoint c =
@ -62,38 +52,19 @@ elToPoint c =
let let
lat = getAttr "lat" lat = getAttr "lat"
lon = getAttr "lon" lon = getAttr "lon"
ele = child c >>= element (gpxNS "ele") >>= child >>= content ele = child c >>= element "ele" >>= child >>= content
ts = child c >>= element (gpxNS "time") >>= child >>= content
gpxtpx = child c >>=
element (gpxNS "extensions")
>>= child
>>= element (tpxNS "TrackPointExtension") >>= child
cadence = gpxtpx >>= element (tpxNS "cad")
>>= child >>= content
power = gpxtpx >>= element (Name "PowerInWatts" (Just "http://www.garmin.com/xmlschemas/PowerExtension/v1") Nothing)
>>= child >>= content
in Point (Pos lat lon) in Point (Pos lat lon)
(case ele of (case ele of
[e] -> Just $ asFloat e e:[] -> Just $ asFloat e
_ -> Nothing) _ -> Nothing)
(case ts of (UTCTime (toEnum 60631) 43200)
[e] -> case Data.Time.ISO8601.parseISO8601 (Data.Text.unpack e) of (Just 0)
Just utime -> utime (Just 0)
_ -> UTCTime (toEnum 0) 0 (Just 0)
_ -> UTCTime (toEnum 0) 0)
(case cadence of
[e] -> Just (asInt e)
_ -> Nothing)
(case power of
[e] -> Just (asInt e)
_ -> Nothing)
Nothing
where where
asFloat v = (read (Data.Text.unpack v) :: Float) asFloat v = (read (Data.Text.unpack v) :: Float)
asInt v = (read (Data.Text.unpack v) :: Int)
getAttr name = getAttr name =
case Map.lookup name attrs of case (Map.lookup name attrs) of
Just v -> asFloat v Just v -> asFloat v
_ -> 0 _ -> 0
_ -> mkPoint (Pos 0 0) _ -> mkPoint (Pos 0 0)
@ -102,9 +73,9 @@ getPoints :: Cursor -> [Point]
getPoints c = getPoints c =
let let
trkpts = trkpts =
element (gpxNS "gpx") c >>= child >>= child c >>=
element (gpxNS "trk") >>= descendant >>= element "trk" >>= descendant >>=
element (gpxNS "trkpt") element "trkpt"
in in
List.map elToPoint trkpts List.map elToPoint trkpts
@ -114,4 +85,4 @@ parse str = do
return (getPoints (fromDocument gpx)) return (getPoints (fromDocument gpx))
length :: Track -> Int length :: Track -> Int
length = Data.List.length length trk = Data.List.length trk

View File

@ -90,7 +90,7 @@ library souplesse-lib
, time , time
, containers , containers
, text , text
, iso8601-time -- , text-iso8601
default-language: GHC2021 default-language: GHC2021
test-suite tests test-suite tests
@ -101,7 +101,5 @@ test-suite tests
build-depends: build-depends:
base >=4.7 && <5 base >=4.7 && <5
, souplesse-lib , souplesse-lib
, raw-strings-qq
, time
, HUnit , HUnit
default-language: GHC2021 default-language: GHC2021

View File

@ -1,69 +1,32 @@
{-# LANGUAGE QuasiQuotes #-}
module Main where module Main where
import qualified Track import qualified Track
import Text.RawString.QQ(r)
import Test.HUnit import Test.HUnit
import qualified System.Exit as Exit import qualified System.Exit as Exit
import Control.Exception import Control.Exception
import Debug.Trace (trace, traceShow) import Debug.Trace (trace, traceShow)
import qualified Data.Time
preamble = [r| onepoint =
<?xml version="1.0" encoding="UTF-8"?> "<gpx> <trk> <trkseg> \n\
<gpx \<trkpt lat=\"51\" lon=\"-0.1\"> </trkpt> \n\
version="1.1" \</trkseg> </trk> </gpx>"
creator="OpenTracks" onepointEle =
xmlns="http://www.topografix.com/GPX/1/1" "<gpx> <trk> <trkseg> \n\
xmlns:topografix="http://www.topografix.com/GPX/Private/TopoGrafix/0/1" \<trkpt lat=\"51\" lon=\"-0.1\"> \n\
xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" \ <ele>25.2</ele>\n\
xmlns:opentracks="http://opentracksapp.com/xmlschemas/v1" \</trkpt> \n\
xmlns:gpxtpx="http://www.garmin.com/xmlschemas/TrackPointExtension/v2" \</trkseg> </trk> </gpx>"
xmlns:gpxtrkx="http://www.garmin.com/xmlschemas/TrackStatsExtension/v1"
xmlns:cluetrust="http://www.cluetrust.com/Schemas/"
xmlns:pwr="http://www.garmin.com/xmlschemas/PowerExtension/v1"
xsi:schemaLocation="http://www.topografix.com/GPX/1/1 http://www.topografix.com/GPX/1/1/gpx.xsd http://www.topografix.com/GPX/Private/TopoGrafix/0/1 http://www.topografix.com/GPX/Private/TopoGrafix/0/1/topografix.xsd http://www.garmin.com/xmlschemas/TrackPointExtension/v2 https://www8.garmin.com/xmlschemas/TrackPointExtensionv2.xsd http://www.garmin.com/xmlschemas/PowerExtension/v1 https://www8.garmin.com/xmlschemas/PowerExtensionv1.xsd http://www.garmin.com/xmlschemas/TrackStatsExtension/v1 http://www.cluetrust.com/Schemas http://www.cluetrust.com/Schemas/gpxdata10.xsd http://opentracksapp.com/xmlschemas/v1 http://opentracksapp.com/xmlschemas/OpenTracks_v1.xsd">
|]
wrap x = preamble ++ x ++ "</gpx>"
onepoint = wrap [r|
<trk> <trkseg>
<trkpt lat="51" lon="-0.1"> </trkpt>
</trkseg> </trk>
|]
onepointWithAttrs = wrap [r|
<trk>
<trkseg>
<trkpt lat="51" lon="-0.1">
<ele>25.2</ele>
<time>2024-10-23T08:34:59.779+01:00</time>
<extensions><gpxtpx:TrackPointExtension>
<gpxtpx:speed>2.4</gpxtpx:speed>
<gpxtpx:cad>128</gpxtpx:cad>
<pwr:PowerInWatts>55</pwr:PowerInWatts>
<opentracks:accuracy_horizontal>3.216</opentracks:accuracy_horizontal><opentracks:distance>10.675</opentracks:distance>
<cluetrust:distance>32.025</cluetrust:distance>
</gpxtpx:TrackPointExtension>
</extensions>
</trkpt>
</trkseg>
</trk>
|]
test1 = TestCase $ test1 = TestCase $
case Track.parse (wrap "") of case Track.parse "<gpx></gpx>" of
Left err -> assertFailure (displayException err) Left err -> assertFailure (displayException err)
Right t -> assertEqual "empty track has no elements" Right t -> assertEqual "empty track has no elements"
0 (Track.length t) 0 (Track.length t)
testMalformed = TestCase $ testMalformed = TestCase $
case Track.parse (wrap "<dgdsfg>>") of case Track.parse "<gpx><dgdsfg>></gpx>" of
Left err -> assertBool "syntax error" True Left err -> assertBool "syntax error" True
Right _ -> assertFailure "no error message parsing bad xml" Right t -> assertFailure "no error message parsing bad xml"
test2 = TestCase $ test2 = TestCase $
case Track.parse onepoint case Track.parse onepoint
@ -73,26 +36,22 @@ test2 = TestCase $
assertEqual "matches lat/lon" assertEqual "matches lat/lon"
(Track.Pos 51.0 (-0.1)) (Track.Pos 51.0 (-0.1))
(Track.pos p) (Track.pos p)
Right [] -> assertFailure "no points"
test3 = TestCase $ test3 = TestCase $
case Track.parse onepoint case Track.parse onepoint
of of
Left err -> assertFailure (displayException err) Left err -> assertFailure (displayException err)
Right (p:ps) -> Right (p:ps) ->
assertEqual "matches attributes" assertEqual "matches elevation"
(Nothing, Nothing) (Track.elevation p, Track.cadence p) Nothing (Track.elevation p)
Right [] -> assertFailure "no points"
test4 = TestCase $ test4 = TestCase $
case Track.parse onepointWithAttrs case Track.parse onepointEle
of of
Left err -> assertFailure (displayException err) Left err -> assertFailure (displayException err)
Right (p:ps) -> Right (p:ps) ->
assertEqual "matches attributes" assertEqual "matches elevation"
(Just 25.2, Just 128, Just 55, Data.Time.UTCTime (toEnum 60606) 27299.779) (Just 25.2) (Track.elevation p)
(Track.elevation p, Track.cadence p, Track.power p, Track.time p)
Right [] -> assertFailure "no points"
tests :: Test tests :: Test
tests = TestList [ tests = TestList [