first example of a map adjustment

this also includes some more monad plumbing, and an option for the
linter to actually write things out again. Some of the previous commit
was reverted a bit since it turned out to be stupid, but overall it was
suprisingly easy once I got around to it, so yay! i guess

Also includes a fairly silly example of how to use it.

6 files changed, 96 insertions, 42 deletions

diff --git a/lib/CheckDir.hs b/lib/CheckDir.hs
index d651815..4654051 100644
--- a/lib/CheckDir.hs
+++ b/lib/CheckDir.hs
@@ -6,17 +6,17 @@
 {-# LANGUAGE TupleSections     #-}
 
 -- | Module that contains high-level checking for an entire directory
-module CheckDir (recursiveCheckDir)  where
+module CheckDir (recursiveCheckDir, writeAdjustedRepository)  where
 
-import           CheckMap               (MapResult (mapresultProvides),
+import           CheckMap               (MapResult (mapresultAdjusted, mapresultProvides),
                                          loadAndLintMap, mapresultDepends)
 import           Control.Monad          (void)
 import           Control.Monad.Extra    (mapMaybeM)
-import           Data.Aeson             (ToJSON, (.=))
+import           Data.Aeson             (ToJSON, encodeFile, (.=))
 import qualified Data.Aeson             as A
 import           Data.Foldable          (fold)
 import           Data.Functor           ((<&>))
-import           Data.Map               (Map)
+import           Data.Map               (Map, toList)
 import qualified Data.Map               as M
 import           Data.Map.Strict        (mapKeys, (\\))
 import           Data.Maybe             (mapMaybe)
@@ -43,8 +43,11 @@ listFromSet = map fst . M.toList
 -- | Result of linting an entire directory / repository
 data DirResult = DirResult
   { dirresultMaps          :: Map FilePath MapResult
+  -- ^ all maps of this respository, by (local) filepath
   , dirresultDeps          :: [MissingDep]
+  -- ^ all dependencies to things outside this repository
   , dirresultMissingAssets :: [MissingAsset]
+  -- ^ local things that are referred to but missing
   } deriving (Generic)
 
 data MissingDep = MissingDep
@@ -176,10 +179,10 @@ recursiveCheckDir' prefix paths done acc = do
 
 
   let mapdeps = concatMap
-       (\(m,res) ->
+       (\(m,lintresult) ->
           let ps = mapMaybe
                 (\case {LocalMap p -> Just p; _ -> Nothing})
-                (mapresultDepends res)
+                (mapresultDepends lintresult)
           in map (FP.normalise . normalise (takeDirectory m)) ps
        )
        lints
@@ -199,3 +202,12 @@ recursiveCheckDir' prefix paths done acc = do
   case unknowns of
     [] -> pure acc'
     _  -> recursiveCheckDir' prefix unknowns knowns acc'
+
+
+
+
+writeAdjustedRepository :: FilePath -> DirResult -> IO ()
+writeAdjustedRepository outPath result =
+  mapM_
+    (\(path,out) -> encodeFile (outPath </> path) $ mapresultAdjusted out)
+    (toList $ dirresultMaps result)
diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs
index 845513d..73909b9 100644
--- a/lib/CheckMap.hs
+++ b/lib/CheckMap.hs
@@ -20,10 +20,12 @@ import qualified Data.Vector      as V
 import           GHC.Generics     (Generic)
 
 
-import           LintWriter       (LintWriter, askContext, filterLintLevel,
-                                   invertLintResult, lintToDep, resultToDeps,
+import           Data.Bifunctor   (Bifunctor (second))
+import           Data.Functor     ((<&>))
+import           LintWriter       (filterLintLevel, invertLintResult, lintToDep,
+                                   resultToAdjusted, resultToDeps,
                                    resultToLints, resultToOffers, runLintWriter)
-import           Properties       (checkLayerProperty, checkMap, checkTileset)
+import           Properties       (checkLayer, checkMap, checkTileset)
 import           Tiled2           (HasName (getName),
                                    HasProperties (getProperties), Layer,
                                    LoadResult (..),
@@ -38,10 +40,17 @@ import           Util             (PrettyPrint (prettyprint), prettyprint)
 -- | What this linter produces: lints for a single map
 data MapResult = MapResult
   { mapresultLayer    :: Map Hint [Layer]
-  , mapresultTileset  :: Map Hint [Tileset] --Map Text (LintResult Tileset)
+  -- ^ lints that occurred in one or more layers
+  , mapresultTileset  :: Map Hint [Tileset]
+  -- ^ lints that occurred in one or more tilesets
   , mapresultDepends  :: [Dep]
+  -- ^ (external and local) dependencies of this map
   , mapresultProvides :: [Text]
+  -- ^ entrypoints provided by this map (needed for dependency checking)
+  , mapresultAdjusted :: Maybe Tiledmap
+  -- ^ the loaded map, with adjustments by the linter
   , mapresultGeneral  :: [Lint]
+  -- ^ general-purpose lints that didn't fit anywhere else
   } deriving (Generic)
 
 instance ToJSON MapResult where
@@ -66,14 +75,14 @@ instance ToJSON CollectedLints where
 -- Lints the map at `path`, and limits local links to at most `depth`
 -- layers upwards in the file hierarchy
 loadAndLintMap :: FilePath -> Int -> IO (Maybe MapResult)
-loadAndLintMap path depth = loadTiledmap path >>= pure . \case
-    DecodeErr err -> Just $ MapResult mempty mempty mempty mempty
+loadAndLintMap path depth = loadTiledmap path <&> (\case
+    DecodeErr err -> Just (MapResult mempty mempty mempty mempty Nothing
         [ hint Fatal . T.pack $
           path <> ": Fatal: " <> err
-        ]
+        ])
     IOErr _ -> Nothing
     Loaded waMap ->
-      Just (runLinter waMap depth)
+      Just (runLinter waMap depth))
 
 -- | lint a loaded map
 runLinter :: Tiledmap -> Int -> MapResult
@@ -85,6 +94,7 @@ runLinter tiledmap depth = MapResult
     <> concatMap resultToDeps layer
     <> concatMap resultToDeps tileset
   , mapresultProvides = concatMap resultToOffers layer
+  , mapresultAdjusted = Just adjustedMap
   }
   where
     layer = checkThing tiledmapLayers checkLayer
@@ -98,14 +108,13 @@ runLinter tiledmap depth = MapResult
     invertThing thing = M.unionsWith (<>) $ fmap invertLintResult thing
     -- lints collected from properties
     generalLints =
-      resultToLints $ runLintWriter tiledmap depth checkMap
+      resultToLints generalResult
 
+    generalResult = runLintWriter tiledmap depth checkMap
 
--- | collect lints on a single map layer
-checkLayer :: LintWriter Layer
-checkLayer = do
-  layer <- askContext
-  mapM_ checkLayerProperty (getProperties layer)
+    adjustedMap = (resultToAdjusted generalResult)
+      { tiledmapLayers = V.fromList . fmap resultToAdjusted $ layer }
+      -- TODO: this appears to have reordered map layers???
 
 -- human-readable lint output, e.g. for consoles
 instance PrettyPrint (Level, MapResult) where
diff --git a/lib/LintWriter.hs b/lib/LintWriter.hs
index 8d91948..54a5954 100644
--- a/lib/LintWriter.hs
+++ b/lib/LintWriter.hs
@@ -84,9 +84,12 @@ resultToOffers (LintResult a) = mapMaybe lintToOffer $ snd a
 resultToLints :: LintResult a -> [Lint]
 resultToLints (LintResult res) = snd res
 
--- | run a linter
+resultToAdjusted :: LintResult a -> a
+resultToAdjusted (LintResult res) = fst res
+
+-- | run a linter. Returns the adjusted context, and a list of lints
 runLintWriter :: ctxt -> Context -> LintWriter ctxt -> LintResult ctxt
-runLintWriter c c' linter =  LintResult (c, fst $ fromLinterState lints)
+runLintWriter c c' linter =  LintResult (snd $ fromLinterState lints,fst $ fromLinterState lints)
   where lints = snd $ runReader ranstate (c',c)
         ranstate = runStateT linter (LinterState ([], c))
 
@@ -104,6 +107,8 @@ dependsOn dep = tell' $ Depends dep
 offersEntrypoint :: Text -> LintWriter a
 offersEntrypoint text = tell' $ Offers text
 
+-- | 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
 
@@ -114,6 +119,8 @@ warn = lint Warning
 forbid = lint Forbidden
 complain = lint Error
 
+
+-- | get the context as it was originally, without any modifications
 askContext :: LintWriter' a a
 askContext = lift $ asks snd
 
diff --git a/lib/Properties.hs b/lib/Properties.hs
index 403df8e..97c5189 100644
--- a/lib/Properties.hs
+++ b/lib/Properties.hs
@@ -3,20 +3,20 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 -- | Contains checks for custom properties of the map json
-module Properties (checkLayerProperty, checkMap, checkTileset) where
+module Properties (checkMap, checkTileset, checkLayer) where
 
 
 import           Control.Monad (unless, when)
 import           Data.Text     (Text, isPrefixOf)
-import           Tiled2        (HasProperties (getProperties), Layer (..),
-                                Property (..), PropertyValue (..),
+import           Tiled2        (HasProperties (adjustProperties, getProperties),
+                                Layer (..), Property (..), PropertyValue (..),
                                 Tiledmap (..), Tileset (..))
 import           Util          (layerIsEmpty, prettyprint)
 
 import           Data.Maybe    (fromMaybe)
-import           LintWriter    (LintWriter, askContext, askFileDepth, complain,
-                                dependsOn, forbid, offersEntrypoint, suggest,
-                                warn)
+import           LintWriter    (LintWriter, adjust, askContext, askFileDepth,
+                                complain, dependsOn, forbid, offersEntrypoint,
+                                suggest, warn)
 import           Paths         (RelPath (..), parsePath)
 import           Types         (Dep (Link, Local, LocalMap, MapLink))
 
@@ -92,6 +92,16 @@ checkTilesetProperty (Property name _value) = case name of
   "copyright" -> pure () -- only allow some licenses?
   _           -> pure () -- are there any other properties?
 
+
+-- | collect lints on a single map layer
+checkLayer :: LintWriter Layer
+checkLayer = do
+  layer <- askContext
+  mapM_ checkLayerProperty (getProperties layer)
+  setProperty "jitsiRoomAdminTag" "Hello, World"
+
+
+
 -- | Checks a single (custom) property of a layer
 --
 -- It gets a reference to its own layer since sometimes the presence
@@ -210,7 +220,6 @@ propertyRequiredBy req by =
   unlessHasProperty req
   $ complain $ "property "<>prettyprint req<>" is required by property "<> prettyprint by
 
-
 -- | suggest some value for another property if that property does not
 -- also already exist
 suggestProperty :: Property -> LintWriter Layer
@@ -218,9 +227,11 @@ suggestProperty (Property name value) =
   unlessHasProperty name
   $ suggest $ "set property " <> prettyprint name <> " to " <> prettyprint value
 
-
-
-
+-- | set a property, overwriting whatever value it had previously
+setProperty :: HasProperties ctxt => Text -> PropertyValue -> LintWriter ctxt
+setProperty name value = adjust $ \ctxt ->
+  adjustProperties (\props -> Just $ Property name value : filter sameName props) ctxt
+  where sameName (Property name' _) = name /= name'
 
 -- | does this layer have the given property?
 containsProperty :: Foldable t => t Property -> Text -> Bool
diff --git a/lib/Tiled2.hs b/lib/Tiled2.hs
index a82de2c..e281d00 100644
--- a/lib/Tiled2.hs
+++ b/lib/Tiled2.hs
@@ -24,9 +24,11 @@ import qualified Data.ByteString.Lazy   as LB
 import           Data.Char              (toLower)
 import           Data.Map               (Map)
 import           Data.Maybe             (fromMaybe)
+import           Data.String            (IsString (fromString))
 import           Data.Text              (Text)
+import qualified Data.Text              as T
 import           Data.Vector            (Vector)
-import           GHC.Exts               (fromList, toList)
+import           GHC.Exts               (IsString, fromList, toList)
 import           GHC.Generics           (Generic)
 
 
@@ -89,6 +91,8 @@ data PropertyValue = StrProp Text | BoolProp Bool
 data Property = Property Text PropertyValue
   deriving (Eq, Generic, Show)
 
+instance IsString PropertyValue where
+  fromString s = StrProp (T.pack s)
 
 instance FromJSON Property where
   parseJSON (A.Object o) = do
@@ -343,12 +347,17 @@ instance ToJSON Tiledmap where
 
 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) }
 
 class HasName a where
   getName :: a -> Text
diff --git a/src/Main.hs b/src/Main.hs
index f4060b9..0e80eab 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -6,16 +6,17 @@
 
 module Main where
 
-import           Data.Aeson                    (encode)
-import           Data.Aeson.Encode.Pretty      (encodePretty)
-import qualified Data.ByteString.Lazy          as LB
-import qualified Data.ByteString.Char8 as C8
-import           Data.Maybe                    (fromMaybe)
+import           Data.Aeson               (encode)
+import           Data.Aeson.Encode.Pretty (encodePretty)
+import qualified Data.ByteString.Char8    as C8
+import qualified Data.ByteString.Lazy     as LB
+import           Data.Maybe               (fromMaybe)
 import           WithCli
 
-import           Util                          (printPretty)
-import CheckDir (recursiveCheckDir)
-import Types (Level(..))
+import           CheckDir                 (recursiveCheckDir,
+                                           writeAdjustedRepository)
+import           Types                    (Level (..))
+import           Util                     (printPretty)
 
 -- | the options this cli tool can take
 data Options = Options
@@ -27,10 +28,11 @@ data Options = Options
   -- ^ pass --allowScripts to allow javascript in map
   , json         :: Bool
   -- ^ emit json if --json was given
-  , lintlevel        :: Maybe Level
+  , lintlevel    :: Maybe Level
   -- ^ maximum lint level to print
   , pretty       :: Bool
   -- ^ pretty-print the json to make it human-readable
+  , out          :: Maybe String
   } deriving (Show, Generic, HasArguments)
 
 
@@ -45,6 +47,10 @@ run options = do
 
   lints <- recursiveCheckDir repo entry
 
+  case out options of
+    Just path -> writeAdjustedRepository path lints
+    Nothing   -> pure ()
+
   if json options
     then printLB
     $ if pretty options then encodePretty lints else encode lints