diff --git a/default.nix b/default.nix index a82412b..ad3f07f 100644 --- a/default.nix +++ b/default.nix @@ -7,6 +7,7 @@ let [ cabal-install hlint + ormolu ]); }; in haskellEnv.overrideAttrs(o: { diff --git a/lib/Track.hs b/lib/Track.hs index f8a5451..d48246c 100644 --- a/lib/Track.hs +++ b/lib/Track.hs @@ -1,41 +1,47 @@ {-# LANGUAGE OverloadedStrings #-} -module Track ( - Track, - Pos(..), - pos, - elevation, - cadence, - power, - time, - parse, - Track.length - ) where +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 import Data.Time -import qualified Data.Time.ISO8601 -import qualified Data.List +import Data.Time.ISO8601 qualified +import Debug.Trace (trace, traceShow) 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] @@ -50,7 +56,7 @@ mkPoint pos = Point pos Nothing - (UTCTime (toEnum 60631) 43200) + (UTCTime (toEnum 60631) 43200) Nothing Nothing Nothing @@ -59,36 +65,47 @@ 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) @@ -100,13 +117,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 diff --git a/tests/UnitTest.hs b/tests/UnitTest.hs index 08a35d9..d6a1be1 100644 --- a/tests/UnitTest.hs +++ b/tests/UnitTest.hs @@ -2,17 +2,17 @@ module Main where -import qualified Track - -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 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 -preamble = [r| +preamble = + [r| |] + wrap x = preamble ++ x ++ "" - -onepoint = wrap [r| +onepoint = + wrap + [r| |] -onepointWithAttrs = wrap [r| +onepointWithAttrs = + wrap + [r| @@ -55,55 +59,72 @@ onepointWithAttrs = wrap [r| |] -test1 = TestCase $ - either - (assertFailure . displayException) - (\ t -> assertEqual "empty track has no elements" - 0 (Track.length t)) - (Track.parse (wrap "")) +test1 = + TestCase $ + either + (assertFailure . displayException) + ( \t -> + assertEqual + "empty track has no elements" + 0 + (Track.length t) + ) + (Track.parse (wrap "")) -testMalformed = TestCase $ - let trk = Track.parse (wrap ">") - in assertBool "catches syntax error" (isLeft trk) +testMalformed = + TestCase $ + let trk = Track.parse (wrap ">") + in assertBool "catches syntax error" (isLeft trk) -test2 = TestCase $ - either - (assertFailure . displayException) - (\ (p:_) -> - assertEqual "matches lat/lon" - (Track.Pos 51.0 (-0.1)) - (Track.pos p)) - (Track.parse onepoint) +test2 = + TestCase $ + either + (assertFailure . displayException) + ( \(p : _) -> + assertEqual + "matches lat/lon" + (Track.Pos 51.0 (-0.1)) + (Track.pos p) + ) + (Track.parse onepoint) -test3 = TestCase $ - either - (assertFailure . displayException) - (\ (p:_) -> - assertEqual "handles missing attributes" - (Nothing, Nothing) (Track.elevation p, Track.cadence p)) - (Track.parse onepoint) +test3 = + TestCase $ + either + (assertFailure . displayException) + ( \(p : _) -> + assertEqual + "handles missing attributes" + (Nothing, Nothing) + (Track.elevation p, Track.cadence p) + ) + (Track.parse onepoint) -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 $ + 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) 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) || (errors result > 0) + then Exit.exitFailure + else Exit.exitSuccess