diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/CheckMap.hs | 59 | ||||
| -rw-r--r-- | lib/LintWriter.hs | 80 | ||||
| -rw-r--r-- | 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 |