From 9a8d793f8f08fd5674bc6a917278ee7251bac56f Mon Sep 17 00:00:00 2001
From: stuebinm <stuebinm@disroot.org>
Date: Mon, 20 Sep 2021 21:41:50 +0200
Subject: [PATCH] rebuilding the core LintWriter monad
it is no longer an Either since that wasn't used anyways, but is now
also a Reader.
---
lib/CheckMap.hs | 59 +++++++++++++++++-----------------
lib/LintWriter.hs | 80 +++++++++++++++++------------------------------
lib/Properties.hs | 22 ++++++-------
3 files changed, 68 insertions(+), 93 deletions(-)
diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs
index 0de9094..b32bad6 100644
--- a/lib/CheckMap.hs
+++ b/lib/CheckMap.hs
@@ -5,33 +5,31 @@
{-# LANGUAGE OverloadedStrings #-}
-- | Module that contains the high-level checking functions
+{-# OPTIONS_GHC -Wno-deferred-out-of-scope-variables #-}
module CheckMap (loadAndLintMap) where
-import Control.Monad.Trans.Writer (WriterT (runWriterT))
-import Data.Aeson (ToJSON)
-import Data.Map (Map, fromList, toList)
-import Data.Maybe (mapMaybe)
-import Data.Text (Text)
-import qualified Data.Text as T
-import qualified Data.Vector as V
-import GHC.Generics (Generic)
-
-import LintWriter (LintResult (..), LintWriter,
- lintResultToDeps, lintToDep,
- runLintWriter)
-import Properties (checkLayerProperty, checkMap)
-import Tiled2 (Layer (layerName, layerProperties),
- Tiledmap (tiledmapLayers),
- loadTiledmap)
-import Types (Dep, Level (..), Lint (..), hint,
- lintLevel)
-import Util (PrettyPrint (prettyprint),
- prettyprint)
+import Data.Aeson (ToJSON)
+import Data.Map (Map, fromList, toList)
+import Data.Maybe (mapMaybe)
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Vector as V
+import GHC.Generics (Generic)
+
+import LintWriter (LayerContext (..), LintResult (..), LintWriter,
+ lintToDep, resultToDeps, resultToLints,
+ runLintWriter)
+import Properties (checkLayerProperty, checkMap)
+import Tiled2 (Layer (layerName, layerProperties),
+ Tiledmap (tiledmapLayers), loadTiledmap)
+import Types (Dep, Level (..), Lint (..), hint, lintLevel)
+import Util (PrettyPrint (prettyprint), prettyprint)
+
-- | What this linter produces: lints for a single map
data MapResult a = MapResult
- { mapresultLayer :: Maybe (Map Text (LintResult a))
+ { mapresultLayer :: Maybe (Map Text (LintResult LayerContext))
, mapresultGeneral :: [Lint]
, mapresultDepends :: [Dep]
} deriving (Generic, ToJSON)
@@ -57,21 +55,22 @@ runLinter :: Tiledmap -> MapResult ()
runLinter tiledmap = MapResult
{ mapresultLayer = Just layerMap
, mapresultGeneral = generalLints -- no general lints for now
- , mapresultDepends = concatMap (lintResultToDeps . snd) layer
+ , mapresultDepends = concatMap (resultToDeps . snd) layer
<> mapMaybe lintToDep generalLints
}
where
- layerMap :: Map Text (LintResult ())
+ layerMap :: Map Text (LintResult LayerContext)
layerMap = fromList layer
layer = V.toList . V.map runCheck $ tiledmapLayers tiledmap
- where runCheck l = (layerName l, LintResult $ runWriterT (checkLayer l))
+ where runCheck l = (layerName l, runLintWriter (LayerContext ()) (checkLayer l))
-- lints collected from properties
- generalLints = runLintWriter (checkMap tiledmap)
+ generalLints =
+ resultToLints $ runLintWriter () (checkMap tiledmap)
-- | collect lints on a single map layer
-checkLayer :: Layer -> LintWriter ()
+checkLayer :: Layer -> LintWriter LayerContext
checkLayer layer =
mapM_ (checkLayerProperty layer) (layerProperties layer)
@@ -95,11 +94,9 @@ showContext ctxt = " (in layer " <> ctxt <> ")\n"
-- | pretty-printer for a LintResult. Isn't an instance of PrettyPrint since
-- it needs to know about the result's context (yes, there could be
-- a wrapper type for that – but I wasn't really in the mood)
-showResult :: Text -> LintResult a -> Maybe Text
-showResult ctxt (LintResult res) = case res of
- Left hint -> Just $ "Fatal: " <> prettyprint hint
- Right (_, []) -> Nothing
- Right (_, hints) -> Just $ T.concat (mapMaybe showHint hints)
+showResult :: Text -> LintResult c -> Maybe Text
+showResult ctxt (LintResult (_, lints)) =
+ Just $ T.concat (mapMaybe showHint lints)
where
-- TODO: make the "log level" configurable
showHint hint = case lintLevel hint of
diff --git a/lib/LintWriter.hs b/lib/LintWriter.hs
index dd5ae7d..a6fa17e 100644
--- a/lib/LintWriter.hs
+++ b/lib/LintWriter.hs
@@ -3,88 +3,66 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
-- | a monad that collects warnings, outputs, etc,
module LintWriter where
-import Control.Monad.Trans.Maybe ()
-import Control.Monad.Writer (MonadTrans (lift),
- MonadWriter (tell), WriterT,
- runWriterT)
-import Data.Aeson (ToJSON (toJSON))
-import Data.Text (Text)
+import Control.Monad.Trans.Maybe ()
+import Control.Monad.Writer (MonadWriter (tell), WriterT,
+ runWriterT)
+import Data.Aeson (ToJSON (toJSON))
+import Data.Text (Text)
-import Data.Maybe (mapMaybe)
+import Control.Monad.Trans.Reader (Reader, runReader)
+import Data.Maybe (mapMaybe)
import Types
+import GHC.Generics (Generic)
--- | a monad to collect hints. If it yields Left, then the
--- map is flawed in some fundamental way which prevented us
--- from getting any hints at all except whatever broke it
-type LintWriter a = WriterT [Lint] (Either Lint) a
+-- | a monad to collect hints, with some context
+type LintWriter ctxt = WriterT [Lint] (Reader ctxt) ()
--- this is wrapped in a newtype because Aeson is silly and wants
--- to serialise Either as { "Right" : … } or { "Left" : … } ...
-type LintResult' a = Either Lint (a, [Lint])
-newtype LintResult a = LintResult (LintResult' a)
+-- wrapped to allow for manual writing of Aeson instances
+type LintResult' ctxt = (ctxt, [Lint]) -- Either Lint (a, [Lint])
+newtype LintResult ctxt = LintResult (LintResult' ctxt)
+
+data LayerContext = LayerContext ()
+ deriving (Generic, ToJSON)
-- better, less confusing serialisation of an Either Hint (a, [Hint]).
-- Note that Left hint is also serialised as a list to make the resulting
-- json schema more regular.
instance ToJSON a => ToJSON (LintResult a) where
- toJSON (LintResult r) = toJson' r
- where toJson' (Left hint) = toJSON [hint]
- toJson' (Right (_, hints)) = toJSON hints
+ toJSON (LintResult res) = toJSON $ snd res
lintToDep :: Lint -> Maybe Dep
lintToDep = \case
Depends dep -> Just dep
_ -> Nothing
-lintResultToDeps :: LintResult a -> [Dep]
-lintResultToDeps (LintResult a) = case a of
- Left (Depends dep) -> [dep]
- Left _ -> []
- Right (_, lints) -> mapMaybe lintToDep lints
+resultToDeps :: LintResult a -> [Dep]
+resultToDeps (LintResult a) = mapMaybe lintToDep $ snd a
-- | convert a lint result into a flat list of lints
-- (throwing away information on if a single error was fatal)
resultToLints :: LintResult a -> [Lint]
-resultToLints (LintResult res) = case res of
- Left l -> [l]
- Right (_, lints) -> lints
+resultToLints (LintResult res) = snd res
--- | Confusingly, this returns lints, not a …
-runLintWriter :: LintWriter a -> [Lint]
-runLintWriter = resultToLints . LintResult . runWriterT
+-- | run a linter
+runLintWriter :: ctxt -> LintWriter ctxt -> LintResult ctxt
+runLintWriter c linter = LintResult (c, lints)
+ where lints = snd $ flip runReader c $ runWriterT linter
-- | write a hint into the LintWriter monad
-lint :: Level -> Text -> LintWriter ()
+lint :: Level -> Text -> LintWriter a
lint level = tell . (: []) . hint level
-dependsOn :: Dep -> LintWriter ()
+dependsOn :: Dep -> LintWriter a
dependsOn dep = tell . (: []) $ Depends dep
-warn = lint Warning
info = lint Info
-forbid = lint Forbidden
suggest = lint Suggestion
+warn = lint Warning
+forbid = lint Forbidden
complain = lint Error
-
-
-
--- TODO: all these functions should probably also just operate on LintWriter
-
--- | converts a Maybe to an Either, with a default value for Left
-unwrap :: b -> Maybe a -> Either b a
-unwrap hint maybe = case maybe of
- Just a -> Right a
- Nothing -> Left hint
-
--- | unwrap and produce a warning if the value was Nothing
-unwrapWarn :: Text -> Maybe a -> Either Lint a
-unwrapWarn msg = unwrap $ hint Warning msg
-
--- | same as unwrapWarn, but for booleans
-assertWarn :: Text -> Bool -> LintWriter ()
-assertWarn msg cond = lift $ if cond then Right () else Left $ hint Warning msg
diff --git a/lib/Properties.hs b/lib/Properties.hs
index 320f132..68cf88a 100644
--- a/lib/Properties.hs
+++ b/lib/Properties.hs
@@ -13,7 +13,7 @@ import Tiled2 (Layer (..), Property (..), PropertyValue (..),
import Util (layerIsEmpty, prettyprint)
import LintWriter (LintWriter, complain, dependsOn, forbid, info,
- suggest, warn)
+ suggest, warn, LayerContext)
import Paths
import Types (Dep (Link, Local, LocalMap, MapLink))
@@ -83,7 +83,7 @@ checkTileset tileset = do
--
-- It gets a reference to its own layer since sometimes the presence
-- of one property implies the presence or absense of another.
-checkLayerProperty :: Layer -> Property -> LintWriter ()
+checkLayerProperty :: Layer -> Property -> LintWriter LayerContext
checkLayerProperty layer p@(Property name value) = case name of
"jitsiRoom" -> do
uselessEmptyLayer
@@ -182,18 +182,18 @@ containsProperty props name = any
(\(Property name' _) -> name' == name) props
-- | this property is forbidden and should not be used
-forbidProperty :: Text -> LintWriter ()
+forbidProperty :: Text -> LintWriter a
forbidProperty name = forbid $ "property " <> prettyprint name <> " should not be used"
-- | asserts that this property is a string, and unwraps it
-unwrapString :: Property -> (Text -> LintWriter ()) -> LintWriter ()
+unwrapString :: Property -> (Text -> LintWriter a) -> LintWriter a
unwrapString (Property name value) f = case value of
StrProp str -> f str
_ -> complain $ "type mismatch in property " <> name <> "; should be of type string"
-- | same as unwrapString, but also forbids http:// as prefix
-unwrapLink :: Property -> (Text -> LintWriter ()) -> LintWriter ()
+unwrapLink :: Property -> (Text -> LintWriter a) -> LintWriter a
unwrapLink (Property name value) f = case value of
StrProp str -> if "http://" `isPrefixOf` str
then complain "cannot access content via http; either use https or include it locally instead."
@@ -201,31 +201,31 @@ unwrapLink (Property name value) f = case value of
_ -> complain $ "type mismatch in property " <> name <> "; should be of typ string"
-- | asserts that this property is a boolean, and unwraps it
-unwrapBool :: Property -> (Bool -> LintWriter ()) -> LintWriter ()
+unwrapBool :: Property -> (Bool -> LintWriter a) -> LintWriter a
unwrapBool (Property name value) f = case value of
BoolProp b -> f b
_ -> complain $ "type mismatch in property " <> name <> "; should be of type bool"
-unwrapPath :: Text -> (RelPath -> LintWriter ()) -> LintWriter ()
+unwrapPath :: Text -> (RelPath -> LintWriter a) -> LintWriter a
unwrapPath str f = case parsePath str of
Just path -> f path
Nothing -> complain $ "path \"" <> str <> "\" is invalid"
-- | just asserts that this is a string
-isString :: Property -> LintWriter ()
+isString :: Property -> LintWriter a
isString = flip unwrapString (const $ pure ())
-- | just asserts that this is a boolean
-isBool :: Property -> LintWriter ()
+isBool :: Property -> LintWriter a
isBool = flip unwrapBool (const $ pure ())
-- | require some property
-requireProperty :: [Property] -> Text -> LintWriter ()
+requireProperty :: [Property] -> Text -> LintWriter a
requireProperty props name = unless (containsProperty props name)
$ complain $ "property "<>prettyprint name<>" requires property "<>prettyprint name
-- | suggest soem value for another property if that property does not
-- also already exist
-suggestPropertyValue :: [Property] -> Property -> LintWriter ()
+suggestPropertyValue :: [Property] -> Property -> LintWriter a
suggestPropertyValue props (Property name value) = unless (containsProperty props name)
$ suggest $ "set property " <> prettyprint name <> " to " <> prettyprint value
--
GitLab