prettier pretty printing and stuff

also, configurable log level, which only required relaxing the type
system once!

4 files changed, 71 insertions, 37 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