reindent using ormolu

This commit is contained in:
Daniel Barlow 2024-10-30 21:03:11 +00:00
parent 31ba15f5a9
commit aa1f69f3d4
3 changed files with 158 additions and 119 deletions

View File

@ -7,6 +7,7 @@ let
[ [
cabal-install cabal-install
hlint hlint
ormolu
]); ]);
}; };
in haskellEnv.overrideAttrs(o: { in haskellEnv.overrideAttrs(o: {

View File

@ -1,41 +1,47 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Track ( module Track
Track, ( Track,
Pos(..), Pos (..),
pos, pos,
elevation, elevation,
cadence, cadence,
power, power,
time, time,
parse, parse,
Track.length Track.length,
) where )
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 Data.Time
import qualified Data.Time.ISO8601 import Data.Time.ISO8601 qualified
import qualified Data.List import Debug.Trace (trace, traceShow)
import Text.XML import Text.XML
import Text.XML.Cursor as Cursor 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) data Pos = Pos Float Float deriving (Show, Eq)
type Power = Maybe Int type Power = Maybe Int
type Cadence = Maybe Int type Cadence = Maybe Int
type HeartRate = Maybe Int type HeartRate = Maybe Int
data Point = Point { data Point = Point
pos :: Pos, { pos :: Pos,
elevation :: Maybe Float, elevation :: Maybe Float,
time :: UTCTime, time :: UTCTime,
cadence :: Cadence, cadence :: Cadence,
power :: Power, power :: Power,
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]
@ -50,7 +56,7 @@ mkPoint pos =
Point Point
pos pos
Nothing Nothing
(UTCTime (toEnum 60631) 43200) (UTCTime (toEnum 60631) 43200)
Nothing Nothing
Nothing Nothing
Nothing Nothing
@ -59,36 +65,47 @@ elToPoint :: Cursor -> Point
elToPoint c = elToPoint c =
case node c of case node c of
NodeElement (Element _ attrs _) -> NodeElement (Element _ attrs _) ->
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 (gpxNS "ele") >>= child >>= content ts = child c >>= element (gpxNS "time") >>= child >>= content
ts = child c >>= element (gpxNS "time") >>= child >>= content gpxtpx =
gpxtpx = child c >>= child c
element (gpxNS "extensions") >>= element (gpxNS "extensions")
>>= child >>= child
>>= element (tpxNS "TrackPointExtension") >>= child >>= element (tpxNS "TrackPointExtension")
cadence = gpxtpx >>= element (tpxNS "cad") >>= child
>>= child >>= content cadence =
power = gpxtpx >>= element (Name "PowerInWatts" (Just "http://www.garmin.com/xmlschemas/PowerExtension/v1") Nothing) gpxtpx
>>= child >>= content >>= element (tpxNS "cad")
in Point (Pos lat lon) >>= child
(case ele of >>= content
[e] -> Just $ asFloat e power =
_ -> Nothing) gpxtpx
(case ts of >>= element (Name "PowerInWatts" (Just "http://www.garmin.com/xmlschemas/PowerExtension/v1") Nothing)
[e] -> case Data.Time.ISO8601.parseISO8601 (Data.Text.unpack e) of >>= child
Just utime -> utime >>= content
_ -> UTCTime (toEnum 0) 0 in Point
_ -> UTCTime (toEnum 0) 0) (Pos lat lon)
(case cadence of ( case ele of
[e] -> Just (asInt e) [e] -> Just $ asFloat e
_ -> Nothing) _ -> Nothing
(case power of )
[e] -> Just (asInt e) ( case ts of
_ -> Nothing) [e] -> case Data.Time.ISO8601.parseISO8601 (Data.Text.unpack e) of
Nothing 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 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) asInt v = (read (Data.Text.unpack v) :: Int)
@ -100,13 +117,13 @@ elToPoint c =
getPoints :: Cursor -> [Point] getPoints :: Cursor -> [Point]
getPoints c = getPoints c =
let let trkpts =
trkpts = element (gpxNS "gpx") c
element (gpxNS "gpx") c >>= child >>= >>= child
element (gpxNS "trk") >>= descendant >>= >>= element (gpxNS "trk")
element (gpxNS "trkpt") >>= descendant
in >>= element (gpxNS "trkpt")
List.map elToPoint trkpts in List.map elToPoint trkpts
parse :: String -> Either SomeException [Point] parse :: String -> Either SomeException [Point]
parse str = do parse str = do

View File

@ -2,17 +2,17 @@
module Main where module Main where
import qualified Track
import Text.RawString.QQ(r)
import Test.HUnit
import qualified System.Exit as Exit
import Control.Exception import Control.Exception
import Debug.Trace (trace, traceShow)
import qualified Data.Time
import Data.Either 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|
<?xml version="1.0" encoding="UTF-8"?> <?xml version="1.0" encoding="UTF-8"?>
<gpx <gpx
version="1.1" version="1.1"
@ -27,16 +27,20 @@ xmlns:cluetrust="http://www.cluetrust.com/Schemas/"
xmlns:pwr="http://www.garmin.com/xmlschemas/PowerExtension/v1" 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"> 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>" wrap x = preamble ++ x ++ "</gpx>"
onepoint =
onepoint = wrap [r| wrap
[r|
<trk> <trkseg> <trk> <trkseg>
<trkpt lat="51" lon="-0.1"> </trkpt> <trkpt lat="51" lon="-0.1"> </trkpt>
</trkseg> </trk> </trkseg> </trk>
|] |]
onepointWithAttrs = wrap [r| onepointWithAttrs =
wrap
[r|
<trk> <trk>
<trkseg> <trkseg>
<trkpt lat="51" lon="-0.1"> <trkpt lat="51" lon="-0.1">
@ -55,55 +59,72 @@ onepointWithAttrs = wrap [r|
</trk> </trk>
|] |]
test1 = TestCase $ test1 =
either TestCase $
(assertFailure . displayException) either
(\ t -> assertEqual "empty track has no elements" (assertFailure . displayException)
0 (Track.length t)) ( \t ->
(Track.parse (wrap "")) assertEqual
"empty track has no elements"
0
(Track.length t)
)
(Track.parse (wrap ""))
testMalformed = TestCase $ testMalformed =
let trk = Track.parse (wrap "<dgdsfg>>") TestCase $
in assertBool "catches syntax error" (isLeft trk) let trk = Track.parse (wrap "<dgdsfg>>")
in assertBool "catches syntax error" (isLeft trk)
test2 = TestCase $ test2 =
either TestCase $
(assertFailure . displayException) either
(\ (p:_) -> (assertFailure . displayException)
assertEqual "matches lat/lon" ( \(p : _) ->
(Track.Pos 51.0 (-0.1)) assertEqual
(Track.pos p)) "matches lat/lon"
(Track.parse onepoint) (Track.Pos 51.0 (-0.1))
(Track.pos p)
)
(Track.parse onepoint)
test3 = TestCase $ test3 =
either TestCase $
(assertFailure . displayException) either
(\ (p:_) -> (assertFailure . displayException)
assertEqual "handles missing attributes" ( \(p : _) ->
(Nothing, Nothing) (Track.elevation p, Track.cadence p)) assertEqual
(Track.parse onepoint) "handles missing attributes"
(Nothing, Nothing)
(Track.elevation p, Track.cadence p)
)
(Track.parse onepoint)
test4 = TestCase $ test4 =
either TestCase $
(assertFailure . displayException) either
(\ (p:_) -> (assertFailure . displayException)
assertEqual "handles attributes" ( \(p : _) ->
(Just 25.2, Just 128, Just 55, Data.Time.UTCTime (toEnum 60606) 27299.779) assertEqual
(Track.elevation p, Track.cadence p, Track.power p, Track.time p)) "handles attributes"
(Track.parse onepointWithAttrs) (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 :: Test
tests = TestList [ tests =
test1, TestList
testMalformed, [ test1,
test2, testMalformed,
test3, test2,
test4 test3,
] test4
]
main :: IO () main :: IO ()
main = do main = do
result <- runTestTT tests result <- runTestTT tests
if (failures result > 0) || (errors result > 0) if (failures result > 0) || (errors result > 0)
then Exit.exitFailure then Exit.exitFailure
else Exit.exitSuccess else Exit.exitSuccess