diff options
| -rw-r--r-- | lib/CheckMap.hs | 33 | ||||
| -rw-r--r-- | lib/LintWriter.hs | 10 | ||||
| -rw-r--r-- | lib/Properties.hs | 17 | ||||
| -rw-r--r-- | lib/Util.hs | 38 | ||||
| -rw-r--r-- | src/Main.hs | 13 |
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 () |