From faa244e1a7e760be88054a5f15b3e115ad8e32e5 Mon Sep 17 00:00:00 2001 From: stuebinm Date: Thu, 17 Feb 2022 00:41:36 +0100 Subject: sprinkle some NFData everywhere (also some evaluateNF, leading to slightly less memory usage) --- lib/Badges.hs | 17 ++++++++++------- lib/CheckDir.hs | 13 ++++++++----- 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, 61 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 b9a3a31..652d58f 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, (.=)) @@ -36,6 +37,7 @@ import Types (Dep (Local, LocalMap), Hint (Hint), Level (..), hintLevel) import Util (PrettyPrint (prettyprint)) + -- 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 () @@ -52,19 +54,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 @@ -97,7 +100,7 @@ instance ToJSON DirResult where [ "missingDeps" .= dirresultDeps res , "missingAssets" .= dirresultMissingAssets res , "mapLints" .= dirresultMaps res - , "exitGraph" .= showDot (dirresultGraph res) + , "exitGraph" .= dirresultGraph res ] , "severity" .= maximumLintLevel res , "mapInfo" .= fmap (\tm -> A.object [ "badges" .= mapresultBadges tm ]) @@ -163,7 +166,7 @@ recursiveCheckDir config prefix root = do pure $ DirResult { dirresultDeps = missingDeps root maps' , dirresultMissingAssets = mAssets , dirresultMaps = maps' - , dirresultGraph = graphToDot exitGraph + , dirresultGraph = T.pack $ showDot $ graphToDot exitGraph } diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs index cfa4b6e..9dd0530 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') 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 ToJSON MapResult where toJSON res = A.object 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 -- cgit v1.2.3