souplesse

commit c514c20e688ce3a17d8787978fb2fd7c822ee657
parent 90101760a2d0c35934fb1b142c8e96fbe5e3bdc9
Author: Daniel Barlow <dan@telent.net>
Date:   Wed, 30 Oct 2024 13:30:33 +0000

use real gpx namespace

Diffstat:
M
lib/Track.hs
 | 
13
++++++++-----
M
souplesse.cabal
 | 
1
+
M
tests/UnitTest.hs
 | 
40
+++++++++++++++++++++++++++++++---------

3 files changed, 40 insertions(+), 14 deletions(-)
diff --git a/lib/Track.hs b/lib/Track.hs
@@ -36,6 +36,8 @@ data Point = Point {
 -- TODO do we even need this type?
 type Track = [Point]
 
+gpxNS = "http://www.topografix.com/GPX/1/1"
+
 mkPoint pos =
   Point
     pos
@@ -52,7 +54,7 @@ elToPoint c =
       let
         lat = getAttr "lat"
         lon = getAttr "lon"
-        ele = child c >>= element "ele" >>= child >>= content
+        ele = child c >>= element (Name "ele" (Just gpxNS) Nothing) >>= child >>= content
       in Point (Pos lat lon)
          (case ele of
              e:[] -> Just $ asFloat e
@@ -72,12 +74,13 @@ elToPoint c =
 getPoints :: Cursor -> [Point]
 getPoints c =
   let
+    ns n = Name n (Just gpxNS) Nothing
     trkpts =
-      child c >>=
-      element "trk" >>= descendant >>=
-      element "trkpt"
+      element (ns "gpx") c >>= child >>=
+      element (ns "trk") >>= descendant >>=
+      element (ns "trkpt")
   in
-    List.map elToPoint trkpts
+    (List.map elToPoint trkpts)
 
 parse :: String -> Either SomeException [Point]
 parse str = do
diff --git a/souplesse.cabal b/souplesse.cabal
@@ -101,5 +101,6 @@ test-suite tests
     build-depends:
         base >=4.7 && <5
       , souplesse-lib
+      , raw-strings-qq
       , HUnit
     default-language: GHC2021
diff --git a/tests/UnitTest.hs b/tests/UnitTest.hs
@@ -1,30 +1,52 @@
+{-# LANGUAGE QuasiQuotes #-}
+
 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)
 
-onepoint =
-  "<gpx> <trk> <trkseg> \n\
+preamble = [r|
+<?xml version="1.0" encoding="UTF-8"?>
+<gpx
+version="1.1"
+creator="OpenTracks"
+xmlns="http://www.topografix.com/GPX/1/1"
+xmlns:topografix="http://www.topografix.com/GPX/Private/TopoGrafix/0/1"
+xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"
+xmlns:opentracks="http://opentracksapp.com/xmlschemas/v1"
+xmlns:gpxtpx="http://www.garmin.com/xmlschemas/TrackPointExtension/v2"
+xmlns:gpxtrkx="http://www.garmin.com/xmlschemas/TrackStatsExtension/v1"
+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 $
+  "<trk> <trkseg> \n\
   \<trkpt lat=\"51\" lon=\"-0.1\"> </trkpt> \n\
-  \</trkseg> </trk> </gpx>"
-onepointEle =
-  "<gpx> <trk> <trkseg> \n\
+  \</trkseg> </trk>"
+onepointWithAttrs = wrap $
+  "<trk> <trkseg> \n\
   \<trkpt lat=\"51\" lon=\"-0.1\"> \n\
   \ <ele>25.2</ele>\n\
   \</trkpt> \n\
-  \</trkseg> </trk> </gpx>"
+  \</trkseg> </trk>"
 
 test1 = TestCase $
-        case Track.parse "<gpx></gpx>" of
+        case Track.parse (wrap "") of
           Left err -> assertFailure (displayException err)
           Right t -> assertEqual "empty track has no elements"
                      0 (Track.length t)
 
 testMalformed = TestCase $
-        case Track.parse "<gpx><dgdsfg>></gpx>" of
+        case Track.parse (wrap "<dgdsfg>>") of
           Left err -> assertBool "syntax error" True
           Right _ -> assertFailure "no error message parsing bad xml"
 
@@ -48,7 +70,7 @@ test3 = TestCase $
           Right [] -> assertFailure "no points"
 
 test4 = TestCase $
-        case Track.parse onepointEle
+        case Track.parse onepointWithAttrs
         of
           Left err -> assertFailure (displayException err)
           Right (p:ps) ->