Commit 5d5300cd authored by Alexandre Delanoë's avatar Alexandre Delanoë

[CLEAN] return -> pure to make hlint happier

parent 8b1b7d15
......@@ -84,9 +84,9 @@ startGargantext mode port file = withLoggerHoisted mode $ \logger -> do
where runDbCheck env = do
r <- runExceptT (runReaderT DB.dbCheck env) `catch`
(\(_ :: SomeException) -> return $ Right False)
(\(_ :: SomeException) -> pure $ Right False)
case r of
Right True -> return ()
Right True -> pure ()
_ -> panic $
"You must run 'gargantext-init " <> pack file <>
"' before running gargantext-server (only the first time)."
......@@ -246,7 +246,7 @@ makeApp env = do
serv <- server env
(ekgStore, ekgMid) <- newEkgStore api
ekgDir <- (</> "ekg-assets") <$> getDataDir
return $ ekgMid $ serveWithContext apiWithEkg cfg
pure $ ekgMid $ serveWithContext apiWithEkg cfg
(ekgServer ekgDir ekgStore :<|> serv)
where
cfg :: Servant.Context AuthContext
......
......@@ -40,7 +40,7 @@ newEkgStore api = do
registerGcMetrics s
registerCounter "ekg.server_timestamp_ms" getTimeMs s -- used by UI
mid <- monitorEndpoints api s
return (s, mid)
pure (s, mid)
where getTimeMs = (round . (* 1000)) `fmap` getPOSIXTime
......
......@@ -97,7 +97,7 @@ getJson :: HasNodeStory env err m =>
getJson lId = do
lst <- getNgramsList lId
let (NodeId id') = lId
return $ addHeader (concat [ "attachment; filename=GarganText_NgramsList-"
pure $ addHeader (concat [ "attachment; filename=GarganText_NgramsList-"
, pack $ show id'
, ".json"
]
......@@ -108,7 +108,7 @@ getCsv :: HasNodeStory env err m =>
getCsv lId = do
lst <- getNgramsList lId
let (NodeId id') = lId
return $ case Map.lookup TableNgrams.NgramsTerms lst of
pure $ case Map.lookup TableNgrams.NgramsTerms lst of
Nothing -> noHeader Map.empty
Just (Versioned { _v_data }) ->
addHeader (concat [ "attachment; filename=GarganText_NgramsList-"
......
......@@ -443,7 +443,7 @@ instance ToSchema a => ToSchema (Replace a) where
declareNamedSchema (_ :: Proxy (Replace a)) = do
-- TODO Keep constructor is not supported here.
aSchema <- declareSchemaRef (Proxy :: Proxy a)
return $ NamedSchema (Just "Replace") $ mempty
pure $ NamedSchema (Just "Replace") $ mempty
& type_ ?~ SwaggerObject
& properties .~
InsOrdHashMap.fromList
......@@ -473,7 +473,7 @@ instance ToSchema NgramsPatch where
childrenSch <- declareSchemaRef (Proxy :: Proxy (PatchMSet NgramsTerm))
listSch <- declareSchemaRef (Proxy :: Proxy (Replace ListType))
nreSch <- declareSchemaRef (Proxy :: Proxy NgramsRepoElement)
return $ NamedSchema (Just "NgramsPatch") $ mempty
pure $ NamedSchema (Just "NgramsPatch") $ mempty
& type_ ?~ SwaggerObject
& properties .~
InsOrdHashMap.fromList
......
......@@ -69,5 +69,5 @@ instance Arbitrary Datafield where
instance ToSchema Datafield where
declareNamedSchema _ = do
return $ NamedSchema (Just "Datafield") $ mempty
pure $ NamedSchema (Just "Datafield") $ mempty
& type_ ?~ SwaggerObject
......@@ -56,7 +56,7 @@ instance Arbitrary ShareNodeParams where
------------------------------------------------------------------------
-- TODO permission
-- TODO refactor userId which is used twice
-- TODO change return type for better warning/info/success/error handling on the front
-- TODO change pure type for better warning/info/success/error handling on the front
api :: (HasNodeError err, HasNLPServer env, CmdRandom env err m)
=> User
-> NodeId
......
......@@ -16,7 +16,7 @@ def fast_maximal_cliques(g):
def rec_maximal_cliques(g, subv):
mc = []
if subv == []: # stop condition
return [[]]
pure [[]]
else :
for i in range(len(subv)):
newsubv = [j for j in subv[i+1:len(subv)]
......@@ -25,7 +25,7 @@ def fast_maximal_cliques(g):
for x in mci:
x.append(subv[i])
mc.append(x)
return mc
pure mc
def purge(clust):
clustset = [set(x) for x in clust]
......@@ -37,13 +37,13 @@ def fast_maximal_cliques(g):
ok = False
if ok and (not (clustset[i] in new_clust)):
new_clust.append(clustset[i])
return [list(x) for x in new_clust]
pure [list(x) for x in new_clust]
# to optimize : rank the vertices on the degrees
subv = [(v.index, v.degree()) for v in g.vs()]
subv.sort(key = lambda z:z[1])
subv = [x for (x, y) in subv]
return purge(rec_maximal_cliques(g, subv))
pure purge(rec_maximal_cliques(g, subv))
-}
......
......@@ -662,7 +662,7 @@ readNodeStoryEnv pool = do
-- printDebug "[readNodeStoryEnv] saver" mv
-- let mv' = clearHistory mv
-- printDebug "[readNodeStoryEnv] saver, cleared" mv'
-- return mv'
-- pure mv'
pure $ NodeStoryEnv { _nse_var = mvar
, _nse_saver = saver
, _nse_saver_immediate = saver_immediate
......
......@@ -30,7 +30,7 @@ import qualified Text.ParserCombinators.Parsec (parse)
-- | Permit to transform a String to an Int in a monadic context
wrapDST :: Monad m => String -> m Int
wrapDST = return . decimalStringToInt
wrapDST = pure . decimalStringToInt
-- | Generic parser which take at least one element not given in argument
many1NoneOf :: Stream s m Char => [Char] -> ParsecT s u m [Char]
......@@ -50,7 +50,7 @@ parseGregorian = do
_ <- char '-'
d <- wrapDST =<< many1NoneOf ['T']
_ <- char 'T'
return $ fromGregorian (toInteger y) m d
pure $ fromGregorian (toInteger y) m d
---- | Parser for time format h:m:s
parseTimeOfDay :: Parser TimeOfDay
......@@ -64,7 +64,7 @@ parseTimeOfDay = do
dec <- many1NoneOf ['+', '-']
let (nb, l) = (decimalStringToInt $ r ++ dec, length dec)
seconds = nb * 10^(12-l)
return $ TimeOfDay h m (MkFixed . toInteger $ seconds)
pure $ TimeOfDay h m (MkFixed . toInteger $ seconds)
-- | Parser for timezone format +hh:mm
......@@ -75,7 +75,7 @@ parseTimeZone = do
_ <- char ':'
m <- wrapDST =<< (many1 $ anyChar)
let timeInMinute = if sign == '+' then h * 60 + m else -h * 60 - m
in return $ TimeZone timeInMinute False "CET"
in pure $ TimeZone timeInMinute False "CET"
---- | Parser which use parseGregorian, parseTimeOfDay and parseTimeZone to create a ZonedTime
parseZonedTime :: Parser ZonedTime
......@@ -83,7 +83,7 @@ parseZonedTime= do
d <- parseGregorian
tod <- parseTimeOfDay
tz <- parseTimeZone
return $ ZonedTime (LocalTime d (tod)) tz
pure $ ZonedTime (LocalTime d (tod)) tz
---- | Opposite of toRFC3339
fromRFC3339 :: Text -> Either ParseError ZonedTime
......
......@@ -63,7 +63,7 @@ fieldTuple = do
constP :: Parser a -> ByteString -> Parser a
constP p t = case parseOnly p t of
Left _ -> empty
Right a -> return a
Right a -> pure a
parseOf :: Parser ByteString -> Parser a -> Parser a
parseOf ptxt pa = bothParse <|> empty
......
......@@ -52,7 +52,7 @@ parseRevision :: MonadThrow m => ConduitT Event o m (Maybe T.Text)
parseRevision = tagNoAttr "{http://www.mediawiki.org/xml/export-0.10/}revision" $ do
text <- force "text is missing" $ ignoreExcept "{http://www.mediawiki.org/xml/export-0.10/}text" content
many_ ignoreAnyTreeContent
return text
pure text
-- | Utility function that matches everything but the tag given
tagUntil :: Name -> NameMatcher Name
......@@ -95,7 +95,7 @@ parsePage =
revision <-
parseRevision
many_ $ ignoreAnyTreeContent
return $ Page { _markupFormat = Mediawiki
pure $ Page { _markupFormat = Mediawiki
, _title = title
, _text = revision }
......@@ -110,14 +110,14 @@ mediawikiPageToPlain :: Page -> IO Page
mediawikiPageToPlain page = do
title <- mediaToPlain $ _title page
revision <- mediaToPlain $ _text page
return $ Page { _markupFormat = Plaintext, _title = title, _text = revision }
pure $ Page { _markupFormat = Plaintext, _title = title, _text = revision }
where mediaToPlain media =
case media of
(Nothing) -> return Nothing
(Nothing) -> pure Nothing
(Just med) -> do
res <- runIO $ do
doc <- readMediaWiki def med
writePlain def doc
case res of
(Left _) -> return Nothing
(Right r) -> return $ Just r
(Left _) -> pure Nothing
(Right r) -> pure $ Just r
......@@ -74,7 +74,7 @@ restrictListSize corpusId listId ngramsType listType size = do
ngrams' <- filterWith listType size occurrences ngrams
_ <- setListNgrams listId ngramsType ngrams'
return ()
pure ()
where filterWith :: ListType -> Int -> HashMap NgramsTerm Int
-> HashMap NgramsTerm NgramsRepoElement
......
......@@ -46,7 +46,7 @@ dicoStruct :: (Integral r, Monad m) => M.Map t r -> m r
dicoStruct dict_occ = do
let keys_size = toInteger $ length $ M.keys dict_occ
let total_occ = sum $ Prelude.map (\(x, y) -> y) $ M.toList dict_occ
return $ div total_occ (fromIntegral keys_size)
pure $ div total_occ (fromIntegral keys_size)
-- heterogeinity sur UCT (Unité de Context Textuel)
heterogeinity :: [Char] -> IO Integer
......@@ -56,7 +56,7 @@ heterogeinity string = do
let keys_size = toInteger $ length $ M.keys dict_occ
let total_occ = sum $ Prelude.map (\(x, y) -> y) $ M.toList dict_occ
return $ div total_occ (fromIntegral keys_size)
pure $ div total_occ (fromIntegral keys_size)
--computeHeterogeinity
......@@ -79,6 +79,6 @@ main2 = do
]
r <- Prelude.map computeHeterogeinity $ Prelude.map (\(t,id) -> id) corpus_ids
return r
pure r
......@@ -83,7 +83,7 @@ statefulReplace predicate str end replacement
replaceEnd :: Eq a => ([a] -> Bool) -> [a] -> [a] -> [a] -> Maybe [a]
replaceEnd predicate str end replacement = do
result <- statefulReplace predicate str end replacement
return (either identity identity result)
pure (either identity identity result)
findStem
:: (Foldable t, Functor t, Eq a) =>
......@@ -103,7 +103,7 @@ beforeStep1b :: [Char] -> Either [Char] [Char]
beforeStep1b word = fromMaybe (Left word) result
where
cond23 x = do { v <- x; either (const Nothing) (return . Right) v }
cond1 x = do { v <- x; return (Left v) }
cond1 x = do { v <- x; pure (Left v) }
result =
cond1 (replaceEnd (measureGT 0) word "eed" "ee") `mplus`
cond23 (statefulReplace containsVowel word "ed" "" ) `mplus`
......
......@@ -131,7 +131,7 @@ negatives x | "n't" `T.isSuffixOf` x = E [ Right . T.reverse . T.drop 3 . T.reve
-- | Currently deals with: 'm, 's, 'd, 've, 'll
contractions :: Tokenizer
contractions x = case catMaybes . map (splitSuffix x) $ cts of
[] -> return x
[] -> pure x
((w,s):_) -> E [ Right w,Left s]
where cts = ["'m","'s","'d","'ve","'ll"]
splitSuffix w sfx =
......@@ -151,7 +151,7 @@ instance Monad (EitherList a) where
E xs >>= f = E $ concatMap (either (return . Left) (unE . f)) xs
instance Applicative (EitherList a) where
pure x = return x
pure = pure
f <*> x = f `ap` x
instance Functor (EitherList a) where
......
......@@ -62,7 +62,7 @@ randomString num = do
pure $ pack str
-- | Given a list of items of type 'a', return list with unique items
-- | Given a list of items of type 'a', pure list with unique items
-- (like List.nub) but tuple-d with their counts in the original list
groupWithCounts :: (Ord a, Eq a) => [a] -> [(a, Int)]
groupWithCounts = map f
......
......@@ -65,4 +65,4 @@ parseJSONFromString v = do
numString <- parseJSON v
case readMaybe (numString :: String) of
Nothing -> fail $ "Invalid number for TransactionID: " ++ show v -- TODO error message too specific
Just n -> return n
Just n -> pure n
......@@ -117,7 +117,7 @@ cooc2graphWith' :: Partitions
-> IO Graph
cooc2graphWith' _doPartitions _bridgenessMethod multi similarity threshold strength myCooc = do
let (distanceMap, diag, ti) = doSimilarityMap similarity threshold strength myCooc
distanceMap `seq` diag `seq` ti `seq` return ()
distanceMap `seq` diag `seq` ti `seq` pure ()
partitions <- if (Map.size distanceMap > 0)
then recursiveClustering' (spinglass' 1) distanceMap
......@@ -129,7 +129,7 @@ cooc2graphWith' _doPartitions _bridgenessMethod multi similarity threshold stren
, "Follow the available tutorials on the Training EcoSystems."
, "Ask your co-users of GarganText how to have access to it."
]
length partitions `seq` return ()
length partitions `seq` pure ()
let
!confluence' = BAC.computeConfluences 3 (Map.keys distanceMap) True
......@@ -140,7 +140,7 @@ cooc2graphWith' _doPartitions _bridgenessMethod multi similarity threshold stren
{-
cooc2graphWith' _doPartitions _bridgenessMethod multi similarity@Distributional threshold strength myCooc = do
let (distanceMap, diag, ti) = doSimilarityMap similarity threshold strength myCooc
distanceMap `seq` diag `seq` ti `seq` return ()
distanceMap `seq` diag `seq` ti `seq` pure ()
partitions <- if (Map.size distanceMap > 0)
then recursiveClustering (spinglass 1) distanceMap
......@@ -148,7 +148,7 @@ cooc2graphWith' _doPartitions _bridgenessMethod multi similarity@Distributional
, "Maybe you should add more Map Terms in your list"
, "Tutorial: TODO"
]
length partitions `seq` return ()
length partitions `seq` pure ()
let
!confluence' = BAC.computeConfluences 3 (Map.keys distanceMap) True
......
......@@ -229,7 +229,7 @@ instance DefaultFromField SqlJsonb HyperdataGraph
defaultFromField = fromPGSFromField
-----------------------------------------------------------
-- This type is used to return graph via API
-- This type is used to pure graph via API
-- hyperdataGraphAPI field is not a Maybe anymore – graph is always computed
data HyperdataGraphAPI =
HyperdataGraphAPI { _hyperdataAPIGraph :: Graph
......
......@@ -616,7 +616,7 @@ separateBranches fdt similarity lambda frequency minBranch thr rise timescale do
((map (\e -> (e,True)) (fst branches')) ++ (map (\e -> (e,False)) (snd branches'))))
else [currentBranch])
in
-- 6) if there is no more branch to separate tne return [done'] else continue with [rest]
-- 6) if there is no more branch to separate tne pure [done'] else continue with [rest]
if null rest
then done'
else separateBranches fdt similarity lambda frequency minBranch thr rise timescale docs coocs roots periods
......
......@@ -116,7 +116,7 @@ searchInCorpusWithNgrams _cId _lId _t _ngt _q _o _l _order = undefined
-- | Compute TF-IDF for all 'ngramIds' in given 'CorpusId'. In this
-- case only the "TF" part makes sense and so we only compute the
-- ratio of "number of times our terms appear in given document" and
-- "number of all terms in document" and return a sorted list of
-- "number of all terms in document" and pure a sorted list of
-- document ids
_tfidfAll :: (HasDBid NodeType, HasNodeError err) => CorpusId -> [Int] -> DBCmd err [Int]
_tfidfAll cId ngramIds = do
......
......@@ -51,7 +51,7 @@ triggerSearchUpdate = execPGSQuery query ( toDBid NodeDocument
ELSE
new.search := to_tsvector( 'english' , new.hyperdata::jsonb );
END IF;
return new;
pure new;
end
$$ LANGUAGE plpgsql;
......
......@@ -225,7 +225,7 @@ instance FromField NodeId where
fromField field mdata = do
n <- fromField field mdata
if (n :: Int) > 0
then return $ NodeId n
then pure $ NodeId n
else mzero
instance ToSchema NodeId
......
......@@ -188,7 +188,7 @@ onDisk_1 action fp = do
liftBase $ action (toFilePath dataPath fp) `catch` handleExists
where
handleExists e
| isDoesNotExistError e = return ()
| isDoesNotExistError e = pure ()
| otherwise = throwIO e
......@@ -207,6 +207,6 @@ onDisk_2 action fp1 fp2 = do
liftBase $ action fp1' fp2' `catch` handleExists
where
handleExists e
| isDoesNotExistError e = return ()
| isDoesNotExistError e = pure ()
| otherwise = throwIO e
------------------------------------------------------------------------
......@@ -141,7 +141,7 @@ runOpaQuery q = mkCmd $ \c -> runSelect c q
runCountOpaQuery :: Select a -> DBCmd err Int
runCountOpaQuery q = do
counts <- mkCmd $ \c -> runSelect c $ countRows q
-- countRows is guaranteed to return a list with exactly one row so DL.head is safe here
-- countRows is guaranteed to pure a list with exactly one row so DL.head is safe here
pure $ fromInt64ToInt $ DL.head counts
formatPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err DB.ByteString
......@@ -231,8 +231,8 @@ dbCheck :: CmdM env err m => m Bool
dbCheck = do
r :: [PGS.Only Text] <- runPGSQuery_ "select username from public.auth_user"
case r of
[] -> return False
_ -> return True
[] -> pure False
_ -> pure True
restrictMaybe :: ( Default Opaleye.Internal.Operators.IfPP b b
, (Default Opaleye.Internal.Constant.ToFields Bool b))
......
......@@ -58,7 +58,7 @@ inputSqlTypes :: [Text]
inputSqlTypes = ["int4","int4","int4","int4"]
-- | SQL query to add documents
-- TODO return id of added documents only
-- TODO pure id of added documents only
queryAdd :: Query
queryAdd = [sql|
WITH input_rows(node_id,context_id,score,category) AS (?)
......
......@@ -159,7 +159,7 @@ queryInsert = [sql|
, ins AS (
INSERT INTO contexts (hash_id, typename,user_id,parent_id,name,date,hyperdata)
SELECT * FROM input_rows
ON CONFLICT (hash_id) DO NOTHING -- on unique index -- this does not return the ids
ON CONFLICT (hash_id) DO NOTHING -- on unique index -- this does not pure the ids
RETURNING id,hash_id
)
......@@ -182,7 +182,7 @@ queryInsert = [sql|
-- | When documents are inserted
-- ReturnType after insertion
data ReturnId = ReturnId { reInserted :: Bool -- if the document is inserted (True: is new, False: is not new)
, reId :: NodeId -- always return the id of the document (even new or not new)
, reId :: NodeId -- always pure the id of the document (even new or not new)
-- this is the uniq id in the database
, reUniqId :: Text -- Hash Id with concatenation of sha parameters
} deriving (Show, Generic)
......
......@@ -31,7 +31,7 @@ import Gargantext.Database.Query.Table.Node.Error
updateHyperdata :: HyperdataC a => NodeId -> a -> DBCmd err Int64
updateHyperdata i h = mkCmd $ \c -> putStrLn "before runUpdate_" >>
runUpdate_ c (updateHyperdataQuery i h) >>= \res ->
putStrLn "after runUpdate_" >> return res
putStrLn "after runUpdate_" >> pure res
updateHyperdataQuery :: HyperdataC a => NodeId -> a -> Update Int64
updateHyperdataQuery i h = seq h' $ {- trace "updateHyperdataQuery: encoded JSON" $ -} Update
......
......@@ -192,7 +192,7 @@ getContextsForNgramsTerms cId ngramsTerms = do
-- | Query the `context_node_ngrams` table and return ngrams for given
-- | Query the `context_node_ngrams` table and pure ngrams for given
-- `context_id` and `list_id`.
-- WARNING: `context_node_ngrams` can be outdated. This is because it
-- is expensive to keep all ngrams matching a given context and if
......@@ -215,7 +215,7 @@ getContextNgrams contextId listId = do
AND node_id = ? |]
-- | Query the `contexts` table and return ngrams for given context_id
-- | Query the `contexts` table and pure ngrams for given context_id
-- and list_id that match the search tsvector.
-- NOTE This is poor man's tokenization that is used as a hint for the
-- frontend highlighter.
......
......@@ -7,7 +7,7 @@ Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
Let a Root Node, return the Tree of the Node as a directed acyclic graph
Let a Root Node, pure the Tree of the Node as a directed acyclic graph
(Tree).
-- TODO delete node, if not owned, then suppress the link only
......
......@@ -145,7 +145,7 @@ instance ToField NgramsTypeId where
instance FromField NgramsTypeId where
fromField fld mdata = do
n <- fromField fld mdata
if (n :: Int) > 0 then return $ NgramsTypeId n
if (n :: Int) > 0 then pure $ NgramsTypeId n
else mzero
instance DefaultFromField (Nullable SqlInt4) NgramsTypeId
where
......
......@@ -65,13 +65,13 @@ parseGargJob s = case s of
_ -> Nothing
parsePrios :: [String] -> IO [(GargJob, Int)]
parsePrios [] = return []
parsePrios [] = pure []
parsePrios (x : xs) = (:) <$> go x <*> parsePrios xs
where go s = case break (=='=') s of
([], _) -> error "parsePrios: empty jobname?"
(prop, valS)
| Just val <- readMaybe (tail valS)
, Just j <- parseGargJob prop -> return (j, val)
, Just j <- parseGargJob prop -> pure (j, val)
| otherwise -> error $
"parsePrios: invalid input. " ++ show (prop, valS)
......@@ -82,5 +82,5 @@ readPrios fp = do
False -> do
putStrLn $
"Warning: " ++ fp ++ " doesn't exist, using default job priorities."
return []
pure []
True -> parsePrios . lines =<< readFile fp
......@@ -96,10 +96,10 @@ newJob newJobHandle getenv jobkind f input = do
r <- f env (newJobHandle jId (liftIO . pushLog logF . Seq.singleton)) inp
case r of
Left e -> postCallback (SJ.mkChanError e) >> throwIO e
Right a -> postCallback (SJ.mkChanResult a) >> return a
Right a -> postCallback (SJ.mkChanResult a) >> pure a
jid <- queueJob jobkind (input ^. SJ.job_input) f'
return (SJ.JobStatus jid [] SJ.IsPending Nothing)
pure (SJ.JobStatus jid [] SJ.IsPending Nothing)
pollJob
:: MonadJob m t (Seq event) output
......@@ -119,7 +119,7 @@ pollJob limit offset jid je = do
me = either (Just . T.pack . show) (const Nothing) r
in pure (ls, st, me)
-- /NOTE/: We need to be careful with the ordering of the logs here:
-- we want to return the logs ordered from the newest to the oldest,
-- we want to pure the logs ordered from the newest to the oldest,
-- because the API will use 'limit' to show only the newest ones,
-- taking 'limit' of them from the front of the list.
--
......@@ -141,15 +141,15 @@ waitJob joberr jid je = do
m <- getJobsMap
erj <- waitTilRunning
case erj of
Left res -> return res
Left res -> pure res
Right rj -> do
(res, _logs) <- liftIO (waitJobDone jid rj m)
return res
pure res
RunningJ rj -> do
m <- getJobsMap
(res, _logs) <- liftIO (waitJobDone jid rj m)
return res
DoneJ _ls res -> return res
pure res
DoneJ _ls res -> pure res
either (throwError . joberr . JobException) (pure . SJ.JobOutput) r
where waitTilRunning =
......@@ -159,8 +159,8 @@ waitJob joberr jid je = do
QueuedJ _qj -> do
liftIO $ threadDelay 50000 -- wait 50ms
waitTilRunning
RunningJ rj -> return (Right rj)
DoneJ _ls res -> return (Left res)
RunningJ rj -> pure (Right rj)
DoneJ _ls res -> pure (Left res)
killJob
:: (Ord t, MonadJob m t (Seq event) output)
......@@ -174,12 +174,12 @@ killJob t limit offset jid je = do
(logs, status, merr) <- case jTask je of
QueuedJ _ -> do
removeJob True t jid
return (mempty, SJ.IsKilled, Nothing)
pure (mempty, SJ.IsKilled, Nothing)
RunningJ rj -> do
liftIO $ cancel (rjAsync rj)
lgs <- liftIO (rjGetLog rj)
removeJob False t jid
return (lgs, SJ.IsKilled, Nothing)
pure (lgs, SJ.IsKilled, Nothing)
DoneJ lgs r -> do
let st = either (const SJ.IsFailure) (const SJ.IsFinished) r
me = either (Just . T.pack . show) (const Nothing) r
......
......@@ -104,10 +104,10 @@ gcThread js (JobMap mvar) = go
mrunningjob <- atomically $ do
case jTask je of
RunningJ rj -> modifyTVar' mvar (Map.delete (jID je))
>> return (Just rj)
_ -> return Nothing
>> pure (Just rj)
_ -> pure Nothing
case mrunningjob of
Nothing -> return ()
Nothing -> pure ()
Just a -> killJ a
go
......@@ -161,7 +161,7 @@ runJob jid qj (JobMap mvar) js = do
, jStarted = Just now
, jTimeoutAfter = Just $ addUTCTime (fromIntegral (jsJobTimeout js)) now
}
return rj
pure rj
waitJobDone
:: Ord jid
......@@ -176,7 +176,7 @@ waitJobDone jid rj (JobMap mvar) = do
atomically $ modifyTVar' mvar $
flip Map.adjust jid $ \je ->
je { jEnded = Just now, jTask = DoneJ logs r }
return (r, logs)
pure (r, logs)
-- | Turn a queued job into a running job by setting up the logging of @w@s and
-- firing up the async action.
......@@ -185,9 +185,9 @@ runJ (QueuedJob a f) = do
logs <- newTVarIO mempty
act <- async $ f a (jobLog logs)
let readLogs = readTVarIO logs
return (RunningJob act readLogs)
pure (RunningJob act readLogs)
-- | Wait for a running job to return (blocking).
-- | Wait for a running job to pure (blocking).
waitJ :: RunningJob w a -> IO (Either SomeException a)
waitJ (RunningJob act _) = waitCatch act
......
......@@ -126,10 +126,10 @@ checkJID
checkJID (SJ.PrivateID tn n t d) = do
now <- liftIO getCurrentTime
js <- getJobsSettings
if | tn /= "job" -> return (Left InvalidIDType)
| now > addUTCTime (fromIntegral $ jsIDTimeout js) t -> return (Left IDExpired)
| d /= SJ.macID tn (jsSecretKey js) t n -> return (Left $ InvalidMacID $ T.pack d)
| otherwise -> return $ Right (SJ.PrivateID tn n t d)
if | tn /= "job" -> pure (Left InvalidIDType)
| now > addUTCTime (fromIntegral $ jsIDTimeout js) t -> pure (Left IDExpired)
| d /= SJ.macID tn (jsSecretKey js) t n -> pure (Left $ InvalidMacID $ T.pack d)
| otherwise -> pure $ Right (SJ.PrivateID tn n t d)
withJob
:: MonadJob m t w a
......@@ -139,11 +139,11 @@ withJob
withJob jid f = do
r <- checkJID jid
case r of
Left e -> return (Left e)
Left e -> pure (Left e)
Right jid' -> do
mj <- findJob jid'
case mj of
Nothing -> return (Right Nothing)
Nothing -> pure (Right Nothing)
Just j -> Right . Just <$> f jid' j
handleIDError
......@@ -153,7 +153,7 @@ handleIDError
-> m a
handleIDError toE act = act >>= \r -> case r of
Left err -> throwError (toE err)
Right a -> return a
Right a -> pure a
removeJob
:: (Ord t, MonadJob m t w a)
......
......@@ -91,7 +91,7 @@ newQueue prios = do
indices = Map.fromList (zip allTs [0..])
n = Map.size indices
vars <- Vector.replicateM n (newTVarIO emptyQ)
return $ Queue vars indices prios
pure $ Queue vars indices prios
-- | Add a new element to the queue, with the given kind.
addQueue :: Ord t => t -> a -> Queue t a -> STM ()
......@@ -110,7 +110,7 @@ debugDumpQueue q = mconcat <$> (forM [minBound..maxBound] $ \t -> do
readTVar (queueData q Vector.! (i t)) >>= debugDumpQ t)
where
i t = fromJust $ Map.lookup t (queueIndices q)
debugDumpQ t (Q xs ys _) = return $ map (\x -> (t, x)) (xs ++ reverse ys)
debugDumpQ t (Q xs ys _) = pure $ map (\x -> (t, x)) (xs ++ reverse ys)
type Picker a = [(a, STM ())] -> STM (a, STM ())
......@@ -127,7 +127,7 @@ popQueue picker q = atomically $ select prioLevels
Map.toList (queuePrios q)
select :: [[(t, Prio)]] -> STM (Maybe a)
select [] = return Nothing
select [] = pure Nothing
select (level:levels) = do
mres <- selectLevel level
case mres of
......@@ -139,15 +139,15 @@ popQueue picker q = atomically $ select prioLevels
let indices = catMaybes $ map (flip Map.lookup (queueIndices q) . fst) xs
queues = map (queueData q Vector.!) indices
go qvar = readTVar qvar >>= \qu ->
return (peekQ qu, modifyTVar' qvar dropQ)
pure (peekQ qu, modifyTVar' qvar dropQ)
mtopItems <- catMaybesFst <$> traverse go queues
case mtopItems of
Nothing -> return Nothing
Just [] -> return Nothing
Nothing -> pure Nothing
Just [] -> pure Nothing
Just topItems -> do
(earliestItem, popItem) <- picker topItems
popItem
return (Just earliestItem)
pure (Just earliestItem)
catMaybesFst ((Nothing, _b) : xs) = catMaybesFst xs
catMaybesFst ((Just a, b) : xs) = ((a, b) :) <$> catMaybesFst xs
......@@ -162,7 +162,7 @@ queueRunner picker f q = go
mres <- popQueue picker q
case mres of
Just a -> f a `catch` exc
Nothing -> return ()
Nothing -> pure ()
threadDelay 5000 -- 5ms
go
......@@ -181,4 +181,4 @@ newQueueWithRunners
newQueueWithRunners n prios picker f = do
q <- newQueue prios
let runners = replicate n (queueRunner picker f q)
return (q, runners)
pure (q, runners)
......@@ -46,17 +46,17 @@ newJobsState js prios = do
(q, runners) <- newQueueWithRunners (jsNumRunners js) prios (picker jmap) $ \jid -> do
mje <- lookupJob jid jmap
case mje of
Nothing -> return ()
Nothing -> pure ()
Just je -> case jTask je of
QueuedJ qj -> do
rj <- runJob jid qj jmap js
(_res, _logs) <- waitJobDone jid rj jmap
return ()
_ -> return ()
pure ()
_ -> pure ()
when (jsDebugLogs js) $ putStrLn $ "Starting " ++ show (jsNumRunners js) ++ " job runners."
gcAsync <- async $ gcThread js jmap
runnersAsyncs <- traverse async runners
return (JobsState jmap q idgen gcAsync runnersAsyncs)
pure (JobsState jmap q idgen gcAsync runnersAsyncs)
where picker
:: JobMap (SJ.JobID 'SJ.Safe) w a
......@@ -65,10 +65,10 @@ newJobsState js prios = do
jinfos <- fmap catMaybes . forM xs $ \(jid, popjid) -> do
mje <- Map.lookup jid <$> readTVar jmap
case mje of
Nothing -> return Nothing
Just je -> return $ Just (jid, popjid, jRegistered je)
Nothing -> pure Nothing
Just je -> pure $ Just (jid, popjid, jRegistered je)
let (jid, popjid, _) = List.minimumBy (comparing _3) jinfos
return (jid, popjid)
pure (jid, popjid)
_3 (_, _, c) = c
......
......@@ -45,7 +45,7 @@ instance MimeRender CSV NgramsTableMap where
instance Read a => MimeUnrender CSV a where
mimeUnrender _ bs = case BSC.take len bs of
"text/csv" -> return . read . BSC.unpack $ BSC.drop len bs
"text/csv" -> pure . read . BSC.unpack $ BSC.drop len bs
_ -> Left "didn't start with the magic incantation"
where
len :: Int64
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment