summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--lib/CheckMap.hs33
-rw-r--r--lib/LintWriter.hs10
-rw-r--r--lib/Properties.hs17
-rw-r--r--lib/Util.hs38
-rw-r--r--src/Main.hs13
5 files changed, 62 insertions, 49 deletions
diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs
index 97e6a8c..0ff3fae 100644
--- a/lib/CheckMap.hs
+++ b/lib/CheckMap.hs
@@ -22,7 +22,7 @@ import Properties (checkProperty)
import Tiled2 (Layer (layerName, layerProperties),
Tiledmap (tiledmapLayers),
loadTiledmap)
-import Util (showText)
+import Util (prettyprint, PrettyPrint (prettyprint))
-- | What this linter produces: lints for a single map
data MapResult a = MapResult
@@ -61,35 +61,34 @@ checkLayer :: Layer -> LintWriter ()
checkLayer layer =
mapM_ (checkProperty layer) (layerProperties layer)
-
--- this instance of show produces a reasonably human-readable
--- list of lints that can be shown e.g. on a console
-instance Show a => Show (MapResult a) where
- show mapResult = concat $ prettyGeneral <> prettyLayer
+-- human-readable lint output, e.g. for consoles
+instance PrettyPrint a => PrettyPrint (MapResult a) where
+ prettyprint mapResult = T.concat $ prettyGeneral <> prettyLayer
where
-- TODO: this can be simplified further
- prettyLayer :: [String]
+ prettyLayer :: [Text]
prettyLayer = mapMaybe
- (\(name, lints) -> T.unpack <$> showResult name lints)
+ (uncurry showResult)
(maybe [] toList . mapresultLayer $ mapResult)
- prettyGeneral :: [String]
- prettyGeneral = show <$> mapresultGeneral mapResult
+ prettyGeneral :: [Text]
+ prettyGeneral = prettyprint <$> mapresultGeneral mapResult
-- TODO: possibly expand this to something more detailed?
showContext :: Text -> Text
showContext ctxt = " (in layer " <> ctxt <> ")\n"
--- | pretty-printer for a LintResult. Isn't an instance of Show since
+-- | 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 :: Show a => Text -> LintResult a -> Maybe Text
-showResult ctxt (LintResult (Left hint)) = Just $ "ERROR: " <> hintMsg hint <> showContext ctxt
-showResult _ (LintResult (Right (_, []))) = Nothing
-showResult ctxt (LintResult (Right (_, hints))) = Just $ T.concat (mapMaybe showHint hints)
+showResult :: Text -> LintResult a -> Maybe Text
+showResult ctxt (LintResult res) = case res of
+ Left hint -> Just $ "ERROR: " <> hintMsg hint <> showContext ctxt
+ Right (_, []) -> Nothing
+ Right (_, hints) -> Just $ T.concat (mapMaybe showHint hints)
where
-- TODO: make the "log level" configurable
- showHint Hint { hintMsg, hintLevel } = case hintLevel of
+ showHint hint = case hintLevel hint of
Info -> Nothing
- _ -> Just $ showText hintLevel <> ": " <> hintMsg <> ctxtHint
+ _ -> Just $ prettyprint hint <> ctxtHint
ctxtHint = showContext ctxt
diff --git a/lib/LintWriter.hs b/lib/LintWriter.hs
index 8e45812..10c727d 100644
--- a/lib/LintWriter.hs
+++ b/lib/LintWriter.hs
@@ -10,9 +10,11 @@ import Control.Monad.Trans.Maybe ()
import Control.Monad.Writer (MonadTrans (lift),
MonadWriter (tell), WriterT)
import Data.Aeson (ToJSON (toJSON))
-import Data.Text (Text, unpack)
+import Data.Text (Text)
import GHC.Generics (Generic)
+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
@@ -24,9 +26,9 @@ data Hint = Hint
, hintMsg :: Text }
deriving (Generic, ToJSON)
-instance Show Hint where
- show Hint { hintMsg, hintLevel } =
- show hintLevel <> ": " <> unpack hintMsg
+instance PrettyPrint Hint where
+ prettyprint Hint { hintMsg, hintLevel } =
+ showText hintLevel <> ": " <> hintMsg
-- shorter constructor
hint :: Level -> Text -> Hint
diff --git a/lib/Properties.hs b/lib/Properties.hs
index 10cbf2c..f4dff3d 100644
--- a/lib/Properties.hs
+++ b/lib/Properties.hs
@@ -11,7 +11,7 @@ import Data.Aeson as Aeson (Value (String))
import Data.Map (Map, (!?))
import Data.Text (Text)
import Tiled2 (Layer (layerProperties))
-import Util (quote, showAeson)
+import Util (prettyprint)
import LintWriter (Hint, LintWriter, Level(..), hint,
assertWarn, complain, forbid, info,
@@ -54,7 +54,7 @@ checkProperty' layer prop ty = case ty of
"jitsiRoom" -> do
propEqual prop "type" "string"
urlValue <- lift $ getAttr prop "value"
- info $ "found jitsi room: " <> showAeson urlValue
+ info $ "found jitsi room: " <> prettyprint urlValue
suggestPropertyValue "jitsiTrigger" "onaction"
"jitsiTrigger" ->
requireProperty "jitsiRoom"
@@ -79,16 +79,17 @@ checkProperty' layer prop ty = case ty of
"startLayer" -> pure ()
-- could also make this a "hard error" (i.e. Left), but then it
-- stops checking other properties as checkLayer short-circuits.
- _ -> warn $ "unknown property type " <> quote ty
+ _ -> warn $ "unknown property type " <> prettyprint ty
where
-- | require some property in this layer
requireProperty name = unless (hasProperty name layer)
- $ complain $ "property "<>quote name<>" requires property "<>quote ty
+ $ complain $ "property "<>prettyprint name<>" requires property "<>prettyprint ty
-- | This property is forbidden and should not be used
- isForbidden = forbid $ "property " <> quote ty <> " should not be used"
+ isForbidden = forbid $ "property " <> prettyprint ty <> " should not be used"
-- TODO: check if the property has the correct value
+ suggestPropertyValue :: Text -> Text -> LintWriter ()
suggestPropertyValue name value = unless (hasProperty name layer)
- $ suggest $ "set property " <> quote name <> " to " <> quote value
+ $ suggest $ "set property " <> prettyprint name <> " to " <> prettyprint value
@@ -108,6 +109,6 @@ getAttr props name = unwrapWarn msg $ props !? name
propEqual :: Properties -> Text -> Aeson.Value -> LintWriter ()
propEqual props name value = do
value' <- lift $ getAttr props name
- assertWarn ("field "<>name<>" has unexpected value "<>showAeson value'
- <>", should be "<>showAeson value)
+ assertWarn ("field "<>name<>" has unexpected value "<>prettyprint value'
+ <>", should be "<>prettyprint value)
$ value' == value
diff --git a/lib/Util.hs b/lib/Util.hs
index be67143..3a0e1d4 100644
--- a/lib/Util.hs
+++ b/lib/Util.hs
@@ -1,27 +1,37 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
-
+-- | has (perhaps inevitably) morphed into a module that mostly
+-- concerns itself with wrangling haskell's string types
module Util where
-import Data.Text (Text)
-import Data.Text as T
-import Data.Aeson as Aeson
+import Data.Aeson as Aeson
+import Data.Text (Text)
+import Data.Text as T
-- | haskell's many string types are FUN …
showText :: Show a => a -> Text
showText = T.pack . show
--- | same as showText, but without the "String"-prefix for strings
--- TODO: serialise back into json for printing? People may get
--- confused by the type annotations if they only know json …
-showAeson :: Aeson.Value -> Text
-showAeson (Aeson.String s) = showText s
-showAeson v = showText v
-
+-- | a class to address all the string conversions necessary
+-- when using Show to much that just uses Text instead
+class PrettyPrint a where
+ prettyprint :: a -> Text
+-- | let's see if this is a good idea or makes type inference bite us
+instance PrettyPrint Text where
+ prettyprint text = "\"" <> text <> "\""
+-- | same as show json, but without the "String" prefix for json strings
+instance PrettyPrint Aeson.Value where
+ prettyprint = \case
+ Aeson.String s -> prettyprint s
+ v -> (T.pack . show) v
+-- | here since Unit is sometimes used as dummy type
+instance PrettyPrint () where
+ prettyprint _ = error "shouldn't pretty-print Unit"
--- | adds quotes (but does not escape, for now!)
-quote :: Text -> Text
-quote text = "\"" <> text <> "\""
+printPretty :: PrettyPrint a => a -> IO ()
+printPretty = putStr . T.unpack . prettyprint
diff --git a/src/Main.hs b/src/Main.hs
index 7884cf9..969fa10 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,21 +1,22 @@
-{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Main where
-import Data.Maybe (fromMaybe)
-import WithCli
-
-import CheckMap (loadAndLintMap)
import Data.Aeson (encode)
import Data.Aeson.Encode.Pretty (encodePretty)
import qualified Data.ByteString.Lazy as LB
import qualified Data.ByteString.Lazy.Encoding as LB
+import Data.Maybe (fromMaybe)
import Data.Text.Lazy as T
import System.IO (utf8)
+import WithCli
+
+import CheckMap (loadAndLintMap)
+import Util (printPretty)
-- | the options this cli tool can take
data Options = Options
@@ -44,7 +45,7 @@ run options = do
if json options
then printLB
$ if pretty options then encodePretty lints else encode lints
- else print lints
+ else printPretty lints
-- | haskell's many string types are FUN …
printLB :: LB.ByteString -> IO ()
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-22 20:07:00 +0000