summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--lib/LintWriter.hs36
-rw-r--r--lib/Properties.hs2
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?