refactor(users/Profpatsch/whatcd-resolver): init MyLabel

move the label stuff into its own temporary module (until we figure
out what to put into pa-label).

Also rewrite a few things to use t2/t3.

Change-Id: I8cc8678ec01a56d6c738eb4833a3ba566a7a1e20
Reviewed-on: https://cl.tvl.fyi/c/depot/+/13242
Tested-by: BuildkiteCI
Reviewed-by: Profpatsch <mail@profpatsch.de>

users/Profpatsch/whatcd-resolver/default.nix

@@ -13,6 +13,7 @@ let
       ./src/WhatcdResolver.hs
       ./src/AppT.hs
       ./src/Bencode.hs
+      ./src/MyLabel.hs
       ./src/JsonLd.hs
       ./src/Optional.hs
       ./src/Html.hs

users/Profpatsch/whatcd-resolver/src/MyLabel.hs

@@ -0,0 +1,47 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module MyLabel where
+
+import GHC.OverloadedLabels (IsLabel (fromLabel))
+import GHC.Records (HasField (..))
+import GHC.TypeLits (Symbol)
+import Label
+import MyPrelude
+import Prelude hiding (span)
+
+-- case-match on an e2 with a t2 that provides the relevant functions
+caseE2 ::
+  forall l1 t1 l2 t2 matcher r.
+  ( HasField l1 matcher (t1 -> r),
+    HasField l2 matcher (t2 -> r)
+  ) =>
+  matcher ->
+  E2 l1 t1 l2 t2 ->
+  r
+{-# INLINE caseE2 #-}
+caseE2 m e2 = do
+  let f1 = getField @l1 m
+  let f2 = getField @l2 m
+  case e2 of
+    E21 a -> f1 $ getField @l1 a
+    E22 b -> f2 $ getField @l2 b
+
+t2 :: forall l1 t1 l2 t2. LabelPrx l1 -> t1 -> LabelPrx l2 -> t2 -> T2 l1 t1 l2 t2
+{-# INLINE t2 #-}
+t2 LabelPrx a LabelPrx b = T2 (label @l1 a) (label @l2 b)
+
+t3 :: forall l1 t1 l2 t2 l3 t3. LabelPrx l1 -> t1 -> LabelPrx l2 -> t2 -> LabelPrx l3 -> t3 -> T3 l1 t1 l2 t2 l3 t3
+{-# INLINE t3 #-}
+t3 LabelPrx a LabelPrx b LabelPrx c = T3 (label @l1 a) (label @l2 b) (label @l3 c)
+
+lbl :: forall l t. LabelPrx l -> t -> Label l t
+{-# INLINE lbl #-}
+lbl LabelPrx a = label @l a
+
+data LabelPrx (l :: Symbol) = LabelPrx
+
+instance (l ~ l') => IsLabel l (LabelPrx l') where
+  fromLabel = LabelPrx
+
+instance (t ~ t') => IsLabel l (t -> (Label l t')) where
+  fromLabel = label @l

users/Profpatsch/whatcd-resolver/src/Redacted.hs

@@ -27,6 +27,7 @@ import FieldParser qualified as Field
 import Http qualified
 import Json qualified
 import Label
+import MyLabel
 import MyPrelude
 import Network.HTTP.Types
 import Network.Wai.Parse qualified as Wai
@@ -60,10 +61,13 @@ redactedSearch extraArguments dat parser =
   inSpan' "Redacted API Search" $ \span ->
     redactedPagedRequest
       span
-      ( T3
-          (label @"action" "browse")
-          (getLabel @"actionArgs" extraArguments)
-          (getLabel @"page" dat)
+      ( t3
+          #action
+          "browse"
+          #actionArgs
+          extraArguments.actionArgs
+          #page
+          dat.page
       )
       parser
 
@@ -81,10 +85,13 @@ redactedGetArtist dat parser =
   inSpan' "Redacted Get Artist" $ \span -> do
     redactedPagedRequest
       span
-      ( T3
-          (label @"action" "artist")
-          (label @"actionArgs" [("id", buildBytes intDecimalB dat.artistId)])
-          (getLabel @"page" dat)
+      ( t3
+          #action
+          "artist"
+          #actionArgs
+          [("id", buildBytes intDecimalB dat.artistId)]
+          #page
+          (dat.page)
       )
       parser
 
@@ -103,14 +110,15 @@ redactedPagedRequest ::
 redactedPagedRequest span dat parser =
   redactedApiRequestJson
     span
-    ( T2
-        (label @"action" dat.action)
-        ( label @"actionArgs" $
-            (dat.actionArgs <&> second Just)
-              <> ( dat.page
-                     & ifExists
-                       (\page -> ("page", Just $ buildBytes naturalDecimalB page))
-                 )
+    ( t2
+        #action
+        dat.action
+        #actionArgs
+        ( (dat.actionArgs <&> second Just)
+            <> ( dat.page
+                   & ifExists
+                     (\page -> ("page", Just $ buildBytes naturalDecimalB page))
+               )
         )
     )
     parser
@@ -149,7 +157,7 @@ mkRedactedTorrentLink torrentId = [fmt|https://redacted.sh/torrents.php?id={torr
 
 exampleSearch :: (MonadThrow m, MonadLogger m, MonadPostgres m, MonadOtel m, MonadRedacted m) => m (Transaction m ())
 exampleSearch = do
-  t1 <-
+  x1 <-
     redactedSearchAndInsert
       [ ("searchstr", "cherish"),
         ("artistname", "kirinji"),
@@ -158,7 +166,7 @@ exampleSearch = do
         -- ("releasetype", "album"),
         ("order_by", "year")
       ]
-  t3 <-
+  x3 <-
     redactedSearchAndInsert
       [ ("searchstr", "mouss et hakim"),
         ("artistname", "mouss et hakim"),
@@ -167,7 +175,7 @@ exampleSearch = do
         -- ("releasetype", "album"),
         ("order_by", "year")
       ]
-  t2 <-
+  x2 <-
     redactedSearchAndInsert
       [ ("searchstr", "thriller"),
         ("artistname", "michael jackson"),
@@ -176,7 +184,7 @@ exampleSearch = do
         -- ("releasetype", "album"),
         ("order_by", "year")
       ]
-  pure (t1 >> t2 >> t3 >> pure ())
+  pure (x1 >> x2 >> x3 >> pure ())
 
 redactedRefreshArtist ::
   ( MonadLogger m,
@@ -190,7 +198,15 @@ redactedRefreshArtist ::
   m (Transaction m (Label "newTorrents" [Label "torrentId" Int]))
 redactedRefreshArtist dat = do
   redactedPagedSearchAndInsert
-    (Json.key "torrentgroup" $ parseTourGroups (T2 (label @"torrentFieldName" "torrent") (label @"torrentIdName" "id")))
+    ( Json.key "torrentgroup" $
+        parseTourGroups
+          ( t2
+              #torrentFieldName
+              "torrent"
+              #torrentIdName
+              "id"
+          )
+    )
     ( \page ->
         redactedGetArtist
           ( T2

users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs

@@ -1,7 +1,5 @@
 {-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE QuasiQuotes #-}
-{-# OPTIONS_GHC -Wno-orphans #-}
 
 module WhatcdResolver where
 
@@ -32,9 +30,7 @@ import Database.PostgreSQL.Simple.Types (Only (..), PGArray (PGArray))
 import Database.Postgres.Temp qualified as TmpPg
 import FieldParser (FieldParser)
 import FieldParser qualified as Field
-import GHC.OverloadedLabels (IsLabel (fromLabel))
 import GHC.Records (HasField (..))
-import GHC.TypeLits (Symbol)
 import Html qualified
 import Http
 import IHP.HSX.QQ (hsx)
@@ -46,6 +42,7 @@ import JsonLd
 import Label
 import Multipart2 (MultipartParseT)
 import Multipart2 qualified as Multipart
+import MyLabel
 import MyPrelude
 import Network.HTTP.Client.Conduit qualified as Http
 import Network.HTTP.Simple qualified as Http
@@ -1559,40 +1556,3 @@ prefetchResourceIntegrity dat = inSpan' [fmt|prefetching resource {dat.integrity
                         (toLazyBytes $ bodyStrict)
           )
     | code <- statusCode -> appThrow span $ AppExceptionPretty [[fmt|Server returned an non-200 error code, code {code}:|], pretty resp]
-
--- case-match on an e2 with a t2 that provides the relevant functions
-caseE2 ::
-  forall l1 t1 l2 t2 matcher r.
-  ( HasField l1 matcher (t1 -> r),
-    HasField l2 matcher (t2 -> r)
-  ) =>
-  matcher ->
-  E2 l1 t1 l2 t2 ->
-  r
-{-# INLINE caseE2 #-}
-caseE2 m e2 = do
-  let f1 = getField @l1 m
-  let f2 = getField @l2 m
-  case e2 of
-    E21 a -> f1 $ getField @l1 a
-    E22 b -> f2 $ getField @l2 b
-
-t2 :: forall l1 t1 l2 t2. LabelPrx l1 -> t1 -> LabelPrx l2 -> t2 -> T2 l1 t1 l2 t2
-{-# INLINE t2 #-}
-t2 LabelPrx a LabelPrx b = T2 (label @l1 a) (label @l2 b)
-
-t3 :: forall l1 t1 l2 t2 l3 t3. LabelPrx l1 -> t1 -> LabelPrx l2 -> t2 -> LabelPrx l3 -> t3 -> T3 l1 t1 l2 t2 l3 t3
-{-# INLINE t3 #-}
-t3 LabelPrx a LabelPrx b LabelPrx c = T3 (label @l1 a) (label @l2 b) (label @l3 c)
-
-lbl :: forall l t. LabelPrx l -> t -> Label l t
-{-# INLINE lbl #-}
-lbl LabelPrx a = label @l a
-
-data LabelPrx (l :: Symbol) = LabelPrx
-
-instance (l ~ l') => IsLabel l (LabelPrx l') where
-  fromLabel = LabelPrx
-
-instance (t ~ t') => IsLabel l (t -> (Label l t')) where
-  fromLabel = label @l

users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal

@@ -32,6 +32,9 @@ common common-options
     -- known as RecordDotSyntax
     OverloadedRecordDot
 
+    -- Make #labels available
+    OverloadedLabels
+
     -- does not export record fields as functions, use OverloadedRecordDot to access instead
     NoFieldSelectors
 
@@ -68,6 +71,7 @@ library
        Bencode
        JsonLd
        Optional
+       MyLabel
        Http
        Html
        Transmission