chore(users/Profpatsch): clean up haskell libs a little r/6464

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

4 files changed, 113 insertions, 62 deletions

diff --git a/users/Profpatsch/mailbox-org/MailboxOrg.hs b/users/Profpatsch/mailbox-org/MailboxOrg.hs
index c66db49c13c7..6c5820080c76 100644
--- a/users/Profpatsch/mailbox-org/MailboxOrg.hs
+++ b/users/Profpatsch/mailbox-org/MailboxOrg.hs
@@ -1,6 +1,5 @@
 {-# LANGUAGE ApplicativeDo #-}
 {-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE GHC2021 #-}
 {-# LANGUAGE LambdaCase #-}
@@ -31,7 +30,6 @@ import Data.List qualified as List
 import Data.Map.Strict qualified as Map
 import Data.Text qualified as Text
 import ExecHelpers
-import GHC.Records (HasField (..))
 import Label
 import Netencode qualified
 import Netencode.Parse qualified as NetParse
@@ -117,9 +115,7 @@ listFilterConfig session = do
     >>= printPretty
 
 applyFilterRule ::
-  ( HasField "folderId" dat Text,
-    HasField "rulename" dat Text
-  ) =>
+  (HasField "folderId" dat Text) =>
   dat ->
   Session ->
   IO ()
@@ -209,48 +205,47 @@ applyFilters session = do
             <&> mapFromListOn (\dat -> getLabel @"rulename" dat.parsed)
       )
       ([] :: [()])
-  let goal = Map.fromList [(label @"rulename" "another", 32), (label @"rulename" "xyz", 23)]
+  let goal = Map.fromList [(label @"rulename" "another", 32 :: Integer), (label @"rulename" "xyz", 23)]
   let actions = declarativeUpdate goal filters
   log [fmt|To * create: {actions.toCreate & Map.keys & show}, * update: {actions.toUpdate & Map.keys & show}, * delete: {actions.toDelete & Map.keys & show}|]
-  where
-    -- filters
-    --   & Map.elems
-    --   & traverse_
-    --     ( updateIfDifferent
-    --         session
-    --         ( \el ->
-    --             pure $
-    --               el.original.mailfilter
-    --                 & KeyMap.insert "active" (Json.Bool False)
-    --         )
-    --         (pure ())
-    --     )
-
-    mapFromListOn :: Ord k => (a -> k) -> [a] -> Map k a
-    mapFromListOn on xs = xs <&> (\x -> (on x, x)) & Map.fromList
-    updateIfDifferent ::
-      forall label parsed.
-      ( HasField "id_" parsed Json.Value,
-        HasField "rulename" parsed Text
-      ) =>
-      Session ->
-      (Dat label Json.Object parsed -> IO Json.Object) ->
-      Json.Parse Error () ->
-      Dat label Json.Object parsed ->
-      IO ()
-    updateIfDifferent session switcheroo parser dat = do
-      new <- switcheroo dat
-      if new /= getField @label dat.original
-        then do
-          log [fmt|Updating filter "{dat.parsed.rulename}" (id {dat.parsed.id_ & show @Json.Value})|]
-          mailfilter
-            session
-            "update"
-            mempty
-            parser
-            new
-        else do
-          log [fmt|Skipping updating filter "{dat.parsed.rulename}" (id {dat.parsed.id_ & show @Json.Value}) because nothing changed.|]
+
+-- where
+-- filters
+--   & Map.elems
+--   & traverse_
+--     ( updateIfDifferent
+--         session
+--         ( \el ->
+--             pure $
+--               el.original.mailfilter
+--                 & KeyMap.insert "active" (Json.Bool False)
+--         )
+--         (pure ())
+--     )
+
+-- updateIfDifferent ::
+--   forall label parsed.
+--   ( HasField "id_" parsed Json.Value,
+--     HasField "rulename" parsed Text
+--   ) =>
+--   Session ->
+--   (Dat label Json.Object parsed -> IO Json.Object) ->
+--   Json.Parse Error () ->
+--   Dat label Json.Object parsed ->
+--   IO ()
+-- updateIfDifferent session switcheroo parser dat = do
+--   new <- switcheroo dat
+--   if new /= getField @label dat.original
+--     then do
+--       log [fmt|Updating filter "{dat.parsed.rulename}" (id {dat.parsed.id_ & show @Json.Value})|]
+--       mailfilter
+--         session
+--         "update"
+--         mempty
+--         parser
+--         new
+--     else do
+--       log [fmt|Skipping updating filter "{dat.parsed.rulename}" (id {dat.parsed.id_ & show @Json.Value}) because nothing changed.|]
 
 -- | https://oxpedia.org/wiki/index.php?title=HTTP_API_MailFilter
 mailfilter ::
diff --git a/users/Profpatsch/mailbox-org/default.nix b/users/Profpatsch/mailbox-org/default.nix
index 2cb4c7af8e6c..73bd28292dcc 100644
--- a/users/Profpatsch/mailbox-org/default.nix
+++ b/users/Profpatsch/mailbox-org/default.nix
@@ -7,7 +7,7 @@ let
 
     src = depot.users.Profpatsch.exactSource ./. [
       ./mailbox-org.cabal
-      ./AesonQQ.hs
+      ./src/AesonQQ.hs
       ./MailboxOrg.hs
     ];
 
diff --git a/users/Profpatsch/mailbox-org/mailbox-org.cabal b/users/Profpatsch/mailbox-org/mailbox-org.cabal
index 8125baef7144..8e5328907a9e 100644
--- a/users/Profpatsch/mailbox-org/mailbox-org.cabal
+++ b/users/Profpatsch/mailbox-org/mailbox-org.cabal
@@ -4,38 +4,93 @@ version:            0.1.0.0
 author:             Profpatsch
 maintainer:         mail@profpatsch.de
 
+
+common common-options
+  ghc-options:
+      -Wall
+      -Wno-type-defaults
+      -Wunused-packages
+      -Wredundant-constraints
+      -fwarn-missing-deriving-strategies
+
+  -- See https://downloads.haskell.org/ghc/latest/docs/users_guide/exts.html
+  -- for a description of all these extensions
+  default-extensions:
+      -- Infer Applicative instead of Monad where possible
+    ApplicativeDo
+
+    -- Allow literal strings to be Text
+    OverloadedStrings
+
+    -- Syntactic sugar improvements
+    LambdaCase
+    MultiWayIf
+
+    -- Makes the (deprecated) usage of * instead of Data.Kind.Type an error
+    NoStarIsType
+
+    -- Convenient and crucial to deal with ambiguous field names, commonly
+    -- known as RecordDotSyntax
+    OverloadedRecordDot
+
+    -- does not export record fields as functions, use OverloadedRecordDot to access instead
+    NoFieldSelectors
+
+    -- Record punning
+    RecordWildCards
+
+    -- Improved Deriving
+    DerivingStrategies
+    DerivingVia
+
+    -- Type-level strings
+    DataKinds
+
+    -- to enable the `type` keyword in import lists (ormolu uses this automatically)
+    ExplicitNamespaces
+
+  default-language: GHC2021
+
+
+library
+    import: common-options
+
+    hs-source-dirs: src
+
+    exposed-modules:
+        AesonQQ
+
+    build-depends:
+        base >=4.15 && <5,
+        pa-prelude,
+        aeson,
+        PyF,
+        template-haskell
+
+
+
 executable mailbox-org
+    import: common-options
     main-is: MailboxOrg.hs
 
     build-depends:
         base >=4.15 && <5,
+        mailbox-org,
         my-prelude,
         pa-prelude,
         pa-label,
+        pa-pretty,
         pa-error-tree,
         exec-helpers,
         netencode,
         text,
-        semigroupoids,
-        nonempty-containers,
-        data-fix,
-        selective,
         directory,
-        mtl,
         filepath,
         arglib-netencode,
         random,
         http-conduit,
-        http-client,
         aeson,
         aeson-better-errors,
         bytestring,
-        PyF,
         typed-process,
-        process,
         containers,
-
-    default-language: Haskell2010
-
-    default-extensions:
-        GHC2021
diff --git a/users/Profpatsch/mailbox-org/AesonQQ.hs b/users/Profpatsch/mailbox-org/src/AesonQQ.hs
index f12afdf51584..2ac3d533aeaa 100644
--- a/users/Profpatsch/mailbox-org/AesonQQ.hs
+++ b/users/Profpatsch/mailbox-org/src/AesonQQ.hs
@@ -3,20 +3,21 @@
 module AesonQQ where
 
 import Data.Aeson qualified as Json
-import Data.Either qualified as Either
+import Language.Haskell.TH.Quote (QuasiQuoter)
 import PossehlAnalyticsPrelude
 import PyF qualified
 import PyF.Internal.QQ qualified as PyFConf
 
+aesonQQ :: QuasiQuoter
 aesonQQ =
   PyF.mkFormatter
     "aesonQQ"
     PyF.defaultConfig
       { PyFConf.delimiters = Just ('|', '|'),
-        PyFConf.postProcess = \exp -> do
+        PyFConf.postProcess = \exp_ -> do
           -- TODO: this does not throw an error at compilation time if the json does not parse
           [|
-            case Json.eitherDecodeStrict' @Json.Value $ textToBytesUtf8 $ stringToText $(exp) of
+            case Json.eitherDecodeStrict' @Json.Value $ textToBytesUtf8 $ stringToText $(exp_) of
               Left err -> error err
               Right a -> a
             |]