module Geo.GPX.Conduit
( Track(..), GPX(..), Segment(..), Point(..)
, readGPXFile, pt
) where
import Control.Monad.Trans.Control
import Control.Monad
import Data.Conduit
import Data.Conduit.Text
import Data.Conduit.List as L
import Data.Void (Void)
import Data.Time.Format
import Data.Text (Text)
import qualified Data.Text as T
import System.Locale
import System.FilePath
import Data.String
import Data.Maybe (fromMaybe)
import Data.Time (UTCTime, buildTime, parseTime)
import Data.XML.Types
import Text.XML hiding (parseText)
import Text.XML.Stream.Parse
import qualified Data.Attoparsec.Text as AT
import Debug.Trace
data GPX = GPX {
tracks :: [Track] }
deriving (Eq, Ord, Show, Read)
data Track = Track
{ trkName :: Maybe Text
, trkDescription :: Maybe Text
, segments :: [Segment]
}
deriving (Eq, Ord, Show, Read)
data Segment = Segment { points :: [Point] }
deriving (Eq, Ord, Show, Read)
type Latitude = Double
type Longitude = Double
data Point = Point
{ pntLat :: Latitude
, pntLon :: Longitude
, pntEle :: Maybe Double
, pntTime :: Maybe UTCTime
}
deriving (Eq, Ord, Show, Read)
pt :: Latitude -> Longitude -> Maybe Double -> Maybe UTCTime -> Point
pt t g e m = Point t g e m
zeroPoint = Point 0 0 Nothing Nothing
readGPXFile :: FilePath -> IO (Maybe GPX)
readGPXFile fp = runResourceT (parseFile def (fromString fp) $$ conduitGPX)
parseGPX :: (MonadThrow m, MonadBaseControl IO m) => Text -> m (Maybe GPX)
parseGPX t = runResourceT (yield t =$= mapOutput snd (parseText def)
$$ conduitGPX)
conduitGPX :: MonadThrow m => Sink Event m (Maybe GPX)
conduitGPX =
tagPredicate ((== "gpx") . nameLocalName)
ignoreAttrs
(\_ -> do
skipTagAndContents "metadata"
ts <- many conduitTrack
return $ GPX ts)
skipTagAndContents :: (MonadThrow m) => Text -> Pipe Event Event Void () m ()
skipTagAndContents n = do
tagPredicate ((== n) . nameLocalName) ignoreAttrs
(const $ L.sinkNull)
return ()
conduitTrack :: MonadThrow m => Sink Event m (Maybe Track)
conduitTrack = do
tagPredicate ((== "trk") . nameLocalName) ignoreAttrs $ \_ -> do
n <- join `fmap` tagPredicate (("name" ==) . nameLocalName) ignoreAttrs (const contentMaybe)
d <- join `fmap` tagPredicate (("desc" ==) . nameLocalName) ignoreAttrs (const contentMaybe)
segs <- many conduitSegment
return (Track n d segs)
conduitSegment :: MonadThrow m => Sink Event m (Maybe Segment)
conduitSegment = do
tagPredicate ((== "trkseg") . nameLocalName) ignoreAttrs $ \_ -> do
pnts <- (many conduitPoint)
return (Segment pnts)
conduitPoint :: MonadThrow m => Sink Event m (Maybe Point)
conduitPoint =
tagPredicate ((== "trkpt") . nameLocalName )
(do l <- parseDouble `fmap` requireAttr "lat"
g <- parseDouble `fmap` requireAttr "lon"
return $ zeroPoint { pntLon = g, pntLat = l })
parseETS
parseETS :: MonadThrow m => Point -> Sink Event m Point
parseETS pnt = do
let nameParse :: Name -> Maybe (Point -> Text -> Point)
nameParse n =
case nameLocalName n of
"ele" -> Just (\p t -> p { pntEle = Just (parseDouble t) })
"time" -> Just (\p t -> p { pntTime = (parseUTC t) })
_ -> Just const
handleName :: (MonadThrow m) => pnt -> (pnt -> Text -> pnt) -> Sink Event m pnt
handleName p op = fmap (op p) content
skipTagAndContents "extensions"
pnt' <- tag nameParse return (handleName pnt)
case pnt' of
Nothing -> return pnt
Just p -> parseETS p
parseDouble :: Text -> Double
parseDouble l = either (const 0) id (AT.parseOnly AT.double l)
parseUTC :: Text -> Maybe UTCTime
parseUTC = either (const Nothing) id . AT.parseOnly (do
yearMonthDay <- AT.manyTill AT.anyChar (AT.char 'T')
hourMinSec <- AT.manyTill AT.anyChar (AT.choice [AT.char '.', AT.char 'Z'])
fraction <- AT.choice [AT.manyTill AT.anyChar (AT.char 'Z'), return ""]
return (parseTime defaultTimeLocale "%F %T %Q"
(unwords [yearMonthDay,hourMinSec,'.':fraction]))
)