diff options
Diffstat (limited to 'lib')
-rw-r--r-- | lib/CheckMap.hs | 5 | ||||
-rw-r--r-- | lib/Properties.hs | 21 | ||||
-rw-r--r-- | lib/Tiled2.hs | 251 |
3 files changed, 79 insertions, 198 deletions
diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs index 036f4e8..d7d45c0 100644 --- a/lib/CheckMap.hs +++ b/lib/CheckMap.hs @@ -23,7 +23,8 @@ import LintWriter (LintResult (..), LintWriter, askContext, filterLintLevel, lintToDep, resultToDeps, resultToLints, resultToOffers, runLintWriter) import Properties (checkLayerProperty, checkMap, checkTileset) -import Tiled2 (Layer (layerName, layerProperties), +import Tiled2 (HasProperties (getProperties), + Layer (layerName, layerProperties), LoadResult (..), Tiledmap (tiledmapLayers, tiledmapTilesets), Tileset (tilesetName), loadTiledmap) @@ -96,7 +97,7 @@ runLinter tiledmap depth = MapResult checkLayer :: LintWriter Layer checkLayer = do layer <- askContext - mapM_ checkLayerProperty (layerProperties layer) + mapM_ checkLayerProperty (getProperties layer) -- human-readable lint output, e.g. for consoles instance PrettyPrint (Level, MapResult) where diff --git a/lib/Properties.hs b/lib/Properties.hs index ed97355..1b0569d 100644 --- a/lib/Properties.hs +++ b/lib/Properties.hs @@ -8,10 +8,12 @@ module Properties (checkLayerProperty, checkMap, checkTileset) where import Control.Monad (unless, when) import Data.Text (Text, isPrefixOf) -import Tiled2 (Layer (..), Property (..), PropertyValue (..), +import Tiled2 (HasProperties (getProperties), Layer (..), + Property (..), PropertyValue (..), Tiledmap (..), Tileset (..)) import Util (layerIsEmpty, prettyprint) +import Data.Maybe (fromMaybe) import LintWriter (LintWriter, askContext, askFileDepth, complain, dependsOn, forbid, offersEntrypoint, suggest, warn) @@ -29,14 +31,14 @@ checkMap = do tiledmap <- askContext -- test other things - mapM_ checkMapProperty (tiledmapProperties tiledmap) + mapM_ checkMapProperty (fromMaybe [] $ tiledmapProperties tiledmap) -- some layers should exist hasLayerNamed "start" (const True) "The map must have one layer named \"start\"" hasLayerNamed "floorLayer" ((==) "objectgroup" . layerType) "The map must have one layer named \"floorLayer\" of type \"objectgroup\"" - hasLayer (flip containsProperty "exitUrl" . layerProperties) + hasLayer (flip containsProperty "exitUrl" . getProperties) "The map must contain at least one layer with the property \"exitUrl\" set" -- reject maps not suitable for workadventure @@ -82,7 +84,7 @@ checkTileset tileset = do -- TODO: check copyright! requireProperty "copyright" - mapM_ checkTilesetProperty (tilesetProperties tileset) + mapM_ checkTilesetProperty (fromMaybe [] $ tilesetProperties tileset) checkTilesetProperty :: Property -> LintWriter Tileset checkTilesetProperty p@(Property name value) = case name of @@ -182,15 +184,6 @@ checkLayerProperty p@(Property name _value) = case name of --------- Helper functions & stuff --------- -class HasProperties a where - getProperties :: a -> [Property] - -instance HasProperties Layer where - getProperties = layerProperties - -instance HasProperties Tileset where - getProperties = tilesetProperties - unlessHasProperty :: HasProperties a => Text -> LintWriter a -> LintWriter a unlessHasProperty name andthen = do layer <- askContext @@ -229,7 +222,7 @@ suggestProperty (Property name value) = -- | does this layer have the given property? -containsProperty :: [Property] -> Text -> Bool +containsProperty :: Foldable t => t Property -> Text -> Bool containsProperty props name = any (\(Property name' _) -> name' == name) props diff --git a/lib/Tiled2.hs b/lib/Tiled2.hs index 3fc8c31..45b8ad0 100644 --- a/lib/Tiled2.hs +++ b/lib/Tiled2.hs @@ -2,29 +2,27 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} + -- | This module provides Haskell types for Tiled's JSON exports, which you can -- read about at http://doc.mapeditor.org/en/latest/reference/json-map-format/. -- That said - as of the writing of this module the JSON documentation does not -- cover some of the types and records that are available in the format. For -- those you should read the TMX documentation at -- http://doc.mapeditor.org/en/latest/reference/tmx-map-format/ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} module Tiled2 where -import Control.Applicative ((<|>)) import Control.Exception (try) import Control.Exception.Base (SomeException) -import Control.Monad (forM) import Data.Aeson hiding (Object) import qualified Data.Aeson as A import Data.Aeson.Types (Parser, typeMismatch) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LB -import Data.Functor ((<&>)) +import Data.Char (toLower) import Data.Map (Map) -import qualified Data.Map as M import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Vector (Vector) @@ -32,6 +30,14 @@ import GHC.Exts (fromList, toList) import GHC.Generics (Generic) +-- | options for Aeson's generic encoding and parsing functions +aesonOptions :: Int -> Options +aesonOptions l = defaultOptions + { omitNothingFields = True + , rejectUnknownFields = True + , fieldLabelModifier = drop l . map toLower + } + -- | A globally indexed identifier. newtype GlobalId = GlobalId { unGlobalId :: Int } deriving (Ord, Eq, Enum, Num, Generic, Show, FromJSON, ToJSON, FromJSONKey, ToJSONKey) @@ -75,13 +81,6 @@ parseDefault :: FromJSON a => A.Object -> Text -> a -> Parser a parseDefault o s d = fromMaybe d <$> o .:? s -{-- | workadventure custom property -data Property = Property { propertyName :: Text - --, propertyType :: Text (unnecessary since always string) - , propertyValue :: Text - } deriving (Eq, Generic, Show) --} - data PropertyValue = StrProp Text | BoolProp Bool deriving (Eq, Generic, Show) data Property = Property Text PropertyValue @@ -145,46 +144,14 @@ data Object = Object { objectId :: Int } deriving (Eq, Generic, Show) instance FromJSON Object where - parseJSON (A.Object o) = Object <$> o .: "id" - <*> o .: "width" - <*> o .: "height" - <*> o .: "name" - <*> o .: "type" - <*> parseDefault o "properties" M.empty - <*> o .: "visible" - <*> o .: "x" - <*> o .: "y" - <*> o .: "rotation" - <*> o .:? "gid" - <*> parseDefault o "ellipse" False - <*> (fmap . fmap . fmap) fromXYPair (o .:? "polygon") - <*> (fmap . fmap . fmap) fromXYPair (o .:? "polyline") - <*> parseDefault o "text" M.empty - parseJSON invalid = typeMismatch "Object" invalid - + parseJSON = genericParseJSON (aesonOptions 6) instance ToJSON Object where - toJSON Object{..} = omitNulls $ - object [ "id" .= objectId - , "width" .= objectWidth - , "height" .= objectHeight - , "name" .= objectName - , "type" .= objectType - , "properties" .= objectProperties - , "visible" .= objectVisible - , "x" .= objectX - , "y" .= objectY - , "rotation" .= objectRotation - , "gid" .= objectGid - , "ellipse" .= objectEllipse - , "polygon" .= (fmap . fmap) toXYPair objectPolygon - , "polyline" .= (fmap . fmap) toXYPair objectPolyline - , "text" .= objectText - ] + toJSON = genericToJSON (aesonOptions 6) -data Layer = Layer { layerWidth :: Double +data Layer = Layer { layerWidth :: Maybe Double -- ^ Column count. Same as map width for fixed-size maps. - , layerHeight :: Double + , layerHeight :: Maybe Double -- ^ Row count. Same as map height for fixed-size maps. , layerName :: Text -- ^ Name assigned to this layer @@ -200,44 +167,19 @@ data Layer = Layer { layerWidth :: Double -- ^ Array of GIDs. tilelayer only. , layerObjects :: Maybe (Vector Object) -- ^ Array of Objects. objectgroup only. - , layerProperties :: [Property] + , layerProperties :: Maybe [Property] -- ^ string key-value pairs. , layerOpacity :: Float -- ^ Value between 0 and 1 - , layerDraworder :: String + , layerDraworder :: Maybe String -- ^ “topdown” (default) or “index”. objectgroup only. + , layerId :: Int } deriving (Eq, Generic, Show) instance FromJSON Layer where - parseJSON (A.Object o) = Layer <$> (o .: "width" <|> pure 0) - <*> (o .: "height" <|> pure 0) - <*> o .: "name" - <*> o .: "type" - <*> o .: "visible" - <*> o .: "x" - <*> o .: "y" - <*> (o .: "data" <|> pure Nothing) - <*> o .:? "objects" - <*> (o .:? "properties" <&> fromMaybe []) - <*> o .: "opacity" - <*> (o .: "draworder" <|> pure "topdown") - parseJSON invalid = typeMismatch "Layer" invalid - + parseJSON = genericParseJSON (aesonOptions 5) instance ToJSON Layer where - toJSON Layer{..} = omitNulls $ - object [ "width" .= layerWidth - , "height" .= layerHeight - , "name" .= layerName - , "type" .= layerType - , "visible" .= layerVisible - , "x" .= layerX - , "y" .= layerY - , "data" .= layerData - , "objects" .= layerObjects - , "properties" .= layerProperties - , "opacity" .= layerOpacity - , "draworder" .= layerDraworder - ] + toJSON = genericToJSON (aesonOptions 5) data Terrain = Terrain { terrainName :: String @@ -264,35 +206,28 @@ data Frame = Frame { frameDuration :: Int instance FromJSON Frame where parseJSON (A.Object o) = Frame <$> o .: "duration" - <*> o .: "tileId" + <*> o .: "tileid" parseJSON invalid = typeMismatch "Frame" invalid instance ToJSON Frame where toJSON Frame{..} = object [ "duration" .= frameDuration - , "tileId" .= frameTileId + , "tileid" .= frameTileId ] -data Tile = Tile { tileId :: LocalId - , tileProperties :: Map Text Text +data Tile = Tile { tileId :: Int + , tileProperties :: Maybe (Vector Value) , tileImage :: Maybe Value , tileObjectGroup :: Maybe (Vector Object) , tileAnimation :: Maybe (Vector Frame) } deriving (Eq, Generic, Show) instance FromJSON Tile where - parseJSON (A.Object o) = Tile 0 <$> (o .: "properties" <|> pure mempty) - <*> (o .: "image" <|> pure Nothing) - <*> (o .: "objectGroup" <|> pure mempty) - <*> (o .: "animation" <|> pure mempty) - parseJSON invalid = typeMismatch "Tile" invalid + parseJSON = genericParseJSON (aesonOptions 4) instance ToJSON Tile where - toJSON Tile{..} = object [ "properties" .= tileProperties - , "image" .= tileImage - , "objectGroup" .= tileObjectGroup - , "animation" .= tileAnimation - ] + toJSON = genericToJSON (aesonOptions 4) + data Tileset = Tileset { tilesetFirstgid :: GlobalId @@ -309,136 +244,88 @@ data Tileset = Tileset { tilesetFirstgid :: GlobalId -- ^ Width of source image in pixels , tilesetImageheight :: Int -- ^ Height of source image in pixels - , tilesetProperties :: [Property] + , tilesetProperties :: Maybe [Property] -- ^ String key-value pairs - , tilesetPropertytypes :: Map Text Text + , tilesetPropertytypes :: Maybe (Map Text Text) -- ^ String key-value pairs , tilesetMargin :: Int -- ^ Buffer between image edge and first tile (pixels) , tilesetSpacing :: Int -- ^ Spacing between adjacent tiles in image (pixels) - , tilesetTileproperties :: Map GlobalId (Map Text Text) + , tilesetTileproperties :: Maybe (Map GlobalId (Map Text Text)) -- ^ Per-tile properties, indexed by gid as string - , tilesetTerrains :: Vector Terrain + , tilesetTerrains :: Maybe (Vector Terrain) -- ^ Array of Terrains (optional) , tilesetColumns :: Int -- ^ The number of tile columns in the tileset , tilesetTilecount :: Int -- ^ The number of tiles in this tileset - , tilesetTiles :: Map LocalId Tile + , tilesetTiles :: Maybe (Vector Tile) -- ^ Tiles (optional) + , tilesetTransparentcolor :: Maybe String } deriving (Eq, Generic, Show) newtype TransitiveTilesetMap = TransitiveTilesetMap (Map LocalId Value) deriving (Show, Eq, Generic, FromJSON) -parseTiles :: A.Object -> Parser (Map LocalId Tile) -parseTiles o = do - TransitiveTilesetMap localId2Value <- o .: "tiles" - localIdAndTiles <- forM (M.toList localId2Value) $ \(lid, val) -> do - tile <- parseJSON val - return (lid, tile{ tileId = lid }) - return $ M.fromList localIdAndTiles - instance FromJSON Tileset where - parseJSON (A.Object o) = Tileset <$> o .: "firstgid" - <*> o .: "image" - <*> o .: "name" - <*> o .: "tilewidth" - <*> o .: "tileheight" - <*> o .: "imagewidth" - <*> o .: "imageheight" - <*> (o .: "properties" <|> pure mempty) - <*> (o .: "propertytypes" <|> pure mempty) - <*> o .: "margin" - <*> o .: "spacing" - <*> (o .: "tileproperties" <|> pure mempty) - <*> (o .: "terrains" <|> pure mempty) - <*> o .: "columns" - <*> o .: "tilecount" - <*> (parseTiles o <|> pure mempty) - parseJSON invalid = typeMismatch "Tileset" invalid + parseJSON = genericParseJSON (aesonOptions 7) instance ToJSON Tileset where - toJSON Tileset{..} = object [ "firstgid" .= tilesetFirstgid - , "image" .= tilesetImage - , "name" .= tilesetName - , "tilewidth" .= tilesetTilewidth - , "tileheight" .= tilesetTileheight - , "imagewidth" .= tilesetImagewidth - , "imageheight" .= tilesetImageheight - , "properties" .= tilesetProperties - , "propertytypes" .= tilesetPropertytypes - , "margin" .= tilesetMargin - , "spacing" .= tilesetSpacing - , "tileproperties" .= tilesetTileproperties - , "terrains" .= tilesetTerrains - , "columns" .= tilesetColumns - , "tilecount" .= tilesetTilecount - , "tiles" .= tilesetTiles - ] + toJSON = genericToJSON (aesonOptions 7) -- | The full monty. -data Tiledmap = Tiledmap { tiledmapVersion :: Float +data Tiledmap = Tiledmap { tiledmapVersion :: Float -- ^ The JSON format version - , tiledmapTiledversion :: String + , tiledmapTiledversion :: String -- ^ The Tiled version used to save the file - , tiledmapWidth :: Int + , tiledmapWidth :: Int -- ^ Number of tile columns - , tiledmapHeight :: Int + , tiledmapHeight :: Int -- ^ Number of tile rows - , tiledmapTilewidth :: Double + , tiledmapTilewidth :: Double -- ^ Map grid width. - , tiledmapTileheight :: Double + , tiledmapTileheight :: Double -- ^ Map grid height. - , tiledmapOrientation :: String + , tiledmapOrientation :: String -- ^ Orthogonal, isometric, or staggered - , tiledmapLayers :: Vector Layer + , tiledmapLayers :: Vector Layer -- ^ Array of Layers - , tiledmapTilesets :: Vector Tileset + , tiledmapTilesets :: Vector Tileset -- ^ Array of Tilesets - , tiledmapBackgroundcolor :: Maybe String + , tiledmapBackgroundcolor :: Maybe String -- ^ Hex-formatted color (#RRGGBB or #AARRGGBB) (optional) - , tiledmapRenderorder :: String + , tiledmapRenderorder :: String -- ^ Rendering direction (orthogonal maps only) - , tiledmapProperties :: [Property] + , tiledmapProperties :: Maybe [Property] -- ^ String key-value pairs - , tiledmapNextobjectid :: Int + , tiledmapNextobjectid :: Int -- ^ Auto-increments for each placed object + , tiledmapCompressionLevel :: Maybe Int + , tiledmapInfinite :: Bool + , tiledmapNextlayerid :: Maybe Int + , tiledmapHexsidelength :: Maybe Int + , tiledmapStaggerindex :: Maybe String + , tiledmapType :: String } deriving (Eq, Generic, Show) instance FromJSON Tiledmap where - parseJSON (A.Object o) = Tiledmap <$> o .: "version" - <*> o .: "tiledversion" - <*> o .: "width" - <*> o .: "height" - <*> o .: "tilewidth" - <*> o .: "tileheight" - <*> o .: "orientation" - <*> o .: "layers" - <*> o .: "tilesets" - <*> (o .: "backgroundcolor" <|> pure Nothing) - <*> o .: "renderorder" - <*> (o .:? "properties" <&> fromMaybe []) - <*> o .: "nextobjectid" - parseJSON invalid = typeMismatch "Tiledmap" invalid - + parseJSON = genericParseJSON (aesonOptions 8) instance ToJSON Tiledmap where - toJSON Tiledmap{..} = object [ "version" .= tiledmapVersion - , "tiledversion" .= tiledmapTiledversion - , "width" .= tiledmapWidth - , "height" .= tiledmapHeight - , "tilewidth" .= tiledmapTilewidth - , "tileheight" .= tiledmapTileheight - , "orientation" .= tiledmapOrientation - , "layers" .= tiledmapLayers - , "tilesets" .= tiledmapTilesets - , "backgroundcolor" .= tiledmapBackgroundcolor - , "renderorder" .= tiledmapRenderorder - , "properties" .= tiledmapProperties - , "nextobjectid" .= tiledmapNextobjectid - ] + toJSON = genericToJSON (aesonOptions 8) + + +class HasProperties a where + getProperties :: a -> [Property] + +instance HasProperties Layer where + getProperties = fromMaybe [] . layerProperties + +instance HasProperties Tileset where + getProperties = fromMaybe [] . tilesetProperties + + data LoadResult = Loaded Tiledmap | IOErr String | DecodeErr String |