sprinkle some NFData everywhere

(also some evaluateNF, leading to slightly less memory usage)

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