diff options
| -rw-r--r-- | .hlint.yaml | 5 | ||||
| -rw-r--r-- | Alpha.hs | 12 | ||||
| -rw-r--r-- | Biz/Bild.hs | 8 | ||||
| -rw-r--r-- | Biz/Cli.hs | 6 | ||||
| -rw-r--r-- | Biz/Devalloc.hs | 156 | ||||
| -rw-r--r-- | Biz/Lint.hs | 12 | ||||
| -rw-r--r-- | Biz/Namespace.hs | 4 | ||||
| -rw-r--r-- | Biz/Pie.hs | 12 | ||||
| -rw-r--r-- | Biz/Que/Host.hs | 8 | ||||
| -rw-r--r-- | Biz/Que/Site.hs | 16 | ||||
| -rw-r--r-- | Biz/Test.hs | 2 | ||||
| -rw-r--r-- | Control/Concurrent/Go.hs | 8 | ||||
| -rw-r--r-- | Hero/Host.hs | 12 | ||||
| -rw-r--r-- | Hero/Keep.hs | 2 | ||||
| -rw-r--r-- | Hero/Node.hs | 6 | ||||
| -rw-r--r-- | System/Random/Shuffle.hs | 6 |
16 files changed, 144 insertions, 131 deletions
diff --git a/.hlint.yaml b/.hlint.yaml index a595d0f..7c00f19 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -75,3 +75,8 @@ # lhs: 'f <. g' # note: 'Use `.>` for natural reading direction' # rhs: 'g .> f' + +- hint: + lhs: 'return' + note: 'Use the more general Applicative interface' + rhs: 'pure' @@ -41,9 +41,9 @@ module Alpha (</), (<//), - -- * Shoving / binding + -- * inding bind, - (>>=), + (+>), -- * Bool don't, @@ -146,7 +146,7 @@ infixl 1 |> -- | Alias for <&>. Can be read as "and then". Basically does into a -- functor, does some computation, then returns the same kind of --- functor. Could also be defined as `f >>= return <. g` +-- functor. Could also be defined as `f +> return <. g` -- -- Pronunciation: fas-gar (/>) :: Functor f => f a -> (a -> b) -> f b @@ -157,10 +157,10 @@ infixl 1 /> bind :: Monad m => m a -> (a -> m b) -> m b bind a f = a Prelude.>>= f -(>>=) :: Monad m => m a -> (a -> m b) -> m b -a >>= b = a Prelude.>>= b +(+>) :: Monad m => m a -> (a -> m b) -> m b +a +> b = a Prelude.>>= b -infixl 1 >>= +infixl 1 +> -- | Removes newlines from text. chomp :: Text -> Text diff --git a/Biz/Bild.hs b/Biz/Bild.hs index 8a7de48..b621797 100644 --- a/Biz/Bild.hs +++ b/Biz/Bild.hs @@ -151,7 +151,7 @@ main = Cli.main <| Cli.Plan help move test "Biz.Bild" [ Test.unit "can bild bild" <| do let ns = Namespace ["Biz", "Bild"] Namespace.Hs - analyze ns >>= build False False >>= \case + analyze ns +> build False False +> \case Exit.ExitFailure _ -> Test.assertFailure "can't bild bild" _ -> pure () ] @@ -162,13 +162,13 @@ move args = >> mapM getNamespace (Cli.getAllArgs args (Cli.argument "target")) /> catMaybes /> filter isBuildableNs - >>= mapM analyze - >>= mapM + +> mapM analyze + +> mapM ( build (args `Cli.has` Cli.longOption "test") (args `Cli.has` Cli.longOption "loud") ) - >>= exitSummary + +> exitSummary help :: Cli.Docopt help = @@ -33,8 +33,8 @@ data Plan = Plan main :: Plan -> IO () main Plan {..} = Environment.getArgs - >>= Docopt.parseArgsOrExit help - >>= \args -> + +> Docopt.parseArgsOrExit help + +> \args -> if args `has` Docopt.command "test" then runTests test else @@ -49,7 +49,7 @@ runTests tree = do Nothing -> do hPutStrLn stderr <| Text.pack "no ingredients agreed to run" exitFailure - Just act -> act >>= \ok -> if ok then exitSuccess else exitFailure + Just act -> act +> \ok -> if ok then exitSuccess else exitFailure has :: Docopt.Arguments -> Docopt.Option -> Bool has = Docopt.isPresent diff --git a/Biz/Devalloc.hs b/Biz/Devalloc.hs index 245d94d..701e95a 100644 --- a/Biz/Devalloc.hs +++ b/Biz/Devalloc.hs @@ -66,6 +66,7 @@ import qualified Clay import qualified Clay.Font import qualified Clay.Render as Clay import qualified Control.Exception as Exception +import Control.Monad ((>=>)) import Crypto.JOSE.JWK (JWK) import Data.Acid (makeAcidic) import qualified Data.Acid as Acid @@ -267,23 +268,23 @@ createUser u = do { users = IxSet.insert newUser (users keep), nextUserId = succ <| nextUserId keep } - return newUser + pure newUser updateUser :: User -> Acid.Update Keep User updateUser u@User {..} = do keep <- get put <| keep {users = IxSet.updateIx userGitHubId u (users keep)} - return u + pure u getUserByEmail :: UserEmail -> Acid.Query Keep (Maybe User) getUserByEmail email = do Keep {..} <- ask - return <| IxSet.getOne <| users @= email + pure <| IxSet.getOne <| users @= email getUsers :: Acid.Query Keep [User] getUsers = do Keep {..} <- ask - return <| IxSet.toList users + pure <| IxSet.toList users createAnalysis :: Analysis -> Acid.Update Keep Analysis createAnalysis a = do @@ -294,27 +295,27 @@ createAnalysis a = do { analyses = IxSet.insert newAnalysis analyses, nextAnalysisId = succ nextAnalysisId } - return newAnalysis + pure newAnalysis getAnalysisById :: Id.Id Analysis -> Acid.Query Keep (Maybe Analysis) getAnalysisById id = do Keep {..} <- ask - return <| IxSet.getOne <| analyses @= id + pure <| IxSet.getOne <| analyses @= id getAllAnalyses :: Acid.Query Keep [Analysis] getAllAnalyses = do Keep {..} <- ask - return <| IxSet.toList analyses + pure <| IxSet.toList analyses getAnalysesByAsker :: User -> Acid.Query Keep [Analysis] getAnalysesByAsker user = do Keep {..} <- ask - return <| IxSet.toList <| analyses @= userId user + pure <| IxSet.toList <| analyses @= userId user getAnalysisByUrlAndCommit :: URL -> Commit -> Acid.Query Keep (Maybe Analysis) getAnalysisByUrlAndCommit url sha = do Keep {..} <- ask - return <| IxSet.getOne <| analyses @= url &&& analyses @= sha + pure <| IxSet.getOne <| analyses @= url &&& analyses @= sha $( makeAcidic ''Keep @@ -334,7 +335,7 @@ upsertGitHubUser :: Acid.AcidState Keep -> ByteString -> GitHub.User -> IO User upsertGitHubUser keep tok ghUser = case GitHub.userEmail ghUser of Nothing -> panic "No user email" Just email -> - Acid.query keep (GetUserByEmail <| UserEmail email) >>= \case + Acid.query keep (GetUserByEmail <| UserEmail email) +> \case Just user -> -- need to refresh the token Acid.update keep <| UpdateUser user {userGitHubToken = Encoding.decodeUtf8 tok} @@ -427,7 +428,7 @@ startup = do Live -> liveCookieSettings let ctx = cooks :. jwtCfg :. EmptyContext let app = serveWithContext paths ctx (toServant <| htmlApp cooks kp cfg jwk oAuthArgs) - return (cfg, app, kp) + pure (cfg, app, kp) shutdown :: (Config, Application, Acid.AcidState Keep) -> IO () shutdown (_, _, kp) = Acid.closeAcidState kp @@ -641,60 +642,65 @@ htmlApp cooks kp cfg jwk oAuthArgs = user <- GitHub.github (GitHub.OAuth token) GitHub.userInfoCurrentR |> liftIO - >>= \case + +> \case Left err -> throwError err502 {errBody = show err} Right ghUser -> liftIO <| upsertGitHubUser kp token ghUser Auth.acceptLogin cooks (Auth.defaultJWTSettings jwk) user |> liftIO - >>= \case + +> \case Nothing -> panic "login didn't work" -- I think this should redirect to instead of rendering UserAccount Just applyCookies -> UserAccount user |> HtmlApp |> applyCookies - |> return, - getAccount = \u -> - guardAuth u >>= UserAccount .> HtmlApp .> pure, + |> pure, + getAccount = + guardAuth >=> UserAccount .> HtmlApp .> pure, postAccount = \a subscription -> - guardAuth a >>= \user -> - UpdateUser user {userSubscription = subscription} - |> Acid.update' kp - >>= UserAccount - .> HtmlApp - .> pure, - selectRepo = \u -> - guardAuth u >>= \user@User {..} -> - GitHub.github - (GitHub.OAuth <| Encoding.encodeUtf8 userGitHubToken) - (GitHub.currentUserReposR GitHub.RepoPublicityAll GitHub.FetchAll) - |> liftIO - >>= \case - Left err -> throwError err502 {errBody = show err} - Right repos -> pure <. HtmlApp <| SelectRepo user repos, - getAnalyses = \u -> - guardAuth u >>= \user@User {..} -> do - GetAnalysesByAsker user - |> Acid.query' kp - >>= Analyses user - .> HtmlApp - .> pure, + guardAuth a + +> \user -> + UpdateUser user {userSubscription = subscription} + |> Acid.update' kp + +> UserAccount + .> HtmlApp + .> pure, + selectRepo = + guardAuth + >=> \user@User {..} -> + GitHub.github + (GitHub.OAuth <| Encoding.encodeUtf8 userGitHubToken) + (GitHub.currentUserReposR GitHub.RepoPublicityAll GitHub.FetchAll) + |> liftIO + +> \case + Left err -> throwError err502 {errBody = show err} + Right repos -> pure <. HtmlApp <| SelectRepo user repos, + getAnalyses = + guardAuth + >=> \user@User {..} -> + GetAnalysesByAsker user + |> Acid.query' kp + +> Analyses user + .> HtmlApp + .> pure, getAnalysis = \a analysisId -> - guardAuth a >>= \user -> - GetAnalysisById analysisId - |> Acid.query' kp - >>= \case - Nothing -> throwError err404 - Just analysis -> pure <| HtmlApp <| AnalysisDisplay user analysis, + guardAuth a + +> \user -> + GetAnalysisById analysisId + |> Acid.query' kp + +> \case + Nothing -> throwError err404 + Just analysis -> pure <| HtmlApp <| AnalysisDisplay user analysis, githubAnalysis = \a owner repo -> - guardAuth a >>= \user -> - analyzeGitHub kp user cfg owner repo - |> liftIO - >>= AnalysisDisplay user - .> HtmlApp - .> pure, + guardAuth a + +> \user -> + analyzeGitHub kp user cfg owner repo + |> liftIO + +> AnalysisDisplay user + .> HtmlApp + .> pure, css = - return <. toStrict <. Clay.render <| do + pure <. toStrict <. Clay.render <| do let yellow = "#ffe000" let black = "#1d2d35" -- really a dark blue Biz.Look.fuckingStyle @@ -909,7 +915,7 @@ data OAuthResponse = OAuthResponse } deriving (Generic, Aeson.FromJSON) --- | POST to GitHub's oAuth service and return the user's oAuth token. +-- | POST to GitHub's oAuth service and pure the user's oAuth token. -- TODO: I can also get access scope etc from this response getAccessToken :: OAuthArgs -> @@ -922,7 +928,7 @@ getAccessToken OAuthArgs {..} code = Req.responseBody x |> access_token |> Encoding.encodeUtf8 - |> return + |> pure where accessTokenRequest :: Req.Req (Req.JsonResponse OAuthResponse) accessTokenRequest = @@ -1056,8 +1062,8 @@ instance Lucid.ToHtml Analysis where analyze :: Acid.AcidState Keep -> Id.Id User -> [Text] -> URL -> FilePath -> IO Analysis analyze keep askedBy activeAuthors url bareRepo = do commit <- Sha </ Text.strip </ Text.pack </ git ["log", "-n1", "--format=%H"] - Acid.query keep (GetAnalysisByUrlAndCommit url commit) >>= \case - Just analysis -> return analysis + Acid.query keep (GetAnalysisByUrlAndCommit url commit) +> \case + Just analysis -> pure analysis Nothing -> do tree <- git @@ -1091,19 +1097,19 @@ analyze keep askedBy activeAuthors url bareRepo = do let numBlackholes = realToFrac <| length blackholes let numLiabilities = realToFrac <| length liabilities let numTotal = realToFrac <| length tree - Acid.update keep - <| CreateAnalysis - <| Analysis - { analysisId = mempty, - stale = - [ (path, days) - | (path, days) <- stalenessMap, - days > 180 - ], - score = calculateScore numTotal numBlackholes numLiabilities, - totalFiles = toInteger <| length tree, - .. - } + Analysis + { analysisId = mempty, + stale = + [ (path, days) + | (path, days) <- stalenessMap, + days > 180 + ], + score = calculateScore numTotal numBlackholes numLiabilities, + totalFiles = toInteger <| length tree, + .. + } + |> CreateAnalysis + |> Acid.update keep where third :: (a, b, c) -> c third (_, _, a) = a @@ -1156,14 +1162,14 @@ lastTouched bareRepo path = do -- TODO: this fails if time is empty? /> Time.parseTimeOrError True Time.defaultTimeLocale "%Y-%m-%dT%H:%M:%S%z" let days = round <| Time.diffUTCTime now timestamp / Time.nominalDay - return (path, days) + pure (path, days) --- | Given a git dir and a path inside the git repo, return a list of tuples +-- | Given a git dir and a path inside the git repo, pure a list of tuples -- with number of commits and author. authorsFor :: FilePath -> FilePath -> - -- | Returns (number of commits, author name, author email) + -- | pures (number of commits, author name, author email) IO [(Text, Text, Text)] authorsFor gitDir path = Process.readProcess @@ -1207,7 +1213,7 @@ analyzeGitHub keep User {..} cfg o r = do -- collaborators on a repo requires authentication for some reason. -- -- If the owner is an organization, then we can just use org members, which is - -- public too. And if the auth'ed user is a member of the org, then it returns + -- public too. And if the auth'ed user is a member of the org, then it pures -- all of the members, not just public ones, so that will work just fine. -- -- In the meantime, what do? Maybe get the number of commits, and consider @@ -1237,12 +1243,12 @@ analyzeGitHub keep User {..} cfg o r = do ghRepo = GitHub.mkName (Proxy :: Proxy GitHub.Repo) r -- | Clone the repo to @<Config.depo>/<url>@. If repo already exists, just do a --- @git fetch@. Returns the full path to the local repo. +-- @git fetch@. pures the full path to the local repo. fetchBareRepo :: Config -> Text -> IO FilePath fetchBareRepo Config {depo} url = Directory.doesPathExist worktree - >>= fetchOrClone - >> return worktree + +> fetchOrClone + >> pure worktree where fetchOrClone True = Process.callProcess "git" ["--git-dir", worktree, "fetch", "origin"] diff --git a/Biz/Lint.hs b/Biz/Lint.hs index 66c7900..bd71835 100644 --- a/Biz/Lint.hs +++ b/Biz/Lint.hs @@ -28,13 +28,13 @@ main = Cli.main <| Cli.Plan help move test move :: Cli.Arguments -> IO () move args = case Cli.getAllArgs args (Cli.argument "file") of - [] -> changedFiles >>= run >>= exit + [] -> changedFiles +> run +> exit files -> files |> filter notcab |> filterM Directory.doesFileExist - >>= run - >>= exit + +> run + +> exit test :: Test.Tree test = @@ -83,7 +83,7 @@ printResult r@(NoOp path_) = >> pure r changedFiles :: IO [FilePath] -changedFiles = mergeBase >>= changed +changedFiles = mergeBase +> changed where git args = Process.readProcess "git" args "" mergeBase = git ["merge-base", "HEAD", "origin/master"] /> filter (/= '\n') @@ -109,7 +109,7 @@ run paths = do concat </ mapM (runOne root cwd) paths runOne :: FilePath -> FilePath -> FilePath -> IO [Result] -runOne root cwd path_ = results >>= mapM_ printResult >> results +runOne root cwd path_ = results +> mapM_ printResult >> results where results = sequence <| case Namespace.fromPath root (cwd </> path_) of @@ -128,7 +128,7 @@ runOne root cwd path_ = results >>= mapM_ printResult >> results lint :: Linter -> [String] -> FilePath -> IO Result lint bin args path_ = - Process.readProcessWithExitCode (Text.unpack bin) (args ++ [path_]) "" >>= \case + Process.readProcessWithExitCode (Text.unpack bin) (args ++ [path_]) "" +> \case (Exit.ExitSuccess, _, _) -> pure <| Ok path_ bin Good (Exit.ExitFailure _, msg, _) -> pure <| Ok path_ bin <| Bad msg diff --git a/Biz/Namespace.hs b/Biz/Namespace.hs index d3835c8..398841e 100644 --- a/Biz/Namespace.hs +++ b/Biz/Namespace.hs @@ -44,8 +44,8 @@ match = Regex.match <| Namespace </ path <* Regex.sym '.' <*> ext fromPath :: String -> String -> Maybe Namespace fromPath bizRoot absPath = List.stripPrefix bizRoot absPath - >>= List.stripPrefix "/" - >>= match + +> List.stripPrefix "/" + +> match toHaskellModule :: Namespace -> String toHaskellModule (Namespace parts Hs) = joinWith "." parts @@ -95,12 +95,12 @@ formFile ns = ns ++ ".pie" loadForm :: String -> IO Form loadForm ns = - Directory.doesFileExist file >>= \case - False -> return mempty + Directory.doesFileExist file +> \case + False -> pure mempty True -> - Aeson.decodeFileStrict file >>= \case + Aeson.decodeFileStrict file +> \case Nothing -> panic <| Text.pack <| "could not decode: " ++ file - Just x -> return x + Just x -> pure x where file = formFile ns @@ -126,10 +126,10 @@ fromArgs args move :: Cli.Arguments -> IO () move args = case fromArgs args of New -> do - week <- Time.getCurrentTime >>= return <. Time.formatTime Time.defaultTimeLocale "%V" + week <- Time.getCurrentTime +> pure <. Time.formatTime Time.defaultTimeLocale "%V" let branch = "sprint-" <> week proc <- Process.spawnProcess "git" ["show-ref", branch] - Process.waitForProcess proc >>= \case + Process.waitForProcess proc +> \case Exit.ExitSuccess -> Process.callProcess "git" ["switch", branch] Exit.ExitFailure _ -> diff --git a/Biz/Que/Host.hs b/Biz/Que/Host.hs index cbf4bfd..e40b2e0 100644 --- a/Biz/Que/Host.hs +++ b/Biz/Que/Host.hs @@ -63,7 +63,7 @@ move :: Cli.Arguments -> IO () move _ = Exception.bracket startup shutdown <| uncurry Warp.run where startup = - Envy.decodeWithDefaults Envy.defConfig >>= \c -> do + Envy.decodeWithDefaults Envy.defConfig +> \c -> do sync <- STM.newTVarIO initialAppState let runActionToIO m = runReaderT (runApp m) sync waiapp <- Scotty.scottyAppT runActionToIO <| routes c @@ -207,7 +207,7 @@ streamQue q write _ = loop q where loop c = Go.read c - >>= (write <. Builder.byteStringInsert) + +> (write <. Builder.byteStringInsert) >> loop c -- | Gets the thing from the Hashmap. Call's 'error' if key doesn't exist. @@ -241,11 +241,11 @@ app = lift -- | Get something from the app state gets :: (AppState -> b) -> App b -gets f = ask >>= liftIO <. STM.readTVarIO >>= return </ f +gets f = ask +> liftIO <. STM.readTVarIO +> return </ f -- | Apply a function to the app state modify :: (AppState -> AppState) -> App () -modify f = ask >>= liftIO <. atomically <. flip STM.modifyTVar' f +modify f = ask +> liftIO <. atomically <. flip STM.modifyTVar' f -- | housing for a set of que paths type Namespace = Text.Lazy.Text diff --git a/Biz/Que/Site.hs b/Biz/Que/Site.hs index 3e456da..0d89400 100644 --- a/Biz/Que/Site.hs +++ b/Biz/Que/Site.hs @@ -83,7 +83,7 @@ getKey ns = do auth ns |> Config.parseIniFile conf |> either errorParsingConf identity - |> return + |> pure errorParsingConf :: error errorParsingConf = panic "could not parse ~/.config/que.conf" @@ -111,11 +111,11 @@ run key ns Sources {..} = Async.runConcurrently actions |> void actions = traverse Async.Concurrently - [ toHtml index >>= serve key ns "index" |> forever, - toHtml quescripts >>= serve key ns "quescripts" |> forever, - BS.readFile client >>= serve key ns "client" |> forever, - toHtml tutorial >>= serve key ns "tutorial" |> forever, - toHtml apidocs >>= serve key ns "apidocs" |> forever + [ toHtml index +> serve key ns "index" |> forever, + toHtml quescripts +> serve key ns "quescripts" |> forever, + BS.readFile client +> serve key ns "client" |> forever, + toHtml tutorial +> serve key ns "tutorial" |> forever, + toHtml apidocs +> serve key ns "apidocs" |> forever ] toHtml :: FilePath -> IO ByteString toHtml md = @@ -143,7 +143,7 @@ serve Nothing "pub" path content = (ReqBodyBs content) ignoreResponse mempty - liftIO <| return () + liftIO <| pure () serve Nothing p _ _ = panic <| "no auth key provided for ns: " <> p serve (Just key) ns path content = runReq defaultHttpConfig <| do @@ -156,4 +156,4 @@ serve (Just key) ns path content = (ReqBodyBs content) ignoreResponse options - liftIO <| return () + liftIO <| pure () diff --git a/Biz/Test.hs b/Biz/Test.hs index 85c405f..fdd89f8 100644 --- a/Biz/Test.hs +++ b/Biz/Test.hs @@ -78,8 +78,10 @@ infixl 2 @?!= (@=?) :: (Eq a, Show a) => a -> a -> HUnit.Assertion a @=? b = a HUnit.@=? b + infixl 2 @=? (@?=) :: (Eq a, Show a) => a -> a -> HUnit.Assertion a @?= b = a HUnit.@?= b + infixr 2 @?= diff --git a/Control/Concurrent/Go.hs b/Control/Concurrent/Go.hs index 92444f4..5057bfe 100644 --- a/Control/Concurrent/Go.hs +++ b/Control/Concurrent/Go.hs @@ -49,7 +49,7 @@ fork = Concurrent.forkIO chan :: Int -> IO (Channel a) chan n = do (i, o) <- Chan.newChan n - return <| Channel i o n + pure <| Channel i o n -- | A channel for broadcasting to multiple consumers. See 'mult'. type Mult a = Chan.OutChan a @@ -64,7 +64,7 @@ mult = Chan.dupChan <. _in -- You can use this to read from a channel in a background process, e.g.: -- -- >>> c <- Go.chan --- >>> Go.fork <. forever <| Go.mult c >>= Go.tap >>= print +-- >>> Go.fork <. forever <| Go.mult c +> Go.tap +> print tap :: Mult a -> IO a tap = Chan.readChan @@ -93,9 +93,9 @@ write = Chan.tryWriteChan <. _in -- >>> Go.read c -- "hi" -- >>> Go.fork --- >>> Go.fork <| forever <| Go.mult c >>= Go.tap >>= \t -> print ("one: " <> t) +-- >>> Go.fork <| forever <| Go.mult c +> Go.tap +> \t -> print ("one: " <> t) -- ThreadId 810 --- >>> Go.fork <| forever <| Go.mult c >>= Go.tap >>= \t -> print ("two: " <> t) +-- >>> Go.fork <| forever <| Go.mult c +> Go.tap +> \t -> print ("two: " <> t) -- ThreadId 825 -- >>> Go.write c "test" -- "two: t"eosnte": diff --git a/Hero/Host.hs b/Hero/Host.hs index fd010af..5496f27 100644 --- a/Hero/Host.hs +++ b/Hero/Host.hs @@ -106,7 +106,7 @@ move _ = bracket startup shutdown run run (cfg, app, _) = Warp.run (heroPort cfg) app prn = IO.hPutStrLn IO.stderr startup = - Envy.decodeEnv >>= \case + Envy.decodeEnv +> \case Left e -> Exit.die e Right cfg -> do @@ -139,7 +139,7 @@ move _ = bracket startup shutdown run :<|> wrapAuth appHostHandlers -- fall through to 404 :<|> Tagged handle404 - return + pure ( cfg, serveWithContext proxy @@ -150,11 +150,11 @@ move _ = bracket startup shutdown run shutdown :: App -> IO () shutdown (_, _, keep) = do Keep.close keep - return () + pure () upsertKey :: FilePath -> IO Crypto.JWK upsertKey fp = - Directory.doesFileExist fp >>= \exists -> + Directory.doesFileExist fp +> \exists -> if exists then Auth.readKey fp else Auth.writeKey fp >> Auth.readKey fp @@ -229,7 +229,7 @@ type CssRoute = "css" :> "main.css" :> Get '[CSS] Text cssHandlers :: Server CssRoute cssHandlers = - return <. Lazy.toStrict <. Clay.render <| Typography.main <> Look.main + pure <. Lazy.toStrict <. Clay.render <| Typography.main <> Look.main type AuthRoute = "auth" @@ -274,7 +274,7 @@ authHandler cookieSettings jwtSettings loginForm = mApplyCookies <- liftIO <| Auth.acceptLogin cookieSettings jwtSettings usr case mApplyCookies of Nothing -> throwError err401 - Just applyCookies -> return <| applyCookies usr + Just applyCookies -> pure <| applyCookies usr -- | See also 'server' above type AllRoutes auths = diff --git a/Hero/Keep.hs b/Hero/Keep.hs index 744313b..10ef732 100644 --- a/Hero/Keep.hs +++ b/Hero/Keep.hs @@ -66,7 +66,7 @@ newComic :: Comic -> Update HeroKeep Comic newComic c = do keep <- get put <| keep {_comics = IxSet.insert c (_comics keep)} - return c + pure c getComics :: Int -> Acid.Query HeroKeep [Comic] getComics n = ask /> _comics /> IxSet.toList /> take n diff --git a/Hero/Node.hs b/Hero/Node.hs index e7eb687..a453a01 100644 --- a/Hero/Node.hs +++ b/Hero/Node.hs @@ -193,7 +193,7 @@ move ValidateUserPassword form = doLogin = do user <- getValue =<< Document.getElementById "user" pass <- getValue =<< Document.getElementById "pass" - sendLogin (ms user) (ms pass) >>= \case + sendLogin (ms user) (ms pass) +> \case Network.Success _ -> pure NoOp -- TODO: handle these error cases Network.Loading -> pure NoOp @@ -202,7 +202,7 @@ move ValidateUserPassword form = fetchComics :: IO (Network.RemoteData MisoString [Comic]) fetchComics = - Ajax.xhrByteString req /> Ajax.contents >>= \case + Ajax.xhrByteString req /> Ajax.contents +> \case Nothing -> pure <| Network.Failure "Could not fetch comics from server." Just json -> @@ -231,7 +231,7 @@ sendLogin :: User ) sendLogin u p = - Ajax.xhrByteString req /> Ajax.contents >>= \case + Ajax.xhrByteString req /> Ajax.contents +> \case Nothing -> pure <| Network.Failure "Could not send login request." Just json -> diff --git a/System/Random/Shuffle.hs b/System/Random/Shuffle.hs index 435f083..cc587da 100644 --- a/System/Random/Shuffle.hs +++ b/System/Random/Shuffle.hs @@ -74,7 +74,7 @@ shuffle elements = shuffleTree (buildTree elements) shuffleTree tree (r : rs) = let (b, rest) = extractTree r tree in b : shuffleTree rest rs shuffleTree _ _ = panic "[shuffle] called with lists of different lengths" - -- Extracts the n-th element from the tree and returns + -- Extracts the n-th element from the tree and pures -- that element, paired with a tree with the element -- deleted. -- The function maintains the invariant of the completeness @@ -112,9 +112,9 @@ shuffle' elements len = shuffle elements <. rseq len -- | shuffle' wrapped in a random monad shuffleM :: (MonadRandom m) => [a] -> m [a] shuffleM elements - | null elements = return [] + | null elements = pure [] | otherwise = shuffle elements <$> rseqM (length elements - 1) where rseqM :: (MonadRandom m) => Int -> m [Int] - rseqM 0 = return [] + rseqM 0 = pure [] rseqM i = liftM2 (:) (getRandomR (0, i)) (rseqM (i - 1)) |