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

ormolu again (no other changes)

Browse Source
This commit is contained in:
Daniel Barlow 2024-10-31 17:13:50 +00:00
parent 7860a189b3
commit c3c31e52b4
2 changed files with 42 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
lib/Track.hs
View File

@ -25,9 +25,10 @@ import Data.Text.Lazy as T
import Data.Time import Data.Time
import Data.Time.ISO8601 qualified import Data.Time.ISO8601 qualified
import Debug.Trace (trace, traceShow) import Debug.Trace (trace, traceShow)
import Text.Read (readMaybe)
import Text.XML import Text.XML
import Text.XML.Cursor as Cursor import Text.XML.Cursor as Cursor
import Text.Read (readMaybe)
data Pos = Pos Float Float (Maybe Float) deriving (Show, Eq) data Pos = Pos Float Float (Maybe Float) deriving (Show, Eq)
type Power = Maybe Int type Power = Maybe Int
@ -62,8 +63,8 @@ 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 = (listToMaybe $ attribute "lat" c) >>= asFloat
lon = (listToMaybe $ attribute "lon" c ) >>= asFloat lon = (listToMaybe $ attribute "lon" c) >>= asFloat
ele = listToMaybe $ child c >>= element (gpxNS "ele") >>= child >>= content ele = listToMaybe $ child c >>= element (gpxNS "ele") >>= child >>= content
ts = ts =
listToMaybe (child c >>= element (gpxNS "time") >>= child >>= content) listToMaybe (child c >>= element (gpxNS "time") >>= child >>= content)

75
tests/UnitTest.hs
View File

@ -4,8 +4,8 @@ module Main where
import Control.Exception import Control.Exception
import Data.Either import Data.Either
import Data.Time qualified
import Data.List as List import Data.List as List
import Data.Time qualified
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
@ -33,7 +33,7 @@ wrap x = preamble ++ x ++ "</gpx>"
wrapPoint x = wrapPoint x =
let trk = "<trk><trkseg>" ++ x ++ "</trkseg></trk>" let trk = "<trk><trkseg>" ++ x ++ "</trkseg></trk>"
in wrap trk in wrap trk
onepoint = onepoint =
wrap wrap
@ -84,56 +84,57 @@ testMalformed =
in assertBool "catches syntax error" (isLeft trk) in assertBool "catches syntax error" (isLeft trk)
testMissingAttrs = testMissingAttrs =
let els = [ let els =
[r| [ [r|
<trkpt lon="2" latsdf="51"> <trkpt lon="2" latsdf="51">
<time>2024-10-23T08:34:59.779+01:00</time> <time>2024-10-23T08:34:59.779+01:00</time>
</trkpt> </trkpt>
|], |],
[r| [r|
<trkpt lon="dsfgsdfg" lat="51"> <trkpt lon="dsfgsdfg" lat="51">
<time>2024-10-23T08:34:59.779+01:00</time> <time>2024-10-23T08:34:59.779+01:00</time>
</trkpt> </trkpt>
|], |],
[r| [r|
<trkpt lon="2" lat="51"> <trkpt lon="2" lat="51">
<time>2024-10-23G87sdCfdfgsdfhg</time> <time>2024-10-23G87sdCfdfgsdfhg</time>
</trkpt> </trkpt>
|] |]
] ]
in in TestCase $
TestCase $ assertBool
assertBool "failed to catch missing/malformed attribute"
"failed to catch missing/malformed attribute" ( List.all
(List.all isLeft isLeft
(List.map (\ text -> Track.parse (wrapPoint text)) ( List.map
els)) (\text -> Track.parse (wrapPoint text))
els
)
)
test2 = test2 =
TestList [ 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) Nothing)
(Track.pos p) (Track.pos p)
) )
(Track.parse onepoint), (Track.parse onepoint),
TestCase $ TestCase $
either either
(assertFailure . displayException) (assertFailure . displayException)
( \(p : _) -> ( \(p : _) ->
assertEqual assertEqual
"matches lat/lon" "matches lat/lon"
(Track.Pos 51.0 (-0.1) (Just 25.2)) (Track.Pos 51.0 (-0.1) (Just 25.2))
(Track.pos p) (Track.pos p)
) )
(Track.parse onepointWithAttrs) (Track.parse onepointWithAttrs)
] ]
test3 = test3 =
TestCase $ TestCase $