From c784da3d0cb2768389ab488060da1e1c7590f23e Mon Sep 17 00:00:00 2001 From: Stephen Morgan Date: Wed, 25 Aug 2021 16:07:16 +1000 Subject: [PATCH] dev: lens: Create a Template Haskell helper for generating classy lenses for hledger options. This works for BalancingOpts, InputOpts, ReportOpts, ReportSpec, and CliOpts. --- hledger-lib/Hledger/Utils.hs | 65 +++++++++++++++++++++++++++++++++-- hledger-lib/hledger-lib.cabal | 3 ++ hledger-lib/package.yaml | 1 + 3 files changed, 67 insertions(+), 2 deletions(-) diff --git a/hledger-lib/Hledger/Utils.hs b/hledger-lib/Hledger/Utils.hs index d4fca830b..0e50db745 100644 --- a/hledger-lib/Hledger/Utils.hs +++ b/hledger-lib/Hledger/Utils.hs @@ -37,16 +37,20 @@ module Hledger.Utils (---- provide these frequently used modules - or not, for c where import Control.Monad (when) +import Data.Char (toLower) import Data.FileEmbed (makeRelativeToProject, embedStringFile) -import Data.List (foldl', foldl1') --- import Data.String.Here (hereFile) +import Data.List.Extra (foldl', foldl1', uncons, unsnoc) +import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text.IO as T import Data.Time.Clock (getCurrentTime) import Data.Time.LocalTime (LocalTime, ZonedTime, getCurrentTimeZone, utcToLocalTime, utcToZonedTime) +import Language.Haskell.TH (DecsQ, Name, mkName, nameBase) -- import Language.Haskell.TH.Quote (QuasiQuoter(..)) import Language.Haskell.TH.Syntax (Q, Exp) +import Lens.Micro ((&), (.~)) +import Lens.Micro.TH (DefName(TopName), lensClass, lensField, makeLensesWith, classyRules) import System.Directory (getHomeDirectory) import System.FilePath (isRelative, ()) import System.IO @@ -243,6 +247,63 @@ embedFileRelative f = makeRelativeToProject f >>= embedStringFile -- where -- QuasiQuoter{quoteExp=hereFileExp} = hereFile + +-- | Make classy lenses for Hledger options fields. +-- This is intended to be used with BalancingOpts, InputOpt, ReportOpts, +-- ReportSpec, and CliOpts. +-- When run on X, it will create a typeclass named HasX (except for ReportOpts, +-- which will be named HasReportOptsNoUpdate) containing all the lenses for that type. +-- If the field name starts with an underscore, the lens name will be created +-- by stripping the underscore from the front on the name. If the field name ends with +-- an underscore, the field name ends with an underscore, the lens name will be +-- mostly created by stripping the underscore, but a few names for which this +-- would create too many conflicts instead have a second underscore appended. +-- ReportOpts fields for which updating them requires updating the query in +-- ReportSpec are instead names by dropping the trailing underscore and +-- appending NoUpdate to the name, e.g. querystring_ -> querystringNoUpdate. +-- +-- There are a few reasons for the complicated rules. +-- - We have some legacy field names ending in an underscore (e.g. value_) +-- which we want to temporarily accommodate, before eventually switching to +-- a more modern style (e.g. _rsReportOpts) +-- - Certain fields in ReportOpts need to update the enclosing ReportSpec when +-- they are updated, and it is a common programming error to forget to do +-- this. We append NoUpdate to those lenses which will not update the +-- enclosing field, and reserve the shorter name for manually define lenses +-- (or at least something lens-like) which will update the ReportSpec. +-- cf. the lengthy discussion here and in surrounding comments: +-- https://github.com/simonmichael/hledger/pull/1545#issuecomment-881974554 +makeHledgerClassyLenses :: Name -> DecsQ +makeHledgerClassyLenses x = flip makeLensesWith x $ classyRules + & lensField .~ (\_ _ n -> fieldName $ nameBase n) + & lensClass .~ (className . nameBase) + where + fieldName n | Just ('_', name) <- uncons n = [TopName (mkName name)] + | Just (name, '_') <- unsnoc n, + name `Set.member` queryFields = [TopName (mkName $ name ++ "NoUpdate")] + | Just (name, '_') <- unsnoc n, + name `Set.member` commonFields = [TopName (mkName $ name ++ "__")] + | Just (name, '_') <- unsnoc n = [TopName (mkName name)] + | otherwise = [] + + -- Fields which would cause too many conflicts if we exposed lenses with these names. + commonFields = Set.fromList + [ "empty", "drop", "color", "transpose" -- ReportOpts + , "anon", "new", "auto" -- InputOpts + , "rawopts", "file", "debug", "width" -- CliOpts + ] + + -- When updating some fields of ReportOpts within a ReportSpec, we need to + -- update the rsQuery term as well. To do this we implement a special + -- HasReportOpts class with some special behaviour. We therefore give the + -- basic lenses a special NoUpdate name to avoid conflicts. + className "ReportOpts" = Just (mkName "HasReportOptsNoUpdate", mkName "reportOptsNoUpdate") + className (x:xs) = Just (mkName ("Has" ++ x:xs), mkName (toLower x : xs)) + className [] = Nothing + + -- Fields of ReportOpts which need to update the Query when they are updated. + queryFields = Set.fromList ["period", "statuses", "depth", "date2", "real", "querystring"] + tests_Utils = tests "Utils" [ tests_Text ] diff --git a/hledger-lib/hledger-lib.cabal b/hledger-lib/hledger-lib.cabal index 0ac014e4f..fa3e90d52 100644 --- a/hledger-lib/hledger-lib.cabal +++ b/hledger-lib/hledger-lib.cabal @@ -119,6 +119,7 @@ library , hashtables >=1.2.3.1 , megaparsec >=7.0.0 && <9.2 , microlens >=0.4 + , microlens-th >=0.4 , mtl >=2.2.1 , parser-combinators >=0.4.0 , pretty-simple >4 && <5 @@ -169,6 +170,7 @@ test-suite doctest , hashtables >=1.2.3.1 , megaparsec >=7.0.0 && <9.2 , microlens >=0.4 + , microlens-th >=0.4 , mtl >=2.2.1 , parser-combinators >=0.4.0 , pretty-simple >4 && <5 @@ -221,6 +223,7 @@ test-suite unittest , hledger-lib , megaparsec >=7.0.0 && <9.2 , microlens >=0.4 + , microlens-th >=0.4 , mtl >=2.2.1 , parser-combinators >=0.4.0 , pretty-simple >4 && <5 diff --git a/hledger-lib/package.yaml b/hledger-lib/package.yaml index 1964a3a1f..daebcac7b 100644 --- a/hledger-lib/package.yaml +++ b/hledger-lib/package.yaml @@ -53,6 +53,7 @@ dependencies: - hashtables >=1.2.3.1 - megaparsec >=7.0.0 && <9.2 - microlens >=0.4 +- microlens-th >=0.4 - mtl >=2.2.1 - parser-combinators >=0.4.0 - pretty-simple >4 && <5