diff --git a/lib/CheckDir.hs b/lib/CheckDir.hs
index d65181533128692bbad42514f75b84a1027387f0..46540516df0281fb69c8d1823d96b56dde157d5b 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 845513d9512155c5d5e457026941b2d01071fc5c..73909b9fd3a31d217b389ea22c736a40f027eb1b 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 8d91948683261835562649cecbd2bd6eff87baf7..54a59542d56a0780b3fda852d13ac89b082e5975 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 403df8e4765988c969dd87842f286fd0bd031a9a..97c5189d69ac26d888ec8a8d3877e43cace95ab5 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 a82de2c5c54a9b757798115b236f43dc890c09d4..e281d000b04f3382521b6e57069902052dbb5d55 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 f4060b9724c216aa32382c0b13771fdd14d1f92e..0e80eabf6b607292174caca5bfc4772bfeb71178 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