can collect dependencies!

There's now a Lint type, which may be either a "true lint" (which is a
Hint, which contains some message and level of severity), or a Depends,
which indicates that this map depends on some ressource or other (and is
otherwise treated as a special info Hint in all other cases)

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)