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

@@ -5,9 +5,9 @@
 {-# 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)
@@ -16,22 +16,20 @@ import qualified Data.Text                  as T
 import qualified Data.Vector  as V
 import           GHC.Generics (Generic)
 
-import           LintWriter                 (LintResult (..), LintWriter,
-                                             lintResultToDeps, lintToDep,
+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)
+                               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

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,
+import           Control.Monad.Writer       (MonadWriter (tell), WriterT,
                                              runWriterT)
 import           Data.Aeson                 (ToJSON (toJSON))
 import           Data.Text                  (Text)
 
+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

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