diff options
| -rw-r--r-- | lib/CheckDir.hs | 24 | ||||
| -rw-r--r-- | lib/CheckMap.hs | 37 | ||||
| -rw-r--r-- | lib/LintWriter.hs | 11 | ||||
| -rw-r--r-- | lib/Properties.hs | 31 | ||||
| -rw-r--r-- | lib/Tiled2.hs | 11 | ||||
| -rw-r--r-- | src/Main.hs | 24 |
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 |