diff options
| -rw-r--r-- | lib/CheckMap.hs | 16 | ||||
| -rw-r--r-- | lib/LintWriter.hs | 47 | ||||
| -rw-r--r-- | lib/Properties.hs | 14 | ||||
| -rw-r--r-- | lib/Tiled2.hs | 4 |
4 files changed, 56 insertions, 25 deletions
diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs index 0ff3fae..36cbf9d 100644 --- a/lib/CheckMap.hs +++ b/lib/CheckMap.hs @@ -16,18 +16,20 @@ import qualified Data.Text as T import qualified Data.Vector as V import GHC.Generics (Generic) -import LintWriter (Hint (..), Level (..), - LintResult (..), LintWriter, hint) +import LintWriter (Level (..), Lint (..), + LintResult (..), LintWriter, hint, + lintLevel) import Properties (checkProperty) import Tiled2 (Layer (layerName, layerProperties), Tiledmap (tiledmapLayers), loadTiledmap) -import Util (prettyprint, PrettyPrint (prettyprint)) +import Util (PrettyPrint (prettyprint), + prettyprint) -- | What this linter produces: lints for a single map data MapResult a = MapResult { mapresultLayer :: Maybe (Map Text (LintResult a)) - , mapresultGeneral :: [Hint] + , mapresultGeneral :: [Lint] } deriving (Generic, ToJSON) @@ -83,12 +85,12 @@ showContext ctxt = " (in layer " <> ctxt <> ")\n" -- 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 $ "ERROR: " <> hintMsg hint <> showContext ctxt - Right (_, []) -> Nothing + Left hint -> Just $ "Fatal: " <> prettyprint hint + Right (_, []) -> Nothing Right (_, hints) -> Just $ T.concat (mapMaybe showHint hints) where -- TODO: make the "log level" configurable - showHint hint = case hintLevel hint of + showHint hint = case lintLevel hint of Info -> Nothing _ -> Just $ prettyprint hint <> ctxtHint ctxtHint = showContext ctxt diff --git a/lib/LintWriter.hs b/lib/LintWriter.hs index 09a2297..bfe543e 100644 --- a/lib/LintWriter.hs +++ b/lib/LintWriter.hs @@ -9,39 +9,63 @@ module LintWriter where import Control.Monad.Trans.Maybe () import Control.Monad.Writer (MonadTrans (lift), MonadWriter (tell), WriterT) -import Data.Aeson (ToJSON (toJSON)) +import Data.Aeson (ToJSON (toJSON), (.=)) import Data.Text (Text) import GHC.Generics (Generic) -import Util (PrettyPrint(..), showText) +import qualified Data.Aeson as A +import Util (PrettyPrint (..), showText) -- | Levels of errors and warnings, collectively called -- "Hints" until I can think of some better name data Level = Warning | Suggestion | Info | Forbidden | Error | Fatal deriving (Show, Generic, ToJSON) --- | a hint comes with an explanation (and a level) +-- | a hint comes with an explanation (and a level), or is a dependency +-- (in which case it'll be otherwise treated as an info hint) +data Lint = Depends Dep | Lint Hint + data Hint = Hint { hintLevel :: Level , hintMsg :: Text } deriving (Generic, ToJSON) -instance PrettyPrint Hint where - prettyprint Hint { hintMsg, hintLevel } = +lintLevel :: Lint -> Level +lintLevel (Lint h) = hintLevel h +lintLevel (Depends dep) = Info + +instance PrettyPrint Lint where + prettyprint (Lint Hint { hintMsg, hintLevel } ) = showText hintLevel <> ": " <> hintMsg + prettyprint (Depends dep) = + "Info: found dependency: " <> prettyprint dep + +instance ToJSON Lint where + toJSON (Lint l) = toJSON l + toJSON (Depends dep) = A.object + [ "hintMsg" .= prettyprint dep + , "hintLevel" .= A.String "Dependency Info" ] + -- shorter constructor -hint :: Level -> Text -> Hint -hint level msg = Hint { hintLevel = level, hintMsg = msg } +hint :: Level -> Text -> Lint +hint level msg = Lint Hint { hintLevel = level, hintMsg = msg } + +-- | TODO: add a reasonable representation of possible urls +newtype Dep = Dep Text + deriving (Generic, ToJSON) + +instance PrettyPrint Dep where + prettyprint (Dep txt) = txt -- | 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 [Hint] (Either Hint) a +type LintWriter a = WriterT [Lint] (Either Lint) a -- this is wrapped in a newtype because Aeson is silly and wants -- to serialise Either as { "Right" : … } or { "Left" : … } ... -type LintResult' a = Either Hint (a, [Hint]) +type LintResult' a = Either Lint (a, [Lint]) newtype LintResult a = LintResult (LintResult' a) -- better, less confusing serialisation of an Either Hint (a, [Hint]). @@ -58,6 +82,9 @@ instance ToJSON a => ToJSON (LintResult a) where lint :: Level -> Text -> LintWriter () lint level = tell . (: []) . hint level +require :: Text -> LintWriter () +require dep = tell . (: []) $ Depends (Dep dep) + warn = lint Warning info = lint Info forbid = lint Forbidden @@ -74,7 +101,7 @@ unwrap hint maybe = case maybe of Nothing -> Left hint -- | unwrap and produce a warning if the value was Nothing -unwrapWarn :: Text -> Maybe a -> Either Hint a +unwrapWarn :: Text -> Maybe a -> Either Lint a unwrapWarn msg = unwrap $ hint Warning msg -- | same as unwrapWarn, but for booleans diff --git a/lib/Properties.hs b/lib/Properties.hs index f48d62e..7d6fc4a 100644 --- a/lib/Properties.hs +++ b/lib/Properties.hs @@ -5,13 +5,14 @@ module Properties (checkProperty) where -import Control.Monad (unless) -import Data.Text (Text) -import Tiled2 (Layer (layerProperties), Property, propertyName, propertyValue) -import Util (prettyprint) +import Control.Monad (unless) +import Data.Text (Text) +import Tiled2 (Layer (layerProperties), Property, propertyName, + propertyValue) +import Util (prettyprint) -import LintWriter (LintWriter, complain, forbid, info, - suggest, warn, Dep(..), require) +import LintWriter (LintWriter, complain, forbid, info, require, + suggest, warn) -- | the point of this module -- @@ -45,6 +46,7 @@ checkProperty layer prop = case propName of requireProperty "playAudio" "openWebsite" -> do suggestPropertyValue "openWebsiteTrigger" "onaction" + require $ propertyValue prop "openWebsiteTrigger" -> requireProperty "openWebsite" "openWebsitePolicy" -> diff --git a/lib/Tiled2.hs b/lib/Tiled2.hs index 20886bd..c751cdc 100644 --- a/lib/Tiled2.hs +++ b/lib/Tiled2.hs @@ -8,7 +8,7 @@ -- cover some of the types and records that are available in the format. For -- those you should read the TMX documentation at -- http://doc.mapeditor.org/en/latest/reference/tmx-map-format/ -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NamedFieldPuns #-} module Tiled2 where import Control.Applicative ((<|>)) @@ -68,7 +68,7 @@ parseDefault o s d = fromMaybe d <$> o .:? s -- | workadventure custom property -data Property = Property { propertyName :: Text +data Property = Property { propertyName :: Text --, propertyType :: Text (unnecessary since always string) , propertyValue :: Text } deriving (Eq, Generic, Show) |