From 68af04a4da6ba4ec61d1469337ce53457526d861 Mon Sep 17 00:00:00 2001
From: stuebinm <stuebinm@disroot.org>
Date: Thu, 23 Sep 2021 04:34:02 +0200
Subject: [PATCH] prettier pretty printing and stuff
also, configurable log level, which only required relaxing the type
system once!
---
lib/CheckDir.hs | 16 ++++++++++------
lib/CheckMap.hs | 48 +++++++++++++++++++++++++----------------------
lib/LintWriter.hs | 16 +++++++++++-----
lib/Types.hs | 28 +++++++++++++++++++++++----
src/Main.hs | 8 +++++---
tiled-hs.cabal | 1 +
6 files changed, 77 insertions(+), 40 deletions(-)
diff --git a/lib/CheckDir.hs b/lib/CheckDir.hs
index f551e6a..ab231b9 100644
--- a/lib/CheckDir.hs
+++ b/lib/CheckDir.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
@@ -21,7 +22,8 @@ import Paths (normalise)
import System.FilePath (splitPath, (</>))
import qualified System.FilePath as FP
import System.FilePath.Posix (takeDirectory)
-import Types (Dep (LocalMap))
+import Types (Dep (LocalMap), Hint (hintLevel),
+ Level (Info))
import Util (PrettyPrint (prettyprint))
-- based on the startling observation that Data.Map has lower complexity
@@ -38,10 +40,13 @@ data DirResult = DirResult
, dirresultDeps :: [Text]
} deriving (Generic, ToJSON)
-
-instance PrettyPrint DirResult where
- prettyprint res = T.concat
- (map (\(p,lints) -> "\nin " <> T.pack p <> ":\n" <> prettyprint lints) $ M.toList $ dirresultMaps res)
+instance PrettyPrint (Level, DirResult) where
+ prettyprint (level, res) = T.concat
+ (map prettyLint $ M.toList $ dirresultMaps res)
+ where
+ prettyLint :: (FilePath, MapResult) -> Text
+ prettyLint (p, lint) =
+ "\nin " <> T.pack p <> ":\n" <> prettyprint (level, lint)
instance Semigroup DirResult where
a <> b = DirResult
@@ -70,7 +75,6 @@ recursiveCheckDir prefix root = recursiveCheckDir' prefix [root] mempty mempty
-- like this seemed convenient at the time
recursiveCheckDir' :: FilePath -> [FilePath] -> Set FilePath -> DirResult -> IO DirResult
recursiveCheckDir' prefix paths done acc = do
- putStrLn $ "linting " <> show paths
-- lint all maps in paths
lints <-
diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs
index 016ec0b..eaeac55 100644
--- a/lib/CheckMap.hs
+++ b/lib/CheckMap.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
@@ -7,24 +8,23 @@
-- | Module that contains the high-level checking functions
module CheckMap (loadAndLintMap, MapResult(..)) where
-import Data.Aeson (ToJSON)
-import Data.Map (Map, fromList, toList)
-import Data.Maybe (mapMaybe)
-import Data.Text (Text)
-import qualified Data.Text as T
-import qualified Data.Vector as V
-import GHC.Generics (Generic)
-import System.FilePath.Posix (splitPath)
+import Data.Aeson (ToJSON)
+import Data.Map (Map, fromList, toList)
+import Data.Maybe (mapMaybe)
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Vector as V
+import GHC.Generics (Generic)
-import LintWriter (LintResult (..), LintWriter, askContext,
- lintToDep, resultToDeps, resultToLints,
- runLintWriter)
-import Properties (checkLayerProperty, checkMap)
-import Tiled2 (Layer (layerName, layerProperties),
- Tiledmap (tiledmapLayers), loadTiledmap)
-import Types (Dep, Level (..), Lint (..), hint)
-import Util (PrettyPrint (prettyprint), prettyprint)
+import LintWriter (LintResult (..), LintWriter, askContext,
+ filterLintLevel, 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)
@@ -79,14 +79,18 @@ checkLayer = do
mapM_ checkLayerProperty (layerProperties layer)
-- human-readable lint output, e.g. for consoles
-instance PrettyPrint MapResult where
- prettyprint mapResult = T.concat $ prettyGeneral <> prettyLayer
+instance PrettyPrint (Level, MapResult) where
+ prettyprint (level, mapResult) = if prettyLints == ""
+ then " all good!\n" else prettyLints
where
+ prettyLints = T.concat $ prettyGeneral <> prettyLayer
-- TODO: this can be simplified further
prettyLayer :: [Text]
- prettyLayer = map
- (prettyprint . snd)
+ prettyLayer = mapMaybe
+ (\(_,l) -> Just $ prettyprint (level, l))
(maybe [] toList . mapresultLayer $ mapResult)
prettyGeneral :: [Text]
- prettyGeneral = flip (<>) "\n" . prettyprint <$> mapresultGeneral mapResult
-
+ prettyGeneral = map
+ ((<> "\n") . prettyprint)
+ . filterLintLevel level
+ $ mapresultGeneral mapResult
diff --git a/lib/LintWriter.hs b/lib/LintWriter.hs
index 5ff56bd..e704a3c 100644
--- a/lib/LintWriter.hs
+++ b/lib/LintWriter.hs
@@ -1,5 +1,7 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
@@ -41,17 +43,21 @@ newtype LintResult ctxt = LintResult (LintResult' ctxt)
instance ToJSON (LintResult a) where
toJSON (LintResult res) = toJSON $ snd res
-instance PrettyPrint ctxt => PrettyPrint (LintResult ctxt) where
- prettyprint (LintResult (ctxt, res)) =
- T.concat (map showHint res)
- where showHint hint = prettyprint hint <> context
- context = " (" <> prettyprint ctxt <> ")\n"
+instance PrettyPrint ctxt => PrettyPrint (Level, LintResult ctxt) where
+ prettyprint (level, LintResult (ctxt, res)) =
+ T.concat $ map ((<> context) . prettyprint) (filterLintLevel level res)
+ where context = " (" <> prettyprint ctxt <> ")\n"
lintToDep :: Lint -> Maybe Dep
lintToDep = \case
Depends dep -> Just dep
_ -> Nothing
+filterLintLevel :: Level -> [Lint] -> [Lint]
+filterLintLevel level = mapMaybe $ \l -> if level <= lintLevel l
+ then Just l
+ else Nothing
+
resultToDeps :: LintResult a -> [Dep]
resultToDeps (LintResult a) = mapMaybe lintToDep $ snd a
diff --git a/lib/Types.hs b/lib/Types.hs
index 5ec91a0..b609012 100644
--- a/lib/Types.hs
+++ b/lib/Types.hs
@@ -17,11 +17,31 @@ import GHC.Generics (Generic)
import qualified Data.Aeson as A
import Paths (RelPath)
import Util (PrettyPrint (..), showText)
+import WithCli (Argument, Proxy (..),
+ atomicArgumentsParser)
+import WithCli.Pure (Argument (argumentType, parseArgument),
+ HasArguments (argumentsParser))
+
-- | 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)
+data Level = Info | Suggestion | Warning | Forbidden | Error | Fatal
+ deriving (Show, Generic, ToJSON, Ord, Eq, A.FromJSON)
+
+instance Argument Level where
+ argumentType Proxy = "Lint Level"
+ parseArgument arg = case arg of
+ "info" -> Just Info
+ "suggestion" -> Just Suggestion
+ "warning" -> Just Warning
+ "forbidden" -> Just Forbidden
+ "error" -> Just Error
+ "fatal" -> Just Fatal
+ _ -> Nothing
+
+
+instance HasArguments Level where
+ argumentsParser = atomicArgumentsParser
-- | 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)
@@ -48,9 +68,9 @@ lintLevel (Depends _) = Info
instance PrettyPrint Lint where
prettyprint (Lint Hint { hintMsg, hintLevel } ) =
- showText hintLevel <> ": " <> hintMsg
+ " " <> showText hintLevel <> ": " <> hintMsg
prettyprint (Depends dep) =
- "Info: found dependency: " <> prettyprint dep
+ " Info: found dependency: " <> prettyprint dep
instance ToJSON Lint where
toJSON (Lint l) = toJSON l
diff --git a/src/Main.hs b/src/Main.hs
index 41f5da6..5072a64 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -17,6 +17,7 @@ import WithCli
import Util (printPretty)
import CheckDir (recursiveCheckDir)
+import Types (Level(..))
-- | the options this cli tool can take
data Options = Options
@@ -26,10 +27,10 @@ data Options = Options
-- ^ entrypoint in that repository
, allowScripts :: Bool
-- ^ pass --allowScripts to allow javascript in map
- , scriptInject :: Maybe String
- -- ^ optional filepath to javascript that should be injected
, json :: Bool
-- ^ emit json if --json was given
+ , lintlevel :: Maybe Level
+ -- ^ maximum lint level to print
, pretty :: Bool
-- ^ pretty-print the json to make it human-readable
} deriving (Show, Generic, HasArguments)
@@ -42,13 +43,14 @@ run :: Options -> IO ()
run options = do
let repo = fromMaybe "." (repository options)
let entry = fromMaybe "main.json" (entrypoint options)
+ let level = fromMaybe Suggestion (lintlevel options)
lints <- recursiveCheckDir repo entry
if json options
then printLB
$ if pretty options then encodePretty lints else encode lints
- else printPretty lints
+ else printPretty (level, lints)
-- | haskell's many string types are FUN …
printLB :: LB.ByteString -> IO ()
diff --git a/tiled-hs.cabal b/tiled-hs.cabal
index 7793f23..05ba0eb 100644
--- a/tiled-hs.cabal
+++ b/tiled-hs.cabal
@@ -44,6 +44,7 @@ library
mtl,
either,
filepath,
+ getopt-generics,
regex-tdfa ^>= 1.3.1.1
-- TODO: move more stuff into lib, these dependencies are silly
--
GitLab