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