diff options
| -rw-r--r-- | .hlint.yaml | 3 | ||||
| -rw-r--r-- | lib/Badges.hs | 5 | ||||
| -rw-r--r-- | lib/CheckDir.hs | 101 | ||||
| -rw-r--r-- | lib/CheckMap.hs | 58 | ||||
| -rw-r--r-- | lib/Dirgraph.hs | 18 | ||||
| -rw-r--r-- | lib/KindLinter.hs | 7 | ||||
| -rw-r--r-- | lib/LayerData.hs | 12 | ||||
| -rw-r--r-- | lib/LintConfig.hs | 32 | ||||
| -rw-r--r-- | lib/LintWriter.hs | 26 | ||||
| -rw-r--r-- | lib/Paths.hs | 31 | ||||
| -rw-r--r-- | lib/Properties.hs | 79 | ||||
| -rw-r--r-- | lib/Tiled.hs | 26 | ||||
| -rw-r--r-- | lib/TiledAbstract.hs | 15 | ||||
| -rw-r--r-- | lib/Types.hs | 15 | ||||
| -rw-r--r-- | lib/Uris.hs | 44 | ||||
| -rw-r--r-- | lib/Util.hs | 19 | ||||
| -rw-r--r-- | lib/WriteRepo.hs | 16 | ||||
| -rw-r--r-- | package.yaml | 5 | ||||
| -rw-r--r-- | server/HtmlOrphans.hs | 2 | ||||
| -rw-r--r-- | server/Server.hs | 5 | ||||
| -rw-r--r-- | server/Worker.hs | 5 | ||||
| -rw-r--r-- | src/Main.hs | 30 | ||||
| -rw-r--r-- | src/Version.hs | 4 | ||||
| -rw-r--r-- | walint.cabal | 8 |
24 files changed, 279 insertions, 287 deletions
diff --git a/.hlint.yaml b/.hlint.yaml index 0415941..202635a 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -136,9 +136,6 @@ - warn: {lhs: "m ?: mempty", rhs: maybeToMonoid m} -- hint: {lhs: pure (), rhs: pass} -- hint: {lhs: return (), rhs: pass} - # Probably will be reduced when function equality is done: # https://github.com/ndmitchell/hlint/issues/434 - warn: {lhs: (case m of Just x -> f x; Nothing -> pure () ), rhs: Universum.whenJust m f} diff --git a/lib/Badges.hs b/lib/Badges.hs index c1a17b3..d6afc43 100644 --- a/lib/Badges.hs +++ b/lib/Badges.hs @@ -8,14 +8,13 @@ -- | module defining Badge types and utility functions module Badges where -import Control.DeepSeq (NFData) +import Universum + import Data.Aeson (Options (fieldLabelModifier, sumEncoding), SumEncoding (UntaggedValue), ToJSON (toJSON), defaultOptions, genericToJSON, (.=)) import qualified Data.Aeson as A import Data.Char (toLower) -import Data.Text (Text) -import GHC.Generics (Generic) import Text.Regex.TDFA ((=~)) diff --git a/lib/CheckDir.hs b/lib/CheckDir.hs index 652d58f..be23747 100644 --- a/lib/CheckDir.hs +++ b/lib/CheckDir.hs @@ -1,38 +1,46 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- | Module that contains high-level checking for an entire directory -module CheckDir (maximumLintLevel, recursiveCheckDir, DirResult(..), MissingAsset(..), MissingDep(..), resultIsFatal) where - -import CheckMap (MapResult (..), loadAndLintMap) -import Control.DeepSeq (NFData) -import Control.Monad (void) +module CheckDir ( maximumLintLevel + , recursiveCheckDir + , DirResult (..) + , MissingAsset(..) + , MissingDep(..) + , resultIsFatal + ,shrinkDirResult) where + +import Universum hiding (Set) + +import CheckMap (MapResult (..), Optional, + ResultKind (..), loadAndLintMap, + shrinkMapResult) import Control.Monad.Extra (mapMaybeM) import Data.Aeson (ToJSON, (.=)) import qualified Data.Aeson as A -import Data.Foldable (fold) -import Data.Functor ((<&>)) -import Data.Map (Map, elems, keys) import qualified Data.Map as M import Data.Map.Strict (mapKeys, mapWithKey, (\\)) -import Data.Maybe (isJust, mapMaybe) -import Data.Text (Text, isInfixOf) +import Data.Text (isInfixOf) import qualified Data.Text as T import Dirgraph (graphToDot, invertGraph, resultToGraph, unreachableFrom) -import GHC.Generics (Generic) import LintConfig (LintConfig', configMaxLintLevel) import Paths (normalise, normaliseWithFrag) import System.Directory.Extra (doesFileExist) import System.FilePath (splitPath, (</>)) import qualified System.FilePath as FP import System.FilePath.Posix (takeDirectory) -import Text.Dot (Dot, showDot) +import Text.Dot (showDot) +import Tiled (Tiledmap) import Types (Dep (Local, LocalMap), Hint (Hint), Level (..), hintLevel) import Util (PrettyPrint (prettyprint)) @@ -47,15 +55,18 @@ listFromSet :: Set a -> [a] listFromSet = map fst . M.toList -- | Result of linting an entire directory / repository -data DirResult = DirResult - { dirresultMaps :: Map FilePath MapResult +data DirResult (complete :: ResultKind) = DirResult + { dirresultMaps :: Map FilePath (MapResult complete) -- ^ all maps of this respository, by (local) filepath , dirresultDeps :: [MissingDep] -- ^ all dependencies to things outside this repository , dirresultMissingAssets :: [MissingAsset] -- ^ entrypoints of maps which are referred to but missing , dirresultGraph :: Text - } deriving (Generic, NFData) + } deriving (Generic) + +instance NFData (Optional a (Maybe Tiledmap)) => NFData (DirResult a) + data MissingDep = MissingDep { depFatal :: Maybe Bool @@ -69,8 +80,14 @@ data MissingDep = MissingDep newtype MissingAsset = MissingAsset MissingDep deriving (Generic, NFData) + +-- | "shrink" the result by throwing the adjusted tiledmaps away +shrinkDirResult :: DirResult Full -> DirResult Shrunk +shrinkDirResult !res = + res { dirresultMaps = fmap shrinkMapResult (dirresultMaps res) } + -- | given this config, should the result be considered to have failed? -resultIsFatal :: LintConfig' -> DirResult -> Bool +resultIsFatal :: LintConfig' -> DirResult Full -> Bool resultIsFatal config res = not (null (dirresultMissingAssets res) || not (any (isJust . depFatal) (dirresultDeps res))) || maximumLintLevel res > configMaxLintLevel config @@ -78,11 +95,11 @@ resultIsFatal config res = -- | maximum lint level that was observed anywhere in any map. -- note that it really does go through all lints, so don't -- call it too often -maximumLintLevel :: DirResult -> Level +maximumLintLevel :: DirResult a -> Level maximumLintLevel res | not (null (dirresultMissingAssets res)) = Fatal | otherwise = - (\t -> if null t then Info else maximum t) + (maybe Info maximum . nonEmpty) . map hintLevel . concatMap (\map -> keys (mapresultLayer map) <> keys (mapresultTileset map) @@ -94,7 +111,7 @@ maximumLintLevel res -instance ToJSON DirResult where +instance ToJSON (DirResult a) where toJSON res = A.object [ "result" .= A.object [ "missingDeps" .= dirresultDeps res @@ -114,7 +131,7 @@ instance ToJSON MissingAsset where ] -instance PrettyPrint (Level, DirResult) where +instance PrettyPrint (Level, DirResult a) where prettyprint (level, res) = prettyMapLints <> prettyMissingDeps where prettyMissingDeps = if not (null (dirresultDeps res)) @@ -122,9 +139,9 @@ instance PrettyPrint (Level, DirResult) where else "" prettyMapLints = T.concat (map prettyLint $ M.toList $ dirresultMaps res) - prettyLint :: (FilePath, MapResult) -> Text + prettyLint :: (FilePath, MapResult a) -> Text prettyLint (p, lint) = - "\nin " <> T.pack p <> ":\n" <> prettyprint (level, lint) + "\nin " <> toText p <> ":\n" <> prettyprint (level, lint) instance PrettyPrint MissingDep where prettyprint (MissingDep _ f n) = @@ -132,7 +149,7 @@ instance PrettyPrint MissingDep where <> prettyDependents <> "\n" where prettyDependents = - T.intercalate "," $ map T.pack n + T.intercalate "," $ map toText n -- | check an entire repository @@ -142,7 +159,7 @@ recursiveCheckDir -- ^ the repository's prefix (i.e. path to its directory) -> FilePath -- ^ the repository's entrypoint (filename of a map, from the repo's root) - -> IO DirResult + -> IO (DirResult Full) recursiveCheckDir config prefix root = do maps <- recursiveCheckDir' config prefix [root] mempty @@ -157,7 +174,7 @@ recursiveCheckDir config prefix root = do let maps' = flip mapWithKey maps $ \path res -> if path `elem` nowayback then res { mapresultGeneral = - Hint Warning ("Cannot go back to " <> T.pack root <> " from this map.") + Hint Warning ("Cannot go back to " <> toText root <> " from this map.") : mapresultGeneral res } else res @@ -166,15 +183,15 @@ recursiveCheckDir config prefix root = do pure $ DirResult { dirresultDeps = missingDeps root maps' , dirresultMissingAssets = mAssets , dirresultMaps = maps' - , dirresultGraph = T.pack $ showDot $ graphToDot exitGraph + , dirresultGraph = toText $ showDot $ graphToDot exitGraph } -- | Given a (partially) completed DirResult, check which local -- maps are referenced but do not actually exist. -missingDeps :: FilePath -> Map FilePath MapResult -> [MissingDep] +missingDeps :: FilePath -> Map FilePath (MapResult a) -> [MissingDep] missingDeps entrypoint maps = - let simple = M.insert (T.pack entrypoint) [] used \\ M.union defined trivial + let simple = M.insert (toText entrypoint) [] used \\ M.union defined trivial in M.foldMapWithKey (\f n -> [MissingDep (Just $ not ("#" `isInfixOf` f)) f n]) simple where -- which maps are linked somewhere? @@ -184,19 +201,19 @@ missingDeps entrypoint maps = (\path v -> map (, [path]) . mapMaybe (extractLocalDeps path) . mapresultDepends $ v) maps where extractLocalDeps prefix = \case - LocalMap name -> Just $ T.pack $ normaliseWithFrag prefix name + LocalMap name -> Just $ toText $ normaliseWithFrag prefix name _ -> Nothing -- which are defined using startLayer? defined :: Set Text defined = setFromList $ M.foldMapWithKey - (\k v -> map ((T.pack k <> "#") <>) . mapresultProvides $ v) + (\k v -> map ((toText k <> "#") <>) . mapresultProvides $ v) maps -- each map file is an entrypoint by itself - trivial = mapKeys T.pack $ void maps + trivial = mapKeys toText $ void maps -- | Checks if all assets referenced in the result actually exist as files -missingAssets :: FilePath -> Map FilePath MapResult -> IO [MissingAsset] +missingAssets :: FilePath -> Map FilePath (MapResult a) -> IO [MissingAsset] missingAssets prefix maps = mapM (fmap (fmap (fmap MissingAsset)) missingOfMap) (M.toList maps) <&> fold where missingOfMap (path, mapres) = mapMaybeM @@ -204,7 +221,7 @@ missingAssets prefix maps = let asset = normalise (takeDirectory path) relpath in doesFileExist (prefix </> asset) <&> \case True -> Nothing - False -> Just $ MissingDep Nothing (T.pack asset) [path] + False -> Just $ MissingDep Nothing (toText asset) [path] _ -> pure Nothing) (mapresultDepends mapres) @@ -216,9 +233,9 @@ recursiveCheckDir' -- ^ the repo's directory -> [FilePath] -- ^ paths of maps yet to check - -> Map FilePath MapResult + -> Map FilePath (MapResult Full) -- ^ accumulator for map results - -> IO (Map FilePath MapResult) + -> IO (Map FilePath (MapResult Full)) recursiveCheckDir' config prefix paths acc = do -- lint all maps in paths. The double fmap skips maps which cause IO errors diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs index 9dd0530..3ac03bd 100644 --- a/lib/CheckMap.hs +++ b/lib/CheckMap.hs @@ -1,27 +1,30 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- | Module that contains the high-level checking functions -module CheckMap (loadAndLintMap, MapResult(..)) where +module CheckMap (loadAndLintMap, MapResult(..), ResultKind(..), Optional,shrinkMapResult) where + +import Universum import Data.Aeson (ToJSON (toJSON)) import qualified Data.Aeson as A import Data.Aeson.Types ((.=)) -import Data.Functor ((<&>)) -import Data.Map (Map, toList) import qualified Data.Map as M -import Data.Text (Text) import qualified Data.Text as T import qualified Data.Vector as V -import GHC.Generics (Generic) import Badges (Badge) -import Control.DeepSeq (NFData) import LintConfig (LintConfig') import LintWriter (LintResult, invertLintResult, resultToAdjusted, resultToBadges, @@ -39,9 +42,14 @@ import Types (Dep (MapLink), import Util (PrettyPrint (prettyprint), prettyprint) +data ResultKind = Full | Shrunk + +type family Optional (a :: ResultKind) (b :: *) where + Optional Full b = b + Optional Shrunk b = () -- | What this linter produces: lints for a single map -data MapResult = MapResult +data MapResult (kind :: ResultKind) = MapResult { mapresultLayer :: Map Hint [Text] -- ^ lints that occurred in one or more layers , mapresultTileset :: Map Hint [Text] @@ -50,15 +58,18 @@ data MapResult = MapResult -- ^ (external and local) dependencies of this map , mapresultProvides :: [Text] -- ^ entrypoints provided by this map (needed for dependency checking) - , mapresultAdjusted :: Maybe Tiledmap + , mapresultAdjusted :: Optional kind (Maybe Tiledmap) -- ^ the loaded map, with adjustments by the linter , mapresultBadges :: [Badge] -- ^ badges that can be found on this map , mapresultGeneral :: [Hint] -- ^ general-purpose lints that didn't fit anywhere else - } deriving (Generic, NFData) + } deriving (Generic) + +instance NFData (Optional a (Maybe Tiledmap)) => NFData (MapResult a) -instance ToJSON MapResult where + +instance ToJSON (MapResult a) where toJSON res = A.object [ "layer" .= CollectedLints (mapresultLayer res) , "tileset" .= CollectedLints (mapresultTileset res) @@ -76,13 +87,16 @@ instance ToJSON CollectedLints where else cs +shrinkMapResult :: MapResult Full -> MapResult Shrunk +shrinkMapResult !res = res { mapresultAdjusted = () } + -- | this module's raison d'être -- Lints the map at `path`, and limits local links to at most `depth` -- layers upwards in the file hierarchy -loadAndLintMap :: LintConfig' -> FilePath -> Int -> IO (Maybe MapResult) +loadAndLintMap :: LintConfig' -> FilePath -> Int -> IO (Maybe (MapResult Full)) loadAndLintMap config path depth = loadTiledmap path <&> (\case DecodeErr err -> Just (MapResult mempty mempty mempty mempty Nothing mempty - [ Hint Fatal . T.pack $ + [ Hint Fatal . toText $ path <> ": Fatal: " <> err ]) IOErr _ -> Nothing @@ -90,7 +104,7 @@ loadAndLintMap config path depth = loadTiledmap path <&> (\case Just (runLinter (takeFileName path == "main.json") config waMap depth)) -- | lint a loaded map -runLinter :: Bool -> LintConfig' -> Tiledmap -> Int -> MapResult +runLinter :: Bool -> LintConfig' -> Tiledmap -> Int -> MapResult Full runLinter isMain config tiledmap depth = MapResult { mapresultLayer = invertThing layer , mapresultTileset = invertThing tileset @@ -174,7 +188,7 @@ checkLayerRec config depth layers = -- human-readable lint output, e.g. for consoles -instance PrettyPrint (Level, MapResult) where +instance PrettyPrint (Level, MapResult a) where prettyprint (_, mapResult) = if complete == "" then " all good!\n" else complete where @@ -185,7 +199,7 @@ instance PrettyPrint (Level, MapResult) where -- | pretty-prints a collection of Hints, printing each -- Hint only once, then a list of its occurences line-wrapped -- to fit onto a decent-sized terminal - prettyLints :: (MapResult -> Map Hint [Text]) -> [Text] + prettyLints :: (MapResult a -> Map Hint [Text]) -> [Text] prettyLints getter = fmap (\(h, cs) -> prettyprint h <> "\n (in " @@ -197,7 +211,7 @@ instance PrettyPrint (Level, MapResult) where ) (0, "") cs) <> ")\n") - (toList . getter $ mapResult) + (M.toList . getter $ mapResult) prettyGeneral :: [Text] prettyGeneral = map diff --git a/lib/Dirgraph.hs b/lib/Dirgraph.hs index b97a644..4873228 100644 --- a/lib/Dirgraph.hs +++ b/lib/Dirgraph.hs @@ -1,23 +1,21 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} -- | Simple directed graphs, for dependency checking module Dirgraph where +import Universum import CheckMap (MapResult (mapresultDepends)) -import Control.Monad (forM_) -import Data.Functor ((<&>)) -import Data.Map.Strict (Map, mapMaybeWithKey, mapWithKey, - traverseWithKey) +import Data.Map.Strict (mapMaybeWithKey, mapWithKey, traverseWithKey) import qualified Data.Map.Strict as M -import Data.Set (Set, (\\)) +import Data.Set ((\\)) import qualified Data.Set as S import Paths (normalise) import Text.Dot (Dot, (.->.)) import qualified Text.Dot as D import Types (Dep (LocalMap)) -import Witherable (mapMaybe) -- | a simple directed graph type Graph a = Map a (Set a) @@ -26,7 +24,7 @@ nodes :: Graph a -> Set a nodes = M.keysSet -- | simple directed graph of exits -resultToGraph :: Map FilePath MapResult -> Graph FilePath +resultToGraph :: Map FilePath (MapResult a) -> Graph FilePath resultToGraph = fmap (S.fromList . mapMaybe onlyLocalMaps . mapresultDepends) where onlyLocalMaps = \case LocalMap path -> Just (normalise "" path) @@ -35,7 +33,7 @@ resultToGraph = fmap (S.fromList . mapMaybe onlyLocalMaps . mapresultDepends) -- | invert edges of a directed graph invertGraph :: (Eq a, Ord a) => Graph a -> Graph a invertGraph graph = mapWithKey collectFroms graph - where collectFroms to _ = S.fromList . M.elems . mapMaybeWithKey (select to) $ graph + where collectFroms to _ = S.fromList . elems . mapMaybeWithKey (select to) $ graph select to from elems = if to `elem` elems then Just from else Nothing -- | all nodes reachable from some entrypoint diff --git a/lib/KindLinter.hs b/lib/KindLinter.hs index ccca1db..a876a8f 100644 --- a/lib/KindLinter.hs +++ b/lib/KindLinter.hs @@ -13,11 +13,10 @@ module KindLinter where +import Universum + import Data.HList -import Data.Kind (Type) -import Data.Map.Strict -import Data.Void (Void) -import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) +import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) func :: a -> HList [Int, String] diff --git a/lib/LayerData.hs b/lib/LayerData.hs index 1a07982..6956c92 100644 --- a/lib/LayerData.hs +++ b/lib/LayerData.hs @@ -2,12 +2,12 @@ module LayerData where +import Universum hiding (maximum, uncons) import Control.Monad.Zip (mzipWith) -import Data.Set (Set, insert) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Vector (Vector, uncons) +import Data.Set (insert) +import Data.Vector (maximum, uncons) +import qualified Text.Show as TS import Tiled (GlobalId (unGlobalId), Layer (..)) import Util (PrettyPrint (..)) @@ -22,8 +22,8 @@ instance Eq Collision where instance PrettyPrint Collision where prettyprint (Collision (a,b)) = a <> " and " <> b -instance Show Collision where - show c = T.unpack $ prettyprint c +instance TS.Show Collision where + show c = toString $ prettyprint c -- | Finds pairwise tile collisions between the given layers. layerOverlaps :: Vector Layer -> Set Collision diff --git a/lib/LintConfig.hs b/lib/LintConfig.hs index e71638b..11a8122 100644 --- a/lib/LintConfig.hs +++ b/lib/LintConfig.hs @@ -12,21 +12,21 @@ -- | Module that deals with handling config options module LintConfig (LintConfig(..), LintConfig', patchConfig) where -import Control.Monad.Identity (Identity) -import Data.Aeson (FromJSON (parseJSON), Options (..), - defaultOptions, eitherDecode) -import Data.Aeson.Types (genericParseJSON) -import qualified Data.ByteString.Char8 as C8 -import qualified Data.ByteString.Lazy as LB -import qualified Data.Map.Strict as M -import Data.Text (Text) -import GHC.Generics (Generic (Rep, from, to), K1 (..), - M1 (..), (:*:) (..)) -import Types (Level) -import Uris (SchemaSet, - Substitution (DomainSubstitution)) -import WithCli (Proxy (..)) -import WithCli.Pure (Argument (argumentType, parseArgument)) +import Universum +import qualified Universum.Unsafe as Unsafe + +import Data.Aeson (FromJSON (parseJSON), Options (..), + defaultOptions, eitherDecode) +import Data.Aeson.Types (genericParseJSON) +import qualified Data.ByteString.Char8 as C8 +import qualified Data.ByteString.Lazy as LB +import qualified Data.Map.Strict as M +import GHC.Generics (Generic (Rep, from, to), K1 (..), + M1 (..), (:*:) (..)) +import Types (Level) +import Uris (SchemaSet, + Substitution (DomainSubstitution)) +import WithCli.Pure (Argument (argumentType, parseArgument)) type family HKD f a where HKD Identity a = a @@ -138,7 +138,7 @@ patchConfig config p = config' DomainSubstitution (M.fromList generated) scope where generated = (\slug -> (slug, "/@/rc3_21/"<>slug)) <$> configAssemblies config' scope = (\(DomainSubstitution _ s) -> s) - . snd . head + . snd . Unsafe.head . filter ((==) "world" . fst) $ configUriSchemas config' diff --git a/lib/LintWriter.hs b/lib/LintWriter.hs index 2b891c3..d0c6c4e 100644 --- a/lib/LintWriter.hs +++ b/lib/LintWriter.hs @@ -42,21 +42,15 @@ module LintWriter , adjust ) where -import Data.Text (Text) - -import Badges (Badge) -import Control.Monad.State (MonadState (put), StateT, modify) -import Control.Monad.Trans.Reader (Reader, asks, runReader) -import Control.Monad.Trans.State (get, runStateT) -import Control.Monad.Writer.Lazy (lift) -import Data.Bifunctor (Bifunctor (second)) -import Data.Map (Map, fromListWith) -import Data.Maybe (mapMaybe) -import qualified Data.Set as S -import LintConfig (LintConfig') -import TiledAbstract (HasName (getName)) -import Types (Dep, Hint, Level (..), Lint (..), - hint, lintsToHints) +import Universum + + +import Badges (Badge) +import Data.Map (fromListWith) +import LintConfig (LintConfig') +import TiledAbstract (HasName (getName)) +import Types (Dep, Hint, Level (..), Lint (..), hint, + lintsToHints) -- | A monad modelling the main linter features @@ -109,7 +103,7 @@ zoom embed extract operation = do -- | "invert" a linter's result, grouping lints by their messages invertLintResult :: HasName ctxt => LintResult ctxt -> Map Hint [Text] invertLintResult (LinterState (lints, ctxt)) = - fmap (S.toList . S.fromList . fmap getName) . fromListWith (<>) $ (, [ctxt]) <$> lintsToHints lints + fmap (sortNub . map getName) . fromListWith (<>) $ (, [ctxt]) <$> lintsToHints lints resultToDeps :: LintResult a -> [Dep] resultToDeps (LinterState (lints,_)) = mapMaybe lintToDep lints diff --git a/lib/Paths.hs b/lib/Paths.hs index 15dc66b..f4dc3ed 100644 --- a/lib/Paths.hs +++ b/lib/Paths.hs @@ -7,15 +7,16 @@ -- I just hope you are running this on some kind of Unix module Paths where -import Control.DeepSeq (NFData) -import Data.Text (Text, isPrefixOf) +import Universum +import qualified Universum.Unsafe as Unsafe + import qualified Data.Text as T -import GHC.Generics (Generic) import System.FilePath (splitPath) import System.FilePath.Posix ((</>)) import Text.Regex.TDFA import Util (PrettyPrint (prettyprint)) + -- | a normalised path: a number of "upwards" steps, and -- a path without any . or .. in it. Also possibly a -- fragment, mostly for map links. @@ -36,9 +37,9 @@ parsePath :: Text -> PathResult parsePath text = if | T.isInfixOf "{{" text || T.isInfixOf "}}" text -> PathVarsDisallowed | rest =~ ("^([^/]*[^\\./]/)*[^/]*[^\\./]$" :: Text) -> OkRelPath (Path up path fragment) - | "/_/" `isPrefixOf` text -> UnderscoreMapLink - | "/@/" `isPrefixOf` text -> AtMapLink - | "/" `isPrefixOf` text -> AbsolutePath + | "/_/" `T.isPrefixOf` text -> UnderscoreMapLink + | "/@/" `T.isPrefixOf` text -> AtMapLink + | "/" `T.isPrefixOf` text -> AbsolutePath | otherwise -> NotAPath where (_, prefix, rest, _) = @@ -47,10 +48,10 @@ parsePath text = up = length . filter (".." ==) . T.splitOn "/" $ prefix parts = T.splitOn "#" rest -- `head` is unsafe, but splitOn will always produce lists with at least one element - path = head parts - fragment = if length parts >= 2 - then Just $ T.concat $ tail parts - else Nothing + path = Unsafe.head parts + fragment = case nonEmpty parts of + Nothing -> Nothing + Just p -> Just $ T.concat $ tail p instance PrettyPrint RelPath where prettyprint (Path up rest frag) = ups <> rest <> fragment @@ -63,14 +64,14 @@ instance PrettyPrint RelPath where -- at the end of the prefix, i.e. it will never return paths -- that lie (naïvely) outside of the prefix. normalise :: FilePath -> RelPath -> FilePath -normalise prefix (Path 0 path _) = prefix </> T.unpack path +normalise prefix (Path 0 path _) = prefix </> toString path normalise prefix (Path i path _) = - concat (take (length dirs - i) dirs) </> T.unpack path + concat (take (length dirs - i) dirs) </> toString path where dirs = splitPath prefix normaliseWithFrag :: FilePath -> RelPath -> FilePath normaliseWithFrag prefix (Path i path frag) = - normalise prefix (Path (i+1) path frag) <> T.unpack (maybe mempty ("#" <>) frag) + normalise prefix (Path (i+1) path frag) <> toString (maybe mempty ("#" <>) frag) -- | does this path contain an old-style pattern for inter-repository -- links as was used at rc3 in 2020? @@ -81,7 +82,5 @@ isOldStyle (Path _ text frag) = path =~ ("{<.+>*}" :: Text) _ -> text getExtension :: RelPath -> Text -getExtension (Path _ text _) = case length splitted of - 0 -> "" - _ -> last splitted +getExtension (Path _ text _) = maybe "" last (nonEmpty splitted) where splitted = T.splitOn "." text diff --git a/lib/Properties.hs b/lib/Properties.hs index 87b2a28..5d9c094 100644 --- a/lib/Properties.hs +++ b/lib/Properties.hs @@ -1,18 +1,21 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} -- | Contains checks for custom ties of the map json module Properties (checkMap, checkTileset, checkLayer) where +import Universum hiding (intercalate, isPrefixOf) -import Control.Monad (forM, forM_, unless, when) -import Data.Text (Text, intercalate, isInfixOf, isPrefixOf) +import Data.Text (intercalate, isInfixOf, isPrefixOf) import qualified Data.Text as T import qualified Data.Vector as V import Tiled (Layer (..), Object (..), Property (..), @@ -21,19 +24,14 @@ import Tiled (Layer (..), Object (..), Property (..), import TiledAbstract (HasName (..), HasProperties (..), HasTypeName (..), IsProperty (..)) import Util (layerIsEmpty, mkProxy, naiveEscapeHTML, - prettyprint, showText) + prettyprint) import Badges (Badge (Badge), BadgeArea (BadgePoint, BadgeRect), BadgeToken, parseToken) -import Data.Data (Proxy (Proxy)) -import Data.Functor ((<&>)) import Data.List ((\\)) -import Data.Maybe (fromMaybe, isJust) -import Data.Set (Set) import qualified Data.Set as S import Data.Text.Metrics (damerauLevenshtein) -import Data.Vector (Vector) import GHC.TypeLits (KnownSymbol) import LayerData (Collision, layerOverlaps) import LintConfig (LintConfig (..)) @@ -85,7 +83,7 @@ checkMap = do let unlessLayer = unlessElement layers -- test custom map properties - mapM_ checkMapProperty (fromMaybe mempty $ tiledmapProperties tiledmap) + mapM_ checkMapProperty (maybeToMonoid $ tiledmapProperties tiledmap) -- can't have these with the rest of layer/tileset lints since they're -- not specific to any one of them @@ -143,10 +141,10 @@ checkMapProperty p@(Property name _) = case name of -- scripts can be used by one map _ | T.toLower name == "script" -> unwrapString p $ \str -> - unless ((checkIsRc3Url str) && - (not $ "/../" `isInfixOf` str) && - (not $ "%" `isInfixOf` str) && - (not $ "@" `isInfixOf` str)) + unless (checkIsRc3Url str && + not ( "/../" `isInfixOf` str) && + not ( "%" `isInfixOf` str) && + not ( "@" `isInfixOf` str)) $ forbid "only scripts hosted on static.rc3.world are allowed." | name `elem` ["jitsiRoom", "bbbRoom", "playAudio", "openWebsite" , "url", "exitUrl", "silent", "getBadge"] @@ -185,7 +183,7 @@ checkTileset = do $ complain "The \"filename\" property on tilesets was removed; use \"image\" instead (and perhaps a newer version of the Tiled Editor)." -- check individual tileset properties - mapM_ checkTilesetProperty (fromMaybe mempty $ tilesetProperties tileset) + mapM_ checkTilesetProperty (maybeToMonoid $ tilesetProperties tileset) case tilesetTiles tileset of Nothing -> pure () @@ -193,7 +191,7 @@ checkTileset = do -- can't set properties on the same tile twice refuseDoubledThings tileId (\tile -> complain $ "cannot set properties on the \ - \tile with the id" <> showText (tileId tile) <> "twice.") + \tile with the id" <> show (tileId tile) <> "twice.") tiles mapM_ checkTile tiles @@ -217,7 +215,7 @@ checkTileset = do \not an individual tile." _ -> warnUnknown' ("unknown tile property " <> prettyprint name <> " in tile with global id " - <> showText (tileId tile)) p knownTilesetProperties + <> show (tileId tile)) p knownTilesetProperties -- | collect lints on a single map layer @@ -252,14 +250,14 @@ checkLayer = do forM_ (getProperties layer) checkObjectGroupProperty unless (layerName layer == "floorLayer") $ - when (null (layerObjects layer) || layerObjects layer == Just mempty) $ + when (isNothing (layerObjects layer) || layerObjects layer == Just mempty) $ warn "objectgroup layer (which aren't the floorLayer) \ \are useless if they are empty." ty -> complain $ "unsupported layer type " <> prettyprint ty <> "." if layerType layer == "group" - then when (null (layerLayers layer)) + then when (isNothing (layerLayers layer)) $ warn "Empty group layers are pointless." else when (isJust (layerLayers layer)) $ complain "Layer is not of type \"group\", but has sublayers." @@ -310,7 +308,7 @@ checkObjectProperty p@(Property name _) = do unless (objectType obj == "variable") $ complain $ "the "<>prettyprint name<>" property should only be set \ \on objects of type \"variable\"" - when (null (objectName obj) || objectName obj == Just mempty) $ + when (isNothing (objectName obj) || objectName obj == Just mempty) $ complain $ "Objects with the property "<>prettyprint name<>" set must \ \be named." | name `elem` [ "openSound", "closeSound", "bellSound", "loadSound" ] -> do @@ -504,7 +502,7 @@ checkTileLayerProperty p@(Property name _value) = case name of requireProperty req = propertyRequiredBy req name requireOneOf names = do context <- askContext - when (all (not . containsProperty context) names) + unless (any (containsProperty context) names) $ complain $ "property " <> prettyprint name <> " requires one of " <> prettyprint names @@ -528,9 +526,8 @@ checkTileLayerProperty p@(Property name _value) = case name of -- | refuse doubled names in everything that's somehow a collection of names refuseDoubledNames - :: (HasName a, HasTypeName a) - => (Foldable t, Functor t) - => t a + :: (Container t, HasName (Element t), HasTypeName (Element t)) + => t -> LintWriter b refuseDoubledNames = refuseDoubledThings getName @@ -539,10 +536,10 @@ refuseDoubledNames = refuseDoubledThings -- | refuse doubled things via equality on after applying some function refuseDoubledThings - :: (Eq a, Ord a, Foldable t, Functor t) - => (a' -> a) - -> (a' -> LintWriter b) - -> t a' + :: (Eq a, Ord a, Container t) + => (Element t -> a) + -> (Element t -> LintWriter b) + -> t -> LintWriter b refuseDoubledThings f ifDouble things = foldr folding base things (mempty, mempty) where @@ -570,15 +567,15 @@ warnUnknown p@(Property name _) = ---- General functions ---- unlessElement - :: Foldable f - => f a - -> (a -> Bool) + :: Container f + => f + -> (Element f -> Bool) -> LintWriter b -> LintWriter b unlessElement things op = unless (any op things) -unlessElementNamed :: (HasName a, Foldable f) - => f a -> Text -> LintWriter b -> LintWriter b +unlessElementNamed :: (HasName (Element f), Container f) + => f -> Text -> LintWriter b -> LintWriter b unlessElementNamed things name = unlessElement things ((==) name . getName) @@ -756,4 +753,4 @@ isOrdInRange :: (Ord a, Show a) isOrdInRange unwrapa l r p@(Property name _) = unwrapa p $ \int -> if l < int && int < r then pure () else complain $ "Property " <> prettyprint name <> " should be between " - <> showText l <> " and " <> showText r<>"." + <> show l <> " and " <> show r<>"." diff --git a/lib/Tiled.hs b/lib/Tiled.hs index ab7d4f4..3162dfd 100644 --- a/lib/Tiled.hs +++ b/lib/Tiled.hs @@ -17,21 +17,15 @@ -- http://doc.mapeditor.org/en/latest/reference/tmx-map-format/ module Tiled where -import Control.DeepSeq (NFData) -import Control.Exception (try) -import Control.Exception.Base (SomeException) -import Data.Aeson hiding (Object) -import qualified Data.Aeson as A -import Data.Aeson.Types (typeMismatch) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LB -import Data.Char (toLower) -import Data.Map (Map) -import Data.String (IsString (fromString)) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Vector (Vector) -import GHC.Generics (Generic) +import Universum + +-- TODO: what ever are these aeson imports +import Data.Aeson hiding (Object) +import qualified Data.Aeson as A +import Data.Aeson.Types (typeMismatch) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LB +import Data.Char (toLower) -- | options for Aeson's generic encoding and parsing functions @@ -68,7 +62,7 @@ data PropertyValue = StrProp Text | BoolProp Bool | IntProp Int | FloatProp Floa deriving (Eq, Generic, Show, NFData) instance IsString PropertyValue where - fromString s = StrProp (T.pack s) + fromString s = StrProp (toText s) instance FromJSON Property where parseJSON (A.Object o) = do diff --git a/lib/TiledAbstract.hs b/lib/TiledAbstract.hs index 6d58f46..9fd2df0 100644 --- a/lib/TiledAbstract.hs +++ b/lib/TiledAbstract.hs @@ -2,9 +2,8 @@ module TiledAbstract where -import Data.Maybe (fromMaybe) -import Data.Proxy (Proxy) -import Data.Text (Text) +import Universum + import qualified Data.Vector as V import Tiled (Layer (..), Object (..), Property (..), PropertyValue (..), Tile (..), Tiledmap (..), @@ -15,27 +14,27 @@ class HasProperties a where adjustProperties :: ([Property] -> Maybe [Property]) -> a -> a instance HasProperties Layer where - getProperties = fromMaybe mempty . layerProperties + getProperties = maybeToMonoid . layerProperties adjustProperties f layer = layer { layerProperties = f (getProperties layer) } instance HasProperties Tileset where - getProperties = fromMaybe mempty . tilesetProperties + getProperties = maybeToMonoid . tilesetProperties adjustProperties f tileset = tileset { tilesetProperties = f (getProperties tileset) } instance HasProperties Tile where - getProperties = V.toList . fromMaybe mempty . tileProperties + getProperties = V.toList . maybeToMonoid . tileProperties adjustProperties f tile = tile { tileProperties = (fmap V.fromList . f) (getProperties tile) } instance HasProperties Object where - getProperties = V.toList . fromMaybe mempty . objectProperties + getProperties = V.toList . maybeToMonoid . objectProperties adjustProperties f obj = obj { objectProperties = (fmap V.fromList . f) (getProperties obj) } instance HasProperties Tiledmap where - getProperties = fromMaybe mempty . tiledmapProperties + getProperties = maybeToMonoid . tiledmapProperties adjustProperties f tiledmap = tiledmap { tiledmapProperties = f (getProperties tiledmap) } diff --git a/lib/Types.hs b/lib/Types.hs index 43a5131..f58705a 100644 --- a/lib/Types.hs +++ b/lib/Types.hs @@ -17,20 +17,17 @@ module Types , lintsToHints ) where +import Universum + import Control.Monad.Trans.Maybe () import Data.Aeson (FromJSON, ToJSON (toJSON), ToJSONKey, (.=)) -import Data.Text (Text) -import GHC.Generics (Generic) import Badges (Badge) -import Control.DeepSeq (NFData) import qualified Data.Aeson as A -import Data.Maybe (mapMaybe) import Paths (RelPath) -import Util (PrettyPrint (..), showText) -import WithCli (Argument, Proxy (..), - atomicArgumentsParser) +import Util (PrettyPrint (..)) +import WithCli (Argument, atomicArgumentsParser) import WithCli.Pure (Argument (argumentType, parseArgument), HasArguments (argumentsParser)) @@ -83,7 +80,7 @@ lintsToHints = mapMaybe (\case {Lint hint -> Just hint ; _ -> Nothing}) instance PrettyPrint Lint where prettyprint (Lint Hint { hintMsg, hintLevel } ) = - " " <> showText hintLevel <> ": " <> hintMsg + " " <> show hintLevel <> ": " <> hintMsg prettyprint (Depends dep) = " Info: found dependency: " <> prettyprint dep prettyprint (Offers dep) = @@ -92,7 +89,7 @@ instance PrettyPrint Lint where " Info: found a badge." instance PrettyPrint Hint where - prettyprint (Hint level msg) = " " <> showText level <> ": " <> msg + prettyprint (Hint level msg) = " " <> show level <> ": " <> msg instance ToJSON Lint where toJSON (Lint h) = toJSON h diff --git a/lib/Uris.hs b/lib/Uris.hs index 00f86a4..a8c7068 100644 --- a/lib/Uris.hs +++ b/lib/Uris.hs @@ -8,26 +8,16 @@ -- | Functions to deal with uris and custom uri schemes module Uris where +import Universum - -import Control.Monad (unless, when) -import Data.Aeson (FromJSON (..), Options (..), - SumEncoding (UntaggedValue), - defaultOptions, genericParseJSON) -import Data.Data (Proxy) -import Data.Either.Combinators (maybeToRight, rightToMaybe) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Text (Text, pack, unpack) -import qualified Data.Text as T -import GHC.Generics (Generic) -import GHC.TypeLits (KnownSymbol, symbolVal) -import Network.URI.Encode as URI -import Text.Regex.TDFA ((=~)) -import Witherable (mapMaybe) - -import Data.String -import Network.URI as NativeUri +import Data.Aeson (FromJSON (..), Options (..), + SumEncoding (UntaggedValue), + defaultOptions, genericParseJSON) +import qualified Data.Map.Strict as M +import qualified Data.Text as T +import GHC.TypeLits (KnownSymbol, symbolVal) +import Network.URI (URI (..), URIAuth (..), parseURI) +import qualified Network.URI.Encode as URI data Substitution = Prefixed { prefix :: Text, blocked :: [Text], allowed :: [Text], scope :: [String] } @@ -56,7 +46,7 @@ extractDomain url = parseUri :: Text -> Maybe (Text, Text, Text) parseUri uri = - case parseURI (unpack uri) of + case parseURI (toString uri) of Nothing -> Nothing Just parsedUri -> case uriAuthority parsedUri of Nothing -> Nothing @@ -84,15 +74,15 @@ data SubstError = applySubsts :: KnownSymbol s => Proxy s -> SchemaSet -> Text -> Either SubstError Text applySubsts s substs uri = do - when (T.isInfixOf (pack "{{") uri || T.isInfixOf (pack "}}") uri) + when (T.isInfixOf (toText "{{") uri || T.isInfixOf (toText "}}") uri) $ Left VarsDisallowed parts@(schema, _, _) <- note NotALink $ parseUri uri let rules = filter ((==) schema . fst) substs - case fmap (applySubst parts . snd) rules of - [] -> Left (SchemaDoesNotExist schema) - results@(_:_) -> case mapMaybe rightToMaybe results of + case nonEmpty (map (applySubst parts . snd) rules) of + Nothing -> Left (SchemaDoesNotExist schema) + Just results -> case rights (toList results) of suc:_ -> Right suc _ -> minimum results @@ -104,14 +94,14 @@ applySubsts s substs uri = do (fmap fst . filter (elem (symbolVal s) . scope . snd) $ substs)) case rule of DomainSubstitution table _ -> do - prefix <- note (DomainDoesNotExist (schema <> pack "://" <> domain)) + prefix <- note (DomainDoesNotExist (schema <> toText "://" <> domain)) $ M.lookup domain table pure (prefix <> rest) Prefixed {..} | domain `elem` blocked -> Left IsBlocked - | domain `elem` allowed || pack "streamproxy.rc3.world" `T.isSuffixOf` domain -> Right uri + | domain `elem` allowed || toText "streamproxy.rc3.world" `T.isSuffixOf` domain -> Right uri | otherwise -> Right (prefix <> URI.encodeText uri) Allowed _ domains -> if domain `elem` domains - || pack "streamproxy.rc3.world" `T.isSuffixOf` domain + || toText "streamproxy.rc3.world" `T.isSuffixOf` domain then Right uri else Left (DomainIsBlocked domains) diff --git a/lib/Util.hs b/lib/Util.hs index 21a2661..f935e78 100644 --- a/lib/Util.hs +++ b/lib/Util.hs @@ -6,30 +6,23 @@ -- concerns itself with wrangling haskell's string types module Util ( mkProxy - , showText , PrettyPrint(..) , printPretty , naiveEscapeHTML , layerIsEmpty ) where +import Universum + import Data.Aeson as Aeson -import Data.Proxy (Proxy (..)) -import Data.Set (Set) import qualified Data.Set as S -import Data.Text (Text) import qualified Data.Text as T import Tiled (Layer (layerData), PropertyValue (..), Tileset (tilesetName), layerName, mkTiledId) --- | helper function to create proxies mkProxy :: a -> Proxy a mkProxy = const Proxy --- | haskell's many string types are FUN … -showText :: Show a => a -> Text -showText = T.pack . show - -- | a class to address all the string conversions necessary -- when using Show to much that just uses Text instead class PrettyPrint a where @@ -43,7 +36,7 @@ instance PrettyPrint Text where instance PrettyPrint Aeson.Value where prettyprint = \case Aeson.String s -> prettyprint s - v -> (T.pack . show) v + v -> show v instance PrettyPrint t => PrettyPrint (Set t) where prettyprint = prettyprint . S.toList @@ -52,8 +45,8 @@ instance PrettyPrint PropertyValue where prettyprint = \case StrProp str -> str BoolProp bool -> if bool then "true" else "false" - IntProp int -> showText int - FloatProp float -> showText float + IntProp int -> show int + FloatProp float -> show float -- | here since Unit is sometimes used as dummy type instance PrettyPrint () where @@ -69,7 +62,7 @@ instance PrettyPrint a => PrettyPrint [a] where prettyprint = T.intercalate ", " . fmap prettyprint printPretty :: PrettyPrint a => a -> IO () -printPretty = putStr . T.unpack . prettyprint +printPretty = putStr . toString . prettyprint layerIsEmpty :: Layer -> Bool diff --git a/lib/WriteRepo.hs b/lib/WriteRepo.hs index 36c0df7..e4815fe 100644 --- a/lib/WriteRepo.hs +++ b/lib/WriteRepo.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -5,14 +6,11 @@ -- | Module for writing an already linted map Repository back out again. module WriteRepo (writeAdjustedRepository) where +import Universum + import CheckDir (DirResult (..), resultIsFatal) -import CheckMap (MapResult (..)) -import Control.Monad (forM_, unless) -import Control.Monad.Extra (ifM) +import CheckMap (MapResult (..), ResultKind (..)) import Data.Aeson (encodeFile) -import Data.Map.Strict (toList) -import Data.Maybe (mapMaybe) -import Data.Set (Set) import qualified Data.Set as S import LintConfig (LintConfig (configDontCopyAssets), LintConfig') @@ -27,7 +25,7 @@ import Types (Dep (Local)) -writeAdjustedRepository :: LintConfig' -> FilePath -> FilePath -> DirResult -> IO ExitCode +writeAdjustedRepository :: LintConfig' -> FilePath -> FilePath -> DirResult Full -> IO ExitCode writeAdjustedRepository config inPath outPath result | resultIsFatal config result = pure (ExitFailure 1) @@ -36,7 +34,7 @@ writeAdjustedRepository config inPath outPath result createDirectoryIfMissing True outPath -- write out all maps - forM_ (toList $ dirresultMaps result) $ \(path,out) -> do + forM_ (toPairs $ dirresultMaps result) $ \(path,out) -> do createDirectoryIfMissing True (takeDirectory (outPath </> path)) encodeFile (outPath </> path) $ mapresultAdjusted out @@ -51,7 +49,7 @@ writeAdjustedRepository config inPath outPath result Local path -> Just . normalise mapdir $ path _ -> Nothing) $ mapresultDepends mapresult) - . toList $ dirresultMaps result + . toPairs $ dirresultMaps result -- copy all assets forM_ localdeps $ \path -> diff --git a/package.yaml b/package.yaml index 7cd6130..4acf9e8 100644 --- a/package.yaml +++ b/package.yaml @@ -6,9 +6,11 @@ author: stuebinm maintainer: stuebinm@disroot.org copyright: 2022 stuebinm ghc-options: -Wall -Wno-name-shadowing -Wno-unticked-promoted-constructors +default-extensions: NoImplicitPrelude dependencies: - base + - universum - aeson - bytestring - mtl @@ -54,8 +56,7 @@ executables: walint-server: main: Main.hs source-dirs: 'server' - default-extensions: - - NoImplicitPrelude + ghc-options: -rtsopts -threaded dependencies: - walint - universum diff --git a/server/HtmlOrphans.hs b/server/HtmlOrphans.hs index ebe65aa..9b09f1d 100644 --- a/server/HtmlOrphans.hs +++ b/server/HtmlOrphans.hs @@ -108,7 +108,7 @@ headerText = \case -- | The fully monky -instance ToHtml DirResult where +instance ToHtml (DirResult a) where toHtml res@DirResult { .. } = do p_ $ do badge maxlevel "Linted:"; " "; headerText maxlevel diff --git a/server/Server.hs b/server/Server.hs index f2b286b..711da88 100644 --- a/server/Server.hs +++ b/server/Server.hs @@ -3,6 +3,8 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -31,6 +33,7 @@ module Server ( loadConfig import Universum import CheckDir (DirResult) +import CheckMap (ResultKind (Full, Shrunk)) import Control.Arrow ((>>>)) import Control.Concurrent (modifyMVar_, withMVar) import Crypto.Hash.SHA1 (hash) @@ -162,7 +165,7 @@ configCodec = Config -- | a job status (of a specific uuid) data JobStatus = - Pending | Linted !DirResult Text | Failed Text + Pending | Linted !(DirResult Shrunk) Text | Failed Text deriving (Generic, ToJSON, NFData) instance TS.Show JobStatus where diff --git a/server/Worker.hs b/server/Worker.hs index 91fa8e2..af07904 100644 --- a/server/Worker.hs +++ b/server/Worker.hs @@ -9,7 +9,8 @@ module Worker (linterThread, Job(..)) where import Universum -import CheckDir (recursiveCheckDir) +import CheckDir (recursiveCheckDir, + shrinkDirResult) import Control.Concurrent.Async (async, link) import Control.Concurrent.STM.TQueue import Control.Exception (IOException, handle) @@ -66,7 +67,7 @@ runJob config Job {..} done = do callgit gitdir [ "worktree", "add", "--force", workdir, toString ref ] res <- recursiveCheckDir (orgLintconfig jobOrg) workdir (orgEntrypoint jobOrg) - >>= evaluateNF + >>= evaluateNF . shrinkDirResult setJobStatus done jobOrg jobRef $ Linted res rev diff --git a/src/Main.hs b/src/Main.hs index beee091..d2546f5 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -6,18 +6,15 @@ module Main where -import Control.Monad (unless, when) -import Control.Monad.Identity (Identity) +import Universum + import Data.Aeson (eitherDecode, encode) import Data.Aeson.Encode.Pretty (encodePretty) import Data.Aeson.KeyMap (coercionToHashMap) import qualified Data.ByteString.Lazy as LB -import Data.Maybe (fromMaybe) import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T -import System.Exit (ExitCode (..), exitWith) -import System.IO (hPutStrLn, stderr) -import WithCli (Generic, HasArguments, withCli) +import WithCli (HasArguments, withCli) import CheckDir (recursiveCheckDir, resultIsFatal) import LintConfig (LintConfig (..), patchConfig) @@ -25,6 +22,7 @@ import Types (Level (..)) import Util (printPretty) import WriteRepo (writeAdjustedRepository) +import System.Exit (ExitCode (ExitFailure, ExitSuccess)) import qualified Version as V (version) -- | the options this cli tool can take @@ -58,7 +56,7 @@ run options = do when (version options) $ do putStrLn V.version - exitWith ExitSuccess + exitSuccess let repo = fromMaybe "." (repository options) let entry = fromMaybe "main.json" (entrypoint options) @@ -68,7 +66,7 @@ run options = do Nothing -> error "Need a config file!" Just path -> LB.readFile path >>= \res -> case eitherDecode res :: Either String (LintConfig Identity) of - Left err -> error $ "config file invalid: " <> err + Left err -> error $ "config file invalid: " <> toText err Right file -> pure (patchConfig file (config options)) lints <- recursiveCheckDir lintconfig repo entry @@ -79,16 +77,14 @@ run options = do else printPretty (level, lints) case out options of - Nothing -> exitWith $ case resultIsFatal lintconfig lints of - False -> ExitSuccess - True -> ExitFailure 1 + Nothing -> exitWith $ if resultIsFatal lintconfig lints then ExitFailure 1 else ExitSuccess Just outpath -> do c <- writeAdjustedRepository lintconfig repo outpath lints unless (json options) $ case c of - ExitFailure 1 -> putStrLn "\nMap failed linting!" - ExitFailure 2 -> putStrLn "\nOutpath already exists, not writing anything." - _ -> pure () + ExitFailure 1 -> putTextLn "\nMap failed linting!" + ExitFailure 2 -> putTextLn "\nOutpath already exists, not writing anything." + _ -> pass exitWith c @@ -107,10 +103,10 @@ printLB a = T.putStrLn $ T.decodeUtf8 $ LB.toStrict a aesonWarning :: IO () aesonWarning = case coercionToHashMap of Just _ -> hPutStrLn stderr - "Warning: this program was compiled using an older version of the Aeson Library\n\ + ("Warning: this program was compiled using an older version of the Aeson Library\n\ \used for parsing JSON, which is susceptible to hash flooding attacks.\n\ \n\ \Recompiling with a newer version is recommended when handling untrusted inputs.\n\ \n\ - \See https://cs-syd.eu/posts/2021-09-11-json-vulnerability for details." - _ -> pure () + \See https://cs-syd.eu/posts/2021-09-11-json-vulnerability for details." :: Text) + _ -> pass diff --git a/src/Version.hs b/src/Version.hs index c0f7edf..2ec1537 100644 --- a/src/Version.hs +++ b/src/Version.hs @@ -3,10 +3,10 @@ module Version ( version ) where -import Control.Monad.Trans (liftIO) +import Universum + import qualified Language.Haskell.TH as TH import System.Process (readProcess) -import GHC.IO (catchAny) version :: String version = "walint rc3 2021 (" <> diff --git a/walint.cabal b/walint.cabal index caf3a4f..ae7f6aa 100644 --- a/walint.cabal +++ b/walint.cabal @@ -34,6 +34,8 @@ library Paths_walint hs-source-dirs: lib + default-extensions: + NoImplicitPrelude ghc-options: -Wall -Wno-name-shadowing -Wno-unticked-promoted-constructors build-depends: HList @@ -53,6 +55,7 @@ library , text , text-metrics , transformers + , universum , uri-encode , vector , witherable @@ -65,6 +68,8 @@ executable walint Paths_walint hs-source-dirs: src + default-extensions: + NoImplicitPrelude ghc-options: -Wall -Wno-name-shadowing -Wno-unticked-promoted-constructors build-depends: aeson @@ -76,6 +81,7 @@ executable walint , process , template-haskell , text + , universum , walint default-language: Haskell2010 @@ -91,7 +97,7 @@ executable walint-server server default-extensions: NoImplicitPrelude - ghc-options: -Wall -Wno-name-shadowing -Wno-unticked-promoted-constructors + ghc-options: -Wall -Wno-name-shadowing -Wno-unticked-promoted-constructors -rtsopts -threaded build-depends: aeson , async |