From 1fd59f51580244bac8e75b4c08f103daa20674d9 Mon Sep 17 00:00:00 2001 From: Profpatsch Date: Sun, 6 Aug 2023 12:46:50 +0200 Subject: chore(users/Profpatsch): clean up haskell libs a little Change-Id: Ia9a6c5a754ca8f2912308feb5a26f5276a08d24c Reviewed-on: https://cl.tvl.fyi/c/depot/+/9011 Reviewed-by: Profpatsch Autosubmit: Profpatsch Tested-by: BuildkiteCI --- users/Profpatsch/mailbox-org/AesonQQ.hs | 23 ------- users/Profpatsch/mailbox-org/MailboxOrg.hs | 85 ++++++++++++-------------- users/Profpatsch/mailbox-org/default.nix | 2 +- users/Profpatsch/mailbox-org/mailbox-org.cabal | 81 ++++++++++++++++++++---- users/Profpatsch/mailbox-org/src/AesonQQ.hs | 24 ++++++++ 5 files changed, 133 insertions(+), 82 deletions(-) delete mode 100644 users/Profpatsch/mailbox-org/AesonQQ.hs create mode 100644 users/Profpatsch/mailbox-org/src/AesonQQ.hs (limited to 'users/Profpatsch/mailbox-org') diff --git a/users/Profpatsch/mailbox-org/AesonQQ.hs b/users/Profpatsch/mailbox-org/AesonQQ.hs deleted file mode 100644 index f12afdf51584..000000000000 --- a/users/Profpatsch/mailbox-org/AesonQQ.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} - -module AesonQQ where - -import Data.Aeson qualified as Json -import Data.Either qualified as Either -import PossehlAnalyticsPrelude -import PyF qualified -import PyF.Internal.QQ qualified as PyFConf - -aesonQQ = - PyF.mkFormatter - "aesonQQ" - PyF.defaultConfig - { PyFConf.delimiters = Just ('|', '|'), - 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 - Left err -> error err - Right a -> a - |] - } 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/src/AesonQQ.hs b/users/Profpatsch/mailbox-org/src/AesonQQ.hs new file mode 100644 index 000000000000..2ac3d533aeaa --- /dev/null +++ b/users/Profpatsch/mailbox-org/src/AesonQQ.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +module AesonQQ where + +import Data.Aeson qualified as Json +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 + -- 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 + Left err -> error err + Right a -> a + |] + } -- cgit 1.4.1