beginning of xml parsing
This commit is contained in:
parent
0ad6eaec2f
commit
5ec65cc49b
82
lib/Track.hs
82
lib/Track.hs
@ -1,17 +1,89 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Track where
|
||||
import Data.Time
|
||||
import qualified Data.List
|
||||
data Pos = Pos Float Float
|
||||
-- import qualified Text.XML as X
|
||||
import Text.XML
|
||||
import Text.XML.Cursor as Cursor
|
||||
import qualified Data.Text
|
||||
-- import qualified Data.Text.Lazy
|
||||
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 Float deriving (Show)
|
||||
|
||||
|
||||
data Point = Point Pos UTCTime
|
||||
type Power = Maybe Int
|
||||
type Cadence = Maybe Int
|
||||
type HeartRate = Maybe Int
|
||||
|
||||
data Point = Point {
|
||||
pos :: Pos,
|
||||
time :: UTCTime,
|
||||
power :: Power,
|
||||
cadence :: Cadence,
|
||||
heartRate :: HeartRate
|
||||
} deriving (Show)
|
||||
|
||||
type Track = [Point]
|
||||
|
||||
parse :: String -> Track
|
||||
parse str = [
|
||||
-- Point (Pos 516 0) (UTCTime (toEnum 60631) 43200)
|
||||
mkPoint pos =
|
||||
Point
|
||||
pos
|
||||
(UTCTime (toEnum 60631) 43200)
|
||||
(Just 0)
|
||||
(Just 0)
|
||||
(Just 0)
|
||||
|
||||
parse :: String -> Either SomeException [Point]
|
||||
parse' str = [
|
||||
Point
|
||||
(Pos 51.6 0 0)
|
||||
(UTCTime (toEnum 60631) 43200)
|
||||
(Just 0)
|
||||
(Just 0)
|
||||
(Just 0)
|
||||
]
|
||||
|
||||
elToPoint :: Cursor -> Point
|
||||
elToPoint n =
|
||||
trace "el" $
|
||||
case traceShow (node n) (node n) of
|
||||
NodeElement (Element _ attrs _) ->
|
||||
let
|
||||
lat = traceShow (getAttr "lat") (getAttr "lat")
|
||||
lon = getAttr "lon"
|
||||
in mkPoint (Pos lat lon 0)
|
||||
where getAttr name =
|
||||
case (Map.lookup name attrs) of
|
||||
Just v -> (read (Data.Text.unpack v) :: Float)
|
||||
_ -> 0
|
||||
_ -> mkPoint (Pos 1 2 3)
|
||||
|
||||
getPoints :: Cursor -> [Point]
|
||||
getPoints c =
|
||||
let
|
||||
trkpts =
|
||||
child c >>=
|
||||
-- element "gpx" >>= child >>=
|
||||
element "trk" >>= descendant >>=
|
||||
element "trkpt"
|
||||
in
|
||||
List.map elToPoint trkpts
|
||||
|
||||
|
||||
parse str =
|
||||
case parseText def (T.pack str) of
|
||||
Right gpx ->
|
||||
let
|
||||
points = getPoints $ fromDocument gpx
|
||||
in traceShow "(gpx)" (Right points)
|
||||
Left err ->
|
||||
Left err
|
||||
|
||||
length :: Track -> Int
|
||||
length trk = Data.List.length trk
|
||||
|
@ -86,8 +86,11 @@ library souplesse-lib
|
||||
lib
|
||||
build-depends:
|
||||
base >=4.7 && <5
|
||||
, HaXml
|
||||
, xml-conduit
|
||||
, time
|
||||
, containers
|
||||
, text
|
||||
-- , text-iso8601
|
||||
default-language: GHC2021
|
||||
|
||||
test-suite tests
|
||||
|
@ -3,18 +3,36 @@ module Main where
|
||||
import qualified Track (Track, parse, length )
|
||||
import Test.HUnit
|
||||
import qualified System.Exit as Exit
|
||||
import Control.Exception
|
||||
import Debug.Trace (trace, traceShow)
|
||||
|
||||
|
||||
test1 :: Test
|
||||
test1 = TestCase $
|
||||
let
|
||||
trk = Track.parse "<gpx></gpx>"
|
||||
in
|
||||
assertEqual "empty track has no elements"
|
||||
0 (Track.length trk)
|
||||
-- test1 :: Test
|
||||
-- test1 = TestCase $
|
||||
-- let
|
||||
-- trk = Track.parse "<gpx></gpx>"
|
||||
-- in
|
||||
-- assertEqual "empty track has no elements"
|
||||
-- 0 (Track.length trk)
|
||||
|
||||
test3 = TestCase $ assertEqual "empty track has no elements" 1 2
|
||||
|
||||
test2 = TestCase $
|
||||
case Track.parse
|
||||
"<gpx> <trk> <trkseg> \n\
|
||||
\<trkpt lat=\"51\" lon=\"-0.1\"> </trkpt> \n\
|
||||
\</trkseg> </trk> </gpx>"
|
||||
of
|
||||
Left err -> assertFailure (displayException err)
|
||||
Right trk ->
|
||||
traceShow trk $
|
||||
assertEqual "one el" 1 (Track.length trk)
|
||||
|
||||
tests :: Test
|
||||
tests = TestList [TestLabel "test1" test1]
|
||||
tests = TestList [
|
||||
-- TestLabel "test1" test1,
|
||||
TestLabel "test2" test2
|
||||
]
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
|
Loading…
Reference in New Issue
Block a user