collect badges from object layers

this includes a halfway-reasonable parsing of object layers, as well as
some monad plumbing to get them all in the right place.

7 files changed, 229 insertions, 52 deletions

diff --git a/lib/Badges.hs b/lib/Badges.hs
new file mode 100644
index 0000000..0369334
--- /dev/null
+++ b/lib/Badges.hs
@@ -0,0 +1,70 @@
+{-# LANGUAGE DeriveAnyClass    #-}
+{-# LANGUAGE DeriveGeneric     #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
+
+-- | module defining Badge types and utility functions
+module Badges where
+
+import           Data.Aeson      (Options (fieldLabelModifier, sumEncoding),
+                                  SumEncoding (UntaggedValue), ToJSON (toJSON),
+                                  defaultOptions, genericToJSON, (.=))
+import qualified Data.Aeson      as A
+import           Data.Char       (toLower)
+import           Data.Text       (Text)
+import           GHC.Generics    (Generic)
+import           Text.Regex.TDFA ((=~))
+
+
+data BadgeArea =
+   BadgePoint
+   { areaX :: Double
+   , areaY :: Double
+   }
+ | BadgeRect
+   { areaX      :: Double
+   , areaY      :: Double
+   , areaWidth  :: Double
+   , areaHeight :: Double
+   , areaIsEllipse :: Bool
+   }
+  deriving (Ord, Eq, Generic, Show)
+
+newtype BadgeToken = BadgeToken Text
+  deriving (Eq, Ord, Show)
+
+instance ToJSON BadgeArea where
+  toJSON = genericToJSON defaultOptions
+    { fieldLabelModifier = drop 4 . map toLower
+    , sumEncoding = UntaggedValue }
+
+instance ToJSON BadgeToken where
+  toJSON (BadgeToken text) = toJSON text
+
+parseToken :: Text -> Maybe BadgeToken
+parseToken text = if text =~ ("^[a-zA-Z0-9]{50}$" :: Text) -- TODO: add character limit
+  then Just (BadgeToken text)
+  else Nothing
+
+data Badge = Badge BadgeToken BadgeArea
+  deriving (Ord, Eq, Generic, Show)
+
+badgeJsonArray :: A.KeyValue a => Badge -> [a]
+badgeJsonArray (Badge token area) =
+  [ "token" .= token ] <> areaObject
+  where areaObject = case area of
+         BadgePoint x y -> [ "x" .= x
+                           , "y" .= y
+                           , "type" .= A.String "point"
+                           ]
+         BadgeRect {..} -> [ "x" .= areaX
+                           , "y" .= areaY
+                           , "width" .= areaWidth
+                           , "height" .= areaHeight
+                           , "type" .= if areaIsEllipse
+                                then A.String "ellipse"
+                                else A.String "rectangle"
+                           ]
+
+badgeJson :: FilePath -> Badge -> A.Value
+badgeJson mappath badge = A.object (badgeJsonArray badge <> [ "map" .= mappath ])
diff --git a/lib/CheckDir.hs b/lib/CheckDir.hs
index d5ea440..17c6f78 100644
--- a/lib/CheckDir.hs
+++ b/lib/CheckDir.hs
@@ -16,7 +16,7 @@ import           Data.Aeson             (ToJSON, (.=))
 import qualified Data.Aeson             as A
 import           Data.Foldable          (fold)
 import           Data.Functor           ((<&>))
-import           Data.Map               (Map, elems, keys)
+import           Data.Map               (Map, elems, keys, mapWithKey)
 import qualified Data.Map               as M
 import           Data.Map.Strict        (mapKeys, (\\))
 import           Data.Maybe             (mapMaybe)
@@ -32,6 +32,7 @@ import           System.FilePath.Posix  (takeDirectory)
 import           Types                  (Dep (Local, LocalMap), Level (..),
                                          hintLevel)
 import           Util                   (PrettyPrint (prettyprint))
+import Badges (badgeJson)
 
 
 -- based on the startling observation that Data.Map has lower complexity
@@ -94,7 +95,12 @@ instance ToJSON DirResult where
       ]
     , "resultText" .= prettyprint (Suggestion, res)
     , "severity" .= maximumLintLevel res
+    , "badges" .= annotatedBadges
     ]
+    where annotatedBadges = concat
+            . M.elems
+            . mapWithKey (\k -> fmap (badgeJson k) . mapresultBadges)
+            $ dirresultMaps res
 
 instance ToJSON MissingAsset where
   toJSON (MissingAsset md) = A.object
diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs
index 8a2ad7e..359452c 100644
--- a/lib/CheckMap.hs
+++ b/lib/CheckMap.hs
@@ -21,11 +21,12 @@ import qualified Data.Vector      as V
 import           GHC.Generics     (Generic)
 
 
+import           Badges           (Badge)
 import           LintConfig       (LintConfig')
-import           LintWriter       (LintResult (..), filterLintLevel,
-                                   invertLintResult, lintToDep,
-                                   resultToAdjusted, resultToDeps,
-                                   resultToLints, resultToOffers, runLintWriter)
+import           LintWriter       (LintResult (..), invertLintResult, lintToDep,
+                                   resultToAdjusted, resultToBadges,
+                                   resultToDeps, resultToLints, resultToOffers,
+                                   runLintWriter)
 import           Properties       (checkLayer, checkMap, checkTileset)
 import           Tiled2           (HasName (getName),
                                    Layer (layerLayers, layerName),
@@ -33,7 +34,7 @@ import           Tiled2           (HasName (getName),
                                    Tiledmap (tiledmapLayers, tiledmapTilesets),
                                    Tileset, loadTiledmap)
 import           Types            (Dep, Hint (Hint, hintLevel, hintMsg),
-                                   Level (..), Lint (..), hint, lintsToHints)
+                                   Level (..), lintsToHints)
 import           Util             (PrettyPrint (prettyprint), prettyprint)
 
 
@@ -50,6 +51,8 @@ data MapResult = MapResult
   -- ^ entrypoints provided by this map (needed for dependency checking)
   , mapresultAdjusted :: Maybe Tiledmap
   -- ^ the loaded map, with adjustments by the linter
+  , mapresultBadges   :: [Badge]
+  -- ^ badges that can be found on this map
   , mapresultGeneral  :: [Hint]
   -- ^ general-purpose lints that didn't fit anywhere else
   } deriving (Generic)
@@ -77,7 +80,7 @@ instance ToJSON CollectedLints where
 -- layers upwards in the file hierarchy
 loadAndLintMap :: LintConfig' -> FilePath -> Int -> IO (Maybe MapResult)
 loadAndLintMap config path depth = loadTiledmap path <&> (\case
-    DecodeErr err -> Just (MapResult mempty mempty mempty mempty Nothing
+    DecodeErr err -> Just (MapResult mempty mempty mempty mempty Nothing mempty
         [ Hint Fatal . T.pack $
           path <> ": Fatal: " <> err
         ])
@@ -96,6 +99,8 @@ runLinter config tiledmap depth = MapResult
     <> concatMap resultToDeps tileset
   , mapresultProvides = concatMap resultToOffers layer
   , mapresultAdjusted = Just adjustedMap
+  , mapresultBadges = concatMap resultToBadges layer
+    <> resultToBadges generalResult
   }
   where
     layer = checkLayerRec config depth (V.toList $ tiledmapLayers tiledmap)
diff --git a/lib/LintWriter.hs b/lib/LintWriter.hs
index c8ab6d5..e235fca 100644
--- a/lib/LintWriter.hs
+++ b/lib/LintWriter.hs
@@ -24,6 +24,7 @@ import           Data.Maybe                 (mapMaybe)
 import qualified Data.Text                  as T
 import           Util                       (PrettyPrint (..))
 
+import           Badges                     (Badge)
 import           LintConfig                 (LintConfig')
 import           Tiled2                     (HasName)
 import           Types
@@ -87,6 +88,11 @@ resultToOffers (LintResult a) = mapMaybe lintToOffer $ snd a
 resultToLints :: LintResult a -> [Lint]
 resultToLints (LintResult res) = snd res
 
+resultToBadges :: LintResult a -> [Badge]
+resultToBadges (LintResult a) = mapMaybe lintToBadge $ snd a
+  where lintToBadge (Badge badge) = Just badge
+        lintToBadge _             = Nothing
+
 resultToAdjusted :: LintResult a -> a
 resultToAdjusted (LintResult res) = fst res
 
@@ -110,6 +116,9 @@ dependsOn dep = tell' $ Depends dep
 offersEntrypoint :: Text -> LintWriter a
 offersEntrypoint text = tell' $ Offers text
 
+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
diff --git a/lib/Properties.hs b/lib/Properties.hs
index f78ceff..27076cb 100644
--- a/lib/Properties.hs
+++ b/lib/Properties.hs
@@ -1,33 +1,38 @@
+{-# LANGUAGE DataKinds         #-}
 {-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE MultiWayIf        #-}
 {-# LANGUAGE NamedFieldPuns    #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
 {-# LANGUAGE TypeApplications  #-}
 
 -- | Contains checks for custom ties of the map json
-{-# LANGUAGE DataKinds         #-}
 module Properties (checkMap, checkTileset, checkLayer) where
 
 
-import           Control.Monad (unless, when)
+import           Control.Monad (forM_, unless, when)
 import           Data.Text     (Text, isPrefixOf)
+import qualified Data.Vector   as V
 import           Tiled2        (HasProperties (adjustProperties, getProperties),
                                 IsProperty (asProperty), Layer (..),
-                                Property (..), PropertyValue (..),
+                                Object (..), Property (..), PropertyValue (..),
                                 Tiledmap (..), Tileset (..))
-import           Util          (layerIsEmpty, prettyprint, showText)
+import           Util          (layerIsEmpty, naiveEscapeHTML, prettyprint,
+                                showText)
 
+import           Badges        (Badge (Badge),
+                                BadgeArea (BadgePoint, BadgeRect), BadgeToken,
+                                parseToken)
 import           Data.Data     (Proxy (Proxy))
 import           Data.Maybe    (fromMaybe, isJust)
 import           GHC.TypeLits  (KnownSymbol)
 import           LintConfig    (LintConfig (..))
 import           LintWriter    (LintWriter, adjust, askContext, askFileDepth,
                                 complain, dependsOn, forbid, lintConfig,
-                                offersEntrypoint, suggest, warn)
+                                offersBadge, offersEntrypoint, suggest, warn)
 import           Paths         (PathResult (..), RelPath (..), parsePath)
 import           Types         (Dep (Link, Local, LocalMap, MapLink))
 import           Uris          (SubstError (..), applySubst)
-import Data.Functor ((<&>))
 
 
 -- | Checks an entire map for "general" lints.
@@ -133,8 +138,25 @@ checkLayer = do
   case layerType layer of
     "tilelayer" -> mapM_ checkLayerProperty (getProperties layer)
     "group" -> pure ()
-    ty -> unless (layerName layer == "floorLayer" && ty == "objectgroup")
-          $ complain "only group and tilelayer are supported."
+    "objectgroup" -> do
+      -- TODO: this still retains object group layers, just empties them out.
+      -- perhaps actually delete the entire layer, since this still leaves hints
+      -- as to where badges are?
+      adjust $ \l -> l { layerObjects = Nothing, layerProperties = Nothing }
+
+      unless (layerName layer == "floorLayer") $ do
+        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."
+
+      -- individual objects can't have properties
+      forM_ (fromMaybe (V.fromList []) $ 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 <> "."
 
   if layerType layer == "group"
     then when (null (layerLayers layer))
@@ -143,7 +165,28 @@ checkLayer = do
     $ complain "Layer is not of type \"group\", but has sublayers."
 
 
--- | Checks a single (custom) property of a layer
+-- | 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
+    unwrapString p $ \str ->
+      unwrapBadgeToken str $ \token -> do
+        layer <- askContext
+        forM_ (fromMaybe (V.fromList []) $ layerObjects layer) $ \object -> do
+          case object of
+            ObjectPoint {..} ->
+              offersBadge (Badge token (BadgePoint objectX objectY))
+            ObjectRectangle {..} ->
+              offersBadge (Badge token area)
+              where area = BadgeRect
+                      objectX objectY
+                      objectWidth objectHeight
+                      (objectEllipse == Just True)
+            ObjectPolygon {} -> complain "cannot use polygons for badges."
+            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.
@@ -371,6 +414,11 @@ unwrapPath str f = case parsePath str of
   UnderscoreMapLink -> complain "map links using /_/ are disallowed. Use world:// instead."
   AtMapLink -> complain "map links using /@/ are disallowed. Use world:// instead."
 
+unwrapBadgeToken :: Text -> (BadgeToken -> LintWriter a) -> LintWriter a
+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 ())
diff --git a/lib/Tiled2.hs b/lib/Tiled2.hs
index 7924d3e..7e8f773 100644
--- a/lib/Tiled2.hs
+++ b/lib/Tiled2.hs
@@ -36,8 +36,9 @@ aesonOptions :: Int -> Options
 aesonOptions l = defaultOptions
   { omitNothingFields = True
   , rejectUnknownFields = True
-  -- can't be bothered to do a nixer prefix strip
+  -- can't be bothered to do a nicer prefix strip
   , fieldLabelModifier = drop l . map toLower
+  , sumEncoding = UntaggedValue
   }
 
 -- | A globally indexed identifier.
@@ -97,8 +98,8 @@ instance ToJSON Property where
                           , "name" .= name
                           , "value" .= int]
 
-data Point = Point { pointX :: Int
-                   , pointY :: Int
+data Point = Point { pointX :: Double
+                   , pointY :: Double
                    } deriving (Eq, Generic, Show)
 
 instance FromJSON Point where
@@ -106,37 +107,74 @@ instance FromJSON Point where
 instance ToJSON Point where
   toJSON = genericToJSON (aesonOptions 5)
 
-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       :: Maybe String
-                       -- ^ String assigned to name field in editor
-                     , objectType       :: String
-                       -- ^ String assigned to type field in editor
-                     , objectProperties :: Maybe Value
-                       -- ^ String key-value pairs
-                     , objectVisible    :: Maybe 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    :: Maybe Bool
-                       -- ^ Used to mark an object as an ellipse
-                     , objectPolygon    :: Maybe (Vector Point)
-                       -- ^ A list of x,y coordinates in pixels
-                     , objectPolyline   :: Maybe (Vector Point)
-                       -- ^ A list of x,y coordinates in pixels
-                     , objectText       :: Maybe Value
-                       -- ^ String key-value pairs
-                     } deriving (Eq, Generic, Show)
+
+-- | 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)
@@ -150,7 +188,7 @@ data Layer = Layer { layerWidth            :: Maybe Double
                      -- ^ Row count. Same as map height for fixed-size maps.
                    , layerName             :: Text
                      -- ^ Name assigned to this layer
-                   , layerType             :: String
+                   , layerType             :: Text
                      -- ^ “tilelayer”, “objectgroup”, or “imagelayer”
                    , layerVisible          :: Bool
                      -- ^ Whether layer is shown or hidden in editor
diff --git a/lib/Types.hs b/lib/Types.hs
index 1099630..481dd22 100644
--- a/lib/Types.hs
+++ b/lib/Types.hs
@@ -15,6 +15,7 @@ import           Data.Aeson                (FromJSON, ToJSON (toJSON),
 import           Data.Text                 (Text)
 import           GHC.Generics              (Generic)
 
+import           Badges                    (Badge)
 import qualified Data.Aeson                as A
 import           Data.Maybe                (mapMaybe)
 import           Paths                     (RelPath)
@@ -47,7 +48,7 @@ instance HasArguments Level where
 
 -- | a hint comes with an explanation (and a level), or is a dependency
 -- (in which case it'll be otherwise treated as an info hint)
-data Lint = Depends Dep | Offers Text | Lint Hint
+data Lint = Depends Dep | Offers Text | Lint Hint | Badge Badge
   deriving (Ord, Eq, Generic, ToJSONKey)
 
 -- | TODO: add a reasonable representation of possible urls