diff options
Diffstat (limited to 'users/Profpatsch/mailbox-org')
| -rw-r--r-- | users/Profpatsch/mailbox-org/MailboxOrg.hs | 85 | ||||
| -rw-r--r-- | users/Profpatsch/mailbox-org/default.nix | 2 | ||||
| -rw-r--r-- | users/Profpatsch/mailbox-org/mailbox-org.cabal | 81 | ||||
| -rw-r--r-- | users/Profpatsch/mailbox-org/src/AesonQQ.hs (renamed from users/Profpatsch/mailbox-org/AesonQQ.hs) | 7 |
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 |] |