From 35566bf15f43c355bdc72d62841a850a90c8ba03 Mon Sep 17 00:00:00 2001 From: stuebinm Date: Thu, 16 Sep 2021 02:27:26 +0200 Subject: moving lots of code around (also renaming things now that concepts seem a bit clearer) --- lib/LintWriter.hs | 61 +++++++++ lib/Properties.hs | 116 ++++++++++++++++ lib/Tiled2.hs | 400 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ lib/Types.hs | 3 + lib/Util.hs | 27 ++++ src/Main.hs | 187 ++++--------------------- src/Tiled2.hs | 400 ------------------------------------------------------ tiled-hs.cabal | 35 +++-- 8 files changed, 660 insertions(+), 569 deletions(-) create mode 100644 lib/LintWriter.hs create mode 100644 lib/Properties.hs create mode 100644 lib/Tiled2.hs create mode 100644 lib/Types.hs create mode 100644 lib/Util.hs delete mode 100644 src/Tiled2.hs diff --git a/lib/LintWriter.hs b/lib/LintWriter.hs new file mode 100644 index 0000000..0146366 --- /dev/null +++ b/lib/LintWriter.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NamedFieldPuns #-} + +-- | a monad that collects warnings, outputs, etc, +module LintWriter where + +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Data.Maybe (isJust, mapMaybe) +import Control.Monad.Writer +import Control.Monad.Trans.Maybe + + +-- | Levels of errors and warnings, collectively called +-- "Hints" until I can think of some better name +data Level = Warning | Suggestion | Info | Forbidden | Error + deriving Show + +-- | a hint comes with an explanation (and a level) +data Hint = Hint + { hintLevel :: Level + , hintMsg :: Text } + deriving Show + +-- shorter constructor +hint level msg = Hint { hintLevel = level, hintMsg = msg } + +-- | a monad to collect hints. If it yields Left, then the +-- map is flawed in some fundamental way which prevented us +-- from getting any hints at all except whatever broke it +type LintWriter a = WriterT [Hint] (Either Hint) a + +type LintResult a = Either Hint (a, [Hint]) + +-- | write a hint into the LintWriter monad +lint :: Level -> Text -> LintWriter () +lint level = tell . (: []) . hint level + +warn = lint Warning +info = lint Info +forbid = lint Forbidden +suggest = lint Suggestion +complain = lint Error + + +-- TODO: all these functions should probably also just operate on LintWriter + +-- | converts a Maybe to an Either, with a default value for Left +unwrap :: b -> Maybe a -> Either b a +unwrap hint maybe = case maybe of + Just a -> Right a + Nothing -> Left hint + +-- | unwrap and produce a warning if the value was Nothing +unwrapWarn :: Text -> Maybe a -> Either Hint a +unwrapWarn msg = unwrap $ hint Warning msg + +-- | same as unwrapWarn, but for booleans +assertWarn :: Text -> Bool -> LintWriter () +assertWarn msg cond = lift $ if cond then Right () else Left $ hint Warning msg diff --git a/lib/Properties.hs b/lib/Properties.hs new file mode 100644 index 0000000..0b9a71f --- /dev/null +++ b/lib/Properties.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Contains checks for custom properties of the map json +module Properties (checkProperty) where + + +import Control.Monad (unless, when) +import Control.Monad.Trans.Class (lift) +import Data.Aeson as Aeson (Value (String)) +import Data.Map (Map, (!?)) +import Data.Text (Text) +import Tiled2 (Layer (layerProperties)) +import Util (quote, showAeson) + +import LintWriter (Hint, LintWriter, Level(..), hint, + assertWarn, complain, forbid, info, + suggest, unwrapWarn, warn) + +-- | values may be anything, and are not typechecked (for now), +-- since they may contain arbitrary json – our only guarantee +-- is that they are named, and therefore a map. +type Properties = Map Text Aeson.Value + + + +-- | /technically/ the main function here +-- +-- given a property, check if it is valid. It gets a reference +-- to its own layer since sometimes the presense of one property +-- implies the presence or absense of another. +-- +-- The tests in here are meant to comply with the informal spec +-- at https://workadventu.re/map-building +-- +-- In practice, the actual specifiaction of what is allowed is +-- handled in checkProperty', since apparently all possible layerProperties +-- are strings anyways, so this just extracts that string and then +-- calls that. +checkProperty :: Layer -> Properties -> LintWriter () +checkProperty layer prop = do + tyObj <- lift $ getAttr prop "name" + ty <- lift $ case tyObj of + Aeson.String str -> Right str + _ -> Left (hint Suggestion "wtf") + checkProperty' layer prop ty + +-- | The /real/ main thing. +-- +-- I've attempted to build the LintWriter monad in a way +-- that should make this readable even to non-Haskellers +checkProperty' :: Layer -> Properties -> Text -> LintWriter () +checkProperty' layer prop ty = case ty of + "jitsiRoom" -> do + propEqual prop "type" "string" + urlValue <- lift $ getAttr prop "value" + info $ "found jitsi room: " <> showAeson urlValue + suggestPropertyValue "jitsiTrigger" "onaction" + "jitsiTrigger" -> + requireProperty "jitsiRoom" + "jitsiUrl" -> isForbidden + "jitsiConfig" -> isForbidden + "jitsiClientConfig" -> isForbidden + "jitsiRoomAdminTag" -> isForbidden + "playAudio" -> do + -- TODO: check for url validity? + propEqual prop "type" "string" + "audioLoop" -> + requireProperty "playAudio" + "audioVolume" -> + requireProperty "playAudio" + "openWebsite" -> + suggestPropertyValue "openWebsiteTrigger" "onaction" + "openWebsiteTrigger" -> + requireProperty "openWebsite" + "openWebsitePolicy" -> + requireProperty "openWebsite" + "exitUrl" -> pure () + "startLayer" -> pure () + -- could also make this a "hard error" (i.e. Left), but then it + -- stops checking other properties as checkLayer short-circuits. + _ -> warn $ "unknown property type " <> quote ty + where + -- | require some property in this layer + requireProperty name = unless (hasProperty name layer) + $ complain $ "property "<>quote name<>" requires property "<>quote ty + -- | forbid some property in this layer + forbidProperty name = when (hasProperty name layer) + $ forbid $ "property " <> quote name <> " should not be used" + -- | This property is forbidden and should not be used + isForbidden = forbid $ "property " <> quote ty <> " should not be used" + -- TODO: check if the property has the correct value + suggestPropertyValue name value = unless (hasProperty name layer) + $ suggest $ "set property " <> quote name <> " to " <> quote value + + + + +-- | does this layer have the given property? +hasProperty :: Text -> Layer -> Bool +hasProperty name = any + (\prop -> prop !? "name" == Just (Aeson.String name)) + . layerProperties + +-- | get an attribute from a map +getAttr :: Properties -> Text -> Either Hint Aeson.Value +getAttr props name = unwrapWarn msg $ props !? name + where msg = "field " <> name <> "does not exist" + +-- | lint goal: the property with the given name has given value +propEqual :: Properties -> Text -> Aeson.Value -> LintWriter () +propEqual props name value = do + value' <- lift $ getAttr props name + assertWarn ("field "<>name<>" has unexpected value "<>showAeson value' + <>", should be "<>showAeson value) + $ value' == value diff --git a/lib/Tiled2.hs b/lib/Tiled2.hs new file mode 100644 index 0000000..17b2b77 --- /dev/null +++ b/lib/Tiled2.hs @@ -0,0 +1,400 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# 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/ +module Tiled2 where + +import Control.Applicative ((<|>)) +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.Lazy.Char8 as C8 +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Data.Vector (Vector) +import GHC.Exts (fromList, toList) +import GHC.Generics (Generic) + + +-- | A globally indexed identifier. +newtype GlobalId = GlobalId { unGlobalId :: Int } + deriving (Ord, Eq, Enum, Num, Generic, Show, FromJSON, ToJSON, FromJSONKey, ToJSONKey) + + +-- | A locally indexed identifier. +newtype LocalId = LocalId { unLocalId :: Int } + deriving (Ord, Eq, Enum, Num, Generic, Show, FromJSON, ToJSON, FromJSONKey, ToJSONKey) + + +data XYPair a = XYPair a a + +instance FromJSON a => FromJSON (XYPair a) where + parseJSON (A.Object o) = + XYPair <$> o .: "x" + <*> o .: "y" + parseJSON invalid = typeMismatch "Object" invalid + +instance ToJSON a => ToJSON (XYPair a) where + toJSON (XYPair x y) = + object [ "x" .= x + , "y" .= y + ] + +fromXYPair :: XYPair a -> (a, a) +fromXYPair (XYPair x y) = (x, y) + +toXYPair :: (a, a) -> XYPair a +toXYPair (x, y) = XYPair x y + +omitNulls :: Value -> Value +omitNulls (A.Object hs) = A.Object + . fromList + . filter ((/= Null) . snd) + $ toList hs +omitNulls x = x + +parseDefault :: FromJSON a => A.Object -> Text -> a -> Parser a +parseDefault o s d = fromMaybe d <$> o .:? s + + +data Object = Object { objectId :: Int + -- ^ Incremental id - unique across all objects + , objectWidth :: Double + -- ^ Width in pixels. Ignored if using a gid. + , objectHeight :: Double + -- ^ Height in pixels. Ignored if using a gid. + , objectName :: String + -- ^ String assigned to name field in editor + , objectType :: String + -- ^ String assigned to type field in editor + , objectProperties :: Map Text Text + -- ^ String key-value pairs + , objectVisible :: Bool + -- ^ Whether object is shown in editor. + , objectX :: Double + -- ^ x coordinate in pixels + , objectY :: Double + -- ^ y coordinate in pixels + , objectRotation :: Float + -- ^ Angle in degrees clockwise + , objectGid :: Maybe GlobalId + -- ^ GID, only if object comes from a Tilemap + , objectEllipse :: Bool + -- ^ Used to mark an object as an ellipse + , objectPolygon :: Maybe (Vector (Double, Double)) + -- ^ A list of x,y coordinates in pixels + , objectPolyline :: Maybe (Vector (Double, Double)) + -- ^ A list of x,y coordinates in pixels + , objectText :: Map Text Text + -- ^ String key-value pairs + } 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 + +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 + ] + + +data Layer = Layer { layerWidth :: Double + -- ^ Column count. Same as map width for fixed-size maps. + , layerHeight :: Double + -- ^ Row count. Same as map height for fixed-size maps. + , layerName :: String + -- ^ Name assigned to this layer + , layerType :: String + -- ^ “tilelayer”, “objectgroup”, or “imagelayer” + , layerVisible :: Bool + -- ^ Whether layer is shown or hidden in editor + , layerX :: Double + -- ^ Horizontal layer offset in tiles. Always 0. + , layerY :: Double + -- ^ Vertical layer offset in tiles. Always 0. + , layerData :: Maybe (Vector GlobalId) + -- ^ Array of GIDs. tilelayer only. + , layerObjects :: Maybe (Vector Object) + -- ^ Array of Objects. objectgroup only. + , layerProperties :: [Map Text Value] + -- ^ string key-value pairs. + , layerOpacity :: Float + -- ^ Value between 0 and 1 + , layerDraworder :: String + -- ^ “topdown” (default) or “index”. objectgroup only. + } 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" <|> pure mempty) + <*> o .: "opacity" + <*> (o .: "draworder" <|> pure "topdown") + parseJSON invalid = typeMismatch "Layer" invalid + +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 + ] + + +data Terrain = Terrain { terrainName :: String + -- ^ Name of terrain + , terrainTile :: LocalId + -- ^ Local ID of tile representing terrain + } deriving (Eq, Generic, Show) + +instance FromJSON Terrain where + parseJSON (A.Object o) = Terrain <$> o .: "name" + <*> o .: "tile" + parseJSON invalid = typeMismatch "Terrain" invalid + +instance ToJSON Terrain where + toJSON Terrain{..} = object [ "name" .= terrainName + , "tile" .= terrainTile + ] + + + +data Frame = Frame { frameDuration :: Int + , frameTileId :: LocalId + } deriving (Eq, Generic, Show) + +instance FromJSON Frame where + parseJSON (A.Object o) = Frame <$> o .: "duration" + <*> o .: "tileId" + parseJSON invalid = typeMismatch "Frame" invalid + +instance ToJSON Frame where + toJSON Frame{..} = object [ "duration" .= frameDuration + , "tileId" .= frameTileId + ] + + +data Tile = Tile { tileId :: LocalId + , tileProperties :: Map Text Text + , 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 + +instance ToJSON Tile where + toJSON Tile{..} = object [ "properties" .= tileProperties + , "image" .= tileImage + , "objectGroup" .= tileObjectGroup + , "animation" .= tileAnimation + ] + + +data Tileset = Tileset { tilesetFirstgid :: GlobalId + -- ^ GID corresponding to the first tile in the set + , tilesetImage :: String + -- ^ Image used for tiles in this set + , tilesetName :: String + -- ^ Name given to this tileset + , tilesetTilewidth :: Int + -- ^ Maximum width of tiles in this set + , tilesetTileheight :: Int + -- ^ Maximum height of tiles in this set + , tilesetImagewidth :: Int + -- ^ Width of source image in pixels + , tilesetImageheight :: Int + -- ^ Height of source image in pixels + , tilesetProperties :: Map Text Text + -- ^ String key-value pairs + , tilesetPropertytypes :: 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) + -- ^ Per-tile properties, indexed by gid as string + , tilesetTerrains :: 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 + -- ^ Tiles (optional) + } 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 + +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 + ] + + +-- | The full monty. +data Tiledmap = Tiledmap { tiledmapVersion :: Float + -- ^ The JSON format version + , tiledmapTiledversion :: String + -- ^ The Tiled version used to save the file + , tiledmapWidth :: Int + -- ^ Number of tile columns + , tiledmapHeight :: Int + -- ^ Number of tile rows + , tiledmapTilewidth :: Double + -- ^ Map grid width. + , tiledmapTileheight :: Double + -- ^ Map grid height. + , tiledmapOrientation :: String + -- ^ Orthogonal, isometric, or staggered + , tiledmapLayers :: Vector Layer + -- ^ Array of Layers + , tiledmapTilesets :: Vector Tileset + -- ^ Array of Tilesets + , tiledmapBackgroundcolor :: Maybe String + -- ^ Hex-formatted color (#RRGGBB or #AARRGGBB) (optional) + , tiledmapRenderorder :: String + -- ^ Rendering direction (orthogonal maps only) + , tiledmapProperties :: Map Text Text + -- ^ String key-value pairs + , tiledmapNextobjectid :: Int + -- ^ Auto-increments for each placed object + } 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" <|> pure mempty) + <*> o .: "nextobjectid" + parseJSON invalid = typeMismatch "Tiledmap" invalid + +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 + ] + + +-- | Load a Tiled map from the given 'FilePath'. +loadTiledmap :: FilePath -> IO (Either String Tiledmap) +loadTiledmap = fmap eitherDecode . C8.readFile diff --git a/lib/Types.hs b/lib/Types.hs new file mode 100644 index 0000000..082b30e --- /dev/null +++ b/lib/Types.hs @@ -0,0 +1,3 @@ +-- | basic types for workadventure maps + +module Types where diff --git a/lib/Util.hs b/lib/Util.hs new file mode 100644 index 0000000..be67143 --- /dev/null +++ b/lib/Util.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} + + +module Util where + +import Data.Text (Text) +import Data.Text as T +import Data.Aeson as Aeson + +-- | haskell's many string types are FUN … +showText :: Show a => a -> Text +showText = T.pack . show + +-- | same as showText, but without the "String"-prefix for strings +-- TODO: serialise back into json for printing? People may get +-- confused by the type annotations if they only know json … +showAeson :: Aeson.Value -> Text +showAeson (Aeson.String s) = showText s +showAeson v = showText v + + + + + +-- | adds quotes (but does not escape, for now!) +quote :: Text -> Text +quote text = "\"" <> text <> "\"" diff --git a/src/Main.hs b/src/Main.hs index 4de1183..d820c20 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,160 +1,28 @@ +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NamedFieldPuns #-} module Main where -import Data.Map (Map, (!?)) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.IO as T -import Data.Maybe (isJust, mapMaybe) -import qualified Data.Aeson as Aeson -import Data.Vector (Vector) -import Data.Set (Set, fromList) -import qualified Data.Vector as V -import Control.Monad.Writer -import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Maybe +import Control.Monad.Writer +import qualified Data.Aeson as Aeson +import Data.Map (Map, (!?)) +import Data.Maybe (isJust, mapMaybe) +import Data.Set (Set, fromList) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Data.Vector (Vector) +import qualified Data.Vector as V -import Tiled2 +import LintWriter (LintWriter, LintResult, Hint(..), Level(..)) +import Properties (checkProperty) +import Tiled2 +import Util (showText) -data Level = Warning | Suggestion | Info | Forbidden | Error - deriving Show -data Hint = Hint - { hintLevel :: Level - , hintMsg :: Text } - deriving Show --- shorter constructors -suggestion msg = Hint { hintLevel = Suggestion, hintMsg = msg } -warning msg = Hint { hintLevel = Warning, hintMsg = msg } -forbidden msg = Hint { hintLevel = Forbidden, hintMsg = msg } - - --- | converts a Maybe to an Either, with a default value for Left -unwrap :: b -> Maybe a -> Either b a -unwrap hint maybe = case maybe of - Just a -> Right a - Nothing -> Left hint - --- | unwrap and produce a warning if the value was Nothing -unwrapWarn :: Text -> Maybe a -> Either Hint a -unwrapWarn msg = unwrap $ warning msg - --- | get an attribute from a map -getAttr :: Map Text Aeson.Value -> Text -> Either Hint Aeson.Value -getAttr props name = unwrapWarn msg $ props !? name - where msg = "field " <> name <> "does not exist" - --- | same as unwrapWarn, but for booleans -assertWarn :: Text -> Bool -> Either Hint () -assertWarn msg cond = if cond then Right () else Left $ warning msg - --- | haskell's many string types are FUN … -showText :: Show a => a -> Text -showText = T.pack . show - --- | same as showText, but without the "String"-prefix for strings --- TODO: serialise back into json for printing? People may get --- confused by the type annotations if they only know json … -showAeson :: Aeson.Value -> Text -showAeson (Aeson.String s) = showText s -showAeson v = showText v - --- | the given property should have the given value. Otherwise, warning. -propEqual :: Map Text Aeson.Value -> Text -> Aeson.Value -> Either Hint () -propEqual props name value = do - value' <- getAttr props name - assertWarn ("field "<>name<>" has unexpected value "<>showAeson value' - <>", should be "<>showAeson value) - $ value' == value - --- | --- This type may require some explanation. --- Essentially, it's a monad that can short-curcuit (i.e. abort), --- and also collect hints as it goes. Currently, both aborts and --- hints are the same type (Hint); if the monad ends up returning --- Left Hint, then something went entirely wrong; if it returns --- Right (a, [Hint]), then it ran through, calculated a, and collected --- a list of linter hints along the way. -type MaybeWriter a = WriterT [Hint] (Either Hint) a - - --- | type juggling to get a single warning into MaybeWriter a -maybeWriterHint :: (Text -> Hint) -> Text -> MaybeWriter () -maybeWriterHint constructor = tell . (: []) . constructor - -warn = maybeWriterHint warning -info = maybeWriterHint (\t -> Hint { hintLevel = Info, hintMsg = t }) -forbid = maybeWriterHint forbidden -suggest = maybeWriterHint suggestion -complain = maybeWriterHint (\t -> Hint { hintLevel = Error, hintMsg = t }) - --- | adds quotes (but does not escape, for now!) -quote :: Text -> Text -quote text = "\"" <> text <> "\"" - --- | does this layer have the given property? -hasProperty :: Text -> Layer -> Bool -hasProperty name = any - (\prop -> prop !? "name" == Just (Aeson.String name)) - . layerProperties - - - --- | The main thing --- --- given a property, check if it is valid. It gets a reference --- to its own layer since sometimes the presense of one property --- implies the presence or absense of another. --- --- The tests in here are meant to comply with the informal spec --- at https://workadventu.re/map-building -checkProperty :: Layer -> Map Text Aeson.Value -> MaybeWriter () -checkProperty layer prop = do - tyObj <- lift $ getAttr prop "name" - ty <- lift $ case tyObj of - Aeson.String str -> Right str - _ -> Left (suggestion "wtf") - checkTyped ty - where checkTyped ty = case ty of - "jitsiRoom" -> do - lift $ propEqual prop "type" "string" - urlValue <- lift $ getAttr prop "value" - info $ "found jitsi room: " <> showAeson urlValue - suggestPropertyValue "jitsiTrigger" "onaction" - "jitsiTrigger" -> requireProperty "jitsiRoom" - "jitsiUrl" -> isForbidden - "jitsiConfig" -> isForbidden - "jitsiClientConfig" -> isForbidden - "jitsiRoomAdminTag" -> isForbidden - "playAudio" -> do - -- TODO: check for url validity? - lift $ propEqual prop "type" "string" - "audioLoop" -> requireProperty "playAudio" - "audioVolume" -> requireProperty "playAudio" - "openWebsite" -> suggestPropertyValue "openWebsiteTrigger" "onaction" - "openWebsiteTrigger" -> requireProperty "openWebsite" - "openWebsitePolicy" -> requireProperty "openWebsite" - "exitUrl" -> return () - "startLayer" -> return () - -- could also make this a "hard error" (i.e. Left), but then it - -- stops checking other properties as checkLayer short-circuits. - _ -> warn $ "unknown property type " <> quote ty - where - -- | require some property in this layer - requireProperty name = unless (hasProperty name layer) - $ complain $ "property "<>quote name<>" requires property "<>quote ty - -- | forbid some property in this layer - forbidProperty name = when (hasProperty name layer) - $ forbid $ "property " <> quote name <> " should not be used" - -- | This property is forbidden and should not be used - isForbidden = forbid $ "property " <> quote ty <> " should not be used" - -- TODO: check if the property has the correct value - suggestPropertyValue name value = unless (hasProperty name layer) - $ suggest $ "set property " <> quote name <> " to " <> quote value - -checkLayer :: Layer -> MaybeWriter () +checkLayer :: Layer -> LintWriter () checkLayer layer = mapM_ (checkProperty layer) (layerProperties layer) @@ -163,7 +31,7 @@ showContext :: Text -> Text showContext ctxt = " (in layer " <> ctxt <> ")\n" -- | pretty-printer for a result of WriterMaybe (currently only for errors/hints) -showResult :: Show a => Text -> Either Hint (a, [Hint]) -> Maybe Text +showResult :: Show a => Text -> LintResult a -> Maybe Text showResult ctxt (Left hint) = Just $ "ERROR: " <> hintMsg hint <> showContext ctxt showResult _ (Right (a, [])) = Nothing showResult ctxt (Right (a, hints)) = Just $ showHints hints @@ -172,21 +40,18 @@ showResult ctxt (Right (a, hints)) = Just $ showHints hints -- TODO: make the "log level" configurable showHint Hint { hintMsg, hintLevel } = case hintLevel of Info -> Nothing - _ -> Just $ showText hintLevel <> ": " <> hintMsg <> ctxtHint + _ -> Just $ showText hintLevel <> ": " <> hintMsg <> ctxtHint ctxtHint = showContext ctxt - main :: IO () main = do Right map <- loadTiledmap "example.json" - --print $ mapJitsiUrls map - --print $ fmap layerJitsiUrls (tiledmapLayers map) - -- TODO: print the layer each hint originates from - let lines = V.mapMaybe (\layer -> - (showResult (T.pack $ layerName layer) - . runWriterT - . checkLayer) - layer) - (tiledmapLayers map) + -- LintWriter is a Writer transformer, so run it with runWriterT + let lints = fmap (runWriterT . checkLayer) (tiledmapLayers map) + + -- well this is a bit awkward (but how to get layer names otherwise?) + let lines = V.mapMaybe thing (tiledmapLayers map) + where thing layer = (showResult (T.pack $ layerName layer) + . runWriterT . checkLayer) layer mapM_ T.putStr lines diff --git a/src/Tiled2.hs b/src/Tiled2.hs deleted file mode 100644 index 17b2b77..0000000 --- a/src/Tiled2.hs +++ /dev/null @@ -1,400 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# 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/ -module Tiled2 where - -import Control.Applicative ((<|>)) -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.Lazy.Char8 as C8 -import Data.Map (Map) -import qualified Data.Map as M -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import Data.Vector (Vector) -import GHC.Exts (fromList, toList) -import GHC.Generics (Generic) - - --- | A globally indexed identifier. -newtype GlobalId = GlobalId { unGlobalId :: Int } - deriving (Ord, Eq, Enum, Num, Generic, Show, FromJSON, ToJSON, FromJSONKey, ToJSONKey) - - --- | A locally indexed identifier. -newtype LocalId = LocalId { unLocalId :: Int } - deriving (Ord, Eq, Enum, Num, Generic, Show, FromJSON, ToJSON, FromJSONKey, ToJSONKey) - - -data XYPair a = XYPair a a - -instance FromJSON a => FromJSON (XYPair a) where - parseJSON (A.Object o) = - XYPair <$> o .: "x" - <*> o .: "y" - parseJSON invalid = typeMismatch "Object" invalid - -instance ToJSON a => ToJSON (XYPair a) where - toJSON (XYPair x y) = - object [ "x" .= x - , "y" .= y - ] - -fromXYPair :: XYPair a -> (a, a) -fromXYPair (XYPair x y) = (x, y) - -toXYPair :: (a, a) -> XYPair a -toXYPair (x, y) = XYPair x y - -omitNulls :: Value -> Value -omitNulls (A.Object hs) = A.Object - . fromList - . filter ((/= Null) . snd) - $ toList hs -omitNulls x = x - -parseDefault :: FromJSON a => A.Object -> Text -> a -> Parser a -parseDefault o s d = fromMaybe d <$> o .:? s - - -data Object = Object { objectId :: Int - -- ^ Incremental id - unique across all objects - , objectWidth :: Double - -- ^ Width in pixels. Ignored if using a gid. - , objectHeight :: Double - -- ^ Height in pixels. Ignored if using a gid. - , objectName :: String - -- ^ String assigned to name field in editor - , objectType :: String - -- ^ String assigned to type field in editor - , objectProperties :: Map Text Text - -- ^ String key-value pairs - , objectVisible :: Bool - -- ^ Whether object is shown in editor. - , objectX :: Double - -- ^ x coordinate in pixels - , objectY :: Double - -- ^ y coordinate in pixels - , objectRotation :: Float - -- ^ Angle in degrees clockwise - , objectGid :: Maybe GlobalId - -- ^ GID, only if object comes from a Tilemap - , objectEllipse :: Bool - -- ^ Used to mark an object as an ellipse - , objectPolygon :: Maybe (Vector (Double, Double)) - -- ^ A list of x,y coordinates in pixels - , objectPolyline :: Maybe (Vector (Double, Double)) - -- ^ A list of x,y coordinates in pixels - , objectText :: Map Text Text - -- ^ String key-value pairs - } 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 - -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 - ] - - -data Layer = Layer { layerWidth :: Double - -- ^ Column count. Same as map width for fixed-size maps. - , layerHeight :: Double - -- ^ Row count. Same as map height for fixed-size maps. - , layerName :: String - -- ^ Name assigned to this layer - , layerType :: String - -- ^ “tilelayer”, “objectgroup”, or “imagelayer” - , layerVisible :: Bool - -- ^ Whether layer is shown or hidden in editor - , layerX :: Double - -- ^ Horizontal layer offset in tiles. Always 0. - , layerY :: Double - -- ^ Vertical layer offset in tiles. Always 0. - , layerData :: Maybe (Vector GlobalId) - -- ^ Array of GIDs. tilelayer only. - , layerObjects :: Maybe (Vector Object) - -- ^ Array of Objects. objectgroup only. - , layerProperties :: [Map Text Value] - -- ^ string key-value pairs. - , layerOpacity :: Float - -- ^ Value between 0 and 1 - , layerDraworder :: String - -- ^ “topdown” (default) or “index”. objectgroup only. - } 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" <|> pure mempty) - <*> o .: "opacity" - <*> (o .: "draworder" <|> pure "topdown") - parseJSON invalid = typeMismatch "Layer" invalid - -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 - ] - - -data Terrain = Terrain { terrainName :: String - -- ^ Name of terrain - , terrainTile :: LocalId - -- ^ Local ID of tile representing terrain - } deriving (Eq, Generic, Show) - -instance FromJSON Terrain where - parseJSON (A.Object o) = Terrain <$> o .: "name" - <*> o .: "tile" - parseJSON invalid = typeMismatch "Terrain" invalid - -instance ToJSON Terrain where - toJSON Terrain{..} = object [ "name" .= terrainName - , "tile" .= terrainTile - ] - - - -data Frame = Frame { frameDuration :: Int - , frameTileId :: LocalId - } deriving (Eq, Generic, Show) - -instance FromJSON Frame where - parseJSON (A.Object o) = Frame <$> o .: "duration" - <*> o .: "tileId" - parseJSON invalid = typeMismatch "Frame" invalid - -instance ToJSON Frame where - toJSON Frame{..} = object [ "duration" .= frameDuration - , "tileId" .= frameTileId - ] - - -data Tile = Tile { tileId :: LocalId - , tileProperties :: Map Text Text - , 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 - -instance ToJSON Tile where - toJSON Tile{..} = object [ "properties" .= tileProperties - , "image" .= tileImage - , "objectGroup" .= tileObjectGroup - , "animation" .= tileAnimation - ] - - -data Tileset = Tileset { tilesetFirstgid :: GlobalId - -- ^ GID corresponding to the first tile in the set - , tilesetImage :: String - -- ^ Image used for tiles in this set - , tilesetName :: String - -- ^ Name given to this tileset - , tilesetTilewidth :: Int - -- ^ Maximum width of tiles in this set - , tilesetTileheight :: Int - -- ^ Maximum height of tiles in this set - , tilesetImagewidth :: Int - -- ^ Width of source image in pixels - , tilesetImageheight :: Int - -- ^ Height of source image in pixels - , tilesetProperties :: Map Text Text - -- ^ String key-value pairs - , tilesetPropertytypes :: 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) - -- ^ Per-tile properties, indexed by gid as string - , tilesetTerrains :: 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 - -- ^ Tiles (optional) - } 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 - -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 - ] - - --- | The full monty. -data Tiledmap = Tiledmap { tiledmapVersion :: Float - -- ^ The JSON format version - , tiledmapTiledversion :: String - -- ^ The Tiled version used to save the file - , tiledmapWidth :: Int - -- ^ Number of tile columns - , tiledmapHeight :: Int - -- ^ Number of tile rows - , tiledmapTilewidth :: Double - -- ^ Map grid width. - , tiledmapTileheight :: Double - -- ^ Map grid height. - , tiledmapOrientation :: String - -- ^ Orthogonal, isometric, or staggered - , tiledmapLayers :: Vector Layer - -- ^ Array of Layers - , tiledmapTilesets :: Vector Tileset - -- ^ Array of Tilesets - , tiledmapBackgroundcolor :: Maybe String - -- ^ Hex-formatted color (#RRGGBB or #AARRGGBB) (optional) - , tiledmapRenderorder :: String - -- ^ Rendering direction (orthogonal maps only) - , tiledmapProperties :: Map Text Text - -- ^ String key-value pairs - , tiledmapNextobjectid :: Int - -- ^ Auto-increments for each placed object - } 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" <|> pure mempty) - <*> o .: "nextobjectid" - parseJSON invalid = typeMismatch "Tiledmap" invalid - -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 - ] - - --- | Load a Tiled map from the given 'FilePath'. -loadTiledmap :: FilePath -> IO (Either String Tiledmap) -loadTiledmap = fmap eitherDecode . C8.readFile diff --git a/tiled-hs.cabal b/tiled-hs.cabal index fa85e00..094d31b 100644 --- a/tiled-hs.cabal +++ b/tiled-hs.cabal @@ -21,16 +21,35 @@ maintainer: stuebinm@disroot.org -- category: extra-source-files: CHANGELOG.md +library + default-language: Haskell2010 + ghc-options: -Wall + hs-source-dirs: lib + exposed-modules: + LintWriter + Properties + Tiled2 + Util + build-depends: base ^>=4.14.1.0, + aeson, + bytestring, + containers, + text, + vector, + transformers, + mtl, + either + +-- TODO: move more stuff into lib, these dependencies are silly executable tiled-hs main-is: Main.hs - other-modules: Tiled2 - - -- Modules included in this executable, other than Main. - -- other-modules: - - -- LANGUAGE extensions used by modules in this package. - -- other-extensions: build-depends: base ^>=4.14.1.0, - aeson, bytestring, containers, text, vector, transformers, mtl, either + aeson, + text, + tiled-hs, + transformers, + containers, + vector, + mtl hs-source-dirs: src default-language: Haskell2010 -- cgit v1.2.3