Weeding (2/?)

## Description

Following on from #4572, this removes more dead code as identified by Weeder. Comments and thoughts similarly welcome!

PR-URL: https://github.com/hasura/graphql-engine-mono/pull/4587
GitOrigin-RevId: 73aa6a5a2833ee41d29b71fcd0a72ed19822ca73

server/graphql-engine.cabal

@@ -388,7 +388,6 @@ library
                      , Control.Arrow.Interpret
                      , Control.Arrow.Trans
                      , Control.Concurrent.Extended
-                     , Control.Lens.Extended
                      , Control.Monad.Stateless
                      , Control.Monad.Trans.Managed
                      , Control.Monad.Unique

server/src-lib/Control/Concurrent/Extended.hs

@@ -12,8 +12,6 @@ module Control.Concurrent.Extended
     forConcurrentlyEIO,
 
     -- * Deprecated
-    threadDelay,
-    forkIO,
     ImmortalThreadLog (..),
     ThreadState (..),
     ThreadShutdown (..),
@@ -21,7 +19,7 @@ module Control.Concurrent.Extended
   )
 where
 
-import Control.Concurrent hiding (forkIO, threadDelay)
+import Control.Concurrent hiding (threadDelay)
 import Control.Concurrent qualified as Base
 import Control.Concurrent.Async as A
 import Control.Concurrent.Async.Lifted.Safe qualified as LA
@@ -50,18 +48,6 @@ import Prelude
 sleep :: DiffTime -> IO ()
 sleep = Base.threadDelay . round . Microseconds
 
-{-# DEPRECATED threadDelay "Please use `sleep` instead (and read the docs!)" #-}
-threadDelay :: Int -> IO ()
-threadDelay = Base.threadDelay
-
-{-# DEPRECATED
-  forkIO
-  "Please use 'Control.Control.Concurrent.Async.Lifted.Safe.withAsync'\
-  \ or our 'forkImmortal' instead formore robust threading."
-  #-}
-forkIO :: IO () -> IO ThreadId
-forkIO = Base.forkIO
-
 -- | Note: Please consider using 'forkManagedT' instead to ensure reliable
 -- resource cleanup.
 forkImmortal ::

server/src-lib/Control/Lens/Extended.hs

@@ -1,22 +0,0 @@
-module Control.Lens.Extended
-  ( module Control.Lens,
-    (^..),
-    (^@..),
-  )
-where
-
-import Control.Lens hiding ((^..), (^@..))
-import Data.Monoid (Endo)
-import GHC.Exts (IsList, Item, fromList)
-
-infixl 8 ^..
-
-(^..) :: (IsList l, Item l ~ a) => s -> Getting (Endo [a]) s a -> l
-v ^.. l = fromList (toListOf l v)
-{-# INLINE (^..) #-}
-
-infixl 8 ^@..
-
-(^@..) :: (IsList l, Item l ~ (i, a)) => s -> IndexedGetting i (Endo [(i, a)]) s a -> l
-v ^@.. l = fromList (itoListOf l v)
-{-# INLINE (^@..) #-}

server/src-lib/Data/HashMap/Strict/Extended.hs

@@ -5,18 +5,15 @@ module Data.HashMap.Strict.Extended
     groupOn,
     groupOnNE,
     differenceOn,
-    lpadZip,
     insertWithM,
     isInverseOf,
     unionWithM,
     unionsAll,
-    unionsWith,
     homogenise,
   )
 where
 
 import Control.Monad (foldM)
-import Data.Align qualified as A
 import Data.Foldable qualified as F
 import Data.Function (on)
 import Data.HashMap.Strict as M
@@ -25,7 +22,6 @@ import Data.HashSet qualified as S
 import Data.Hashable (Hashable)
 import Data.List qualified as L
 import Data.List.NonEmpty (NonEmpty (..))
-import Data.These (These (That, These, This))
 import Prelude
 
 catMaybes :: HashMap k (Maybe v) -> HashMap k v
@@ -54,18 +50,6 @@ differenceOn ::
   (Eq k, Hashable k, Foldable t) => (v -> k) -> t v -> t v -> HashMap k v
 differenceOn f = M.difference `on` (fromListOn f . F.toList)
 
--- | Analogous to 'A.lpadZip', but on 'HashMap's instead of lists.
-lpadZip ::
-  (Eq k, Hashable k) => HashMap k a -> HashMap k b -> HashMap k (Maybe a, b)
-lpadZip left =
-  catMaybes . flip
-    A.alignWith
-    left
-    \case
-      This _ -> Nothing
-      That b -> Just (Nothing, b)
-      These a b -> Just (Just a, b)
-
 -- | Monadic version of https://hackage.haskell.org/package/unordered-containers-0.2.18.0/docs/Data-HashMap-Internal.html#v:insertWith
 insertWithM :: (Monad m, Hashable k, Eq k) => (v -> v -> m v) -> k -> v -> HashMap k v -> m (HashMap k v)
 insertWithM f k v m =
@@ -124,20 +108,6 @@ unionsAll ::
   (Eq k, Hashable k, Foldable t) => t (HashMap k v) -> HashMap k (NonEmpty v)
 unionsAll = F.foldl' (\a b -> unionWith (<>) a (fmap (:| []) b)) M.empty
 
--- | The union of a list of maps, with a combining operation:
---   (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@).
---
--- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]
--- >     == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")]
---
--- copied from https://hackage.haskell.org/package/containers-0.6.4.1/docs/src/Data.Map.Internal.html#unionsWith
-unionsWith ::
-  (Foldable f, Hashable k, Ord k) =>
-  (a -> a -> a) ->
-  f (HashMap k a) ->
-  HashMap k a
-unionsWith f ts = F.foldl' (unionWith f) empty ts
-
 -- | Homogenise maps, such that all maps range over the full set of
 -- keys, inserting a default value as needed.
 homogenise :: (Hashable a, Eq a) => b -> [HashMap a b] -> (HashSet a, [HashMap a b])

server/src-lib/Data/HashMap/Strict/InsOrd/Extended.hs

@@ -1,8 +1,6 @@
 module Data.HashMap.Strict.InsOrd.Extended
   ( module OMap,
     catMaybes,
-    groupTuples,
-    groupListWith,
     partition,
     alterF,
   )
@@ -10,31 +8,11 @@ where
 
 import Data.HashMap.Strict.InsOrd as OMap
 import Data.Hashable (Hashable)
-import Data.List qualified as L
-import Data.Sequence.NonEmpty qualified as NE
 import Prelude
 
 catMaybes :: InsOrdHashMap k (Maybe v) -> InsOrdHashMap k v
 catMaybes = OMap.mapMaybe id
 
-groupTuples ::
-  (Eq k, Hashable k, Foldable t) =>
-  t (k, v) ->
-  OMap.InsOrdHashMap k (NE.NESeq v)
-groupTuples =
-  L.foldl' groupFlds OMap.empty
-  where
-    groupFlds m (k, v) =
-      OMap.insertWith (flip (<>)) k (NE.singleton v) m
-
-groupListWith ::
-  (Eq k, Hashable k, Foldable t, Functor t) =>
-  (v -> k) ->
-  t v ->
-  OMap.InsOrdHashMap k (NE.NESeq v)
-groupListWith f l =
-  groupTuples $ fmap (\v -> (f v, v)) l
-
 partition :: (Eq k, Hashable k) => (v -> Bool) -> OMap.InsOrdHashMap k v -> (OMap.InsOrdHashMap k v, OMap.InsOrdHashMap k v)
 partition predicate =
   OMap.foldlWithKey'

server/src-lib/Data/List/Extended.hs

@@ -4,10 +4,8 @@ module Data.List.Extended
     getDifference,
     getDifferenceOn,
     getOverlapWith,
-    hasNoDuplicates,
     longestCommonPrefix,
     appendToNonEmpty,
-    singleton,
     module L,
   )
 where
@@ -40,9 +38,6 @@ getOverlapWith getKey left right =
   where
     mkMap = Map.fromList . map (\v -> (getKey v, v))
 
-hasNoDuplicates :: (Eq a, Hashable a) => [a] -> Bool
-hasNoDuplicates xs = Set.size (Set.fromList xs) == length xs
-
 -- | Returns the longest prefix common to all given lists. Returns an empty list on an empty list.
 --
 -- >>> longestCommonPrefix ["abcd", "abce", "abgh"]
@@ -59,7 +54,3 @@ longestCommonPrefix (x : xs) = foldr prefix x xs
 appendToNonEmpty :: NE.NonEmpty a -> [a] -> NE.NonEmpty a
 appendToNonEmpty (neHead NE.:| neList) list =
   neHead NE.:| (neList <> list)
-
--- | As of base-4.15.0.0 (GHC > 9) singleton now exists in Data.List so we should be able to remove this when we upgrade.
-singleton :: a -> [a]
-singleton = pure

server/src-lib/Data/URL/Template.hs

@@ -7,7 +7,6 @@ module Data.URL.Template
     mkPlainURLTemplate,
     parseURLTemplate,
     renderURLTemplate,
-    genURLTemplate,
   )
 where
 
@@ -96,6 +95,3 @@ instance Arbitrary URLTemplate where
     where
       genText = TIText . T.pack <$> listOf1 (elements $ alphaNumerics <> " ://")
       genVariable = TIVariable <$> arbitrary
-
-genURLTemplate :: Gen URLTemplate
-genURLTemplate = arbitrary

server/src-lib/Hasura/GraphQL/Parser/Internal/Input.hs

@@ -14,7 +14,7 @@ module Hasura.GraphQL.Parser.Internal.Input
   )
 where
 
-import Control.Lens.Extended hiding (enum, index)
+import Control.Lens hiding (enum, index)
 import Data.Aeson qualified as A
 import Data.Aeson.Key qualified as K
 import Data.Aeson.KeyMap qualified as KM

server/src-lib/Hasura/GraphQL/Parser/Schema.hs

@@ -51,7 +51,7 @@ module Hasura.GraphQL.Parser.Schema
   )
 where
 
-import Control.Lens.Extended
+import Control.Lens
 import Data.Aeson qualified as J
 import Data.Functor.Classes
 import Data.Has

server/src-lib/Hasura/GraphQL/Schema.hs

@@ -7,7 +7,7 @@ module Hasura.GraphQL.Schema
 where
 
 import Control.Concurrent.Extended (forConcurrentlyEIO)
-import Control.Lens.Extended
+import Control.Lens
 import Data.Aeson.Ordered qualified as JO
 import Data.Has
 import Data.HashMap.Strict qualified as Map
@@ -102,7 +102,7 @@ buildGQLContext ServerConfigCtx {..} queryType sources allRemoteSchemas allActio
   let remoteSchemasRoles = concatMap (Map.keys . _rscPermissions . fst . snd) $ Map.toList allRemoteSchemas
       nonTableRoles =
         Set.insert adminRoleName $
-          (allActionInfos ^.. folded . aiPermissions . to Map.keys . folded)
+          Set.fromList (allActionInfos ^.. folded . aiPermissions . to Map.keys . folded)
             <> Set.fromList (bool mempty remoteSchemasRoles $ _sccRemoteSchemaPermsCtx == RemoteSchemaPermsEnabled)
       allActionInfos = Map.elems allActions
       allTableRoles = Set.fromList $ getTableRoles =<< Map.elems sources

server/src-lib/Hasura/RQL/DDL/RemoteRelationship.hs

@@ -19,8 +19,7 @@ module Hasura.RQL.DDL.RemoteRelationship
   )
 where
 
-import Control.Lens (at, non)
-import Control.Lens.Extended (to, (^?))
+import Control.Lens (at, non, to, (^?))
 import Data.Aeson (FromJSON (..), ToJSON (..), (.!=), (.:), (.:?), (.=))
 import Data.Aeson qualified as J
 import Data.Aeson.KeyMap qualified as KM

server/src-lib/Hasura/RQL/DDL/Schema/Table.hs

@@ -21,7 +21,7 @@ module Hasura.RQL.DDL.Schema.Table
 where
 
 import Control.Arrow.Extended
-import Control.Lens.Extended hiding ((.=))
+import Control.Lens hiding ((.=))
 import Control.Monad.Trans.Control (MonadBaseControl)
 import Data.Aeson
 import Data.Aeson.Ordered qualified as JO
@@ -355,7 +355,7 @@ unTrackExistingTableOrViewP2 (UntrackTable source qtn cascade) = withNewInconsis
       indirectDeps = mapMaybe getIndirectDep allDeps
 
   -- Report bach with an error if cascade is not set
-  when (not (null indirectDeps) && not cascade) $
+  unless (null indirectDeps || cascade) $
     reportDependentObjectsExist indirectDeps
   -- Purge all the dependents from state
   metadataModifier <- execWriterT do

server/src-lib/Hasura/SQL/TH.hs

@@ -20,7 +20,6 @@ module Hasura.SQL.TH
     getBackendTypeValue,
     getBackendTagName,
     getBackendValueName,
-    backendList,
     backendCase,
     backendData,
     mkDispatch,
@@ -70,10 +69,6 @@ getBackendTagName backend = mkName $ concatMap nameBase backend ++ "Tag"
 getBackendValueName :: BackendConstructor -> Name
 getBackendValueName backend = mkName $ concatMap nameBase backend ++ "Value"
 
--- | Creates a list of values by associating an expression to each backend.
-backendList :: (BackendConstructor -> Q Exp) -> Q Exp
-backendList f = ListE <$> forEachBackend f
-
 -- | Creates a case expression with a match for each backend. It is not possible
 -- do directly expand a @Q [Match]@, which is a body of a case, hence the need
 -- to instead generate the full @Q Exp@.

server/src-lib/Hasura/Server/Init.hs

@@ -31,7 +31,6 @@ import Hasura.Prelude
 import Hasura.RQL.Types.Common
 import Hasura.RQL.Types.Function
 import Hasura.RQL.Types.RemoteSchema
-import Hasura.RQL.Types.SchemaCache
 import Hasura.RQL.Types.SourceCustomization (NamingCase)
 import Hasura.Server.Auth
 import Hasura.Server.Cors
@@ -1453,12 +1452,6 @@ mkGenericLog :: (J.ToJSON a) => L.LogLevel -> Text -> a -> StartupLog
 mkGenericLog logLevel k msg =
   StartupLog logLevel k $ J.toJSON msg
 
-inconsistentMetadataLog :: SchemaCache -> StartupLog
-inconsistentMetadataLog sc =
-  StartupLog L.LevelWarn "inconsistent_metadata" infoVal
-  where
-    infoVal = J.object ["objects" J..= scInconsistentObjs sc]
-
 serveOptionsParser :: L.EnabledLogTypes impl => Parser (RawServeOptions impl)
 serveOptionsParser =
   RawServeOptions

server/src-lib/Hasura/Server/Utils.hs

@@ -31,7 +31,6 @@ module Hasura.Server.Utils
     redactSensitiveHeader,
     requestIdHeader,
     sqlHeader,
-    htmlHeader,
     useBackendOnlyPermissionsHeader,
     userIdHeader,
     userRoleHeader,
@@ -75,9 +74,6 @@ jsonHeader = ("Content-Type", "application/json; charset=utf-8")
 sqlHeader :: HTTP.Header
 sqlHeader = ("Content-Type", "application/sql; charset=utf-8")
 
-htmlHeader :: HTTP.Header
-htmlHeader = ("Content-Type", "text/html; charset=utf-8")
-
 gzipHeader :: HTTP.Header
 gzipHeader = ("Content-Encoding", "gzip")
 

server/src-lib/Hasura/Session.hs

@@ -3,7 +3,6 @@ module Hasura.Session
     mkRoleName,
     mkRoleNameSafe,
     adminRoleName,
-    isAdmin,
     roleNameToTxt,
     SessionVariable,
     mkSessionVariable,
@@ -78,9 +77,6 @@ mkRoleNameSafe = RoleName
 adminRoleName :: RoleName
 adminRoleName = RoleName $ mkNonEmptyTextUnsafe "admin"
 
-isAdmin :: RoleName -> Bool
-isAdmin = (adminRoleName ==)
-
 newtype SessionVariable = SessionVariable {unSessionVariable :: CI.CI Text}
   deriving (Show, Eq, Hashable, IsString, Cacheable, Data, NFData, Ord)
 

server/src-test/Data/Parser/URLTemplateSpec.hs

@@ -9,7 +9,7 @@ spec :: Spec
 spec = describe "parseURLTemplate" $
   it "URL template parser and printer" $
     withMaxSuccess 1000 $
-      forAll genURLTemplate $ \urlTemplate -> do
+      forAll (arbitrary :: Gen URLTemplate) $ \urlTemplate -> do
         let templateString = printURLTemplate urlTemplate
         case parseURLTemplate templateString of
           Left e -> counterexample e False

server/src-test/Hasura/RQL/IR/SelectSpec.hs

@@ -1,7 +1,6 @@
 module Hasura.RQL.IR.SelectSpec (spec) where
 
 import Data.Bifoldable
-import Data.List.Extended (singleton)
 import Hasura.Backends.Postgres.RQLGenerator
 import Hasura.Generator.Common (defaultRange)
 import Hasura.Prelude
@@ -25,6 +24,9 @@ genMyPair genR genV = do
 spec :: Spec
 spec = do
   describe "bifoldMapAnnSelectG" $ do
+    let singleton :: a -> [a]
+        singleton x = [x]
+
     it "bifoldMapAnnSelectG (const mempty) == foldMap" $
       hedgehog $ do
         annSelectG :: AnnSelectG ('Postgres 'Vanilla) (MyPair ('Postgres 'Vanilla) Int) Int <-

weeder.dhall

@@ -12,7 +12,16 @@
       -- things. While these functions may not all be used, they're still worth
       -- keeping around until this module is extracted from the monorepo.
     , "^Control.Arrow.Extended.*"
+
+    , "^Data.Aeson.Ordered.*"
+    , "^Data.HashMap.Strict.Multi.*"
     , "^Data.HashMap.Strict.NonEmpty.*"
+    , "^Data.Sequence.NonEmpty.*"
+    , "^Data.Text.Casing.*"
+    , "^Data.Text.Extended.*"
+    , "^Data.Trie.*"
+
+    , "^Database.MSSQL.Transaction.*"
 
       -- Debugging functions. They are not entry points, but if we include them
       -- as such, Weeder won't try to get rid of the definitions.
@@ -20,6 +29,20 @@
       -- https://github.com/ocharles/weeder/pull/58
     , "^Hasura.Prelude.ltrace$"
     , "^Hasura.Prelude.ltraceM$"
+
+      -- TemplateHaskell and QuasiQuotes aren't detected by Weeder, so we have
+      -- to sort through these manually.
+    , "^Data.Text.NonEmpty.nonEmptyTextQQ$"
+
+    , "^Hasura.SQL.TH.backendCase$"
+    , "^Hasura.SQL.TH.backendConstructors$"
+    , "^Hasura.SQL.TH.backendData$"
+    , "^Hasura.SQL.TH.forEachBackend$"
+    , "^Hasura.SQL.TH.getBackendTagName$"
+    , "^Hasura.SQL.TH.getBackendTypeValue$"
+    , "^Hasura.SQL.TH.getBackendValue$"
+    , "^Hasura.SQL.TH.getBackendValueName$"
+    , "^Hasura.SQL.TH.mkDispatch$"
     ]
 
 , type-class-roots = True