dan/souplesse
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Compare commits

base: dan:7860a189b35c73835929ad4fd2e807dedd5e0056
Branches Tags
dan:main
..
compare: dan:7af52b4fbfd953cd1ed659d09232cfa5c7dbed6f
Branches Tags
dan:main

No commits in common. "7860a189b35c73835929ad4fd2e807dedd5e0056" and "7af52b4fbfd953cd1ed659d09232cfa5c7dbed6f" have entirely different histories.
7860a189b3 ... 7af52b4fbf

2 changed files with 42 additions and 81 deletions
Show Stats Expand all files Collapse all files

66
lib/Track.hs
View File

@ -3,11 +3,10 @@
module Track module Track
( Track, ( Track,
Pos (..), Pos (..),
BadFile,
pos, pos,
elevation,
cadence, cadence,
power, power,
heartRate,
time, time,
parse, parse,
Track.length, Track.length,
@ -15,7 +14,6 @@ module Track
where where
import Control.Exception import Control.Exception
import Data.Functor ((<&>))
import Data.List as List import Data.List as List
import Data.List qualified import Data.List qualified
import Data.Map as Map import Data.Map as Map
@ -27,8 +25,9 @@ import Data.Time.ISO8601 qualified
import Debug.Trace (trace, traceShow) import Debug.Trace (trace, traceShow)
import Text.XML import Text.XML
import Text.XML.Cursor as Cursor import Text.XML.Cursor as Cursor
import Text.Read (readMaybe) import Data.Functor((<&>))
data Pos = Pos Float Float (Maybe Float) deriving (Show, Eq)
data Pos = Pos Float Float deriving (Show, Eq)
type Power = Maybe Int type Power = Maybe Int
@ -38,6 +37,7 @@ type HeartRate = Maybe Int
data Point = Point data Point = Point
{ pos :: Pos, { pos :: Pos,
elevation :: Maybe Float,
time :: UTCTime, time :: UTCTime,
cadence :: Cadence, cadence :: Cadence,
power :: Power, power :: Power,
@ -54,7 +54,8 @@ gpxNS localName =
tpxNS localName = tpxNS localName =
Name localName (Just "http://www.garmin.com/xmlschemas/TrackPointExtension/v2") Nothing Name localName (Just "http://www.garmin.com/xmlschemas/TrackPointExtension/v2") Nothing
data BadFile = BadFile String deriving (Show)
data BadFile = BadFile deriving (Show)
instance Exception BadFile instance Exception BadFile
@ -62,38 +63,45 @@ elToPoint :: Cursor -> Either SomeException Point
elToPoint c = elToPoint c =
case node c of case node c of
NodeElement (Element _ attrs _) -> NodeElement (Element _ attrs _) ->
let lat = (listToMaybe $ attribute "lat" c ) >>= asFloat let lat = getAttr "lat"
lon = (listToMaybe $ attribute "lon" c ) >>= asFloat lon = getAttr "lon"
ele = listToMaybe $ child c >>= element (gpxNS "ele") >>= child >>= content ele = child c >>= element (gpxNS "ele") >>= child >>= content
ts = ts = child c >>= element (gpxNS "time") >>= child >>= content
listToMaybe (child c >>= element (gpxNS "time") >>= child >>= content)
>>= (Data.Time.ISO8601.parseISO8601 . Data.Text.unpack)
gpxtpx = gpxtpx =
child c child c
>>= element (gpxNS "extensions") >>= element (gpxNS "extensions")
>>= child >>= child
>>= element (tpxNS "TrackPointExtension") >>= element (tpxNS "TrackPointExtension")
>>= child >>= child
extn n = cadence =
gpxtpx >>= element n >>= child >>= content gpxtpx
>>= element (tpxNS "cad")
cadence = extn (tpxNS "cad") >>= child
hr = extn (tpxNS "hr") >>= content
power = extn "{http://www.garmin.com/xmlschemas/PowerExtension/v1}PowerInWatts" power =
in if isJust lat && isJust lon && isJust ts gpxtpx
then >>= element (Name "PowerInWatts" (Just "http://www.garmin.com/xmlschemas/PowerExtension/v1") Nothing)
>>= child
>>= content
parsedTime =
listToMaybe ts
>>= (Data.Time.ISO8601.parseISO8601 . Data.Text.unpack)
in case parsedTime of
Nothing -> Left (toException BadFile)
Just utime ->
Right $ Right $
Point Point
(Pos (fromJust lat) (fromJust lon) (ele >>= asFloat)) (Pos lat lon)
(fromJust ts) (listToMaybe ele <&> asFloat)
(listToMaybe cadence >>= asInt) utime
(listToMaybe power >>= asInt) (listToMaybe cadence <&> asInt)
(listToMaybe hr >>= asInt) (listToMaybe power <&> asInt)
else Left (toException (BadFile "missing a required attribute")) Nothing
where where
asFloat v = return (Data.Text.unpack v) >>= (readMaybe :: String -> Maybe Float) asFloat v = (read (Data.Text.unpack v) :: Float)
asInt v = return (Data.Text.unpack v) >>= (readMaybe :: String -> Maybe Int) asInt v = (read (Data.Text.unpack v) :: Int)
_ -> Left (toException (BadFile "did not find trkpt")) getAttr name = maybe 0 asFloat (Map.lookup name attrs)
_ -> Left (toException BadFile)
getPoints :: Cursor -> Either SomeException [Point] getPoints :: Cursor -> Either SomeException [Point]
getPoints c = getPoints c =

57
tests/UnitTest.hs
View File

@ -5,7 +5,6 @@ module Main where
import Control.Exception import Control.Exception
import Data.Either import Data.Either
import Data.Time qualified import Data.Time qualified
import Data.List as List
import Debug.Trace (trace, traceShow) import Debug.Trace (trace, traceShow)
import System.Exit qualified as Exit import System.Exit qualified as Exit
import Test.HUnit import Test.HUnit
@ -31,10 +30,6 @@ xsi:schemaLocation="http://www.topografix.com/GPX/1/1 http://www.topografix.com/
wrap x = preamble ++ x ++ "</gpx>" wrap x = preamble ++ x ++ "</gpx>"
wrapPoint x =
let trk = "<trk><trkseg>" ++ x ++ "</trkseg></trk>"
in wrap trk
onepoint = onepoint =
wrap wrap
[r| [r|
@ -56,7 +51,6 @@ onepointWithAttrs =
<extensions><gpxtpx:TrackPointExtension> <extensions><gpxtpx:TrackPointExtension>
<gpxtpx:speed>2.4</gpxtpx:speed> <gpxtpx:speed>2.4</gpxtpx:speed>
<gpxtpx:cad>128</gpxtpx:cad> <gpxtpx:cad>128</gpxtpx:cad>
<gpxtpx:hr>160</gpxtpx:hr>
<pwr:PowerInWatts>55</pwr:PowerInWatts> <pwr:PowerInWatts>55</pwr:PowerInWatts>
<opentracks:accuracy_horizontal>3.216</opentracks:accuracy_horizontal><opentracks:distance>10.675</opentracks:distance> <opentracks:accuracy_horizontal>3.216</opentracks:accuracy_horizontal><opentracks:distance>10.675</opentracks:distance>
<cluetrust:distance>32.025</cluetrust:distance> <cluetrust:distance>32.025</cluetrust:distance>
@ -83,57 +77,17 @@ testMalformed =
let trk = Track.parse (wrap "<dgdsfg>>") let trk = Track.parse (wrap "<dgdsfg>>")
in assertBool "catches syntax error" (isLeft trk) in assertBool "catches syntax error" (isLeft trk)
testMissingAttrs =
let els = [
[r|
<trkpt lon="2" latsdf="51">
<time>2024-10-23T08:34:59.779+01:00</time>
</trkpt>
|],
[r|
<trkpt lon="dsfgsdfg" lat="51">
<time>2024-10-23T08:34:59.779+01:00</time>
</trkpt>
|],
[r|
<trkpt lon="2" lat="51">
<time>2024-10-23G87sdCfdfgsdfhg</time>
</trkpt>
|]
]
in
TestCase $
assertBool
"failed to catch missing/malformed attribute"
(List.all isLeft
(List.map (\ text -> Track.parse (wrapPoint text))
els))
test2 = test2 =
TestList [
TestCase $ TestCase $
either either
(assertFailure . displayException) (assertFailure . displayException)
( \(p : _) -> ( \(p : _) ->
assertEqual assertEqual
"matches lat/lon" "matches lat/lon"
(Track.Pos 51.0 (-0.1) Nothing) (Track.Pos 51.0 (-0.1))
(Track.pos p) (Track.pos p)
) )
(Track.parse onepoint), (Track.parse onepoint)
TestCase $
either
(assertFailure . displayException)
( \(p : _) ->
assertEqual
"matches lat/lon"
(Track.Pos 51.0 (-0.1) (Just 25.2))
(Track.pos p)
)
(Track.parse onepointWithAttrs)
]
test3 = test3 =
TestCase $ TestCase $
@ -143,7 +97,7 @@ test3 =
assertEqual assertEqual
"handles missing attributes" "handles missing attributes"
(Nothing, Nothing) (Nothing, Nothing)
(Track.power p, Track.cadence p) (Track.elevation p, Track.cadence p)
) )
(Track.parse onepoint) (Track.parse onepoint)
@ -154,8 +108,8 @@ test4 =
( \(p : _) -> ( \(p : _) ->
assertEqual assertEqual
"handles attributes" "handles attributes"
(Just 128, Just 55, Data.Time.UTCTime (toEnum 60606) 27299.779, Just 160) (Just 25.2, Just 128, Just 55, Data.Time.UTCTime (toEnum 60606) 27299.779)
(Track.cadence p, Track.power p, Track.time p, Track.heartRate p) (Track.elevation p, Track.cadence p, Track.power p, Track.time p)
) )
(Track.parse onepointWithAttrs) (Track.parse onepointWithAttrs)
@ -164,7 +118,6 @@ tests =
TestList TestList
[ test1, [ test1,
testMalformed, testMalformed,
testMissingAttrs,
test2, test2,
test3, test3,
test4 test4