Fix hlint warnings for hlint v2.1.20 (#1320)

* Apply some hlint suggestions.

* Simplify config parser (to avoid hlint error)

* Reorganize for clarity (and fix hlint error)

* Remove redundant language extension

* Reformat slice more conventionally to avoid hlint bug

* Refactor for clarity (and to avoid hlint error)

* Simplify (and avoid hlint error)

* Fix hlint complaint

main/Main.hs

@@ -135,8 +135,8 @@ connectionStatus pool =
 
     shouldRetry :: RetryStatus -> ConnectionStatus -> IO Bool
     shouldRetry rs isConnSucc = do
-      delay <- pure $ fromMaybe 0 (rsPreviousDelay rs) `div` 1000000
-      itShould <- pure $ NotConnected == isConnSucc
+      let delay    = fromMaybe 0 (rsPreviousDelay rs) `div` 1000000
+          itShould = NotConnected == isConnSucc
       when itShould $
         putStrLn $ "Attempting to reconnect to the database in " <> (show delay::Text) <> " seconds..."
       return itShould

src/PostgREST/ApiRequest.hs

@@ -137,7 +137,7 @@ userApiRequest schema req reqBody
       , iColumns = columns
       , iOrder = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["order"] k ]
       , iCanonicalQS = toS $ urlEncodeVars
-        . L.sortBy (comparing fst)
+        . L.sortOn fst
         . map (join (***) toS . second (fromMaybe BS.empty))
         $ queryStringWPlus
       , iJWT = tokenStr

src/PostgREST/Config.hs

@@ -146,18 +146,18 @@ readOptions = do
       AppConfig
         <$> reqString "db-uri"
         <*> reqString "db-anon-role"
-        <*> (mfilter (/= "") <$> optString "server-proxy-uri")
+        <*> optString "server-proxy-uri"
         <*> reqString "db-schema"
-        <*> (fromMaybe "!4" . mfilter (/= "") <$> optString "server-host")
-        <*> (fromMaybe 3000 . join . fmap coerceInt <$> optValue "server-port")
+        <*> (fromMaybe "!4" <$> optString "server-host")
+        <*> (fromMaybe 3000 <$> optInt "server-port")
         <*> optString "server-unix-socket"
-        <*> (fmap encodeUtf8 . mfilter (/= "") <$> optString "jwt-secret")
-        <*> (fromMaybe False . join . fmap coerceBool <$> optValue "secret-is-base64")
+        <*> (fmap encodeUtf8 <$> optString "jwt-secret")
+        <*> (fromMaybe False <$> optBool "secret-is-base64")
         <*> parseJwtAudience "jwt-aud"
-        <*> (fromMaybe 10 . join . fmap coerceInt <$> optValue "db-pool")
-        <*> (fromMaybe 10 . join . fmap coerceInt <$> optValue "db-pool-timeout")
-        <*> (join . fmap coerceInt <$> optValue "max-rows")
-        <*> (mfilter (/= "") <$> optString "pre-request")
+        <*> (fromMaybe 10 <$> optInt "db-pool")
+        <*> (fromMaybe 10 <$> optInt "db-pool-timeout")
+        <*> optInt "max-rows"
+        <*> optString "pre-request"
         <*> pure False
         <*> (fmap (fmap coerceText) <$> C.subassocs "app.settings" C.value)
         <*> (maybe (Right [JSPKey "role"]) parseRoleClaimKey <$> optValue "role-claim-key")
@@ -176,11 +176,17 @@ readOptions = do
     reqString k = C.required k C.string
 
     optString :: C.Key -> C.Parser C.Config (Maybe Text)
-    optString k = C.optional k C.string
+    optString k = mfilter (/= "") <$> C.optional k C.string
 
     optValue :: C.Key -> C.Parser C.Config (Maybe C.Value)
     optValue k = C.optional k C.value
 
+    optInt :: (Read i, Integral i) => C.Key -> C.Parser C.Config (Maybe i)
+    optInt k = join <$> C.optional k (coerceInt <$> C.value)
+
+    optBool :: C.Key -> C.Parser C.Config (Maybe Bool)
+    optBool k = join <$> C.optional k (coerceBool <$> C.value)
+
     coerceText :: C.Value -> Text
     coerceText (C.String s) = s
     coerceText v            = show v

src/PostgREST/DbStructure.hs

@@ -240,7 +240,7 @@ addForeignKeys :: [Relation] -> [Column] -> [Column]
 addForeignKeys rels = map addFk
   where
     addFk col = col { colFK = fk col }
-    fk col = join $ relToFk col <$> find (lookupFn col) rels
+    fk col = find (lookupFn col) rels >>= relToFk col
     lookupFn :: Column -> Relation -> Bool
     lookupFn c Relation{relColumns=cs, relType=rty} = c `elem` cs && rty==Child
     relToFk col Relation{relColumns=cols, relFColumns=colsF} = do
@@ -295,19 +295,28 @@ addViewChildRelations allSyns = concatMap (\rel ->
           -- Relation is dependent on the order of relColumns and relFColumns to get the join conditions right in the generated query.
           -- So we need to change the order of the synonyms to match the relColumns
           -- This could be avoided if the Relation type is improved with a structure that maintains the association of relColumns and relFColumns
-          syns `sortAccordingTo` columns = sortOn (\(k, _) -> L.lookup k $ zip columns [0::Int ..]) syns in
+          syns `sortAccordingTo` columns = sortOn (\(k, _) -> L.lookup k $ zip columns [0::Int ..]) syns
 
-      -- View Table Child Relations
-      [Relation (getView syns) (snd <$> syns `sortAccordingTo` relColumns) relFTable relFColumns Child Nothing Nothing Nothing
-        | syns <- colsSyns, syns `allSynsOf` relColumns] ++
+          viewTableChild =
+            [ Relation (getView syns) (snd <$> syns `sortAccordingTo` relColumns)
+                       relFTable relFColumns
+                       Child Nothing Nothing Nothing
+            | syns <- colsSyns, syns `allSynsOf` relColumns ]
 
-      -- Table View Child Relations
-      [Relation relTable relColumns (getView fSyns) (snd <$> fSyns `sortAccordingTo` relFColumns) Child Nothing Nothing Nothing
-        | fSyns <- fColsSyns, fSyns `allSynsOf` relFColumns] ++
+          tableViewChild =
+            [ Relation relTable relColumns
+                       (getView fSyns) (snd <$> fSyns `sortAccordingTo` relFColumns)
+                       Child Nothing Nothing Nothing
+            | fSyns <- fColsSyns, fSyns `allSynsOf` relFColumns ]
 
-      -- View View Child Relations
-      [Relation (getView syns) (snd <$> syns `sortAccordingTo` relColumns) (getView fSyns) (snd <$> fSyns `sortAccordingTo` relFColumns) Child Nothing Nothing Nothing
-        | syns <- colsSyns, fSyns <- fColsSyns, syns `allSynsOf` relColumns, fSyns `allSynsOf` relFColumns]
+          viewViewChild =
+            [ Relation (getView syns) (snd <$> syns `sortAccordingTo` relColumns)
+                       (getView fSyns) (snd <$> fSyns `sortAccordingTo` relFColumns)
+                       Child Nothing Nothing Nothing
+            | syns <- colsSyns, syns `allSynsOf` relColumns
+            , fSyns <- fColsSyns, fSyns `allSynsOf` relFColumns ]
+
+      in viewTableChild ++ tableViewChild ++ viewViewChild
 
     _ -> [])
 

src/PostgREST/Error.hs

@@ -3,8 +3,7 @@ Module      : PostgREST.Error
 Description : PostgREST error HTTP responses
 -}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# LANGUAGE FlexibleInstances    #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
 
 module PostgREST.Error (
   errorResponseFor

src/PostgREST/OpenAPI.hs

@@ -349,7 +349,7 @@ isUriValid:: URI -> Bool
 isUriValid = fAnd [isSchemeValid, isQueryValid, isAuthorityValid]
 
 fAnd :: [a -> Bool] -> a -> Bool
-fAnd fs x = all ($x) fs
+fAnd fs x = all ($ x) fs
 
 isSchemeValid :: URI -> Bool
 isSchemeValid URI {uriScheme = s}

src/PostgREST/Parsers.hs

@@ -56,9 +56,11 @@ pRequestLogicTree (k, v) = mapError $ (,) <$> embedPath <*> logicTree
   where
     path = parse pLogicPath ("failed to parser logic path (" ++ toS k ++ ")") $ toS k
     embedPath = fst <$> path
-    op = snd <$> path
-    -- Concat op and v to make pLogicTree argument regular, in the form of "?and=and(.. , ..)" instead of "?and=(.. , ..)"
-    logicTree = join $ parse pLogicTree ("failed to parse logic tree (" ++ toS v ++ ")") . toS <$> ((<>) <$> op <*> pure v)
+    logicTree = do
+      op <- snd <$> path
+      -- Concat op and v to make pLogicTree argument regular,
+      -- in the form of "?and=and(.. , ..)" instead of "?and=(.. , ..)"
+      parse pLogicTree ("failed to parse logic tree (" ++ toS v ++ ")") $ toS (op <> v)
 
 pRequestColumns :: Maybe Text -> Either ApiRequestError (Maybe (S.Set FieldName))
 pRequestColumns colStr =

src/PostgREST/Types.hs

@@ -91,20 +91,21 @@ instance Ord ProcDescription where
     | otherwise = (name1, des1, args1, rt1, vol1) `compare` (name2, des2, args2, rt2, vol2)
 
 {-|
-  Search a pg procedure by its parameters, since a function can be overloaded the name is not enough to find it.
+  Search a pg procedure by its parameters. Since a function can be overloaded, the name is not enough to find it.
   An overloaded function can have a different volatility or even a different return type.
 -}
 findProc :: QualifiedIdentifier -> S.Set Text -> Bool -> M.HashMap Text [ProcDescription] -> Maybe ProcDescription
 findProc qi payloadKeys paramsAsSingleObject allProcs =
-  let procs = M.lookup (qiName qi) allProcs in
- -- Handle overloaded functions case
-  join $ (case length <$> procs of
-    Just 1 -> headMay -- if it's not an overloaded function then immediatly get the ProcDescription
-    _ -> find (\x ->
-           if paramsAsSingleObject
-             then length (pdArgs x) == 1 -- if the arg is not of json type let the db give the err
-             else payloadKeys `S.isSubsetOf` S.fromList (pgaName <$> pdArgs x))
-  ) <$> procs
+  case M.lookup (qiName qi) allProcs of
+    Nothing     -> Nothing
+    Just [proc] -> Just proc           -- if it's not an overloaded function then immediately get the ProcDescription
+    Just procs  -> find matches procs  -- Handle overloaded functions case
+  where
+    matches proc =
+      if paramsAsSingleObject
+        -- if the arg is not of json type let the db give the err
+        then length (pdArgs proc) == 1
+        else payloadKeys `S.isSubsetOf` S.fromList (pgaName <$> pdArgs proc)
 
 {-|
   Search the procedure parameters by matching them with the specified keys.

test/Main.hs

@@ -55,7 +55,7 @@ main = do
     ver <- getPgVersion
     HT.transaction HT.ReadCommitted HT.Read $ getDbStructure "test" ver
 
-  dbStructure <- pure $ either (panic.show) id result
+  let dbStructure = either (panic.show) id result
 
   getTime <- mkAutoUpdate defaultUpdateSettings { updateAction = getCurrentTime }