From 52bf0fa6dace596a4bd5b4e4229fbb9704fbf443 Mon Sep 17 00:00:00 2001
From: stuebinm <stuebinm@disroot.org>
Date: Fri, 18 Feb 2022 18:09:23 +0100
Subject: [PATCH] switch to universum prelude
also don't keep adjusted maps around if not necessary
---
.hlint.yaml | 3 --
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 +++----
package.yaml | 5 ++-
server/HtmlOrphans.hs | 2 +-
server/Server.hs | 5 ++-
server/Worker.hs | 5 ++-
src/Main.hs | 30 ++++++-------
src/Version.hs | 4 +-
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
--
GitLab