summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--lib/CheckDir.hs19
-rw-r--r--lib/CheckMap.hs15
-rw-r--r--lib/LintConfig.hs4
-rw-r--r--lib/LintWriter.hs20
-rw-r--r--lib/Properties.hs17
-rw-r--r--lib/Tiled2.hs9
-rw-r--r--lib/Types.hs5
-rw-r--r--src/Main.hs5
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-22 21:01:45 +0000