Compare commits
No commits in common. "2befb534a17c45cc8d1a6541362efe0db421ca25" and "dd49bc50fa81e7f166e47641840af73a338e0d35" have entirely different histories.
2befb534a1
...
dd49bc50fa
@ -7,7 +7,6 @@ let
|
||||
[
|
||||
cabal-install
|
||||
hlint
|
||||
ormolu
|
||||
]);
|
||||
};
|
||||
in haskellEnv.overrideAttrs(o: {
|
||||
|
||||
147
lib/Track.hs
147
lib/Track.hs
@ -1,47 +1,41 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Track
|
||||
( Track,
|
||||
Pos (..),
|
||||
pos,
|
||||
elevation,
|
||||
cadence,
|
||||
power,
|
||||
time,
|
||||
parse,
|
||||
Track.length,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Exception
|
||||
import Data.List as List
|
||||
import Data.List qualified
|
||||
import Data.Map as Map
|
||||
import Data.Text qualified
|
||||
import Data.Text.Lazy as T
|
||||
module Track (
|
||||
Track,
|
||||
Pos(..),
|
||||
pos,
|
||||
elevation,
|
||||
cadence,
|
||||
power,
|
||||
time,
|
||||
parse,
|
||||
Track.length
|
||||
) where
|
||||
import Data.Time
|
||||
import Data.Time.ISO8601 qualified
|
||||
import Debug.Trace (trace, traceShow)
|
||||
import qualified Data.Time.ISO8601
|
||||
import qualified Data.List
|
||||
import Text.XML
|
||||
import Text.XML.Cursor as Cursor
|
||||
import qualified Data.Text
|
||||
import Data.Text.Lazy as T
|
||||
import Debug.Trace (trace, traceShow)
|
||||
import Data.List as List
|
||||
import Data.Map as Map
|
||||
import Control.Exception
|
||||
|
||||
data Pos = Pos Float Float deriving (Show, Eq)
|
||||
|
||||
type Power = Maybe Int
|
||||
|
||||
type Cadence = Maybe Int
|
||||
|
||||
type HeartRate = Maybe Int
|
||||
|
||||
data Point = Point
|
||||
{ pos :: Pos,
|
||||
elevation :: Maybe Float,
|
||||
time :: UTCTime,
|
||||
cadence :: Cadence,
|
||||
power :: Power,
|
||||
heartRate :: HeartRate
|
||||
}
|
||||
deriving (Show)
|
||||
data Point = Point {
|
||||
pos :: Pos,
|
||||
elevation :: Maybe Float,
|
||||
time :: UTCTime,
|
||||
cadence :: Cadence,
|
||||
power :: Power,
|
||||
heartRate :: HeartRate
|
||||
} deriving (Show)
|
||||
|
||||
-- TODO do we even need this type?
|
||||
type Track = [Point]
|
||||
@ -56,7 +50,7 @@ mkPoint pos =
|
||||
Point
|
||||
pos
|
||||
Nothing
|
||||
(UTCTime (toEnum 60631) 43200)
|
||||
(UTCTime (toEnum 60631) 43200)
|
||||
Nothing
|
||||
Nothing
|
||||
Nothing
|
||||
@ -65,47 +59,36 @@ elToPoint :: Cursor -> Point
|
||||
elToPoint c =
|
||||
case node c of
|
||||
NodeElement (Element _ attrs _) ->
|
||||
let lat = getAttr "lat"
|
||||
lon = getAttr "lon"
|
||||
ele = child c >>= element (gpxNS "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)
|
||||
( case ele of
|
||||
[e] -> Just $ asFloat e
|
||||
_ -> Nothing
|
||||
)
|
||||
( case ts of
|
||||
[e] -> case Data.Time.ISO8601.parseISO8601 (Data.Text.unpack e) of
|
||||
Just utime -> utime
|
||||
_ -> UTCTime (toEnum 0) 0
|
||||
_ -> UTCTime (toEnum 0) 0
|
||||
)
|
||||
( case cadence of
|
||||
[e] -> Just (asInt e)
|
||||
_ -> Nothing
|
||||
)
|
||||
( case power of
|
||||
[e] -> Just (asInt e)
|
||||
_ -> Nothing
|
||||
)
|
||||
Nothing
|
||||
let
|
||||
lat = getAttr "lat"
|
||||
lon = getAttr "lon"
|
||||
ele = child c >>= element (gpxNS "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)
|
||||
(case ele of
|
||||
[e] -> Just $ asFloat e
|
||||
_ -> Nothing)
|
||||
(case ts of
|
||||
[e] -> case Data.Time.ISO8601.parseISO8601 (Data.Text.unpack e) of
|
||||
Just utime -> utime
|
||||
_ -> UTCTime (toEnum 0) 0
|
||||
_ -> UTCTime (toEnum 0) 0)
|
||||
(case cadence of
|
||||
[e] -> Just (asInt e)
|
||||
_ -> Nothing)
|
||||
(case power of
|
||||
[e] -> Just (asInt e)
|
||||
_ -> Nothing)
|
||||
Nothing
|
||||
|
||||
where
|
||||
asFloat v = (read (Data.Text.unpack v) :: Float)
|
||||
asInt v = (read (Data.Text.unpack v) :: Int)
|
||||
@ -117,13 +100,13 @@ elToPoint c =
|
||||
|
||||
getPoints :: Cursor -> [Point]
|
||||
getPoints c =
|
||||
let trkpts =
|
||||
element (gpxNS "gpx") c
|
||||
>>= child
|
||||
>>= element (gpxNS "trk")
|
||||
>>= descendant
|
||||
>>= element (gpxNS "trkpt")
|
||||
in List.map elToPoint trkpts
|
||||
let
|
||||
trkpts =
|
||||
element (gpxNS "gpx") c >>= child >>=
|
||||
element (gpxNS "trk") >>= descendant >>=
|
||||
element (gpxNS "trkpt")
|
||||
in
|
||||
List.map elToPoint trkpts
|
||||
|
||||
parse :: String -> Either SomeException [Point]
|
||||
parse str = do
|
||||
|
||||
@ -2,17 +2,16 @@
|
||||
|
||||
module Main where
|
||||
|
||||
import Control.Exception
|
||||
import Data.Either
|
||||
import Data.Time qualified
|
||||
import Debug.Trace (trace, traceShow)
|
||||
import System.Exit qualified as Exit
|
||||
import Test.HUnit
|
||||
import Text.RawString.QQ (r)
|
||||
import Track qualified
|
||||
import qualified Track
|
||||
|
||||
preamble =
|
||||
[r|
|
||||
import Text.RawString.QQ(r)
|
||||
import Test.HUnit
|
||||
import qualified System.Exit as Exit
|
||||
import Control.Exception
|
||||
import Debug.Trace (trace, traceShow)
|
||||
import qualified Data.Time
|
||||
|
||||
preamble = [r|
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<gpx
|
||||
version="1.1"
|
||||
@ -27,20 +26,16 @@ 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|
|
||||
|
||||
onepoint = wrap [r|
|
||||
<trk> <trkseg>
|
||||
<trkpt lat="51" lon="-0.1"> </trkpt>
|
||||
</trkseg> </trk>
|
||||
|]
|
||||
|
||||
onepointWithAttrs =
|
||||
wrap
|
||||
[r|
|
||||
onepointWithAttrs = wrap [r|
|
||||
<trk>
|
||||
<trkseg>
|
||||
<trkpt lat="51" lon="-0.1">
|
||||
@ -59,71 +54,56 @@ onepointWithAttrs =
|
||||
</trk>
|
||||
|]
|
||||
|
||||
test1 =
|
||||
TestCase $
|
||||
either
|
||||
(assertFailure . displayException)
|
||||
( assertEqual
|
||||
"empty track has no elements"
|
||||
0
|
||||
. Track.length
|
||||
)
|
||||
(Track.parse (wrap ""))
|
||||
test1 = TestCase $
|
||||
case Track.parse (wrap "") of
|
||||
Left err -> assertFailure (displayException err)
|
||||
Right t -> assertEqual "empty track has no elements"
|
||||
0 (Track.length t)
|
||||
|
||||
testMalformed =
|
||||
TestCase $
|
||||
let trk = Track.parse (wrap "<dgdsfg>>")
|
||||
in assertBool "catches syntax error" (isLeft trk)
|
||||
testMalformed = TestCase $
|
||||
case Track.parse (wrap "<dgdsfg>>") of
|
||||
Left err -> assertBool "syntax error" True
|
||||
Right _ -> assertFailure "no error message parsing bad xml"
|
||||
|
||||
test2 =
|
||||
TestCase $
|
||||
either
|
||||
(assertFailure . displayException)
|
||||
( \(p : _) ->
|
||||
assertEqual
|
||||
"matches lat/lon"
|
||||
(Track.Pos 51.0 (-0.1))
|
||||
(Track.pos p)
|
||||
)
|
||||
(Track.parse onepoint)
|
||||
test2 = TestCase $
|
||||
case Track.parse onepoint
|
||||
of
|
||||
Left err -> assertFailure (displayException err)
|
||||
Right (p:ps) ->
|
||||
assertEqual "matches lat/lon"
|
||||
(Track.Pos 51.0 (-0.1))
|
||||
(Track.pos p)
|
||||
Right [] -> assertFailure "no points"
|
||||
|
||||
test3 =
|
||||
TestCase $
|
||||
either
|
||||
(assertFailure . displayException)
|
||||
( \(p : _) ->
|
||||
assertEqual
|
||||
"handles missing attributes"
|
||||
(Nothing, Nothing)
|
||||
(Track.elevation p, Track.cadence p)
|
||||
)
|
||||
(Track.parse onepoint)
|
||||
test3 = TestCase $
|
||||
case Track.parse onepoint
|
||||
of
|
||||
Left err -> assertFailure (displayException err)
|
||||
Right (p:ps) ->
|
||||
assertEqual "matches attributes"
|
||||
(Nothing, Nothing) (Track.elevation p, Track.cadence p)
|
||||
Right [] -> assertFailure "no points"
|
||||
|
||||
test4 =
|
||||
TestCase $
|
||||
either
|
||||
(assertFailure . displayException)
|
||||
( \(p : _) ->
|
||||
assertEqual
|
||||
"handles attributes"
|
||||
(Just 25.2, Just 128, Just 55, Data.Time.UTCTime (toEnum 60606) 27299.779)
|
||||
(Track.elevation p, Track.cadence p, Track.power p, Track.time p)
|
||||
)
|
||||
(Track.parse onepointWithAttrs)
|
||||
test4 = TestCase $
|
||||
case Track.parse onepointWithAttrs
|
||||
of
|
||||
Left err -> assertFailure (displayException err)
|
||||
Right (p:ps) ->
|
||||
assertEqual "matches attributes"
|
||||
(Just 25.2, Just 128, Just 55, Data.Time.UTCTime (toEnum 60606) 27299.779)
|
||||
(Track.elevation p, Track.cadence p, Track.power p, Track.time p)
|
||||
Right [] -> assertFailure "no points"
|
||||
|
||||
tests :: Test
|
||||
tests =
|
||||
TestList
|
||||
[ test1,
|
||||
testMalformed,
|
||||
test2,
|
||||
test3,
|
||||
test4
|
||||
]
|
||||
tests = TestList [
|
||||
test1,
|
||||
testMalformed,
|
||||
test2,
|
||||
test3,
|
||||
test4
|
||||
]
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
result <- runTestTT tests
|
||||
if (failures result > 0) || (errors result > 0)
|
||||
then Exit.exitFailure
|
||||
else Exit.exitSuccess
|
||||
result <- runTestTT tests
|
||||
if failures result > 0 then Exit.exitFailure else Exit.exitSuccess
|
||||
|
||||
Loading…
Reference in New Issue
Block a user