diff --git a/Example.hs b/Example.hs new file mode 100644 --- /dev/null +++ b/Example.hs @@ -0,0 +1,17 @@ +import Geo.OSM + +-- Return all nodes tagged as camp-sites (tourism=camp_site) in the give OSM file. +campSites :: FilePath -> IO [Node] +campSites f = let p = filter ("tourism" `hasTagValue` "camp_site") . (nodes =<<) + in fmap p (runX (xunpickleDocument (xpickle :: PU OSM) [(a_remove_whitespace, v_1)] f)) + + + +{- + + +*Main> campSites "MountBarney.osm" +[,,,,,,,,,,] + + +-} diff --git a/Geo/OSM.hs b/Geo/OSM.hs new file mode 100644 --- /dev/null +++ b/Geo/OSM.hs @@ -0,0 +1,80 @@ +module Geo.OSM( + module Text.XML.HXT.Arrow, + module Geo.OSM.Bound, + module Geo.OSM.Bounds, + module Geo.OSM.Member, + module Geo.OSM.MemberType, + module Geo.OSM.Nd, + module Geo.OSM.Node, + module Geo.OSM.NodeWayRelation, + module Geo.OSM.OSM, + module Geo.OSM.Relation, + module Geo.OSM.Tag, + module Geo.OSM.Way, + module Geo.OSM.Accessor.BoundOrs, + module Geo.OSM.Accessor.Box, + module Geo.OSM.Accessor.Changeset, + module Geo.OSM.Accessor.Generator, + module Geo.OSM.Accessor.Id, + module Geo.OSM.Accessor.K, + module Geo.OSM.Accessor.Lat, + module Geo.OSM.Accessor.Lon, + module Geo.OSM.Accessor.Maxlat, + module Geo.OSM.Accessor.Maxlon, + module Geo.OSM.Accessor.Members, + module Geo.OSM.Accessor.Minlat, + module Geo.OSM.Accessor.Minlon, + module Geo.OSM.Accessor.Mtype, + module Geo.OSM.Accessor.Nds, + module Geo.OSM.Accessor.NodeWayRelations, + module Geo.OSM.Accessor.Origin, + module Geo.OSM.Accessor.Ref, + module Geo.OSM.Accessor.Role, + module Geo.OSM.Accessor.Tags, + module Geo.OSM.Accessor.Timestamp, + module Geo.OSM.Accessor.Uid, + module Geo.OSM.Accessor.User, + module Geo.OSM.Accessor.Version, + module Geo.OSM.Accessor.V, + module Geo.OSM.Accessor.Visible + ) where + + +import Text.XML.HXT.Arrow +import Geo.OSM.Bound +import Geo.OSM.Bounds +import Geo.OSM.Member +import Geo.OSM.MemberType +import Geo.OSM.Nd +import Geo.OSM.Node +import Geo.OSM.NodeWayRelation +import Geo.OSM.OSM +import Geo.OSM.Relation +import Geo.OSM.Tag +import Geo.OSM.Way +import Geo.OSM.Accessor.BoundOrs +import Geo.OSM.Accessor.Box +import Geo.OSM.Accessor.Changeset +import Geo.OSM.Accessor.Generator +import Geo.OSM.Accessor.Id +import Geo.OSM.Accessor.K +import Geo.OSM.Accessor.Lat +import Geo.OSM.Accessor.Lon +import Geo.OSM.Accessor.Maxlat +import Geo.OSM.Accessor.Maxlon +import Geo.OSM.Accessor.Members +import Geo.OSM.Accessor.Minlat +import Geo.OSM.Accessor.Minlon +import Geo.OSM.Accessor.Mtype +import Geo.OSM.Accessor.Nds +import Geo.OSM.Accessor.NodeWayRelations +import Geo.OSM.Accessor.Origin +import Geo.OSM.Accessor.Ref +import Geo.OSM.Accessor.Role +import Geo.OSM.Accessor.Tags +import Geo.OSM.Accessor.Timestamp +import Geo.OSM.Accessor.Uid +import Geo.OSM.Accessor.User +import Geo.OSM.Accessor.Version +import Geo.OSM.Accessor.V +import Geo.OSM.Accessor.Visible diff --git a/Geo/OSM/Accessor/BoundOrs.hs b/Geo/OSM/Accessor/BoundOrs.hs new file mode 100644 --- /dev/null +++ b/Geo/OSM/Accessor/BoundOrs.hs @@ -0,0 +1,8 @@ +-- | Values with a @bounds@ accessor which is either empty, a @Bound@ or a @Bounds@. +module Geo.OSM.Accessor.BoundOrs where + +import Geo.OSM.Bound +import Geo.OSM.Bounds + +class BoundOrs a where + boundOrs :: a -> x -> (Bound -> x) -> (Bounds -> x) -> x diff --git a/Geo/OSM/Accessor/Box.hs b/Geo/OSM/Accessor/Box.hs new file mode 100644 --- /dev/null +++ b/Geo/OSM/Accessor/Box.hs @@ -0,0 +1,5 @@ +-- | Values with a @box@ string accessor. +module Geo.OSM.Accessor.Box where + +class Box a where + box :: a -> String diff --git a/Geo/OSM/Accessor/Changeset.hs b/Geo/OSM/Accessor/Changeset.hs new file mode 100644 --- /dev/null +++ b/Geo/OSM/Accessor/Changeset.hs @@ -0,0 +1,5 @@ +-- | Values with a @changeset@ optional string accessor. +module Geo.OSM.Accessor.Changeset where + +class Changeset a where + changeset :: a -> Maybe String diff --git a/Geo/OSM/Accessor/Generator.hs b/Geo/OSM/Accessor/Generator.hs new file mode 100644 --- /dev/null +++ b/Geo/OSM/Accessor/Generator.hs @@ -0,0 +1,5 @@ +-- | Values with a @generator@ optional string accessor. +module Geo.OSM.Accessor.Generator where + +class Generator a where + generator :: a -> Maybe String diff --git a/Geo/OSM/Accessor/Id.hs b/Geo/OSM/Accessor/Id.hs new file mode 100644 --- /dev/null +++ b/Geo/OSM/Accessor/Id.hs @@ -0,0 +1,5 @@ +-- | Values with a @id@ string accessor. +module Geo.OSM.Accessor.Id where + +class Id a where + id :: a -> String diff --git a/Geo/OSM/Accessor/K.hs b/Geo/OSM/Accessor/K.hs new file mode 100644 --- /dev/null +++ b/Geo/OSM/Accessor/K.hs @@ -0,0 +1,5 @@ +-- | Values with a @k@ string accessor. +module Geo.OSM.Accessor.K where + +class K a where + k :: a -> String diff --git a/Geo/OSM/Accessor/Lat.hs b/Geo/OSM/Accessor/Lat.hs new file mode 100644 --- /dev/null +++ b/Geo/OSM/Accessor/Lat.hs @@ -0,0 +1,5 @@ +-- | Values with a @lat@ string accessor. +module Geo.OSM.Accessor.Lat where + +class Lat a where + lat :: a -> String diff --git a/Geo/OSM/Accessor/Lon.hs b/Geo/OSM/Accessor/Lon.hs new file mode 100644 --- /dev/null +++ b/Geo/OSM/Accessor/Lon.hs @@ -0,0 +1,5 @@ +-- | Values with a @lon@ string accessor. +module Geo.OSM.Accessor.Lon where + +class Lon a where + lon :: a -> String diff --git a/Geo/OSM/Accessor/Maxlat.hs b/Geo/OSM/Accessor/Maxlat.hs new file mode 100644 --- /dev/null +++ b/Geo/OSM/Accessor/Maxlat.hs @@ -0,0 +1,5 @@ +-- | Values with a @maxlat@ string accessor. +module Geo.OSM.Accessor.Maxlat where + +class Maxlat a where + maxlat :: a -> String diff --git a/Geo/OSM/Accessor/Maxlon.hs b/Geo/OSM/Accessor/Maxlon.hs new file mode 100644 --- /dev/null +++ b/Geo/OSM/Accessor/Maxlon.hs @@ -0,0 +1,5 @@ +-- -- | Values with a @maxlon@ string accessor. +module Geo.OSM.Accessor.Maxlon where + +class Maxlon a where + maxlon :: a -> String diff --git a/Geo/OSM/Accessor/Members.hs b/Geo/OSM/Accessor/Members.hs new file mode 100644 --- /dev/null +++ b/Geo/OSM/Accessor/Members.hs @@ -0,0 +1,7 @@ +-- | Values with a @member@ accessor that is a list of @Member@. +module Geo.OSM.Accessor.Members where + +import Geo.OSM.Member + +class Members a where + members :: a -> [Member] diff --git a/Geo/OSM/Accessor/Minlat.hs b/Geo/OSM/Accessor/Minlat.hs new file mode 100644 --- /dev/null +++ b/Geo/OSM/Accessor/Minlat.hs @@ -0,0 +1,5 @@ +-- | Values with a @minlat@ string accessor. +module Geo.OSM.Accessor.Minlat where + +class Minlat a where + minlat :: a -> String diff --git a/Geo/OSM/Accessor/Minlon.hs b/Geo/OSM/Accessor/Minlon.hs new file mode 100644 --- /dev/null +++ b/Geo/OSM/Accessor/Minlon.hs @@ -0,0 +1,5 @@ +-- | Values with a @minlon@ string accessor. +module Geo.OSM.Accessor.Minlon where + +class Minlon a where + minlon :: a -> String diff --git a/Geo/OSM/Accessor/Mtype.hs b/Geo/OSM/Accessor/Mtype.hs new file mode 100644 --- /dev/null +++ b/Geo/OSM/Accessor/Mtype.hs @@ -0,0 +1,7 @@ +-- | Values with a @type@ accessor. +module Geo.OSM.Accessor.Mtype where + +import Geo.OSM.MemberType + +class Mtype a where + mtype :: a -> MemberType diff --git a/Geo/OSM/Accessor/Nds.hs b/Geo/OSM/Accessor/Nds.hs new file mode 100644 --- /dev/null +++ b/Geo/OSM/Accessor/Nds.hs @@ -0,0 +1,7 @@ +-- | Values with a @nd@ accessor that is a list of @Nd@. +module Geo.OSM.Accessor.Nds where + +import Geo.OSM.Nd + +class Nds a where + nds :: a -> [Nd] diff --git a/Geo/OSM/Accessor/NodeWayRelations.hs b/Geo/OSM/Accessor/NodeWayRelations.hs new file mode 100644 --- /dev/null +++ b/Geo/OSM/Accessor/NodeWayRelations.hs @@ -0,0 +1,19 @@ +-- | Values with a @nwrs@ accessor that is a list of @NodeWayRelation@. +module Geo.OSM.Accessor.NodeWayRelations where + +import Geo.OSM.NodeWayRelation +import Geo.OSM.Node +import Geo.OSM.Way +import Geo.OSM.Relation + +class NodeWayRelations a where + nwrs :: a -> [NodeWayRelation] + +nodes :: (NodeWayRelations a) => a -> [Node] +nodes k = nwrs k >>= \t -> foldNodeWayRelation t return (const []) (const []) + +ways :: (NodeWayRelations a) => a -> [Way] +ways k = nwrs k >>= \t -> foldNodeWayRelation t (const []) return (const []) + +relations :: (NodeWayRelations a) => a -> [Relation] +relations k = nwrs k >>= \t -> foldNodeWayRelation t (const []) (const []) return diff --git a/Geo/OSM/Accessor/Origin.hs b/Geo/OSM/Accessor/Origin.hs new file mode 100644 --- /dev/null +++ b/Geo/OSM/Accessor/Origin.hs @@ -0,0 +1,5 @@ +-- | Values with a @origin@ optional string accessor. +module Geo.OSM.Accessor.Origin where + +class Origin a where + origin :: a -> Maybe String diff --git a/Geo/OSM/Accessor/Ref.hs b/Geo/OSM/Accessor/Ref.hs new file mode 100644 --- /dev/null +++ b/Geo/OSM/Accessor/Ref.hs @@ -0,0 +1,5 @@ +-- | Values with a @ref@ string accessor. +module Geo.OSM.Accessor.Ref where + +class Ref a where + ref :: a -> String diff --git a/Geo/OSM/Accessor/Role.hs b/Geo/OSM/Accessor/Role.hs new file mode 100644 --- /dev/null +++ b/Geo/OSM/Accessor/Role.hs @@ -0,0 +1,5 @@ +-- | Values with a @role@ string accessor. +module Geo.OSM.Accessor.Role where + +class Role a where + role :: a -> String diff --git a/Geo/OSM/Accessor/Tags.hs b/Geo/OSM/Accessor/Tags.hs new file mode 100644 --- /dev/null +++ b/Geo/OSM/Accessor/Tags.hs @@ -0,0 +1,19 @@ +-- | Values with a @tags@ accessor that is a list of tags. +module Geo.OSM.Accessor.Tags where + +import Geo.OSM.Tag +import Geo.OSM.Accessor.K +import Geo.OSM.Accessor.V +import qualified Data.Map as M +import Control.Arrow +import Data.Foldable +import Prelude hiding (any) + +class Tags a where + tags :: a -> [Tag] + +tagMap :: (Tags a) => a -> M.Map String String +tagMap = M.fromList . map (k &&& v) . tags + +hasTagValue :: (Tags a) => String -> String -> a -> Bool +hasTagValue k' v' n = any (== v') (k' `M.lookup` tagMap n) diff --git a/Geo/OSM/Accessor/Timestamp.hs b/Geo/OSM/Accessor/Timestamp.hs new file mode 100644 --- /dev/null +++ b/Geo/OSM/Accessor/Timestamp.hs @@ -0,0 +1,5 @@ +-- | Values with a @timestamp@ optional string accessor. +module Geo.OSM.Accessor.Timestamp where + +class Timestamp a where + timestamp :: a -> Maybe String diff --git a/Geo/OSM/Accessor/Uid.hs b/Geo/OSM/Accessor/Uid.hs new file mode 100644 --- /dev/null +++ b/Geo/OSM/Accessor/Uid.hs @@ -0,0 +1,5 @@ +-- | Values with a @uid@ optional string accessor. +module Geo.OSM.Accessor.Uid where + +class Uid a where + uid :: a -> Maybe String diff --git a/Geo/OSM/Accessor/User.hs b/Geo/OSM/Accessor/User.hs new file mode 100644 --- /dev/null +++ b/Geo/OSM/Accessor/User.hs @@ -0,0 +1,5 @@ +-- | Values with a @user@ optional string accessor. +module Geo.OSM.Accessor.User where + +class User a where + user :: a -> Maybe String diff --git a/Geo/OSM/Accessor/V.hs b/Geo/OSM/Accessor/V.hs new file mode 100644 --- /dev/null +++ b/Geo/OSM/Accessor/V.hs @@ -0,0 +1,5 @@ +-- | Values with a @v@ string accessor. +module Geo.OSM.Accessor.V where + +class V a where + v :: a -> String diff --git a/Geo/OSM/Accessor/Version.hs b/Geo/OSM/Accessor/Version.hs new file mode 100644 --- /dev/null +++ b/Geo/OSM/Accessor/Version.hs @@ -0,0 +1,5 @@ +-- | Values with a @version@ string accessor. +module Geo.OSM.Accessor.Version where + +class Version a where + version :: a -> String diff --git a/Geo/OSM/Accessor/Visible.hs b/Geo/OSM/Accessor/Visible.hs new file mode 100644 --- /dev/null +++ b/Geo/OSM/Accessor/Visible.hs @@ -0,0 +1,5 @@ +-- | Values with a @visible@ boolean accessor. +module Geo.OSM.Accessor.Visible where + +class Visible a where + visible :: a -> Bool diff --git a/Geo/OSM/Bound.hs b/Geo/OSM/Bound.hs new file mode 100644 --- /dev/null +++ b/Geo/OSM/Bound.hs @@ -0,0 +1,32 @@ +-- | The @bound@ element of a OSM file. +module Geo.OSM.Bound( + Bound, + bound + ) where + +import Text.XML.HXT.Arrow +import Geo.OSM.Util +import Geo.OSM.Accessor.Box +import Geo.OSM.Accessor.Origin + +-- | The @bound@ element of a OSM file. +data Bound = Bound String (Maybe String) + deriving Eq + +instance XmlPickler Bound where + xpickle = xpElem "bound" (xpWrap (uncurry Bound, \(Bound b o) -> (b, o)) (xpPair (xpAttr "box" xpText) (xpOption (xpAttr "origin" xpText)))) + +instance Show Bound where + show = showPickled [] + +instance Box Bound where + box (Bound x _) = x + +instance Origin Bound where + origin (Bound _ x) = x + +-- | Constructs a bound with a box and origin attributes. +bound :: String -- ^ The @box@ attribute. + -> Maybe String -- ^ The @origin@ attribute. + -> Bound +bound = Bound diff --git a/Geo/OSM/Bounds.hs b/Geo/OSM/Bounds.hs new file mode 100644 --- /dev/null +++ b/Geo/OSM/Bounds.hs @@ -0,0 +1,48 @@ +-- | The @bounds@ element of a OSM file. +module Geo.OSM.Bounds( + Bounds, + bounds + ) where + +import Text.XML.HXT.Arrow +import Geo.OSM.Util +import Geo.OSM.Accessor.Minlat +import Geo.OSM.Accessor.Maxlat +import Geo.OSM.Accessor.Minlon +import Geo.OSM.Accessor.Maxlon +import Geo.OSM.Accessor.Origin + +-- | The @bounds@ element of a OSM file. +data Bounds = Bounds String String String String (Maybe String) + deriving Eq + +instance XmlPickler Bounds where + xpickle = xpElem "bounds" (xpWrap (\(minlat', minlon', maxlat', maxlon', origin') -> Bounds minlat' minlon' maxlat' maxlon' origin', \(Bounds minlat' minlon' maxlat' maxlon' origin') -> (minlat', minlon', maxlat', maxlon', origin')) + (xp5Tuple (xpAttr "minlat" xpText) (xpAttr "minlon" xpText) (xpAttr "maxlat" xpText) (xpAttr "maxlon" xpText) (xpOption (xpAttr "origin" xpText)))) + +instance Show Bounds where + show = showPickled [] + +instance Minlat Bounds where + minlat (Bounds x _ _ _ _) = x + +instance Minlon Bounds where + minlon (Bounds _ x _ _ _) = x + +instance Maxlat Bounds where + maxlat (Bounds _ _ x _ _) = x + +instance Maxlon Bounds where + maxlon (Bounds _ _ _ x _) = x + +instance Origin Bounds where + origin (Bounds _ _ _ _ x) = x + +-- | Constructs a bounds with a minlat, minlon, maxlat, maxlon and origin attributes. +bounds :: String -- ^ The @minlat@ attribute. + -> String -- ^ The @minlon@ attribute. + -> String -- ^ The @maxlat@ attribute. + -> String -- ^ The @maxlon@ attribute. + -> Maybe String -- ^ The @origin@ attribute. + -> Bounds +bounds = Bounds diff --git a/Geo/OSM/Member.hs b/Geo/OSM/Member.hs new file mode 100644 --- /dev/null +++ b/Geo/OSM/Member.hs @@ -0,0 +1,39 @@ +-- | The @member@ element of a OSM file. +module Geo.OSM.Member( + Member, + member + ) where + +import Text.XML.HXT.Arrow +import Geo.OSM.MemberType +import Geo.OSM.Util +import Geo.OSM.Accessor.Mtype +import Geo.OSM.Accessor.Ref +import Geo.OSM.Accessor.Role + +-- | The @member@ element of a OSM file. +data Member = Member MemberType String String + deriving Eq + +instance XmlPickler Member where + xpickle = xpElem "member" (xpWrap (\(mtype', mref', mrole') -> Member mtype' mref' mrole', \(Member mtype' mref' mrole') -> (mtype', mref', mrole')) + (xpTriple xpickle (xpAttr "ref" xpText) (xpAttr "role" xpText))) + +instance Show Member where + show = showPickled [] + +instance Mtype Member where + mtype (Member x _ _) = x + +instance Ref Member where + ref (Member _ x _) = x + +instance Role Member where + role (Member _ _ x) = x + +-- | Constructs a member with a type, ref and role. +member :: MemberType -- ^ The member @type@ attribute. + -> String -- ^ The member @ref@ attribute. + -> String -- ^ The member @role@ attribute. + -> Member +member = Member diff --git a/Geo/OSM/MemberType.hs b/Geo/OSM/MemberType.hs new file mode 100644 --- /dev/null +++ b/Geo/OSM/MemberType.hs @@ -0,0 +1,51 @@ +-- | The @type@ attribute of a @member@ element of a OSM file. +module Geo.OSM.MemberType( + MemberType, + foldMemberType, + wayType, + nodeType, + relationType + ) where + +import Text.XML.HXT.Arrow +import Control.Applicative +import Data.Char +import Geo.OSM.Util + +-- | The @type@ attribute of a @member@ element of a OSM file. +data MemberType = WayType | NodeType | RelationType + deriving Eq + +-- | Folds a member-type (catamorphism). +foldMemberType :: MemberType -- ^ The member-type to fold. + -> x -- ^ If the type is a way. + -> x -- ^ If the type is a node. + -> x -- ^ If the type is a relation. + -> x +foldMemberType WayType x _ _ = x +foldMemberType NodeType _ x _ = x +foldMemberType RelationType _ _ x = x + +instance XmlPickler MemberType where + xpickle = xpWrapMaybe (\s -> case toLower <$> s of "way" -> Just WayType + "node" -> Just NodeType + "relation" -> Just RelationType + _ -> Nothing, + \t -> case t of WayType -> "way" + NodeType -> "node" + RelationType -> "relation") (xpAttr "type" xpText) + +instance Show MemberType where + show = showPickled [] + +-- | Constructs a member-type that is a way. +wayType :: MemberType +wayType = WayType + +-- | Constructs a member-type that is a node. +nodeType :: MemberType +nodeType = NodeType + +-- | Constructs a member-type that is a relation. +relationType :: MemberType +relationType = RelationType diff --git a/Geo/OSM/NWRCommon.hs b/Geo/OSM/NWRCommon.hs new file mode 100644 --- /dev/null +++ b/Geo/OSM/NWRCommon.hs @@ -0,0 +1,67 @@ +-- | The common attributes between the @node@, @way@ and @relation@ elements. +module Geo.OSM.NWRCommon( + NWRCommon, + nwrCommon + ) where + +import Text.XML.HXT.Arrow +import Control.Applicative +import Data.Char +import Geo.OSM.Tag +import Geo.OSM.Util +import Geo.OSM.Accessor.Id +import Geo.OSM.Accessor.Tags +import Geo.OSM.Accessor.Changeset +import Geo.OSM.Accessor.Visible +import Geo.OSM.Accessor.User +import Geo.OSM.Accessor.Uid +import Geo.OSM.Accessor.Timestamp + +-- | The common attributes between the @node@, @way@ and @relation@ elements. +data NWRCommon = NWRCommon String [Tag] (Maybe String) Bool (Maybe String, Maybe String) (Maybe String) + deriving Eq + +instance XmlPickler NWRCommon where + xpickle = xpWrap (\(a, b, c, d, e, f) -> NWRCommon a b c d e f, \(NWRCommon a b c d e f) -> (a, b, c, d, e, f)) + (xp6Tuple (xpAttr "id" xpText) + (xpList xpickle) + (xpOption (xpAttr "changeset" xpText)) + (xpDefault True (xpWrapMaybe (\s -> case toLower <$> s of "true" -> Just True + "false" -> Just False + _ -> Nothing, (toLower <$>) . show) (xpAttr "visible" xpText))) + (xpPair (xpOption (xpAttr "user" xpText)) (xpOption (xpAttr "uid" xpText))) + (xpOption (xpAttr "timestamp" xpText))) + +instance Show NWRCommon where + show = showPickled [] + +instance Id NWRCommon where + id (NWRCommon x _ _ _ _ _) = x + +instance Tags NWRCommon where + tags (NWRCommon _ x _ _ _ _) = x + +instance Changeset NWRCommon where + changeset (NWRCommon _ _ x _ _ _) = x + +instance Visible NWRCommon where + visible (NWRCommon _ _ _ x _ _) = x + +instance User NWRCommon where + user (NWRCommon _ _ _ _ (x, _) _) = x + +instance Uid NWRCommon where + uid (NWRCommon _ _ _ _ (_, x) _) = x + +instance Timestamp NWRCommon where + timestamp (NWRCommon _ _ _ _ _ x) = x + +-- | Constructs with id, list of tags, changeset, visible, user&uid and timestamp. +nwrCommon :: String -- ^ The @id@ attribute. + -> [Tag] -- ^ The list of tags (@tag@ elements). + -> Maybe String -- ^ The @changeset@ attribute. + -> Bool -- ^ The @visible@ attribute. + -> (Maybe String, Maybe String) -- ^ The @user@ and @uid@ attributes. + -> Maybe String -- ^ The @timestamp@ attribute. + -> NWRCommon +nwrCommon = NWRCommon diff --git a/Geo/OSM/Nd.hs b/Geo/OSM/Nd.hs new file mode 100644 --- /dev/null +++ b/Geo/OSM/Nd.hs @@ -0,0 +1,27 @@ +-- | The @nd@ element of a OSM file. +module Geo.OSM.Nd( + Nd, + nd + ) where + +import Text.XML.HXT.Arrow +import Geo.OSM.Util +import Geo.OSM.Accessor.Ref + +-- | The @nd@ element of a OSM file. +newtype Nd = Nd String + deriving Eq + +instance XmlPickler Nd where + xpickle = xpElem "nd" (xpWrap (Nd, \(Nd r) -> r) (xpAttr "ref" xpText)) + +instance Show Nd where + show = showPickled [] + +instance Ref Nd where + ref (Nd x) = x + +-- | Constructs a nd with a ref. +nd :: String -- ^ The @ref@ attribute. + -> Nd +nd = Nd diff --git a/Geo/OSM/Node.hs b/Geo/OSM/Node.hs new file mode 100644 --- /dev/null +++ b/Geo/OSM/Node.hs @@ -0,0 +1,70 @@ +-- | The @node@ element of a OSM file. +module Geo.OSM.Node( + Node, + node + ) where + +import Text.XML.HXT.Arrow +import Geo.OSM.NWRCommon +import Geo.OSM.Util +import Geo.OSM.Tag +import Geo.OSM.Accessor.Id +import Geo.OSM.Accessor.Tags +import Geo.OSM.Accessor.Changeset +import Geo.OSM.Accessor.Visible +import Geo.OSM.Accessor.User +import Geo.OSM.Accessor.Uid +import Geo.OSM.Accessor.Timestamp +import Geo.OSM.Accessor.Lat +import Geo.OSM.Accessor.Lon +import Prelude hiding (id) + +-- | The @node@ element of a OSM file. +data Node = Node String String NWRCommon + deriving Eq + +instance XmlPickler Node where + xpickle = xpElem "node" (xpWrap (\(lat', lon', nwr') -> Node lat' lon' nwr', \(Node lat' lon' nwr') -> (lat', lon', nwr')) + (xpTriple (xpAttr "lat" xpText) (xpAttr "lon" xpText) xpickle)) + +instance Show Node where + show = showPickled [] + +instance Lat Node where + lat (Node x _ _) = x + +instance Lon Node where + lon (Node _ x _) = x + +instance Id Node where + id (Node _ _ x) = id x + +instance Tags Node where + tags (Node _ _ x) = tags x + +instance Changeset Node where + changeset (Node _ _ x) = changeset x + +instance Visible Node where + visible (Node _ _ x) = visible x + +instance User Node where + user (Node _ _ x) = user x + +instance Uid Node where + uid (Node _ _ x) = uid x + +instance Timestamp Node where + timestamp (Node _ _ x) = timestamp x + +-- | Constructs a node with a lat, lon, id, list of tags, changeset, visible, user&uid and timestamp. +node :: String -- ^ The @lat@ attribute. + -> String -- ^ The @lon@ attribute. + -> String -- ^ The @id@ attribute. + -> [Tag] -- ^ The list of tags (@tag@ elements). + -> Maybe String -- ^ The @changeset@ attribute. + -> Bool -- ^ The @visible@ attribute. + -> (Maybe String, Maybe String) -- ^ The @user@ and @uid@ attributes. + -> Maybe String -- ^ The @timestamp@ attribute. + -> Node +node = flip flip nwrCommon . (((.) . (.) . (.) . (.) . (.) . (.)) .) . Node diff --git a/Geo/OSM/NodeWayRelation.hs b/Geo/OSM/NodeWayRelation.hs new file mode 100644 --- /dev/null +++ b/Geo/OSM/NodeWayRelation.hs @@ -0,0 +1,67 @@ +-- | The @node@, @way@, or @relation@ element of a OSM file. +module Geo.OSM.NodeWayRelation( + NodeWayRelation, + foldNodeWayRelation, + way', + relation', + node', + isNode, + isWay, + isRelation + ) where + +import Text.XML.HXT.Arrow +import Geo.OSM.Node +import Geo.OSM.Way +import Geo.OSM.Relation +import Geo.OSM.Util + +-- | The @node@, @way@, or @relation@ element of a OSM file. +data NodeWayRelation = N Node | W Way | R Relation + deriving Eq + +-- | Folds a node-way-relation (catamorphism). +foldNodeWayRelation :: NodeWayRelation -- ^ The @node@, @way@ or @relation@ element. + -> (Node -> x) -- ^ If this is a @node@ element. + -> (Way -> x) -- ^ If this is a @way@ element. + -> (Relation -> x) -- ^ If this is a @relation@ element. + -> x +foldNodeWayRelation (N n) x _ _ = x n +foldNodeWayRelation (W w) _ x _ = x w +foldNodeWayRelation (R r) _ _ x = x r + +instance XmlPickler NodeWayRelation where + xpickle = xpAlt (\r -> case r of N _ -> 0 + W _ -> 1 + R _ -> 2) + [xpWrap (N, \(N n) -> n) xpickle, xpWrap (W, \(W w) -> w) xpickle, xpWrap (R, \(R r) -> r) xpickle] + +instance Show NodeWayRelation where + show = showPickled [] + +-- | Construct a @way@ element value. +way' :: Way -> NodeWayRelation +way' = W + +-- | Construct a @relation@ element value. +relation' :: Relation -> NodeWayRelation +relation' = R + +-- | Construct a @node@ element value. +node' :: Node -> NodeWayRelation +node' = N + +-- | Returns whether the @node@, @way@ or @relation@ element is a node. +isNode :: NodeWayRelation -> Bool +isNode (N _) = True +isNode _ = False + +-- | Returns whether the @node@, @way@ or @relation@ element is a way. +isWay :: NodeWayRelation -> Bool +isWay (W _) = True +isWay _ = False + +-- | Returns whether the @node@, @way@ or @relation@ element is a relation. +isRelation :: NodeWayRelation -> Bool +isRelation (R _) = True +isRelation _ = False diff --git a/Geo/OSM/OSM.hs b/Geo/OSM/OSM.hs new file mode 100644 --- /dev/null +++ b/Geo/OSM/OSM.hs @@ -0,0 +1,51 @@ +-- | The @osm@ element of a OSM file, which is the root element. +module Geo.OSM.OSM( + OSM, + osm + ) where + +import Text.XML.HXT.Arrow +import Geo.OSM.NodeWayRelation +import Geo.OSM.Bound +import Geo.OSM.Bounds +import Geo.OSM.Util +import Geo.OSM.Accessor.Version +import Geo.OSM.Accessor.Generator +import Geo.OSM.Accessor.BoundOrs +import Geo.OSM.Accessor.NodeWayRelations + +-- | The @osm@ element of a OSM file, which is the root element. +data OSM = OSM String (Maybe String) (Maybe (Either Bound Bounds)) [NodeWayRelation] + deriving Eq + +instance XmlPickler OSM where + xpickle = xpElem "osm" (xpWrap (\(version', generator', bound', nwr') -> OSM version' generator' bound' nwr', \(OSM version' generator' bound' nwr') -> (version', generator', bound', nwr')) + (xp4Tuple (xpAttr "version" xpText) + (xpOption (xpAttr "generator" xpText)) + (xpOption (xpAlt (either (const 0) (const 1)) [xpWrap (Left, \(Left b) -> b) xpickle, xpWrap (Right, \(Right b) -> b) xpickle])) + (xpList1 xpickle))) + +instance Show OSM where + show = showPickled [] + +instance Version OSM where + version (OSM x _ _ _) = x + +instance Generator OSM where + generator (OSM _ x _ _) = x + +instance BoundOrs OSM where + boundOrs (OSM _ _ x _) n b bs = case x of Nothing -> n + Just (Left b') -> b b' + Just (Right b') -> bs b' + +instance NodeWayRelations OSM where + nwrs (OSM _ _ _ x) = x + +-- | Constructs a osm with a version, bound or bounds, and node attributes and way or relation elements. +osm :: String -- ^ The @version@ attribute. + -> Maybe String -- ^ The @generator@ attribute. + -> Maybe (Either Bound Bounds) -- ^ The @bound@ or @bounds@ elements. + -> [NodeWayRelation] -- ^ The @node@, @way@ or @relation@ elements. + -> OSM +osm = OSM diff --git a/Geo/OSM/Relation.hs b/Geo/OSM/Relation.hs new file mode 100644 --- /dev/null +++ b/Geo/OSM/Relation.hs @@ -0,0 +1,66 @@ +-- | The @relation@ element of a OSM file. +module Geo.OSM.Relation( + Relation, + relation + ) where + +import Text.XML.HXT.Arrow +import Geo.OSM.Member +import Geo.OSM.NWRCommon +import Geo.OSM.Util +import Geo.OSM.Tag +import Geo.OSM.Accessor.Id +import Geo.OSM.Accessor.Tags +import Geo.OSM.Accessor.Changeset +import Geo.OSM.Accessor.Visible +import Geo.OSM.Accessor.User +import Geo.OSM.Accessor.Uid +import Geo.OSM.Accessor.Timestamp +import Geo.OSM.Accessor.Members +import Prelude hiding (id) + +-- | The @relation@ element of a OSM file. +data Relation = Relation [Member] NWRCommon + deriving Eq + +instance XmlPickler Relation where + xpickle = xpElem "relation" (xpWrap (uncurry Relation, \(Relation m r) -> (m, r)) + (xpPair (xpList xpickle) xpickle)) + +instance Show Relation where + show = showPickled [] + +instance Members Relation where + members (Relation x _) = x + +instance Id Relation where + id (Relation _ x) = id x + +instance Tags Relation where + tags (Relation _ x) = tags x + +instance Changeset Relation where + changeset (Relation _ x) = changeset x + +instance Visible Relation where + visible (Relation _ x) = visible x + +instance User Relation where + user (Relation _ x) = user x + +instance Uid Relation where + uid (Relation _ x) = uid x + +instance Timestamp Relation where + timestamp (Relation _ x) = timestamp x + +-- | Constructs a relation with a list of members, id, list of tags, changeset, visible, user&uid and timestamp. +relation :: [Member] -- ^ The list of members (@member@ elements). + -> String -- ^ The @id@ attribute. + -> [Tag] -- ^ The list of tags (@tag@ elements). + -> Maybe String -- ^ The @changeset@ attribute. + -> Bool -- ^ The @visible@ attribute. + -> (Maybe String, Maybe String) -- ^ The @user@ and @uid@ attributes. + -> Maybe String -- ^ The @timestamp@ attribute. + -> Relation +relation = (. nwrCommon) . (.) . (.) . (.) . (.) . (.) . Relation diff --git a/Geo/OSM/Tag.hs b/Geo/OSM/Tag.hs new file mode 100644 --- /dev/null +++ b/Geo/OSM/Tag.hs @@ -0,0 +1,32 @@ +-- | The @tag@ element of a OSM file. +module Geo.OSM.Tag( + Tag, + tag + ) where + +import Text.XML.HXT.Arrow +import Geo.OSM.Util +import Geo.OSM.Accessor.K +import Geo.OSM.Accessor.V + +-- | The @tag@ element of a OSM file. +data Tag = Tag String String + deriving Eq + +instance XmlPickler Tag where + xpickle = xpElem "tag" (xpWrap (uncurry Tag, \(Tag k' v') -> (k', v')) (xpPair (xpAttr "k" xpText) (xpAttr "v" xpText))) + +instance Show Tag where + show = showPickled [] + +instance K Tag where + k (Tag x _) = x + +instance V Tag where + v (Tag _ x) = x + +-- | Constructs a tag with a key and value. +tag :: String -- ^ The key (@k@ attribute). + -> String -- ^ The value (@v@ attribute). + -> Tag +tag = Tag diff --git a/Geo/OSM/Util.hs b/Geo/OSM/Util.hs new file mode 100644 --- /dev/null +++ b/Geo/OSM/Util.hs @@ -0,0 +1,10 @@ +-- | Utilities for parsing OSM files. +module Geo.OSM.Util( + showPickled + ) where + +import Text.XML.HXT.Arrow + +-- | Pickles a value then writes the document to a string. +showPickled :: (XmlPickler a) => Attributes -> a -> String +showPickled a = concat . (pickleDoc xpickle >>> runLA (writeDocumentToString a)) diff --git a/Geo/OSM/Way.hs b/Geo/OSM/Way.hs new file mode 100644 --- /dev/null +++ b/Geo/OSM/Way.hs @@ -0,0 +1,66 @@ +-- | The @way@ element of a OSM file. +module Geo.OSM.Way( + Way, + way + ) where + +import Text.XML.HXT.Arrow +import Geo.OSM.Nd +import Geo.OSM.NWRCommon +import Geo.OSM.Util +import Geo.OSM.Tag +import Geo.OSM.Accessor.Id +import Geo.OSM.Accessor.Tags +import Geo.OSM.Accessor.Changeset +import Geo.OSM.Accessor.Visible +import Geo.OSM.Accessor.User +import Geo.OSM.Accessor.Uid +import Geo.OSM.Accessor.Timestamp +import Geo.OSM.Accessor.Nds +import Prelude hiding (id) + +-- | The @way@ element of a OSM file. +data Way = Way [Nd] NWRCommon + deriving Eq + +instance XmlPickler Way where + xpickle = xpElem "way" (xpWrap (uncurry Way, \(Way n r) -> (n, r)) + (xpPair (xpList xpickle) xpickle)) + +instance Show Way where + show = showPickled [] + +instance Nds Way where + nds (Way x _) = x + +instance Id Way where + id (Way _ x) = id x + +instance Tags Way where + tags (Way _ x) = tags x + +instance Changeset Way where + changeset (Way _ x) = changeset x + +instance Visible Way where + visible (Way _ x) = visible x + +instance User Way where + user (Way _ x) = user x + +instance Uid Way where + uid (Way _ x) = uid x + +instance Timestamp Way where + timestamp (Way _ x) = timestamp x + +-- | Constructs a way with a list of nds, id, list of tags, changeset, visible, user&uid and timestamp. +way :: [Nd] -- ^ The list of nds (@nd@ elements). + -> String -- ^ The @id@ attribute. + -> [Tag] -- ^ The list of tags (@tag@ elements). + -> Maybe String -- ^ The @changeset@ attribute. + -> Bool -- ^ The @visible@ attribute. + -> (Maybe String, Maybe String) -- ^ The @user@ and @uid@ attributes. + -> Maybe String -- ^ The @timestamp@ attribute. + -> Way +way = (. nwrCommon) . (.) . (.) . (.) . (.) . (.) . Way diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright 2009 Tony Morris + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/MountBarney.osm b/MountBarney.osm new file mode 100644 # file too large to diff: MountBarney.osm diff --git a/OSM.cabal b/OSM.cabal new file mode 100644 --- /dev/null +++ b/OSM.cabal @@ -0,0 +1,65 @@ +Name: OSM +Version: 0.1 +License: BSD3 +License-File: LICENSE +Synopsis: Parse OpenStreetMap files +Description: Parse OpenStreetMap http:\/\/osm.org/ files using HXT into data structures. + The Geo.OSM module is the core module that exports all others. +Category: Utils +Author: Tony Morris +Maintainer: tmorris@tmorris.net +Copyright: 2009 Tony Morris +build-type: Simple +cabal-version: >= 1.2 +extra-source-files: Example.hs, MountBarney.osm + +Flag small_base + Description: Choose the new, split-up base package. + +Library + if flag(small_base) + Build-Depends: base < 4 && >= 3, hxt, containers + else + Build-Depends: base < 3, hxt, containers + + GHC-Options: -Wall + Exposed-Modules: Geo.OSM + Geo.OSM.Tag + Geo.OSM.Nd + Geo.OSM.NWRCommon + Geo.OSM.MemberType + Geo.OSM.Member + Geo.OSM.Way + Geo.OSM.Node + Geo.OSM.Relation + Geo.OSM.Bounds + Geo.OSM.Bound + Geo.OSM.NodeWayRelation + Geo.OSM.OSM + Geo.OSM.Util + Geo.OSM.Accessor.K + Geo.OSM.Accessor.V + Geo.OSM.Accessor.Ref + Geo.OSM.Accessor.Mtype + Geo.OSM.Accessor.Role + Geo.OSM.Accessor.Id + Geo.OSM.Accessor.Tags + Geo.OSM.Accessor.Changeset + Geo.OSM.Accessor.Visible + Geo.OSM.Accessor.User + Geo.OSM.Accessor.Uid + Geo.OSM.Accessor.Timestamp + Geo.OSM.Accessor.Nds + Geo.OSM.Accessor.Lat + Geo.OSM.Accessor.Lon + Geo.OSM.Accessor.Members + Geo.OSM.Accessor.Minlat + Geo.OSM.Accessor.Maxlat + Geo.OSM.Accessor.Minlon + Geo.OSM.Accessor.Maxlon + Geo.OSM.Accessor.Origin + Geo.OSM.Accessor.Box + Geo.OSM.Accessor.Version + Geo.OSM.Accessor.Generator + Geo.OSM.Accessor.BoundOrs + Geo.OSM.Accessor.NodeWayRelations diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain