summaryrefslogtreecommitdiff
path: root/server
diff options
context:
space:
mode:
authorstuebinm2022-02-18 18:09:23 +0100
committerstuebinm2022-02-18 18:09:23 +0100
commit7c49e6c367c9d021f3630c08a4a13ba9abc5df08 (patch)
treec278d23a6e39c353f5aa02d1ce9785122e1eea62 /server
parentfaa244e1a7e760be88054a5f15b3e115ad8e32e5 (diff)
switch to universum prelude
also don't keep adjusted maps around if not necessary
Diffstat (limited to '')
-rw-r--r--server/HtmlOrphans.hs2
-rw-r--r--server/Server.hs5
-rw-r--r--server/Worker.hs5
3 files changed, 8 insertions, 4 deletions
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