From 52b73711fc21e121267318677840a54fbe174b10 Mon Sep 17 00:00:00 2001 From: stuebinm Date: Sun, 14 Nov 2021 03:09:50 +0100 Subject: Functional jitsiRoomAdminTag adjustment also yet another typeclass™, because why not? --- lib/CheckDir.hs | 19 ++++++++----------- lib/CheckMap.hs | 15 ++++++++------- lib/LintConfig.hs | 4 ++-- lib/LintWriter.hs | 20 +++++++++++++------- lib/Properties.hs | 17 +++++++++++------ lib/Tiled2.hs | 9 +++++++++ lib/Types.hs | 5 +++-- src/Main.hs | 5 +---- 8 files changed, 55 insertions(+), 39 deletions(-) diff --git a/lib/CheckDir.hs b/lib/CheckDir.hs index 5540aae..4d81bc2 100644 --- a/lib/CheckDir.hs +++ b/lib/CheckDir.hs @@ -23,6 +23,7 @@ import Data.Maybe (mapMaybe) import Data.Text (Text) import qualified Data.Text as T import GHC.Generics (Generic) +import LintConfig (LintConfig') import Paths (normalise, normaliseWithFrag) import System.Directory.Extra (doesFileExist) import System.FilePath (splitPath, ()) @@ -119,9 +120,9 @@ instance Monoid DirResult where -- gets a prefix (i.e. the bare path to the repository) and -- a root (i.e. the name of the file containing the entrypoint -- map within that file) -recursiveCheckDir :: FilePath -> FilePath -> IO DirResult -recursiveCheckDir prefix root = do - linted <- recursiveCheckDir' prefix [root] mempty mempty +recursiveCheckDir :: LintConfig' -> FilePath -> FilePath -> IO DirResult +recursiveCheckDir config prefix root = do + linted <- recursiveCheckDir' config prefix [root] mempty mempty mAssets <- missingAssets prefix linted pure $ linted <> mempty { dirresultDeps = missingDeps linted , dirresultMissingAssets = mAssets @@ -173,14 +174,14 @@ missingAssets prefix res = -- Strictly speaking it probably doesn't need to have `done` and -- `acc` since they are essentially the same thing, but doing it -- like this seemed convenient at the time -recursiveCheckDir' :: FilePath -> [FilePath] -> Set FilePath -> DirResult -> IO DirResult -recursiveCheckDir' prefix paths done acc = do +recursiveCheckDir' :: LintConfig' -> FilePath -> [FilePath] -> Set FilePath -> DirResult -> IO DirResult +recursiveCheckDir' config prefix paths done acc = do -- lint all maps in paths. The double fmap skips maps which cause IO errors -- (in which case loadAndLintMap returns Nothing); appropriate warnings will -- show up later during dependency checks lints <- - let lintPath p = fmap (fmap (p,)) (loadAndLintMap (prefix p) depth) + let lintPath p = fmap (fmap (p,)) (loadAndLintMap config (prefix p) depth) where depth = length (splitPath p) - 1 in mapMaybeM lintPath paths @@ -208,8 +209,4 @@ recursiveCheckDir' prefix paths done acc = do -- Tail recursion! case unknowns of [] -> pure acc' - _ -> recursiveCheckDir' prefix unknowns knowns acc' - - - - + _ -> recursiveCheckDir' config prefix unknowns knowns acc' diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs index 1b42854..962da22 100644 --- a/lib/CheckMap.hs +++ b/lib/CheckMap.hs @@ -21,6 +21,7 @@ import qualified Data.Vector as V import GHC.Generics (Generic) +import LintConfig (LintConfig') import LintWriter (filterLintLevel, invertLintResult, lintToDep, resultToAdjusted, resultToDeps, resultToLints, resultToOffers, runLintWriter) @@ -71,19 +72,19 @@ instance ToJSON CollectedLints where -- | this module's raison d'être -- 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 <&> (\case +loadAndLintMap :: LintConfig' -> FilePath -> Int -> IO (Maybe MapResult) +loadAndLintMap config 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 config waMap depth)) -- | lint a loaded map -runLinter :: Tiledmap -> Int -> MapResult -runLinter tiledmap depth = MapResult +runLinter :: LintConfig' -> Tiledmap -> Int -> MapResult +runLinter config tiledmap depth = MapResult { mapresultLayer = invertThing layer , mapresultTileset = invertThing tileset , mapresultGeneral = resultToLints generalResult @@ -96,10 +97,10 @@ runLinter tiledmap depth = MapResult where layer = checkThing tiledmapLayers checkLayer tileset = checkThing tiledmapTilesets checkTileset - generalResult = runLintWriter tiledmap depth checkMap + generalResult = runLintWriter config tiledmap depth checkMap checkThing getter checker = V.toList . V.map runCheck $ getter tiledmap - where runCheck thing = runLintWriter thing depth checker + where runCheck thing = runLintWriter config thing depth checker -- | "inverts" a LintResult, i.e. groups it by lints instead of -- layers / maps diff --git a/lib/LintConfig.hs b/lib/LintConfig.hs index 0f65752..1493fe2 100644 --- a/lib/LintConfig.hs +++ b/lib/LintConfig.hs @@ -12,8 +12,8 @@ module LintConfig where import Control.Monad.Identity (Identity) -import Data.Aeson (FromJSON (parseJSON), defaultOptions, - eitherDecode, Options(..)) +import Data.Aeson (FromJSON (parseJSON), Options (..), + defaultOptions, eitherDecode) import Data.Aeson.Types (genericParseJSON) import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Lazy as LB diff --git a/lib/LintWriter.hs b/lib/LintWriter.hs index 54a5954..c8ab6d5 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 LintConfig (LintConfig') import Tiled2 (HasName) import Types @@ -31,12 +32,14 @@ import Types -- we currently are type Context = Int -newtype LinterState ctxt = LinterState { fromLinterState :: ([Lint], ctxt)} +newtype LinterState ctxt = LinterState + { fromLinterState :: ([Lint], ctxt)} -- | a monad to collect hints, with some context (usually the containing layer/etc.) type LintWriter ctxt = LintWriter' ctxt () -type LintWriter' ctxt res = StateT (LinterState ctxt) (Reader (Context, ctxt)) res +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]) @@ -88,9 +91,9 @@ 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 (snd $ fromLinterState lints,fst $ fromLinterState lints) - where lints = snd $ runReader ranstate (c',c) +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 @@ -122,7 +125,10 @@ complain = lint Error -- | get the context as it was originally, without any modifications askContext :: LintWriter' a a -askContext = lift $ asks snd +askContext = lift $ asks (\(_,a,_) -> a) askFileDepth :: LintWriter' a Int -askFileDepth = lift $ asks fst +askFileDepth = lift $ asks (\(a,_,_) -> a) + +lintConfig :: (LintConfig' -> a) -> LintWriter' ctxt a +lintConfig get = lift $ asks (\(_,_,config) -> get config) diff --git a/lib/Properties.hs b/lib/Properties.hs index 3ad8af2..e6a3384 100644 --- a/lib/Properties.hs +++ b/lib/Properties.hs @@ -9,14 +9,16 @@ module Properties (checkMap, checkTileset, checkLayer) where import Control.Monad (unless, when) import Data.Text (Text, isPrefixOf) import Tiled2 (HasProperties (adjustProperties, getProperties), - Layer (..), Property (..), PropertyValue (..), + IsProperty (asProperty), Layer (..), + Property (..), PropertyValue (..), Tiledmap (..), Tileset (..)) import Util (layerIsEmpty, prettyprint) import Data.Maybe (fromMaybe) +import LintConfig (LintConfig (configAssemblyTag)) import LintWriter (LintWriter, adjust, askContext, askFileDepth, - complain, dependsOn, forbid, offersEntrypoint, - suggest, warn) + complain, dependsOn, forbid, lintConfig, + offersEntrypoint, suggest, warn) import Paths (RelPath (..), parsePath) import Types (Dep (Link, Local, LocalMap, MapLink)) @@ -108,7 +110,8 @@ checkLayer = do checkLayerProperty :: Property -> LintWriter Layer checkLayerProperty p@(Property name _value) = case name of "jitsiRoom" -> do - setProperty "jitsiRoomAdminTag" "Hello, World" + lintConfig configAssemblyTag + >>= setProperty "jitsiRoomAdminTag" uselessEmptyLayer unwrapString p $ \_val -> do suggestProperty $ Property "jitsiTrigger" (StrProp "onaction") @@ -228,9 +231,11 @@ suggestProperty (Property name value) = $ 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 :: (IsProperty prop, HasProperties ctxt) + => Text -> prop -> LintWriter ctxt setProperty name value = adjust $ \ctxt -> - adjustProperties (\props -> Just $ Property name value : filter sameName props) ctxt + flip adjustProperties ctxt + $ \ps -> Just $ Property name (asProperty value) : filter sameName ps where sameName (Property name' _) = name /= name' -- | does this layer have the given property? diff --git a/lib/Tiled2.hs b/lib/Tiled2.hs index efa8a07..873e22d 100644 --- a/lib/Tiled2.hs +++ b/lib/Tiled2.hs @@ -339,6 +339,15 @@ instance HasName Layer where instance HasName Tileset where getName = tilesetName +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'. diff --git a/lib/Types.hs b/lib/Types.hs index 00f0ee7..0d35432 100644 --- a/lib/Types.hs +++ b/lib/Types.hs @@ -10,7 +10,8 @@ module Types where import Control.Monad.Trans.Maybe () -import Data.Aeson (ToJSON (toJSON), ToJSONKey, (.=)) +import Data.Aeson (FromJSON, ToJSON (toJSON), + ToJSONKey, (.=)) import Data.Text (Text) import GHC.Generics (Generic) @@ -27,7 +28,7 @@ import WithCli.Pure (Argument (argumentType, parseArgumen -- | Levels of errors and warnings, collectively called -- "Hints" until I can think of some better name data Level = Info | Suggestion | Warning | Forbidden | Error | Fatal - deriving (Show, Generic, Ord, Eq, ToJSON) + deriving (Show, Generic, Ord, Eq, ToJSON, FromJSON) instance Argument Level where argumentType Proxy = "Lint Level" diff --git a/src/Main.hs b/src/Main.hs index 5dcf13c..a7710eb 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -49,7 +49,6 @@ run options = do let repo = fromMaybe "." (repository options) let entry = fromMaybe "main.json" (entrypoint options) let level = fromMaybe Suggestion (lintlevel options) - print (config options) lintconfig <- case configFile options of Nothing -> error "Need a config file!" @@ -60,9 +59,7 @@ run options = do Just p -> pure (patch file p) Nothing -> pure file - print lintconfig - - lints <- recursiveCheckDir repo entry + lints <- recursiveCheckDir lintconfig repo entry if json options then printLB -- cgit v1.2.3