diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013, Ben Gamari + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * 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. + + * Neither the name of Ben Gamari nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT +OWNER 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/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Data/Geo/WKT.hs b/src/Data/Geo/WKT.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geo/WKT.hs @@ -0,0 +1,7 @@ +module Data.Geo.WKT ( module Data.Geo.WKT.Types + , module Data.Geo.WKT.Parser + ) where + +import Data.Geo.WKT.Types +import Data.Geo.WKT.Parser + diff --git a/src/Data/Geo/WKT/Parser.hs b/src/Data/Geo/WKT/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geo/WKT/Parser.hs @@ -0,0 +1,135 @@ +module Data.Geo.WKT.Parser where + +import Data.Geo.WKT.Types +import Linear hiding (unit) +import Control.Applicative +import Control.Monad (ap) +import Text.ParserCombinators.Parsec hiding (many) +import Text.ParserCombinators.Parsec.Number hiding (number) + +object :: String -> Parser a -> Parser a +object keyword parser = do + string keyword + between (char '[') (char ']') parser + +quotedString :: Parser String +quotedString = do + char '"' + manyTill anyChar (char '"') + +fieldSep :: Parser () +fieldSep = char ',' >> spaces + +number :: Parser Double +number = sign `ap` floating2 True + +twinAxes = do + ax1 <- axis + fieldSep + ax2 <- axis + fieldSep + return (ax1, ax2) + +unit :: Parser Unit +unit = object "UNIT" $ do + name <- quotedString + fieldSep + conv <- number + auth <- optionMaybe $ fieldSep *> authority + return $ Unit name conv auth + +parameter :: Parser Parameter +parameter = object "PARAMETER" $ do + name <- quotedString + fieldSep + value <- number + return $ Parameter name value + +authority :: Parser Authority +authority = object "AUTHORITY" $ do + name <- quotedString + fieldSep + code <- quotedString + return $ Authority name code + +axis :: Parser Axis +axis = object "AXIS" $ do + name <- quotedString + fieldSep + dir <- choice [ string "NORTH" >> return North + , string "SOUTH" >> return South + , string "EAST" >> return East + , string "WEST" >> return West + , string "UP" >> return Up + , string "DOWN" >> return Down + , string "OTHER" >> return Other + ] + return $ Axis name dir + +projection :: Parser Projection +projection = object "PROJECTION" $ do + name <- quotedString + auth <- optionMaybe $ fieldSep *> authority + return $ Proj name auth + +spheroid :: Parser Spheroid +spheroid = object "SPHEROID" $ do + name <- quotedString + fieldSep + semiMajor <- number + fieldSep + invFlat <- number + auth <- optionMaybe $ fieldSep *> authority + return $ Spheroid name semiMajor invFlat auth + +datum :: Parser Datum +datum = object "DATUM" $ do + name <- quotedString + fieldSep + s <- spheroid + wgs <- optionMaybe $ fieldSep *> toWGS84 + auth <- optionMaybe $ fieldSep *> authority + return $ Datum name s wgs auth + +primeMeridian :: Parser PrimeMeridian +primeMeridian = object "PRIMEM" $ do + name <- quotedString + fieldSep + long <- number + auth <- optionMaybe $ fieldSep *> authority + return $ PrimeMeridian name long auth + +toWGS84 :: Parser ToWGS84 +toWGS84 = object "TOWGS84" $ do + d <- V3 <$> number <*> number <*> number + e <- V3 <$> number <*> number <*> number + ppm <- number + return $ ToWGS84 d e ppm + +projectedCS :: Parser ProjectedCS +projectedCS = object "PROJCS" $ do + name <- quotedString + fieldSep + geogcs <- geographicCS + fieldSep + proj <- projection + fieldSep + params <- many $ parameter <* fieldSep + linearUnit <- unit + axes <- optionMaybe $ fieldSep *> twinAxes + auth <- optionMaybe $ fieldSep *> authority + return $ ProjCS name geogcs proj params linearUnit axes auth + +geographicCS :: Parser GeographicCS +geographicCS = object "GEOGCS" $ do + name <- quotedString + fieldSep + dat <- datum + fieldSep + primem <- primeMeridian + fieldSep + angularUnit <- unit + axes <- optionMaybe $ fieldSep *> twinAxes + auth <- optionMaybe $ fieldSep *> authority + return $ GeogCS name dat primem angularUnit axes auth + diff --git a/src/Data/Geo/WKT/Types.hs b/src/Data/Geo/WKT/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/Geo/WKT/Types.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, DeriveGeneric #-} + +module Data.Geo.WKT.Types where + +import GHC.Generics +import Data.Typeable +import Control.Lens +import Linear + +-- ^ From http://www.geoapi.org/3.0/javadoc/org/opengis/referencing/doc-files/WKT.html + +data Parameter = Parameter { _paramName :: String + , _paramValue :: Double + } + deriving (Show, Eq, Ord, Typeable, Generic) +makeLenses ''Parameter + +data Authority = Authority { _authorityName :: String + , _authorityCode :: String + } + deriving (Show, Eq, Ord, Typeable, Generic) +makeLenses ''Authority + +data Unit = Unit { _unitName :: String + , _unitConversionFactor :: Double + , _unitAuthority :: Maybe Authority + } + deriving (Show, Eq, Ord, Typeable, Generic) +makeLenses ''Unit + +data Spheroid = Spheroid { _spheroidName :: String + , _spheroidSemiMajor :: Double + , _spheroidInverseFlattening :: Double + , _spheroidAuthority :: Maybe Authority + } + deriving (Show, Eq, Ord, Typeable, Generic) +makeLenses ''Spheroid + +data ToWGS84 = ToWGS84 { _towgs84D :: V3 Double + , _towgs84E :: V3 Double + , _towgs84PPM :: Double + } + deriving (Show, Eq, Ord, Typeable, Generic) +makeLenses ''ToWGS84 + +data Datum = Datum { _datumName :: String + , _datumSpheroid :: Spheroid + , _datumToWGS84 :: Maybe ToWGS84 + , _datumAuthority :: Maybe Authority + } + deriving (Show, Eq, Ord, Typeable, Generic) +makeLenses ''Datum + +data PrimeMeridian = PrimeMeridian { _primemName :: String + , _primemLongitude :: Double + , _primemAuthority :: Maybe Authority + } + deriving (Show, Eq, Ord, Typeable, Generic) +makeLenses ''PrimeMeridian + +data AxisDirection = North | South | East | West | Up | Down | Other + deriving (Show, Eq, Ord, Typeable, Generic) + +data Axis = Axis { _axisName :: String + , _axisDirection :: AxisDirection + } + deriving (Show, Eq, Ord, Typeable, Generic) +makeLenses ''Axis + +data GeographicCS = GeogCS { _geogcsName :: String + , _geogcsDatum :: Datum + , _geogcsPrimeMeridian :: PrimeMeridian + , _geogcsAngularUnit :: Unit + , _geogcsTwinAxes :: Maybe (Axis, Axis) + , _geogcsAuthority :: Maybe Authority + } + deriving (Show, Eq, Ord, Typeable, Generic) +makeLenses ''GeographicCS + +data Projection = Proj { _projName :: String + , _projAuthority :: Maybe Authority + } + deriving (Show, Eq, Ord, Typeable, Generic) +makeLenses ''Projection + +data ProjectedCS = ProjCS { _projcsName :: String + , _projcsGeographicCS :: GeographicCS + , _projcsProjection :: Projection + , _projcsParameters :: [Parameter] + , _projcsLinearUnit :: Unit + , _projcsTwinAxes :: Maybe (Axis, Axis) + , _projcsAuthority :: Maybe Authority + } + deriving (Show, Eq, Ord, Typeable, Generic) +makeLenses ''ProjectedCS diff --git a/wkt.cabal b/wkt.cabal new file mode 100644 --- /dev/null +++ b/wkt.cabal @@ -0,0 +1,28 @@ +name: wkt +version: 0.2 +synopsis: Parsers and types for Well-Known Text data +description: Parsers and types for Well-Known Text data +homepage: http://github.com/bgamari/wkt +license: BSD3 +license-file: LICENSE +author: Ben Gamari +maintainer: bgamari.foss@gmail.com +copyright: (c) 2014 Ben Gamari +category: Data +build-type: Simple +cabal-version: >=1.10 + +source-repository head + type: git + location: git://github.com/bgamari/wkt.git + +library + exposed-modules: Data.Geo.WKT, Data.Geo.WKT.Types, Data.Geo.WKT.Parser + other-extensions: TemplateHaskell + build-depends: base >=4.6 && <4.8, + lens >=3.9 && <4.3, + linear >=1.3 && <1.11, + parsec >=3.1 && <3.2, + parsec-numbers >=0.0 && <0.1 + hs-source-dirs: src + default-language: Haskell2010