prettier pretty printing and stuff

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

lib/CheckDir.hs

 {-# 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 <-

lib/CheckMap.hs

 {-# LANGUAGE DeriveAnyClass    #-}
 {-# LANGUAGE DeriveGeneric     #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE NamedFieldPuns    #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -14,16 +15,15 @@ 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           LintWriter   (LintResult (..), LintWriter, askContext,
-                                        lintToDep, resultToDeps, resultToLints,
-                                        runLintWriter)
+                               filterLintLevel, lintToDep, resultToDeps,
+                               resultToLints, runLintWriter)
 import           Properties   (checkLayerProperty, checkMap)
 import           Tiled2       (Layer (layerName, layerProperties),
                                Tiledmap (tiledmapLayers), loadTiledmap)
-import           Types                 (Dep, Level (..), Lint (..), hint)
+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

lib/LintWriter.hs

 {-# 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
 

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,7 +68,7 @@ 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
 

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 ()

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