From 53fb449b008e9b6aed9877b9d33f4026e454e0f9 Mon Sep 17 00:00:00 2001
From: stuebinm <stuebinm@disroot.org>
Date: Thu, 17 Feb 2022 00:41:36 +0100
Subject: [PATCH] sprinkle some NFData everywhere
(also some evaluateNF, leading to slightly less memory usage)
---
lib/Badges.hs | 17 ++++++++++-------
lib/CheckDir.hs | 14 +++++++++-----
lib/CheckMap.hs | 3 ++-
lib/Paths.hs | 6 +++++-
lib/Tiled.hs | 29 ++++++++++++++++-------------
lib/Types.hs | 7 ++++---
package.yaml | 2 +-
server/HtmlOrphans.hs | 3 +--
server/Server.hs | 17 ++++++++++++-----
server/Worker.hs | 1 +
walint.cabal | 2 +-
11 files changed, 62 insertions(+), 39 deletions(-)
diff --git a/lib/Badges.hs b/lib/Badges.hs
index 5da2643..c1a17b3 100644
--- a/lib/Badges.hs
+++ b/lib/Badges.hs
@@ -1,11 +1,14 @@
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
-- | module defining Badge types and utility functions
module Badges where
+import Control.DeepSeq (NFData)
import Data.Aeson (Options (fieldLabelModifier, sumEncoding),
SumEncoding (UntaggedValue), ToJSON (toJSON),
defaultOptions, genericToJSON, (.=))
@@ -27,10 +30,10 @@ data BadgeArea =
, areaWidth :: Double
, areaHeight :: Double
}
- deriving (Ord, Eq, Generic, Show)
+ deriving (Ord, Eq, Generic, Show, NFData)
newtype BadgeToken = BadgeToken Text
- deriving (Eq, Ord, Show)
+ deriving newtype (Eq, Ord, Show, NFData)
instance ToJSON BadgeArea where
toJSON = genericToJSON defaultOptions
@@ -46,7 +49,7 @@ parseToken text = if text =~ ("^[a-zA-Z0-9]{50}$" :: Text)
else Nothing
data Badge = Badge BadgeToken BadgeArea
- deriving (Ord, Eq, Generic, Show)
+ deriving (Ord, Eq, Generic, Show, NFData)
instance ToJSON Badge where
toJSON (Badge token area) = A.object $ case area of
diff --git a/lib/CheckDir.hs b/lib/CheckDir.hs
index eeb94a8..1aeb5e3 100644
--- a/lib/CheckDir.hs
+++ b/lib/CheckDir.hs
@@ -10,6 +10,7 @@
module CheckDir (maximumLintLevel, recursiveCheckDir, DirResult(..), MissingAsset(..), MissingDep(..), resultIsFatal) where
import CheckMap (MapResult (..), loadAndLintMap)
+import Control.DeepSeq (NFData)
import Control.Monad (void)
import Control.Monad.Extra (mapMaybeM)
import Data.Aeson (ToJSON, (.=))
@@ -38,6 +39,7 @@ import Types (Dep (Local, LocalMap), Hint (Hint),
Level (..), hintLevel)
import Util (PrettyPrint (prettyprint), ellipsis)
+
-- based on the startling observation that Data.Map has lower complexity
-- for difference than Data.Set, but the same complexity for fromList
type Set a = Map a ()
@@ -54,19 +56,20 @@ data DirResult = DirResult
-- ^ all dependencies to things outside this repository
, dirresultMissingAssets :: [MissingAsset]
-- ^ entrypoints of maps which are referred to but missing
- , dirresultGraph :: Dot ()
- } deriving (Generic)
+ , dirresultGraph :: Text
+ } deriving (Generic, NFData)
data MissingDep = MissingDep
{ depFatal :: Maybe Bool
, entrypoint :: Text
, neededBy :: [FilePath]
- } deriving (Generic, ToJSON)
+ } deriving (Generic, ToJSON, NFData)
-- | Missing assets are the same thing as missing dependencies,
-- but should not be confused (and also serialise differently
-- to json)
newtype MissingAsset = MissingAsset MissingDep
+ deriving (Generic, NFData)
-- | given this config, should the result be considered to have failed?
resultIsFatal :: LintConfig' -> DirResult -> Bool
@@ -105,7 +108,6 @@ instance ToJSON DirResult where
. foldr aggregateSameResults []
. M.toList
$ dirresultMaps res)
- -- unused in the hub, temporarily removed to make the output smaller
, "exitGraph" .= showDot (dirresultGraph res)
]
, "severity" .= maximumLintLevel res
@@ -178,7 +180,9 @@ recursiveCheckDir config prefix root = do
, dirresultMissingAssets = mAssets
, dirresultMaps = maps'
, dirresultGraph =
- graphToDot
+ T.pack
+ . showDot
+ . graphToDot
. takeSubGraph 7 root
$ exitGraph
}
diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs
index 885ee70..b6361b5 100644
--- a/lib/CheckMap.hs
+++ b/lib/CheckMap.hs
@@ -21,6 +21,7 @@ import GHC.Generics (Generic)
import Badges (Badge)
+import Control.DeepSeq (NFData)
import LintConfig (LintConfig (configAssemblyTag), LintConfig')
import LintWriter (LintResult, invertLintResult,
resultToAdjusted, resultToBadges,
@@ -55,7 +56,7 @@ data MapResult = MapResult
-- ^ badges that can be found on this map
, mapresultGeneral :: [Hint]
-- ^ general-purpose lints that didn't fit anywhere else
- } deriving (Generic)
+ } deriving (Generic, NFData)
instance Eq MapResult where
diff --git a/lib/Paths.hs b/lib/Paths.hs
index b9b0d50..15dc66b 100644
--- a/lib/Paths.hs
+++ b/lib/Paths.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
@@ -5,8 +7,10 @@
-- 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 qualified Data.Text as T
+import GHC.Generics (Generic)
import System.FilePath (splitPath)
import System.FilePath.Posix ((</>))
import Text.Regex.TDFA
@@ -16,7 +20,7 @@ import Util (PrettyPrint (prettyprint))
-- a path without any . or .. in it. Also possibly a
-- fragment, mostly for map links.
data RelPath = Path Int Text (Maybe Text)
- deriving (Show, Eq, Ord)
+ deriving (Show, Eq, Ord, NFData, Generic)
diff --git a/lib/Tiled.hs b/lib/Tiled.hs
index bca5f1a..ab7d4f4 100644
--- a/lib/Tiled.hs
+++ b/lib/Tiled.hs
@@ -1,5 +1,7 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
@@ -15,6 +17,7 @@
-- 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)
@@ -43,26 +46,26 @@ aesonOptions l = defaultOptions
-- | A globally indexed identifier.
newtype GlobalId = GlobalId { unGlobalId :: Int }
- deriving (Ord, Eq, Enum, Num, Generic, Show, FromJSON, ToJSON, FromJSONKey, ToJSONKey)
+ deriving newtype (Ord, Eq, Enum, Num, Show, FromJSON, ToJSON, FromJSONKey, ToJSONKey, NFData)
mkTiledId :: Int -> GlobalId
mkTiledId i = GlobalId { unGlobalId = i }
-- | A locally indexed identifier.
newtype LocalId = LocalId { unLocalId :: Int }
- deriving (Ord, Eq, Enum, Num, Generic, Show, FromJSON, ToJSON, FromJSONKey, ToJSONKey)
+ deriving newtype (Ord, Eq, Enum, Num, Show, FromJSON, ToJSON, FromJSONKey, ToJSONKey, NFData)
type Color = Text
-- | A custom tiled property, which just has a name and a value.
data Property = Property Text PropertyValue
- deriving (Eq, Generic, Show)
+ deriving (Eq, Generic, Show, NFData)
-- | The value of a custom tiled property.
-- It is strongly typed via a tag in the json representation,
-- and needs a custom ToJSON and FromJSON instance because of that.
data PropertyValue = StrProp Text | BoolProp Bool | IntProp Int | FloatProp Float
- deriving (Eq, Generic, Show)
+ deriving (Eq, Generic, Show, NFData)
instance IsString PropertyValue where
fromString s = StrProp (T.pack s)
@@ -111,7 +114,7 @@ instance ToJSON Property where
data Point = Point { pointX :: Double
, pointY :: Double
- } deriving (Eq, Generic, Show)
+ } deriving (Eq, Generic, Show, NFData)
instance FromJSON Point where
parseJSON = genericParseJSON (aesonOptions 5)
@@ -178,7 +181,7 @@ data Object = ObjectRectangle
, objectHeight :: Maybe Double
, objectEllipse :: Maybe Bool
, objectType :: Text
- } deriving (Eq, Generic, Show)
+ } deriving (Eq, Generic, Show, NFData)
@@ -226,7 +229,7 @@ data Layer = Layer { layerWidth :: Maybe Double
, layerStartX :: Maybe Int
, layerStartY :: Maybe Int
, layerColor :: Maybe Color
- } deriving (Eq, Generic, Show)
+ } deriving (Eq, Generic, Show, NFData)
instance FromJSON Layer where
parseJSON = genericParseJSON (aesonOptions 5)
@@ -238,7 +241,7 @@ data Terrain = Terrain { terrainName :: String
-- ^ Name of terrain
, terrainTile :: LocalId
-- ^ Local ID of tile representing terrain
- } deriving (Eq, Generic, Show)
+ } deriving (Eq, Generic, Show, NFData)
instance FromJSON Terrain where
parseJSON (A.Object o) = Terrain <$> o .: "name"
@@ -254,7 +257,7 @@ instance ToJSON Terrain where
data Frame = Frame { frameDuration :: Int
, frameTileId :: LocalId
- } deriving (Eq, Generic, Show)
+ } deriving (Eq, Generic, Show, NFData)
instance FromJSON Frame where
parseJSON (A.Object o) = Frame <$> o .: "duration"
@@ -277,7 +280,7 @@ data Tile = Tile { tileId :: Int
, tileProbability :: Maybe Float
, tileType :: Maybe Text
, tileTerrain :: Maybe [Int]
- } deriving (Eq, Generic, Show)
+ } deriving (Eq, Generic, Show, NFData)
instance FromJSON Tile where
parseJSON = genericParseJSON (aesonOptions 4)
@@ -331,10 +334,10 @@ data Tileset = Tileset { tilesetFirstgid :: GlobalId
, tilesetWangsets :: Maybe Value
, tilesetType :: Maybe Text
, tilesetFileName :: Maybe Text
- } deriving (Eq, Generic, Show)
+ } deriving (Eq, Generic, Show, NFData)
newtype TransitiveTilesetMap = TransitiveTilesetMap (Map LocalId Value)
- deriving (Show, Eq, Generic, FromJSON)
+ deriving newtype (Show, Eq, FromJSON)
instance FromJSON Tileset where
parseJSON = genericParseJSON (aesonOptions 7)
@@ -378,7 +381,7 @@ data Tiledmap = Tiledmap { tiledmapVersion :: Value
, tiledmapStaggerindex :: Maybe String
, tiledmapType :: String
, tiledmapEditorsettings :: Maybe Value
- } deriving (Eq, Generic, Show)
+ } deriving (Eq, Generic, Show, NFData)
instance FromJSON Tiledmap where
parseJSON = genericParseJSON (aesonOptions 8)
diff --git a/lib/Types.hs b/lib/Types.hs
index 588c8ea..43a5131 100644
--- a/lib/Types.hs
+++ b/lib/Types.hs
@@ -24,6 +24,7 @@ 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)
@@ -37,7 +38,7 @@ import WithCli.Pure (Argument (argumentType, parseArgumen
-- | Levels of errors and warnings, collectively called
-- "Hints" until I can think of some better name
data Level = Info | Suggestion | Warning | Forbidden | Error | Fatal
- deriving (Show, Generic, Ord, Eq, ToJSON, FromJSON)
+ deriving (Show, Generic, Ord, Eq, ToJSON, FromJSON, NFData)
instance Argument Level where
argumentType Proxy = "Lint Level"
@@ -60,12 +61,12 @@ data Lint = Depends Dep | Offers Text | Lint Hint | Badge Badge
deriving (Ord, Eq, Generic, ToJSONKey)
data Dep = Local RelPath | Link Text | MapLink Text | LocalMap RelPath
- deriving (Generic, Ord, Eq)
+ deriving (Generic, Ord, Eq, NFData)
data Hint = Hint
{ hintLevel :: Level
, hintMsg :: Text
- } deriving (Generic, Ord, Eq)
+ } deriving (Generic, Ord, Eq, NFData)
-- | shorter constructor (called hint because (a) older name and
-- (b) lint also exists and is monadic)
diff --git a/package.yaml b/package.yaml
index ac13e9a..7cd6130 100644
--- a/package.yaml
+++ b/package.yaml
@@ -26,6 +26,7 @@ library:
- getopt-generics
- regex-tdfa
- extra
+ - deepseq
- witherable
- dotgen
- text-metrics
@@ -78,7 +79,6 @@ executables:
- microlens-platform
- fmt
- tomland
- - dotgen
- stm
- async
- cryptohash-sha1
diff --git a/server/HtmlOrphans.hs b/server/HtmlOrphans.hs
index c9fa852..ebe65aa 100644
--- a/server/HtmlOrphans.hs
+++ b/server/HtmlOrphans.hs
@@ -29,7 +29,6 @@ import Lucid.Html5 (a_, body_, class_, code_, div_, em_, h1_, h2_,
import Server (JobStatus (..), Org (orgSlug),
RemoteRef (reporef, repourl), prettySha,
unState)
-import Text.Dot (showDot)
import Types (Hint (Hint), Level (..))
@@ -139,7 +138,7 @@ instance ToHtml DirResult where
"\
\d3.select(\"#exitGraph\")\n\
\ .graphviz()\n\
- \ .dot(\"" <> toText (escapeJSON $ showDot dirresultGraph) <> "\")\n\
+ \ .dot(\"" <> toText (escapeJSON $ toString dirresultGraph) <> "\")\n\
\ .render()\n\
\"
diff --git a/server/Server.hs b/server/Server.hs
index f89dc7b..f2b286b 100644
--- a/server/Server.hs
+++ b/server/Server.hs
@@ -3,6 +3,7 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
@@ -15,6 +16,7 @@
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
module Server ( loadConfig
, Org(..)
@@ -57,7 +59,7 @@ data RemoteRef = RemoteRef
, reporef :: Text
, reponame :: Text
-- ^ the "world name" for the hub / world:// links
- } deriving (Generic, FromJSON, ToJSON, Eq, Ord, Show)
+ } deriving (Generic, FromJSON, ToJSON, Eq, Ord, Show, NFData)
type family ConfigRes (b :: Bool) a where
ConfigRes True a = a
@@ -65,7 +67,7 @@ type family ConfigRes (b :: Bool) a where
-- | the internal text is actually already base64-encoded
newtype Sha1 = Sha1 Text
- deriving newtype (Eq, Show, Ord, FromHttpApiData, ToJSON)
+ deriving newtype (Eq, Show, Ord, FromHttpApiData, ToJSON, NFData)
-- | base64-encoded sha1
prettySha :: Sha1 -> Text
@@ -88,7 +90,9 @@ data Org (loaded :: Bool) = Org
, orgRepos :: [RemoteRef]
, orgUrl :: Text
, orgWebdir :: Text
- } deriving Generic
+ } deriving (Generic)
+
+instance NFData LintConfig' => NFData (Org True)
-- | Orgs are compared via their slugs only
-- TODO: the server should probably refuse to start if two orgs have the
@@ -159,7 +163,7 @@ configCodec = Config
-- | a job status (of a specific uuid)
data JobStatus =
Pending | Linted !DirResult Text | Failed Text
- deriving (Generic, ToJSON)
+ deriving (Generic, ToJSON, NFData)
instance TS.Show JobStatus where
show = \case
@@ -171,6 +175,9 @@ instance TS.Show JobStatus where
-- stuff in here, hence the newtype
newtype ServerState = ServerState
{ _unState :: Map (Org True) (Map Sha1 (RemoteRef, JobStatus)) }
+ deriving Generic
+
+instance NFData LintConfig' => NFData ServerState
makeLenses ''ServerState
@@ -204,7 +211,7 @@ setJobStatus mvar !org !ref !status = do
-- will otherwise cause a thunk leak, since Data.Map is annoyingly un-strict
-- even in its strict variety. for some reason it also doesn't work when
-- moved inside the `over` though …
- _ <- evaluateWHNF (view (unState . ix org) state)
+ _ <- evaluateNF (view (unState . ix org) state)
pure $ over (unState . ix org . at (toSha ref))
(const $ Just (ref, status)) state
diff --git a/server/Worker.hs b/server/Worker.hs
index b5d71fc..91fa8e2 100644
--- a/server/Worker.hs
+++ b/server/Worker.hs
@@ -66,6 +66,7 @@ runJob config Job {..} done = do
callgit gitdir [ "worktree", "add", "--force", workdir, toString ref ]
res <- recursiveCheckDir (orgLintconfig jobOrg) workdir (orgEntrypoint jobOrg)
+ >>= evaluateNF
setJobStatus done jobOrg jobRef $
Linted res rev
diff --git a/walint.cabal b/walint.cabal
index c2a19a1..caf3a4f 100644
--- a/walint.cabal
+++ b/walint.cabal
@@ -41,6 +41,7 @@ library
, base
, bytestring
, containers
+ , deepseq
, dotgen
, either
, extra
@@ -101,7 +102,6 @@ executable walint-server
, containers
, cryptohash-sha1
, directory
- , dotgen
, extra
, filepath
, fmt
--
GitLab