From 6cfdefc3438100ea829b1c86e790a0f2d56ec503 Mon Sep 17 00:00:00 2001 From: stuebinm Date: Sat, 4 Dec 2021 04:33:01 +0100 Subject: lots of code reorganising and some deduplication it was kinda getting messy in places. Also found some accidental isomorphisms between types, so these are now only one type because the consequences were getting silly. --- lib/Badges.hs | 8 +- lib/CheckMap.hs | 9 +- lib/LintWriter.hs | 180 ++++++++++++--------- lib/Properties.hs | 209 +++++++++++++----------- lib/Tiled.hs | 388 +++++++++++++++++++++++++++++++++++++++++++++ lib/Tiled2.hs | 437 --------------------------------------------------- lib/TiledAbstract.hs | 55 +++++++ lib/Util.hs | 2 +- 8 files changed, 673 insertions(+), 615 deletions(-) create mode 100644 lib/Tiled.hs delete mode 100644 lib/Tiled2.hs create mode 100644 lib/TiledAbstract.hs (limited to 'lib') diff --git a/lib/Badges.hs b/lib/Badges.hs index 0369334..b78f08d 100644 --- a/lib/Badges.hs +++ b/lib/Badges.hs @@ -22,10 +22,10 @@ data BadgeArea = , areaY :: Double } | BadgeRect - { areaX :: Double - , areaY :: Double - , areaWidth :: Double - , areaHeight :: Double + { areaX :: Double + , areaY :: Double + , areaWidth :: Double + , areaHeight :: Double , areaIsEllipse :: Bool } deriving (Ord, Eq, Generic, Show) diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs index 359452c..779123d 100644 --- a/lib/CheckMap.hs +++ b/lib/CheckMap.hs @@ -14,7 +14,6 @@ import Data.Aeson.Types ((.=)) import Data.Functor ((<&>)) import Data.Map (Map, toList) import qualified Data.Map as M -import Data.Maybe (mapMaybe) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Vector as V @@ -23,16 +22,16 @@ import GHC.Generics (Generic) import Badges (Badge) import LintConfig (LintConfig') -import LintWriter (LintResult (..), invertLintResult, lintToDep, +import LintWriter (LintResult, invertLintResult, resultToAdjusted, resultToBadges, resultToDeps, resultToLints, resultToOffers, runLintWriter) import Properties (checkLayer, checkMap, checkTileset) -import Tiled2 (HasName (getName), - Layer (layerLayers, layerName), +import Tiled (Layer (layerLayers, layerName), LoadResult (..), Tiledmap (tiledmapLayers, tiledmapTilesets), Tileset, loadTiledmap) +import TiledAbstract (HasName (..)) import Types (Dep, Hint (Hint, hintLevel, hintMsg), Level (..), lintsToHints) import Util (PrettyPrint (prettyprint), prettyprint) @@ -94,7 +93,7 @@ runLinter config tiledmap depth = MapResult { mapresultLayer = invertThing layer , mapresultTileset = invertThing tileset , mapresultGeneral = lintsToHints $ resultToLints generalResult - , mapresultDepends = mapMaybe lintToDep (resultToLints generalResult) + , mapresultDepends = resultToDeps generalResult <> concatMap resultToDeps layer <> concatMap resultToDeps tileset , mapresultProvides = concatMap resultToOffers layer diff --git a/lib/LintWriter.hs b/lib/LintWriter.hs index e235fca..12c4311 100644 --- a/lib/LintWriter.hs +++ b/lib/LintWriter.hs @@ -7,11 +7,39 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} -- | a monad that collects warnings, outputs, etc, -module LintWriter where +module LintWriter + ( runLintWriter + , LintWriter + , LintWriter' + , LintResult + , invertLintResult + -- * working with lint results + , resultToDeps + , resultToOffers + , resultToBadges + , resultToLints + , resultToAdjusted + -- * Add lints to a linter + , info + , suggest + , warn + , forbid + , complain + -- * add other information to the linter + , offersEntrypoint + , offersBadge + , dependsOn + -- * get information about the linter's context + , askContext + , askFileDepth + , lintConfig + -- * adjust the linter's context + , adjust + ) where -import Data.Aeson (ToJSON (toJSON)) import Data.Text (Text) import Control.Monad.State (StateT, modify) @@ -21,123 +49,123 @@ import Control.Monad.Writer.Lazy (lift) import Data.Bifunctor (Bifunctor (second)) import Data.Map (Map, fromListWith) import Data.Maybe (mapMaybe) -import qualified Data.Text as T -import Util (PrettyPrint (..)) - import Badges (Badge) import LintConfig (LintConfig') -import Tiled2 (HasName) -import Types - --- | for now, all context we have is how "deep" in the directory tree --- we currently are -type Context = Int - -newtype LinterState ctxt = LinterState - { fromLinterState :: ([Lint], ctxt)} +import TiledAbstract (HasName) +import Types (Dep, Hint, Level (..), Lint (..), + hint, lintsToHints) --- | a monad to collect hints, with some context (usually the containing layer/etc.) +-- | A monad modelling the main linter features type LintWriter ctxt = LintWriter' ctxt () +-- | A linter that can use pure / return things monadically type LintWriter' ctxt res = StateT (LinterState ctxt) (Reader (Context, ctxt, LintConfig')) res --- wrapped to allow for manual writing of Aeson instances -type LintResult' ctxt = (ctxt, [Lint]) -- Either Lint (a, [Lint]) -newtype LintResult ctxt = LintResult (LintResult' ctxt) +-- | A Linter's state: some context (which it may adjust), and a list of lints +-- | it already collected. +newtype LinterState ctxt = LinterState + { fromLinterState :: ([Lint], ctxt)} + +-- | The result of running a linter: an adjusted context, and a list of lints. +-- | This is actually just a type synonym of LinterState, but kept seperately +-- | for largely historic reasons since I don't think I'll change it again +type LintResult ctxt = LinterState ctxt +-- | for now, all context we have is how "deep" in the directory tree +-- we currently are +type Context = Int +-- | run a linter. Returns the adjusted context, and a list of lints +runLintWriter + :: LintConfig' -> ctxt -> Context -> LintWriter ctxt -> LintResult ctxt +runLintWriter config context depth linter = LinterState + . fromLinterState + . snd + . runReader runstate + $ (depth, context, config) + where runstate = runStateT linter (LinterState ([], context)) + +-- | "invert" a linter's result, grouping lints by their messages invertLintResult :: HasName ctxt => LintResult ctxt -> Map Hint [ctxt] -invertLintResult (LintResult (ctxt, lints)) = +invertLintResult (LinterState (lints, ctxt)) = fromListWith (<>) $ (, [ctxt]) <$> lintsToHints lints --- better, less confusing serialisation of an Either Hint (a, [Hint]). --- Note that Left hint is also serialised as a list to make the resulting --- json schema more regular. -instance ToJSON (LintResult a) where - toJSON (LintResult res) = toJSON $ snd res - -instance PrettyPrint ctxt => PrettyPrint (Level, LintResult ctxt) where - prettyprint (level, LintResult (ctxt, res)) = - T.concat $ map ((<> context) . prettyprint) (filterLintLevel level res) - where context = " (" <> prettyprint ctxt <> ")\n" - -lintToDep :: Lint -> Maybe Dep -lintToDep = \case - Depends dep -> Just dep - _ -> Nothing - -lintToOffer :: Lint -> Maybe Text -lintToOffer = \case - Offers frag -> Just frag - _ -> Nothing - -filterLintLevel :: Level -> [Lint] -> [Lint] -filterLintLevel level = mapMaybe $ \l -> if level <= lintLevel l - then Just l - else Nothing - resultToDeps :: LintResult a -> [Dep] -resultToDeps (LintResult a) = mapMaybe lintToDep $ snd a +resultToDeps (LinterState (lints,_)) = mapMaybe lintToDep lints + where lintToDep = \case + Depends dep -> Just dep + _ -> Nothing resultToOffers :: LintResult a -> [Text] -resultToOffers (LintResult a) = mapMaybe lintToOffer $ snd a - --- | convert a lint result into a flat list of lints --- (throwing away information on if a single error was fatal) -resultToLints :: LintResult a -> [Lint] -resultToLints (LintResult res) = snd res +resultToOffers (LinterState a) = mapMaybe lintToOffer $ fst a + where lintToOffer = \case + Offers frag -> Just frag + _ -> Nothing resultToBadges :: LintResult a -> [Badge] -resultToBadges (LintResult a) = mapMaybe lintToBadge $ snd a +resultToBadges (LinterState a) = mapMaybe lintToBadge $ fst a where lintToBadge (Badge badge) = Just badge lintToBadge _ = Nothing +-- | convert a lint result into a flat list of lints +resultToLints :: LintResult a -> [Lint] +resultToLints (LinterState res) = fst res + +-- | extract the adjusted context from a lint result resultToAdjusted :: LintResult a -> a -resultToAdjusted (LintResult res) = fst res +resultToAdjusted (LinterState res) = snd res --- | run a linter. Returns the adjusted context, and a list of lints -runLintWriter :: LintConfig' -> ctxt -> Context -> LintWriter ctxt -> LintResult ctxt -runLintWriter config c c' linter = LintResult (snd $ fromLinterState lints,fst $ fromLinterState lints) - where lints = snd $ runReader ranstate (c',c, config) - ranstate = runStateT linter (LinterState ([], c)) -tell' :: Lint -> LintWriter ctxt -tell' l = modify $ \(LinterState (lints, ctxt)) -> LinterState (l:lints, ctxt) --- | write a hint into the LintWriter monad -lint :: Level -> Text -> LintWriter a -lint level text = tell' $ hint level text +-- | fundamental linter operations: add a lint of some severity +info = lint Info +suggest = lint Suggestion +warn = lint Warning +forbid = lint Forbidden +complain = lint Error +-- | add a dependency to the linter dependsOn :: Dep -> LintWriter a dependsOn dep = tell' $ Depends dep +-- | add an offer for an entrypoint to the linter offersEntrypoint :: Text -> LintWriter a offersEntrypoint text = tell' $ Offers text +-- | add an offer for a badge to the linter offersBadge :: Badge -> LintWriter a offersBadge badge = tell' $ Badge badge --- | adjusts the context. Gets a copy of the /current/ context, i.e. one which might --- have already been changed by other lints -adjust :: (a -> a) -> LintWriter a -adjust f = modify $ LinterState . second f . fromLinterState -info = lint Info -suggest = lint Suggestion -warn = lint Warning -forbid = lint Forbidden -complain = lint Error - - --- | get the context as it was originally, without any modifications +-- | get the context as it was initially, without any modifications askContext :: LintWriter' a a askContext = lift $ asks (\(_,a,_) -> a) +-- | ask for the file depth within the repository tree of the current map. +-- | This function brings in a lot more conceptual baggage than I'd like, but +-- | it's needed to check if relative paths lie outside the repository askFileDepth :: LintWriter' a Int askFileDepth = lift $ asks (\(a,_,_) -> a) +-- | ask for a specific part of the linter's global config lintConfig :: (LintConfig' -> a) -> LintWriter' ctxt a lintConfig get = lift $ asks (\(_,_,config) -> get config) + + + + +-- | tell, but for a singular lint. Leaves the context unchanged +tell' :: Lint -> LintWriter ctxt +tell' l = modify $ \(LinterState (lints, ctxt)) -> LinterState (l:lints, ctxt) + +-- | small helper to tell a singlular proper lint +lint :: Level -> Text -> LintWriter a +lint level text = tell' $ hint level text + +-- | adjusts the context. Gets a copy of the /current/ context, +-- | i.e. one which might have already been changed by other adjustments +adjust :: (a -> a) -> LintWriter a +adjust f = modify $ LinterState . second f . fromLinterState diff --git a/lib/Properties.hs b/lib/Properties.hs index d65c9da..a9bf113 100644 --- a/lib/Properties.hs +++ b/lib/Properties.hs @@ -13,11 +13,10 @@ module Properties (checkMap, checkTileset, checkLayer) where import Control.Monad (forM_, unless, when) import Data.Text (Text, isPrefixOf) import qualified Data.Vector as V -import Tiled2 (HasName (getName), - HasProperties (adjustProperties, getProperties), - HasTypeName (typeName), IsProperty (asProperty), - Layer (..), Object (..), Property (..), +import Tiled (Layer (..), Object (..), Property (..), PropertyValue (..), Tiledmap (..), Tileset (..)) +import TiledAbstract (HasName (..), HasProperties (..), + HasTypeName (..), IsProperty (..)) import Util (layerIsEmpty, mkProxy, naiveEscapeHTML, prettyprint, showText) @@ -39,67 +38,59 @@ import Uris (SubstError (..), applySubst) -- | Checks an entire map for "general" lints. -- --- Note that it does /not/ call checkMapProperty; this is handled --- seperately in CheckMap.hs, since these lints go into a different --- field of the resulting json. +-- Note that it does /not/ check any tile layer/tileset properties; +-- these are handled seperately in CheckMap, since these lints go +-- into a different field of the output. checkMap :: LintWriter Tiledmap checkMap = do tiledmap <- askContext + let unlessLayer = unlessElement (tiledmapLayers tiledmap) - -- test other things - 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" . getProperties) - "The map must contain at least one layer with the property \"exitUrl\" set." + -- test custom map properties + mapM_ checkMapProperty (fromMaybe mempty $ tiledmapProperties tiledmap) + -- can't have these with the rest of layer/tileset lints since they're + -- not specific to any one of them refuseDoubledNames (tiledmapLayers tiledmap) refuseDoubledNames (tiledmapTilesets tiledmap) + -- some layers should exist + unlessElementNamed (tiledmapLayers tiledmap) "start" + $ complain "The map must have one layer named \"start\"." + unlessLayer (\l -> getName l == "floorLayer" && layerType l == "objectgroup") + $ complain "The map must have one layer named \"floorLayer\" of type \"objectgroup\"." + unlessLayer (flip containsProperty "exitUrl" . getProperties) + $ complain "The map must contain at least one layer with the property \"exitUrl\" set." + -- reject maps not suitable for workadventure unless (tiledmapOrientation tiledmap == "orthogonal") $ complain "The map's orientation must be set to \"orthogonal\"." unless (tiledmapTileheight tiledmap == 32 && tiledmapTilewidth tiledmap == 32) $ complain "The map's tile size must be 32 by 32 pixels." - where - hasLayerNamed name p = hasLayer (\l -> layerName l == name && p l) - hasLayer p err = do - tiledmap <- askContext - unless (any p (tiledmapLayers tiledmap)) - $ complain err - -- | Checks a single property of a map. -- -- Doesn't really do all that much, but could in theory be expanded into a -- longer function same as checkLayerProperty. checkMapProperty :: Property -> LintWriter Tiledmap -checkMapProperty p@(Property name _value) = case name of +checkMapProperty p@(Property name _) = case name of "script" -> do -- this is kind of stupid, since if we also inject script this -- will be overriden anyways, but it also doesn't really hurt I guess -- TODO: perhaps include an explanation in the lint, or allow -- exactly that one value? lintConfig configAllowScripts >>= \case - False -> isForbidden + False -> forbid "cannot use property \"script\"; custom scripts are disallowed" True -> pure () lintConfig configScriptInject >>= \case Nothing -> pure () Just url -> setProperty "script" url "mapName" -> naiveEscapeProperty p - "mapLink" -> pure () - "mapImage" -> pure () "mapDescription" -> naiveEscapeProperty p "mapCopyright" -> naiveEscapeProperty p - + "mapLink" -> pure () + "mapImage" -> pure () _ -> complain $ "unknown map property " <> prettyprint name - where - -- | this property is forbidden and should not be used - isForbidden = forbid $ "property " <> prettyprint name <> " should not be used" -- | check an embedded tile set. @@ -126,24 +117,25 @@ checkTileset = do unlessHasProperty "copyright" $ forbid "property \"copyright\" is required for tilesets." - + -- check individual tileset properties mapM_ checkTilesetProperty (fromMaybe [] $ tilesetProperties tileset) - -checkTilesetProperty :: Property -> LintWriter Tileset -checkTilesetProperty p@(Property name _value) = case name of - "copyright" -> naiveEscapeProperty p - _ -> pure () -- are there any other properties? + where + checkTilesetProperty :: Property -> LintWriter Tileset + checkTilesetProperty p@(Property name _value) = case name of + "copyright" -> naiveEscapeProperty p + _ -> warn $ "unknown tileset property " <> prettyprint name -- | collect lints on a single map layer checkLayer :: LintWriter Layer checkLayer = do layer <- askContext - when (isJust (layerImage layer)) - $ complain "imagelayer are not supported." refuseDoubledNames (getProperties layer) + when (isJust (layerImage layer)) + $ complain "imagelayer are not supported." + case layerType layer of "tilelayer" -> mapM_ checkTileLayerProperty (getProperties layer) "group" -> pure () @@ -154,18 +146,24 @@ checkLayer = do adjust $ \l -> l { layerObjects = Nothing, layerProperties = Nothing } unless (layerName layer == "floorLayer") $ do + + -- TODO: these two checks can probably be unified unlessHasProperty "getBadge" - $ warn "objectgrouop layer (which aren't the floor layer) are useless if not used to define badges." - when (null (layerObjects layer) || layerObjects layer == Just (V.fromList [])) - $ warn "empty objectgroup layers (which aren't the floor layer) are useless." + $ warn "objectgrouop layer (which aren't the floor layer)\ + \are useless if not used to define badges." + + when (null (layerObjects layer) || layerObjects layer == Just mempty) + $ warn "empty objectgroup layers (which aren't the floor\ + \layer) are useless." -- individual objects can't have properties - forM_ (fromMaybe (V.fromList []) $ layerObjects layer) $ \object -> + forM_ (fromMaybe mempty (layerObjects layer)) $ \object -> unless (null (objectProperties object)) - $ warn "Properties cannot be set on individual objects. For setting badge tokens, use per-layer properties instead." - mapM_ checkObjectGroupProperty (getProperties layer) - ty -> --unless (layerName layer == "floorLayer" && ty == "objectgroup") - complain $ "unsupported layer type " <> prettyprint ty <> "." + $ warn "Properties cannot be set on individual objects. For setting\ + \badge tokens, use per-layer properties instead." + + forM_ (getProperties layer) checkObjectGroupProperty + ty -> complain $ "unsupported layer type " <> prettyprint ty <> "." if layerType layer == "group" then when (null (layerLayers layer)) @@ -177,7 +175,7 @@ checkLayer = do -- | Checks a single (custom) property of an objectgroup layer checkObjectGroupProperty :: Property -> LintWriter Layer checkObjectGroupProperty p@(Property name _) = case name of - "getBadge" -> -- TODO check if all objects of this layer are allowed, then collect them + "getBadge" -> unwrapString p $ \str -> unwrapBadgeToken str $ \token -> do layer <- askContext @@ -195,10 +193,8 @@ checkObjectGroupProperty p@(Property name _) = case name of ObjectPolyline {} -> complain "cannot use polylines for badges." _ -> warn $ "unknown property " <> prettyprint name <> " for objectgroup layers" + -- | Checks a single (custom) property of a "normal" tile layer --- --- It gets a reference to its own layer since sometimes the presence --- of one property implies the presence or absense of another. checkTileLayerProperty :: Property -> LintWriter Layer checkTileLayerProperty p@(Property name _value) = case name of "jitsiRoom" -> do @@ -216,7 +212,8 @@ checkTileLayerProperty p@(Property name _value) = case name of "jitsiTrigger" -> do isString p unlessHasProperty "jitsiTriggerMessage" - $ suggest "set \"jitsiTriggerMessage\" to a custom message to overwrite the default \"press SPACE to enter in jitsi meet room\"." + $ suggest "set \"jitsiTriggerMessage\" to a custom message to overwrite\ + \the default \"press SPACE to enter in jitsi meet room\"." requireProperty "jitsiRoom" "jitsiTriggerMessage" -> do isString p @@ -245,9 +242,10 @@ checkTileLayerProperty p@(Property name _value) = case name of unwrapString p (setProperty "openWebsiteTrigger") unlessHasProperty "bbbTriggerMessage" $ do - suggest "set \"bbbTriggerMessage\" to a custom message to overwrite the default \"press SPACE to enter the bbb room\"" setProperty "openWebsiteTriggerMessage" ("press SPACE to enter bbb room" :: Text) + suggest "set \"bbbTriggerMessage\" to a custom message to overwrite the\ + \default \"press SPACE to enter the bbb room\"" "bbbTriggerMessage" -> do removeProperty "bbbTriggerMessage" requireProperty "bbbRoom" @@ -274,9 +272,10 @@ checkTileLayerProperty p@(Property name _value) = case name of (dependsOn . Local) "openWebsiteTrigger" -> do isString p - unlessHasProperty "openWebsiteTriggerMessage" - $ suggest "set \"openWebsiteTriggerMessage\" to a custom message to overwrite the default \"press SPACE to open Website\"." requireProperty "openWebsite" + unlessHasProperty "openWebsiteTriggerMessage" + $ suggest "set \"openWebsiteTriggerMessage\" to a custom message to\ + \overwrite the default \"press SPACE to open Website\"." "openWebsiteTriggerMessage" -> do isString p requireProperty "openWebsiteTrigger" @@ -320,12 +319,13 @@ checkTileLayerProperty p@(Property name _value) = case name of deprecatedUseInstead instead = warn $ "property \"" <> name <> "\" is deprecated. Use \"" <> instead <> "\" instead." - - -- | this property can only be used on a layer that contains at least one tiles + -- | this property can only be used on a layer that contains + -- | at least one tile forbidEmptyLayer = do layer <- askContext when (layerIsEmpty layer) $ complain ("property " <> prettyprint name <> " should not be set on an empty layer.") + -- | this layer is allowed, but also useless on a layer that contains no tiles uselessEmptyLayer = do layer <- askContext @@ -349,24 +349,45 @@ refuseDoubledNames things = foldr folding base things mempty where name = getName thing base _ = pure () ---------- Helper functions & stuff --------- + +---- General functions ---- + +unlessElement + :: Foldable f + => f a + -> (a -> Bool) + -> LintWriter b + -> LintWriter b +unlessElement things op = unless (any op things) + +unlessElementNamed :: (HasName a, Foldable f) + => f a -> Text -> LintWriter b -> LintWriter b +unlessElementNamed things name = + unlessElement things ((==) name . getName) unlessHasProperty :: HasProperties a => Text -> LintWriter a -> LintWriter a -unlessHasProperty name andthen = do - layer <- askContext - let hasprop = any (\(Property name' _) -> name == name') (getProperties layer) - unless hasprop andthen +unlessHasProperty name linter = + askContext >>= \ctxt -> + unlessElementNamed (getProperties ctxt) name linter + +-- | does this layer have the given property? +containsProperty :: Foldable t => t Property -> Text -> Bool +containsProperty props name = any + (\(Property name' _) -> name' == name) props + +----- Functions with concrete lint messages ----- -- | this property is forbidden and should not be used forbidProperty :: Text -> LintWriter Layer forbidProperty name = do - forbid $ "property " <> prettyprint name <> " should not be used." + forbid $ "property " <> prettyprint name <> " is disallowed." propertyRequiredBy :: HasProperties a => Text -> Text -> LintWriter a propertyRequiredBy req by = unlessHasProperty req - $ complain $ "property "<>prettyprint req<>" is required by property "<> prettyprint by<>"." + $ complain $ "property " <> prettyprint req <> + " is required by property " <> prettyprint by <> "." -- | suggest some value for another property if that property does not -- also already exist @@ -375,6 +396,11 @@ suggestProperty (Property name value) = unlessHasProperty name $ suggest $ "set property " <> prettyprint name <> " to " <> prettyprint value<>"." + + +---- Functions for adjusting the context ----- + + -- | set a property, overwriting whatever value it had previously setProperty :: (IsProperty prop, HasProperties ctxt) => Text -> prop -> LintWriter ctxt @@ -388,37 +414,41 @@ removeProperty name = adjust $ \ctxt -> flip adjustProperties ctxt $ \ps -> Just $ filter (\(Property name' _) -> name' /= name) ps +naiveEscapeProperty :: HasProperties a => Property -> LintWriter a +naiveEscapeProperty prop@(Property name _) = + unwrapString prop (setProperty name . naiveEscapeHTML) --- | does this layer have the given property? -containsProperty :: Foldable t => t Property -> Text -> Bool -containsProperty props name = any - (\(Property name' _) -> name' == name) props - +---- "unwrappers" checking that a property has some type, then do something ---- -- | asserts that this property is a string, and unwraps it unwrapString :: Property -> (Text -> LintWriter a) -> LintWriter a unwrapString (Property name value) f = case value of StrProp str -> f str - _ -> complain $ "type error: property " <> prettyprint name <> " should be of type string." + _ -> complain $ "type error: property " + <> prettyprint name <> " should be of type string." -- | same as unwrapString, but also forbids http:// as prefix unwrapLink :: Property -> (Text -> LintWriter a) -> LintWriter a unwrapLink (Property name value) f = case value of StrProp str -> if "http://" `isPrefixOf` str - then complain "cannot access content via http; either use https or include it locally instead." + then complain "cannot access content via http; either use https or include\ + \it locally in your repository instead." else f str - _ -> complain $ "type error: property " <> prettyprint name <> " should be of type string and contain a valid uri." + _ -> complain $ "type error: property " <> prettyprint name <> " should be\ + \of type string and contain a valid uri." -- | asserts that this property is a boolean, and unwraps it unwrapBool :: Property -> (Bool -> LintWriter a) -> LintWriter a unwrapBool (Property name value) f = case value of BoolProp b -> f b - _ -> complain $ "type error: property " <> prettyprint name <> " should be of type bool." + _ -> complain $ "type error: property " <> prettyprint name + <> " should be of type bool." unwrapInt :: Property -> (Int -> LintWriter a) -> LintWriter a unwrapInt (Property name value) f = case value of IntProp float -> f float - _ -> complain $ "type error: property " <> prettyprint name <> " should be of type int." + _ -> complain $ "type error: property " <> prettyprint name + <> " should be of type int." unwrapPath :: Text -> (RelPath -> LintWriter a) -> LintWriter a unwrapPath str f = case parsePath str of @@ -437,20 +467,6 @@ unwrapBadgeToken str f = case parseToken str of Just a -> f a Nothing -> complain "invalid badge token." --- | just asserts that this is a string -isString :: Property -> LintWriter a -isString = flip unwrapString (const $ pure ()) - --- | just asserts that this is a boolean -isBool :: Property -> LintWriter a -isBool = flip unwrapBool (const $ pure ()) - -isIntInRange :: Int -> Int -> Property -> LintWriter a -isIntInRange l r p@(Property name _) = unwrapInt p $ \int -> - if l < int && int < r then pure () - else complain $ "Property " <> prettyprint name <> " should be between" <> showText l <> " and " <> showText r<>"." - - unwrapURI :: (KnownSymbol s, HasProperties a) => Proxy s -> Property -> (Text -> LintWriter a) -> (RelPath -> LintWriter a) -> LintWriter a unwrapURI sym p@(Property name _) f g = unwrapLink p $ \link -> do @@ -468,6 +484,15 @@ unwrapURI sym p@(Property name _) f g = unwrapLink p $ \link -> do WrongScope schema -> "the URI schema " <> schema <> ":// cannot be used on \""<>name<>"\"." -naiveEscapeProperty :: HasProperties a => Property -> LintWriter a -naiveEscapeProperty prop@(Property name _) = - unwrapString prop (setProperty name . naiveEscapeHTML) +-- | just asserts that this is a string +isString :: Property -> LintWriter a +isString = flip unwrapString (const $ pure ()) + +-- | just asserts that this is a boolean +isBool :: Property -> LintWriter a +isBool = flip unwrapBool (const $ pure ()) + +isIntInRange :: Int -> Int -> Property -> LintWriter a +isIntInRange l r p@(Property name _) = unwrapInt p $ \int -> + if l < int && int < r then pure () + else complain $ "Property " <> prettyprint name <> " should be between" <> showText l <> " and " <> showText r<>"." diff --git a/lib/Tiled.hs b/lib/Tiled.hs new file mode 100644 index 0000000..9df52d3 --- /dev/null +++ b/lib/Tiled.hs @@ -0,0 +1,388 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | 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 Tiled where + +import Control.Exception (try) +import Control.Exception.Base (SomeException) +import Data.Aeson hiding (Object) +import qualified Data.Aeson as A +import Data.Aeson.Types (typeMismatch) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LB +import Data.Char (toLower) +import Data.Map (Map) +import Data.String (IsString (fromString)) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Vector (Vector) +import GHC.Generics (Generic) + + +-- | options for Aeson's generic encoding and parsing functions +aesonOptions :: Int -> Options +aesonOptions l = defaultOptions + { omitNothingFields = True + , rejectUnknownFields = True + -- can't be bothered to do a nicer prefix strip + , fieldLabelModifier = drop l . map toLower + , sumEncoding = UntaggedValue + } + +-- | A globally indexed identifier. +newtype GlobalId = GlobalId { unGlobalId :: Int } + deriving (Ord, Eq, Enum, Num, Generic, Show, FromJSON, ToJSON, FromJSONKey, ToJSONKey) + +mkTiledId :: Int -> GlobalId +mkTiledId i = GlobalId { unGlobalId = i } + +-- | A locally indexed identifier. +newtype LocalId = LocalId { unLocalId :: Int } + deriving (Ord, Eq, Enum, Num, Generic, Show, FromJSON, ToJSON, FromJSONKey, ToJSONKey) + +-- | TODO: type-check colours? +type Color = Text + +-- | A custom tiled property, which just has a name and a value. +data Property = Property Text PropertyValue + deriving (Eq, Generic, Show) + +-- | The value of a custom tiled property. +-- It is strongly typed via a tag in the json representation, +-- and needs a custom ToJSON and FromJSON instance because of that. +data PropertyValue = StrProp Text | BoolProp Bool | IntProp Int + deriving (Eq, Generic, Show) + +instance IsString PropertyValue where + fromString s = StrProp (T.pack s) + +instance FromJSON Property where + parseJSON (A.Object o) = do + name <- o .: "name" + o .: "type" >>= \case + A.String "string" -> do + val <- o .: "value" + pure $ Property name (StrProp val) + A.String "bool" -> do + val <- o .: "value" + pure $ Property name (BoolProp val) + A.String "int" -> do + val <- o .: "value" + pure $ Property name (IntProp val) + ty -> fail $ "properties can only have types string, int, bool, but encountered type" <> show ty + parseJSON invalid = typeMismatch "Property" invalid + +instance ToJSON Property where + toJSON (Property name val) = case val of + StrProp str -> object [ "type" .= A.String "string" + , "name" .= name + , "value" .= str + ] + BoolProp bool -> object [ "type" .= A.String "bool" + , "name" .= name + , "value" .= bool + ] + IntProp int -> object [ "type" .= A.String "int" + , "name" .= name + , "value" .= int] + +data Point = Point { pointX :: Double + , pointY :: Double + } deriving (Eq, Generic, Show) + +instance FromJSON Point where + parseJSON = genericParseJSON (aesonOptions 5) +instance ToJSON Point where + toJSON = genericToJSON (aesonOptions 5) + + +-- | all kinds of objects that can occur in object layers, even +-- | those that we don't want to allow. +data Object = ObjectPoint + { objectId :: Int + , objectName :: Maybe String + , objectProperties :: Maybe (Vector Property) + , objectVisible :: Maybe Bool + , objectX :: Double + , objectY :: Double + , objectHeight :: Double + , objectWidth :: Double + , objectRotation :: Double + , objectGid :: Maybe GlobalId + , objectText :: Maybe Text + , objectType :: Text + , objectPoint :: Bool + } + | ObjectRectangle + { objectId :: Int + , objectName :: Maybe String + , objectProperties :: Maybe (Vector Property) + , objectVisible :: Maybe Bool + , objectX :: Double + , objectY :: Double + , objectRotation :: Double + , objectGid :: Maybe GlobalId + , objectText :: Maybe Text + , objectWidth :: Double + , objectHeight :: Double + , objectEllipse :: Maybe Bool + , objectType :: Text + } + | ObjectPolygon + { objectId :: Int + , objectName :: Maybe String + , objectProperties :: Maybe (Vector Property) + , objectVisible :: Maybe Bool + , objectX :: Double + , objectY :: Double + , objectRotation :: Double + , objectGid :: Maybe GlobalId + , objectText :: Maybe Text + , objectWidth :: Double + , objectHeight :: Double + , objectType :: Text + , objectPolygon :: Vector Point + } + | ObjectPolyline + { objectId :: Int + , objectName :: Maybe String + , objectProperties :: Maybe (Vector Property) + , objectVisible :: Maybe Bool + , objectX :: Double + , objectY :: Double + , objectRotation :: Double + , objectGid :: Maybe GlobalId + , objectText :: Maybe Text + , objectWidth :: Double + , objectType :: Text + , objectHeight :: Double + , objectPolyline :: Vector Point + } deriving (Eq, Generic, Show) + + + + + + +instance FromJSON Object where + parseJSON = genericParseJSON (aesonOptions 6) +instance ToJSON Object where + toJSON = genericToJSON (aesonOptions 6) + + +data Layer = Layer { layerWidth :: Maybe Double + -- ^ Column count. Same as map width for fixed-size maps. + , layerHeight :: Maybe Double + -- ^ Row count. Same as map height for fixed-size maps. + , layerName :: Text + -- ^ Name assigned to this layer + , layerType :: Text + -- ^ “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 :: Maybe [Property] + -- ^ string key-value pairs. + , layerOpacity :: Float + -- ^ Value between 0 and 1 + , layerDraworder :: Maybe String + -- ^ “topdown” (default) or “index”. objectgroup only. + , layerId :: Int + , layerOffsetx :: Maybe Int + , layerOffsety :: Maybe Int + , layerParallaxx :: Maybe Float + , layerParallaxy :: Maybe Float + , layerTintColor :: Maybe Color + , layerTransparentColor :: Maybe Color + , layerImage :: Maybe Text + , layerLayers :: Maybe [Layer] + , layerStartX :: Maybe Int + , layerStartY :: Maybe Int + } deriving (Eq, Generic, Show) + +instance FromJSON Layer where + parseJSON = genericParseJSON (aesonOptions 5) +instance ToJSON Layer where + toJSON = genericToJSON (aesonOptions 5) + + +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 :: Int + , tileProperties :: Maybe (Vector Value) + , tileImage :: Maybe Value + , tileObjectGroup :: Maybe Value + , tileAnimation :: Maybe (Vector Frame) + , tileImageheight :: Maybe Int + , tileImagewidth :: Maybe Int + , tileProbability :: Maybe Float + , tileType :: Maybe Text + , tileTerrain :: Maybe [Int] + } deriving (Eq, Generic, Show) + +instance FromJSON Tile where + parseJSON = genericParseJSON (aesonOptions 4) + +instance ToJSON Tile where + toJSON = genericToJSON (aesonOptions 4) + + + +data Tileset = Tileset { tilesetFirstgid :: GlobalId + -- ^ GID corresponding to the first tile in the set + , tilesetImage :: Text + -- ^ Image used for tiles in this set + , tilesetName :: Text + -- ^ 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 :: Maybe [Property] + -- ^ String key-value pairs + , 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 :: Maybe (Map GlobalId (Map Text Text)) + -- ^ Per-tile properties, indexed by gid as string + , 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 :: Maybe (Vector Tile) + -- ^ Tiles (optional) + , tilesetTransparentcolor :: Maybe Text + , tilesetEditorsettings :: Maybe Value + , tilesetBackgroundColor :: Maybe Text + , tilesetGrid :: Maybe Value + , tilesetSource :: Maybe Text + , tilesetTiledversion :: Maybe Text + , tilesetTileoffset :: Maybe Value + , tilesetTransformations :: Maybe Value + , tilesetVersion :: Maybe Value + , tilesetWangsets :: Maybe Value + , tilesetType :: Maybe Text + } deriving (Eq, Generic, Show) + +newtype TransitiveTilesetMap = TransitiveTilesetMap (Map LocalId Value) + deriving (Show, Eq, Generic, FromJSON) + +instance FromJSON Tileset where + parseJSON = genericParseJSON (aesonOptions 7) + +instance ToJSON Tileset where + toJSON = genericToJSON (aesonOptions 7) + + +-- | The full monty. +data Tiledmap = Tiledmap { tiledmapVersion :: Value + -- ^ The JSON format version + , tiledmapTiledversion :: Maybe 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 :: Maybe [Property] + -- ^ String key-value pairs + , tiledmapNextobjectid :: Int + -- ^ Auto-increments for each placed object + , tiledmapCompressionLevel :: Maybe Int + , tiledmapInfinite :: Bool + , tiledmapNextlayerid :: Maybe Int + , tiledmapHexsidelength :: Maybe Int + , tiledmapStaggeraxis :: Maybe Text + , tiledmapStaggerindex :: Maybe String + , tiledmapType :: String + , tiledmapEditorsettings :: Maybe Value + } deriving (Eq, Generic, Show) + +instance FromJSON Tiledmap where + parseJSON = genericParseJSON (aesonOptions 8) +instance ToJSON Tiledmap where + toJSON = genericToJSON (aesonOptions 8) + +data LoadResult = Loaded Tiledmap | IOErr String | DecodeErr String + +-- | Load a Tiled map from the given 'FilePath'. +loadTiledmap :: FilePath -> IO LoadResult +loadTiledmap path = do + res <- try (BS.readFile path) + pure $ case res of + Right file -> case eitherDecode . LB.fromStrict $ file of + Left err -> DecodeErr err + Right tiledmap -> Loaded tiledmap + Left (err :: SomeException) -> IOErr $ show err diff --git a/lib/Tiled2.hs b/lib/Tiled2.hs deleted file mode 100644 index 44f2db7..0000000 --- a/lib/Tiled2.hs +++ /dev/null @@ -1,437 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | 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.Exception (try) -import Control.Exception.Base (SomeException) -import Data.Aeson hiding (Object) -import qualified Data.Aeson as A -import Data.Aeson.Types (typeMismatch) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LB -import Data.Char (toLower) -import Data.Map (Map) -import Data.Maybe (fromMaybe) -import Data.Proxy (Proxy) -import Data.String (IsString (fromString)) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Vector (Vector) -import GHC.Generics (Generic) - - --- | options for Aeson's generic encoding and parsing functions -aesonOptions :: Int -> Options -aesonOptions l = defaultOptions - { omitNothingFields = True - , rejectUnknownFields = True - -- can't be bothered to do a nicer prefix strip - , fieldLabelModifier = drop l . map toLower - , sumEncoding = UntaggedValue - } - --- | A globally indexed identifier. -newtype GlobalId = GlobalId { unGlobalId :: Int } - deriving (Ord, Eq, Enum, Num, Generic, Show, FromJSON, ToJSON, FromJSONKey, ToJSONKey) - -mkTiledId :: Int -> GlobalId -mkTiledId i = GlobalId { unGlobalId = i } - --- | A locally indexed identifier. -newtype LocalId = LocalId { unLocalId :: Int } - deriving (Ord, Eq, Enum, Num, Generic, Show, FromJSON, ToJSON, FromJSONKey, ToJSONKey) - --- | TODO: type-check colours? -type Color = Text - --- | A custom tiled property, which just has a name and a value. -data Property = Property Text PropertyValue - deriving (Eq, Generic, Show) - --- | The value of a custom tiled property. --- It is strongly typed via a tag in the json representation, --- and needs a custom ToJSON and FromJSON instance because of that. -data PropertyValue = StrProp Text | BoolProp Bool | IntProp Int - deriving (Eq, Generic, Show) - -instance IsString PropertyValue where - fromString s = StrProp (T.pack s) - -instance FromJSON Property where - parseJSON (A.Object o) = do - name <- o .: "name" - o .: "type" >>= \case - A.String "string" -> do - val <- o .: "value" - pure $ Property name (StrProp val) - A.String "bool" -> do - val <- o .: "value" - pure $ Property name (BoolProp val) - A.String "int" -> do - val <- o .: "value" - pure $ Property name (IntProp val) - ty -> fail $ "properties can only have types string, int, bool, but encountered type" <> show ty - parseJSON invalid = typeMismatch "Property" invalid - -instance ToJSON Property where - toJSON (Property name val) = case val of - StrProp str -> object [ "type" .= A.String "string" - , "name" .= name - , "value" .= str - ] - BoolProp bool -> object [ "type" .= A.String "bool" - , "name" .= name - , "value" .= bool - ] - IntProp int -> object [ "type" .= A.String "int" - , "name" .= name - , "value" .= int] - -data Point = Point { pointX :: Double - , pointY :: Double - } deriving (Eq, Generic, Show) - -instance FromJSON Point where - parseJSON = genericParseJSON (aesonOptions 5) -instance ToJSON Point where - toJSON = genericToJSON (aesonOptions 5) - - --- | all kinds of objects that can occur in object layers, even --- | those that we don't want to allow. -data Object = ObjectPoint - { objectId :: Int - , objectName :: Maybe String - , objectProperties :: Maybe (Vector Property) - , objectVisible :: Maybe Bool - , objectX :: Double - , objectY :: Double - , objectHeight :: Double - , objectWidth :: Double - , objectRotation :: Double - , objectGid :: Maybe GlobalId - , objectText :: Maybe Text - , objectType :: Text - , objectPoint :: Bool - } - | ObjectRectangle - { objectId :: Int - , objectName :: Maybe String - , objectProperties :: Maybe (Vector Property) - , objectVisible :: Maybe Bool - , objectX :: Double - , objectY :: Double - , objectRotation :: Double - , objectGid :: Maybe GlobalId - , objectText :: Maybe Text - , objectWidth :: Double - , objectHeight :: Double - , objectEllipse :: Maybe Bool - , objectType :: Text - } - | ObjectPolygon - { objectId :: Int - , objectName :: Maybe String - , objectProperties :: Maybe (Vector Property) - , objectVisible :: Maybe Bool - , objectX :: Double - , objectY :: Double - , objectRotation :: Double - , objectGid :: Maybe GlobalId - , objectText :: Maybe Text - , objectWidth :: Double - , objectHeight :: Double - , objectType :: Text - , objectPolygon :: Vector Point - } - | ObjectPolyline - { objectId :: Int - , objectName :: Maybe String - , objectProperties :: Maybe (Vector Property) - , objectVisible :: Maybe Bool - , objectX :: Double - , objectY :: Double - , objectRotation :: Double - , objectGid :: Maybe GlobalId - , objectText :: Maybe Text - , objectWidth :: Double - , objectType :: Text - , objectHeight :: Double - , objectPolyline :: Vector Point - } deriving (Eq, Generic, Show) - - - - - - -instance FromJSON Object where - parseJSON = genericParseJSON (aesonOptions 6) -instance ToJSON Object where - toJSON = genericToJSON (aesonOptions 6) - - -data Layer = Layer { layerWidth :: Maybe Double - -- ^ Column count. Same as map width for fixed-size maps. - , layerHeight :: Maybe Double - -- ^ Row count. Same as map height for fixed-size maps. - , layerName :: Text - -- ^ Name assigned to this layer - , layerType :: Text - -- ^ “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 :: Maybe [Property] - -- ^ string key-value pairs. - , layerOpacity :: Float - -- ^ Value between 0 and 1 - , layerDraworder :: Maybe String - -- ^ “topdown” (default) or “index”. objectgroup only. - , layerId :: Int - , layerOffsetx :: Maybe Int - , layerOffsety :: Maybe Int - , layerParallaxx :: Maybe Float - , layerParallaxy :: Maybe Float - , layerTintColor :: Maybe Color - , layerTransparentColor :: Maybe Color - , layerImage :: Maybe Text - , layerLayers :: Maybe [Layer] - , layerStartX :: Maybe Int - , layerStartY :: Maybe Int - } deriving (Eq, Generic, Show) - -instance FromJSON Layer where - parseJSON = genericParseJSON (aesonOptions 5) -instance ToJSON Layer where - toJSON = genericToJSON (aesonOptions 5) - - -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 :: Int - , tileProperties :: Maybe (Vector Value) - , tileImage :: Maybe Value - , tileObjectGroup :: Maybe Value - , tileAnimation :: Maybe (Vector Frame) - , tileImageheight :: Maybe Int - , tileImagewidth :: Maybe Int - , tileProbability :: Maybe Float - , tileType :: Maybe Text - , tileTerrain :: Maybe [Int] - } deriving (Eq, Generic, Show) - -instance FromJSON Tile where - parseJSON = genericParseJSON (aesonOptions 4) - -instance ToJSON Tile where - toJSON = genericToJSON (aesonOptions 4) - - - -data Tileset = Tileset { tilesetFirstgid :: GlobalId - -- ^ GID corresponding to the first tile in the set - , tilesetImage :: Text - -- ^ Image used for tiles in this set - , tilesetName :: Text - -- ^ 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 :: Maybe [Property] - -- ^ String key-value pairs - , 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 :: Maybe (Map GlobalId (Map Text Text)) - -- ^ Per-tile properties, indexed by gid as string - , 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 :: Maybe (Vector Tile) - -- ^ Tiles (optional) - , tilesetTransparentcolor :: Maybe Text - , tilesetEditorsettings :: Maybe Value - , tilesetBackgroundColor :: Maybe Text - , tilesetGrid :: Maybe Value - , tilesetSource :: Maybe Text - , tilesetTiledversion :: Maybe Text - , tilesetTileoffset :: Maybe Value - , tilesetTransformations :: Maybe Value - , tilesetVersion :: Maybe Value - , tilesetWangsets :: Maybe Value - , tilesetType :: Maybe Text - } deriving (Eq, Generic, Show) - -newtype TransitiveTilesetMap = TransitiveTilesetMap (Map LocalId Value) - deriving (Show, Eq, Generic, FromJSON) - -instance FromJSON Tileset where - parseJSON = genericParseJSON (aesonOptions 7) - -instance ToJSON Tileset where - toJSON = genericToJSON (aesonOptions 7) - - --- | The full monty. -data Tiledmap = Tiledmap { tiledmapVersion :: Value - -- ^ The JSON format version - , tiledmapTiledversion :: Maybe 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 :: Maybe [Property] - -- ^ String key-value pairs - , tiledmapNextobjectid :: Int - -- ^ Auto-increments for each placed object - , tiledmapCompressionLevel :: Maybe Int - , tiledmapInfinite :: Bool - , tiledmapNextlayerid :: Maybe Int - , tiledmapHexsidelength :: Maybe Int - , tiledmapStaggeraxis :: Maybe Text - , tiledmapStaggerindex :: Maybe String - , tiledmapType :: String - , tiledmapEditorsettings :: Maybe Value - } deriving (Eq, Generic, Show) - -instance FromJSON Tiledmap where - parseJSON = genericParseJSON (aesonOptions 8) -instance ToJSON Tiledmap where - toJSON = genericToJSON (aesonOptions 8) - - -class HasProperties a where - getProperties :: a -> [Property] - adjustProperties :: ([Property] -> Maybe [Property]) -> a -> a - -instance HasProperties Layer where - getProperties = fromMaybe [] . layerProperties - adjustProperties f layer = layer - { layerProperties = f (getProperties layer) } - -instance HasProperties Tileset where - getProperties = fromMaybe [] . tilesetProperties - adjustProperties f tileset = tileset - { tilesetProperties = f (getProperties tileset) } - -instance HasProperties Tiledmap where - getProperties = fromMaybe [] . tiledmapProperties - adjustProperties f tiledmap = tiledmap - { tiledmapProperties = f (getProperties tiledmap) } - -class HasTypeName a where - typeName :: Proxy a -> Text -instance HasTypeName Layer where - typeName _ = "layer" -instance HasTypeName Tileset where - typeName _ = "tileset" -instance HasTypeName Property where - typeName _ = "property" - -class HasName a where - getName :: a -> Text -instance HasName Layer where - getName = layerName -instance HasName Tileset where - getName = tilesetName -instance HasName Property where - getName (Property n _) = n - -class IsProperty a where - asProperty :: a -> PropertyValue -instance IsProperty PropertyValue where - asProperty = id - {-# INLINE asProperty #-} -instance IsProperty Text where - asProperty = StrProp - {-# INLINE asProperty #-} - -data LoadResult = Loaded Tiledmap | IOErr String | DecodeErr String - --- | Load a Tiled map from the given 'FilePath'. -loadTiledmap :: FilePath -> IO LoadResult -loadTiledmap path = do - res <- try (BS.readFile path) - pure $ case res of - Right file -> case eitherDecode . LB.fromStrict $ file of - Left err -> DecodeErr err - Right tiledmap -> Loaded tiledmap - Left (err :: SomeException) -> IOErr $ show err diff --git a/lib/TiledAbstract.hs b/lib/TiledAbstract.hs new file mode 100644 index 0000000..f7bbbb9 --- /dev/null +++ b/lib/TiledAbstract.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE OverloadedStrings #-} + +module TiledAbstract where + +import Data.Maybe (fromMaybe) +import Data.Proxy (Proxy) +import Data.Text (Text) +import Tiled (Layer (..), Property (..), PropertyValue (..), + Tiledmap (..), Tileset (..)) + +class HasProperties a where + getProperties :: a -> [Property] + adjustProperties :: ([Property] -> Maybe [Property]) -> a -> a + +instance HasProperties Layer where + getProperties = fromMaybe mempty . layerProperties + adjustProperties f layer = layer + { layerProperties = f (getProperties layer) } + +instance HasProperties Tileset where + getProperties = fromMaybe mempty . tilesetProperties + adjustProperties f tileset = tileset + { tilesetProperties = f (getProperties tileset) } + +instance HasProperties Tiledmap where + getProperties = fromMaybe mempty . tiledmapProperties + adjustProperties f tiledmap = tiledmap + { tiledmapProperties = f (getProperties tiledmap) } + +class HasTypeName a where + typeName :: Proxy a -> Text +instance HasTypeName Layer where + typeName _ = "layer" +instance HasTypeName Tileset where + typeName _ = "tileset" +instance HasTypeName Property where + typeName _ = "property" + +class HasName a where + getName :: a -> Text +instance HasName Layer where + getName = layerName +instance HasName Tileset where + getName = tilesetName +instance HasName Property where + getName (Property n _) = n + +class IsProperty a where + asProperty :: a -> PropertyValue +instance IsProperty PropertyValue where + asProperty = id + {-# INLINE asProperty #-} +instance IsProperty Text where + asProperty = StrProp + {-# INLINE asProperty #-} diff --git a/lib/Util.hs b/lib/Util.hs index c082bfe..e676e7e 100644 --- a/lib/Util.hs +++ b/lib/Util.hs @@ -10,7 +10,7 @@ import Data.Aeson as Aeson import Data.Proxy (Proxy (..)) import Data.Text (Text) import qualified Data.Text as T -import Tiled2 (Layer (layerData), PropertyValue (..), +import Tiled (Layer (layerData), PropertyValue (..), Tileset (tilesetName), layerName, mkTiledId) -- | helper function to create proxies -- cgit v1.2.3