From 52bf0fa6dace596a4bd5b4e4229fbb9704fbf443 Mon Sep 17 00:00:00 2001 From: stuebinm Date: Fri, 18 Feb 2022 18:09:23 +0100 Subject: switch to universum prelude also don't keep adjusted maps around if not necessary --- lib/Badges.hs | 5 +-- lib/CheckDir.hs | 102 +++++++++++++++++++++++++++++---------------------- lib/CheckMap.hs | 59 +++++++++++++++++------------ lib/Dirgraph.hs | 43 +++++++++------------- lib/KindLinter.hs | 7 ++-- lib/LayerData.hs | 12 +++--- lib/LintConfig.hs | 32 ++++++++-------- lib/LintWriter.hs | 26 +++++-------- lib/Paths.hs | 31 ++++++++-------- lib/Properties.hs | 75 ++++++++++++++++++------------------- lib/Tiled.hs | 26 +++++-------- lib/TiledAbstract.hs | 16 ++++---- lib/Types.hs | 15 +++----- lib/Uris.hs | 44 +++++++++------------- lib/Util.hs | 19 +++------- lib/WriteRepo.hs | 16 ++++---- 16 files changed, 254 insertions(+), 274 deletions(-) (limited to 'lib') 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 -> -- cgit v1.2.3