From d0dc669c495f5f9e3dae20481e0aae183f606519 Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Tue, 2 Nov 2021 22:00:34 +0100
Subject: monad plumbing to let the linter modify things
I'm not sure if this is the right approach tbh — it lets the LintWriter monad
modify its own context, but maybe we might run into cases where lints and
modifications depend on each other across longer "distances" than just the
context of the linter (i.e. just across a property?)
---
lib/LintWriter.hs | 36 +++++++++++++++++++++++-------------
lib/Properties.hs | 2 +-
2 files changed, 24 insertions(+), 14 deletions(-)
diff --git a/lib/LintWriter.hs b/lib/LintWriter.hs
index d71d037..8d91948 100644
--- a/lib/LintWriter.hs
+++ b/lib/LintWriter.hs
@@ -6,34 +6,37 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TupleSections #-}
-- | a monad that collects warnings, outputs, etc,
-{-# LANGUAGE TupleSections #-}
module LintWriter where
-import Control.Monad.Trans.Maybe ()
-import Control.Monad.Writer (MonadWriter (tell), WriterT,
- runWriterT)
import Data.Aeson (ToJSON (toJSON))
import Data.Text (Text)
+import Control.Monad.State (StateT, modify)
import Control.Monad.Trans.Reader (Reader, asks, runReader)
+import Control.Monad.Trans.State (runStateT)
import Control.Monad.Writer.Lazy (lift)
+import Data.Bifunctor (Bifunctor (second))
import Data.Map (Map, fromListWith)
import Data.Maybe (mapMaybe)
import qualified Data.Text as T
-import Tiled2 (HasName (getName))
-import Types
import Util (PrettyPrint (..))
+import Tiled2 (HasName)
+import Types
-- | for now, all context we have is how "deep" in the directory tree
-- we currently are
type Context = Int
+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 = WriterT [Lint] (Reader (Context, ctxt)) res
+type LintWriter' ctxt res = StateT (LinterState ctxt) (Reader (Context, ctxt)) res
-- wrapped to allow for manual writing of Aeson instances
type LintResult' ctxt = (ctxt, [Lint]) -- Either Lint (a, [Lint])
@@ -42,7 +45,7 @@ newtype LintResult ctxt = LintResult (LintResult' ctxt)
invertLintResult :: HasName ctxt => LintResult ctxt -> Map Hint [ctxt]
invertLintResult (LintResult (ctxt, lints)) =
- fromListWith (<>) $ fmap (, [ctxt]) $ lintsToHints lints
+ fromListWith (<>) $ (, [ctxt]) <$> lintsToHints lints
-- better, less confusing serialisation of an Either Hint (a, [Hint]).
-- Note that Left hint is also serialised as a list to make the resulting
@@ -83,19 +86,26 @@ resultToLints (LintResult res) = snd res
-- | run a linter
runLintWriter :: ctxt -> Context -> LintWriter ctxt -> LintResult ctxt
-runLintWriter c c' linter = LintResult (c, lints)
- where lints = snd $ flip runReader (c',c) $ runWriterT linter
+runLintWriter c c' linter = LintResult (c, fst $ fromLinterState lints)
+ where lints = snd $ runReader ranstate (c',c)
+ ranstate = runStateT linter (LinterState ([], c))
+
+tell' :: Lint -> LintWriter ctxt
+tell' l = modify $ \(LinterState (lints, ctxt)) -> LinterState (l:lints, ctxt)
+
-- | write a hint into the LintWriter monad
lint :: Level -> Text -> LintWriter a
-lint level = tell . (: []) . hint level
+lint level text = tell' $ hint level text
dependsOn :: Dep -> LintWriter a
-dependsOn dep = tell . (: []) $ Depends dep
+dependsOn dep = tell' $ Depends dep
offersEntrypoint :: Text -> LintWriter a
-offersEntrypoint = tell . (: []) . Offers
+offersEntrypoint text = tell' $ Offers text
+adjust :: (a -> a) -> LintWriter a
+adjust f = modify $ LinterState . second f . fromLinterState
info = lint Info
diff --git a/lib/Properties.hs b/lib/Properties.hs
index 65782c8..403df8e 100644
--- a/lib/Properties.hs
+++ b/lib/Properties.hs
@@ -88,7 +88,7 @@ checkTileset = do
mapM_ checkTilesetProperty (fromMaybe [] $ tilesetProperties tileset)
checkTilesetProperty :: Property -> LintWriter Tileset
-checkTilesetProperty p@(Property name value) = case name of
+checkTilesetProperty (Property name _value) = case name of
"copyright" -> pure () -- only allow some licenses?
_ -> pure () -- are there any other properties?
--
cgit v1.2.3