diff options
| -rw-r--r-- | lib/CheckDir.hs | 16 | ||||
| -rw-r--r-- | lib/CheckMap.hs | 48 | ||||
| -rw-r--r-- | lib/LintWriter.hs | 16 | ||||
| -rw-r--r-- | lib/Types.hs | 28 | ||||
| -rw-r--r-- | src/Main.hs | 8 | ||||
| -rw-r--r-- | 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 |