diff options
| -rw-r--r-- | .hlint.yaml | 3 | ||||
| -rw-r--r-- | lib/Badges.hs | 5 | ||||
| -rw-r--r-- | lib/CheckDir.hs | 102 | ||||
| -rw-r--r-- | lib/CheckMap.hs | 59 | ||||
| -rw-r--r-- | lib/Dirgraph.hs | 43 | ||||
| -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 | 75 | ||||
| -rw-r--r-- | lib/Tiled.hs | 26 | ||||
| -rw-r--r-- | lib/TiledAbstract.hs | 16 | ||||
| -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, 287 insertions, 303 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 1aeb5e3..a19a412 100644 --- a/lib/CheckDir.hs +++ b/lib/CheckDir.hs @@ -1,29 +1,35 @@ -{-# 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.Bifunctor (first) -import Data.Foldable (fold) -import Data.Functor ((<&>)) -import Data.List (partition) -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, takeSubGraph, unreachableFrom) @@ -34,7 +40,8 @@ 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), ellipsis) @@ -49,15 +56,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 @@ -71,8 +81,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 @@ -80,11 +96,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) @@ -96,7 +112,7 @@ maximumLintLevel res -instance ToJSON DirResult where +instance ToJSON (DirResult a) where toJSON res = A.object [ "result" .= A.object [ "missingDeps" .= dirresultDeps res @@ -127,7 +143,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)) @@ -135,9 +151,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) = @@ -145,7 +161,7 @@ instance PrettyPrint MissingDep where <> prettyDependents <> "\n" where prettyDependents = - T.intercalate "," $ map T.pack n + T.intercalate "," $ map toText n -- | check an entire repository @@ -155,7 +171,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 @@ -170,7 +186,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 @@ -180,7 +196,7 @@ recursiveCheckDir config prefix root = do , dirresultMissingAssets = mAssets , dirresultMaps = maps' , dirresultGraph = - T.pack + toText . showDot . graphToDot . takeSubGraph 7 root @@ -190,9 +206,9 @@ recursiveCheckDir config prefix root = do -- | 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? @@ -202,19 +218,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 @@ -222,7 +238,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) @@ -234,9 +250,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 b6361b5..23267a8 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 (configAssemblyTag), 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,16 +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 Eq MapResult where + +instance Eq (MapResult a) where a == b = mapresultLayer a == mapresultLayer b && mapresultTileset a == mapresultTileset b && @@ -67,7 +77,7 @@ instance Eq MapResult where mapresultGeneral a == mapresultGeneral b -instance ToJSON MapResult where +instance ToJSON (MapResult a) where toJSON res = A.object [ "layer" .= CollectedLints (mapresultLayer res) , "tileset" .= CollectedLints (mapresultTileset res) @@ -85,13 +95,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 @@ -99,7 +112,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 @@ -184,7 +197,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 @@ -195,7 +208,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 " @@ -207,7 +220,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 8d4a5f2..fe9dc96 100644 --- a/lib/Dirgraph.hs +++ b/lib/Dirgraph.hs @@ -1,26 +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_, unless) -import Data.Functor ((<&>)) -import Data.Map.Strict (Map, mapMaybeWithKey, mapWithKey, - traverseMaybeWithKey, traverseWithKey) -import qualified Data.Map.Strict as M -import Data.Maybe (fromMaybe) -import Data.Set (Set, (\\)) -import qualified Data.Set as S -import Paths (normalise) -import qualified System.FilePath as FP -import System.FilePath.Posix (takeDirectory, (</>)) -import Text.Dot (Dot, (.->.)) -import qualified Text.Dot as D -import Types (Dep (LocalMap)) -import Witherable (mapMaybe) +import CheckMap (MapResult (mapresultDepends)) +import Data.Map.Strict (mapMaybeWithKey, mapWithKey, traverseWithKey) +import qualified Data.Map.Strict as M +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)) -- | a simple directed graph type Graph a = Map a (Set a) @@ -29,18 +24,16 @@ nodes :: Graph a -> Set a nodes = M.keysSet -- | simple directed graph of exits -resultToGraph :: Map FilePath MapResult -> Graph FilePath -resultToGraph = mapWithKey (\p r -> S.fromList - . mapMaybe (onlyLocalMaps (takeDirectory p)) - . mapresultDepends $ r) - where onlyLocalMaps prefix = \case - LocalMap path -> Just (FP.normalise (prefix </> normalise "" path)) +resultToGraph :: Map FilePath (MapResult a) -> Graph FilePath +resultToGraph = fmap (S.fromList . mapMaybe onlyLocalMaps . mapresultDepends) + where onlyLocalMaps = \case + LocalMap path -> Just (normalise "" path) _ -> Nothing -- | 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 9cde1ec..eb31403 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 (..), @@ -27,14 +30,9 @@ import Util (mkProxy, naiveEscapeHTML, 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 (..)) @@ -86,7 +84,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 @@ -144,10 +142,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"] @@ -192,14 +190,14 @@ checkTileset = do adjust (\t -> t { tilesetTiles = tiles' }) -- check individual tileset properties - mapM_ checkTilesetProperty (fromMaybe mempty $ tilesetProperties tileset) + mapM_ checkTilesetProperty (maybeToMonoid $ tilesetProperties tileset) case tilesetTiles tileset of Nothing -> pure () Just tiles -> refuseDoubledThings tileId -- can't set properties on the same tile twice (\tile -> complain $ "cannot set properties on the \ - \tile with the id" <> showText (tileId tile) <> "twice.") + \tile with the id" <> show (tileId tile) <> "twice.") tiles where @@ -258,14 +256,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." @@ -316,7 +314,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 @@ -525,7 +523,7 @@ checkTileThing removeExits 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 @@ -549,9 +547,8 @@ checkTileThing removeExits 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 @@ -560,10 +557,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 @@ -591,15 +588,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) @@ -777,4 +774,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 5589207..f55e75e 100644 --- a/lib/TiledAbstract.hs +++ b/lib/TiledAbstract.hs @@ -2,10 +2,8 @@ module TiledAbstract where -import Data.Maybe (fromMaybe) -import Data.Proxy (Proxy) -import Data.Text (Text) -import Data.Vector (Vector) +import Universum + import qualified Data.Vector as V import Tiled (GlobalId, Layer (..), Object (..), Property (..), PropertyValue (..), Tile (..), Tiledmap (..), @@ -17,27 +15,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 ffd9faa..1ffbbe5 100644 --- a/lib/Util.hs +++ b/lib/Util.hs @@ -6,31 +6,24 @@ -- 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 @@ -44,7 +37,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 @@ -53,8 +46,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 @@ -70,7 +63,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 -- | for long lists which shouldn't be printed out in their entirety 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 f0a6c09..bf39564 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -7,18 +7,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, DirResult (dirresultGraph)) import Control.Monad (when) @@ -28,6 +25,7 @@ import Util (printPretty) import WriteRepo (writeAdjustedRepository) import Text.Dot (showDot) +import System.Exit (ExitCode (ExitFailure, ExitSuccess)) import qualified Version as V (version) -- | the options this cli tool can take @@ -62,7 +60,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) @@ -72,7 +70,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 @@ -85,16 +83,14 @@ run options = do | otherwise -> 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 @@ -113,10 +109,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 |