diff --git a/Penny.hs b/Penny.hs deleted file mode 100644 --- a/Penny.hs +++ /dev/null @@ -1,457 +0,0 @@ --- | Penny - extensible double-entry accounting system - -module Penny - ( -- * Building a custom Penny binary - - -- | Everything you need to create a custom Penny program is - -- available by importing only this module. - Version(..) - , Defaults(..) - , Z.Matcher(..) - - -- ** Color schemes - , E.Scheme(..) - , E.Changers - , E.Labels(..) - , E.EvenAndOdd(..) - , module System.Console.Rainbow - - -- ** Sorting - , Z.SortField(..) - , CabP.SortOrder(..) - - -- ** Expression type - , Exp.ExprDesc(..) - - -- ** Formatting quantities - , defaultQtyFormat - - -- ** Convert report options - , Target(..) - , CP.SortBy(..) - - -- ** Postings report options - , M.Box - , Fields(..) - , Spacers(..) - , widthFromRuntime - , Ps.yearMonthDay - , Ps.qtyAsIs - , Ps.balanceAsIs - - -- ** Runtime - , S.Runtime - , S.environment - - -- ** Text - , X.Text - , X.pack - - -- ** Main function - , runPenny - - -- * Developer overview - - -- | Penny is organized into a tree of modules, each with a - -- name. Check out the links for details on each component of - -- Penny. - -- - -- "Penny.Brenner" - Penny financial institution transaction - -- handling. Depends on Lincoln and Copper. - -- - -- "Penny.Cabin" - Penny reports. Depends on Lincoln and Liberty. - -- - -- "Penny.Copper" - the Penny parser. Depends on Lincoln. - -- - -- "Penny.Liberty" - Penny command line parser helpers. Depends on - -- Lincoln and Copper. - -- - -- "Penny.Lincoln" - the Penny core. Depends on no other Penny - -- components. - -- - -- "Penny.Shield" - the Penny runtime environment. Depends on - -- Lincoln. - -- - -- "Penny.Steel" - independent utilities. Depends on no other - -- Penny components. - -- - -- "Penny.Wheat" - tools to use with - -- "Penny.Steel.Prednote". Depends on Steel, Lincoln, and Copper. - -- - -- "Penny.Zinc" - the Penny command-line interface. Depends on - -- Cabin, Copper, Liberty, and Lincoln. - -- - -- The dependencies are represented as a dot file in - -- bin/doc/dependencies.dot in the Penny git repository. - ) where - -import qualified Data.Text as X -import Data.Version (Version(..)) -import qualified Penny.Cabin.Balance.Convert as Conv -import qualified Penny.Cabin.Balance.Convert.Parser as CP -import qualified Penny.Cabin.Balance.Convert.Options as ConvOpts -import qualified Penny.Cabin.Balance.MultiCommodity as MC -import qualified Penny.Cabin.Balance.MultiCommodity.Parser as MP -import System.Console.Rainbow -import qualified Penny.Cabin.Interface as I -import qualified Penny.Cabin.Options as CO -import qualified Penny.Cabin.Parsers as CabP -import qualified Penny.Cabin.Posts as Ps -import qualified Penny.Cabin.Posts.Fields as PF -import qualified Penny.Cabin.Posts.Spacers as PS -import qualified Penny.Cabin.Posts.Meta as M -import qualified Penny.Cabin.Scheme as E -import qualified Penny.Lincoln as L -import qualified Data.Prednote.Expressions as Exp -import qualified Penny.Zinc as Z -import qualified Penny.Shield as S -import qualified Text.Matchers as Mr - --- | This type contains settings for all the reports, as well as --- default settings for the global options. Some of these can be --- overridden on the command line. -data Defaults = Defaults - { caseSensitive :: Bool - -- ^ Whether the matcher is case sensitive by default - - , matcher :: Z.Matcher - -- ^ Which matcher to use - - , colorToFile :: Bool - -- ^ Use colors when standard output is not a terminal? - - , expressionType :: Exp.ExprDesc - -- ^ Use RPN or infix expressions? This affects both the posting - -- filter and the filter for the Postings report. - - , defaultScheme :: Maybe E.Scheme - -- ^ Default color scheme. If Nothing, there is no default color - -- scheme. If there is no default color scheme and the user does - -- not pick one on the command line, no colors will be used. - - , additionalSchemes :: [E.Scheme] - -- ^ Additional color schemes the user can pick from on the - -- command line. - - , sorter :: [(Z.SortField, CabP.SortOrder)] - -- ^ Postings are sorted in this order by default. For example, if - -- the first pair is (Date, Ascending), then postings are first - -- sorted by date in ascending order. If the second pair is - -- (Payee, Ascending), then postings with the same date are then - -- sorted by payee. - -- - -- If this list is empty, then by default postings are left in the - -- same order as they appear in the ledger files. - - , balanceFormat :: L.Commodity -> L.Qty -> X.Text - -- ^ How to format balances in the balance report. Change this - -- function if, for example, you want to allow for digit grouping. - - , balanceShowZeroBalances :: Bool - -- ^ Show zero balances in the balance report? If True, show them; - -- if False, hide them. - - , balanceOrder :: CabP.SortOrder - -- ^ Whether to sort the accounts in ascending or descending order - -- by account name in the balance report. - - , convertShowZeroBalances :: Bool - -- ^ Show zero balances in the convert report? If True, show them; - -- if False, hide them. - - , convertTarget :: Target - -- ^ The commodity to which to convert the commodities in the - -- convert report. - - , convertOrder :: CabP.SortOrder - -- ^ Sort the convert report in ascending or descending order. - - , convertSortBy :: CP.SortBy - -- ^ Sort by account or by quantity in the convert report. - - , convertFormat :: L.Commodity -> L.Qty -> X.Text - -- ^ How to format balances in the convert report. For instance, - -- this function might perform digit grouping. - - , postingsFields :: Fields Bool - -- ^ Fields to show by default in the postings report. - - , postingsWidth :: Int - -- ^ The postings report is roughly this wide by - -- default. Typically this will be as wide as your terminal. - - , postingsShowZeroBalances :: Bool - -- ^ Show zero balances in the postings report? If True, show - -- them; if False, hide them. - - , postingsDateFormat :: M.Box -> X.Text - -- ^ How to format dates in the postings report. - - , postingsQtyFormat :: M.Box -> X.Text - -- ^ How to format quantities in the balance report. This function - -- is used when showing the quantity for the posting itself, and - -- not the quantity for the totals columns (for that, see - -- postingsBalanceFormat.) For example this function might perform - -- digit grouping. - - , postingsBalanceFormat :: L.Commodity -> L.Qty -> X.Text - -- ^ How to format balance totals in the postings report. - - , postingsSubAccountLength :: Int - -- ^ Account names in the postings report are shortened if - -- necessary in order to help the report fit within the allotted - -- width (see postingsWidth). Account names are only shortened as - -- much as is necessary for them to fit; however, each sub-account - -- name will not be shortened any more than the amount given here. - - , postingsPayeeAllocation :: Int - -- ^ postingsPayeeAllocation and postingsAccountAllocation - -- determine how much space is allotted to the payee and account - -- fields in the postings report. These fields are variable - -- width. After space for most other fields is allotted, space is - -- allotted for these two fields. The two fields divide the space - -- proportionally depending on postingsPayeeAllocation and - -- postingsAccountAllocation. For example, if - -- postingsPayeeAllocation is 60 and postingsAccountAllocation is - -- 40, then the payee field gets 60 percent of the leftover space - -- and the account field gets 40 percent of the leftover space. - -- - -- Both postingsPayeeAllocation and postingsAccountAllocation - -- must be positive integers; if either one is less than 1, your - -- program will crash at runtime. - - , postingsAccountAllocation :: Int - -- ^ See postingsPayeeAllocation above for an explanation - - , postingsSpacers :: Spacers Int - -- ^ Determines the number of spaces that appears to the right of - -- each named field; for example, sPayee indicates how many spaces - -- will appear to the right of the payee field. Each field of the - -- Spacers should be a non-negative integer (although currently - -- the absolute value of the field is taken.) - } - --- | Creates an IO action that you can use for the main function. -runPenny - :: Version - -- ^ Version of the executable - -> (S.Runtime -> Defaults) - -- ^ runPenny will apply this function to the Runtime. This way - -- the defaults you use can vary depending on environment - -- variables, the terminal type, the date, etc. - -> IO () -runPenny ver getDefaults = do - rt <- S.runtime - let df = getDefaults rt - rs = allReports df - Z.runZinc ver (toZincDefaults df) rt rs - --- | The commodity to which to convert the commodities in the convert --- report. -data Target - = AutoTarget - -- ^ Selects a target commodity automatically, based on which - -- commodity is the most common target commodity in the prices in - -- your ledger files. If there is a tie for most common target - -- commodity, the target that appears later in your ledger files - -- is used. - | ManualTarget String - -- ^ Always uses the commodity named by the string given. - deriving Show - --- | Gets the current screen width from the runtime. If the COLUMNS --- environment variable is not set, uses 80. -widthFromRuntime :: S.Runtime -> Int -widthFromRuntime rt = case S.screenWidth rt of - Nothing -> 80 - Just sw -> S.unScreenWidth sw - -convTarget :: Target -> CP.Target -convTarget t = case t of - AutoTarget -> CP.AutoTarget - ManualTarget s -> CP.ManualTarget . L.To . L.Commodity . X.pack $ s - -allReports - :: Defaults - -> [I.Report] -allReports df = - let bd = toBalanceDefaults df - cd = toConvertDefaults df - pd = toPostingsDefaults df - in [ Ps.zincReport pd - , MC.parseReport (balanceFormat df) bd - , Conv.cmdLineReport cd - ] - -toZincDefaults :: Defaults -> Z.Defaults -toZincDefaults d = Z.Defaults - { Z.sensitive = - if caseSensitive d then Mr.Sensitive else Mr.Insensitive - , Z.matcher = matcher d - , Z.colorToFile = Z.ColorToFile . colorToFile $ d - , Z.defaultScheme = defaultScheme d - , Z.moreSchemes = additionalSchemes d - , Z.sorter = sorter d - , Z.exprDesc = expressionType d - } - -toBalanceDefaults :: Defaults -> MP.ParseOpts -toBalanceDefaults d = MP.ParseOpts - { MP.showZeroBalances = - CO.ShowZeroBalances . balanceShowZeroBalances $ d - , MP.order = balanceOrder d - } - -toConvertDefaults :: Defaults -> ConvOpts.DefaultOpts -toConvertDefaults d = ConvOpts.DefaultOpts - { ConvOpts.showZeroBalances = - CO.ShowZeroBalances . convertShowZeroBalances $ d - , ConvOpts.target = convTarget . convertTarget $ d - , ConvOpts.sortOrder = convertOrder d - , ConvOpts.sortBy = convertSortBy d - , ConvOpts.format = convertFormat d - } - -toPostingsDefaults :: Defaults -> Ps.ZincOpts -toPostingsDefaults d = Ps.ZincOpts - { Ps.fields = convFields . postingsFields $ d - , Ps.width = Ps.ReportWidth . postingsWidth $ d - , Ps.showZeroBalances = - CO.ShowZeroBalances . postingsShowZeroBalances $ d - , Ps.dateFormat = postingsDateFormat d - , Ps.qtyFormat = postingsQtyFormat d - , Ps.balanceFormat = postingsBalanceFormat d - , Ps.subAccountLength = - Ps.SubAccountLength . postingsSubAccountLength $ d - , Ps.payeeAllocation = - Ps.alloc . postingsPayeeAllocation $ d - , Ps.accountAllocation = - Ps.alloc . postingsAccountAllocation $ d - , Ps.spacers = convSpacers . postingsSpacers $ d - } - -defaultQtyFormat :: L.Qty -> X.Text -defaultQtyFormat = X.pack . show - -data Spacers a = Spacers - { sGlobalTransaction :: a - , sRevGlobalTransaction :: a - , sGlobalPosting :: a - , sRevGlobalPosting :: a - , sFileTransaction :: a - , sRevFileTransaction :: a - , sFilePosting :: a - , sRevFilePosting :: a - , sFiltered :: a - , sRevFiltered :: a - , sSorted :: a - , sRevSorted :: a - , sVisible :: a - , sRevVisible :: a - , sLineNum :: a - , sDate :: a - , sFlag :: a - , sNumber :: a - , sPayee :: a - , sAccount :: a - , sPostingDrCr :: a - , sPostingCmdty :: a - , sPostingQty :: a - , sTotalDrCr :: a - , sTotalCmdty :: a - } deriving (Show, Eq) - -data Fields a = Fields - { fGlobalTransaction :: a - , fRevGlobalTransaction :: a - , fGlobalPosting :: a - , fRevGlobalPosting :: a - , fFileTransaction :: a - , fRevFileTransaction :: a - , fFilePosting :: a - , fRevFilePosting :: a - , fFiltered :: a - , fRevFiltered :: a - , fSorted :: a - , fRevSorted :: a - , fVisible :: a - , fRevVisible :: a - , fLineNum :: a - , fDate :: a - , fFlag :: a - , fNumber :: a - , fPayee :: a - , fAccount :: a - , fPostingDrCr :: a - , fPostingCmdty :: a - , fPostingQty :: a - , fTotalDrCr :: a - , fTotalCmdty :: a - , fTotalQty :: a - , fTags :: a - , fMemo :: a - , fFilename :: a - } deriving (Show, Eq) - -convSpacers :: Spacers a -> PS.Spacers a -convSpacers s = PS.Spacers - { PS.globalTransaction = sGlobalTransaction s - , PS.revGlobalTransaction = sRevGlobalTransaction s - , PS.globalPosting = sGlobalPosting s - , PS.revGlobalPosting = sRevGlobalPosting s - , PS.fileTransaction = sFileTransaction s - , PS.revFileTransaction = sRevFileTransaction s - , PS.filePosting = sFilePosting s - , PS.revFilePosting = sRevFilePosting s - , PS.filtered = sFiltered s - , PS.revFiltered = sRevFiltered s - , PS.sorted = sSorted s - , PS.revSorted = sRevSorted s - , PS.visible = sVisible s - , PS.revVisible = sRevVisible s - , PS.lineNum = sLineNum s - , PS.date = sDate s - , PS.flag = sFlag s - , PS.number = sNumber s - , PS.payee = sPayee s - , PS.account = sAccount s - , PS.postingDrCr = sPostingDrCr s - , PS.postingCmdty = sPostingCmdty s - , PS.postingQty = sPostingQty s - , PS.totalDrCr = sTotalDrCr s - , PS.totalCmdty = sTotalCmdty s - } - -convFields :: Fields a -> PF.Fields a -convFields f = PF.Fields - { PF.globalTransaction = fGlobalTransaction f - , PF.revGlobalTransaction = fRevGlobalTransaction f - , PF.globalPosting = fGlobalPosting f - , PF.revGlobalPosting = fRevGlobalPosting f - , PF.fileTransaction = fFileTransaction f - , PF.revFileTransaction = fRevFileTransaction f - , PF.filePosting = fFilePosting f - , PF.revFilePosting = fRevFilePosting f - , PF.filtered = fFiltered f - , PF.revFiltered = fRevFiltered f - , PF.sorted = fSorted f - , PF.revSorted = fRevSorted f - , PF.visible = fVisible f - , PF.revVisible = fRevVisible f - , PF.lineNum = fLineNum f - , PF.date = fDate f - , PF.flag = fFlag f - , PF.number = fNumber f - , PF.payee = fPayee f - , PF.account = fAccount f - , PF.postingDrCr = fPostingDrCr f - , PF.postingCmdty = fPostingCmdty f - , PF.postingQty = fPostingQty f - , PF.totalDrCr = fTotalDrCr f - , PF.totalCmdty = fTotalCmdty f - , PF.totalQty = fTotalQty f - , PF.tags = fTags f - , PF.memo = fMemo f - , PF.filename = fFilename f - } - diff --git a/Penny/Brenner.hs b/Penny/Brenner.hs deleted file mode 100644 --- a/Penny/Brenner.hs +++ /dev/null @@ -1,259 +0,0 @@ --- | Brenner - Penny financial institution interfaces --- --- Brenner provides a uniform way to interact with downloaded data --- from financial Given a parser, Brenner will import the transactions --- and store them in a database. From there it is easy to merge the --- transactions (without duplicates) into a ledger file, and then to --- clear transactions from statements in an automated fashion. -module Penny.Brenner - ( FitAcct(..) - , Config(..) - , R.GroupSpecs(..) - , R.GroupSpec(..) - , Y.Translator(..) - , L.Side(..) - , L.SpaceBetween(..) - , usePayeeOrDesc - , brennerMain - ) where - -import qualified Penny.Brenner.Types as Y -import Control.Monad (join) -import Data.Either (partitionEithers) -import qualified Data.Text as X -import qualified Data.Version as V -import qualified Penny.Liberty as Ly -import qualified Penny.Lincoln as L -import qualified Penny.Lincoln.Builders as Bd -import qualified Penny.Copper.Render as R -import qualified Penny.Brenner.Clear as C -import qualified Penny.Brenner.Database as D -import qualified Penny.Brenner.Import as I -import qualified Penny.Brenner.Merge as M -import qualified Penny.Brenner.Print as P -import Control.Applicative ((<*>)) -import qualified System.Console.MultiArg as MA -import qualified Control.Monad.Exception.Synchronous as Ex - -brennerMain - :: V.Version - -- ^ Binary version - -> Config - -> IO () -brennerMain v cf = do - let cf' = convertConfig cf - join $ MA.modesWithHelp (help cf') (globalOpts v) - (preProcessor cf') - -globalOpts - :: V.Version - -- ^ Binary version - -> [MA.OptSpec (Either (IO ()) String)] -globalOpts v = - [ MA.OptSpec ["fit-account"] "f" (MA.OneArg Right) - , fmap Left (Ly.version v) - ] - -preProcessor - :: Y.Config - -> [Either (IO ()) String] - -> Either (a -> IO ()) [MA.Mode (IO ())] -preProcessor cf args = - let (vers, as) = partitionEithers args - in case vers of - [] -> makeModes cf as - x:_ -> Left (const x) - -makeModes - :: Y.Config - -> [String] - -- ^ Names of financial institutions given on command line - -> Either (a -> IO ()) [MA.Mode (IO ())] -makeModes cf as = Ex.toEither . Ex.mapException (const . fail) $ do - fi <- case as of - [] -> return $ Y.defaultFitAcct cf - _ -> - let pdct (Y.Name n, _) = n == X.pack s - s = last as - in case filter pdct (Y.moreFitAccts cf) of - [] -> Ex.throw $ - "financial institution account " - ++ s ++ " not configured." - (_, c):[] -> return $ Just c - _ -> Ex.throw $ - "more than one financial institution account " - ++ "named " ++ s ++ " configured." - return $ [C.mode, I.mode, M.mode, P.mode, D.mode] <*> [fi] - -help - :: Y.Config - -> String - -- ^ Program name - - -> String -help c n = unlines ls ++ cs - where - ls = [ "usage: " ++ n ++ " [global-options]" - ++ " COMMAND [local-options]" - ++ " ARGS..." - , "" - , "where COMMAND is one of:" - , "import, merge, clear, database, print" - , "" - , "For help on an individual command and its" - ++ " local options, use " - , n ++ " COMMAND --help" - , "" - , "Global Options:" - , "-f, --fit-account ACCOUNT" - , " Use one of the Additional Financial Institution" - , " Accounts shown below. If this option does not appear," - , " the default account is used if there is one." - , "-h, --help" - , " Show help and exit" - , "" - ] - showPair (Y.Name a, cd) = "Additional financial institution " - ++ "account: " ++ X.unpack a ++ "\n" ++ showFitAcct cd - cs = showDefaultFitAcct (Y.defaultFitAcct c) - ++ more - more = if null (Y.moreFitAccts c) - then "No additional financial institution accounts\n" - else concatMap showPair . Y.moreFitAccts $ c - -showDefaultFitAcct :: Maybe Y.FitAcct -> String -showDefaultFitAcct mc = case mc of - Nothing -> "No default financial institution account\n" - Just c -> "Default financial institution account:\n" ++ showFitAcct c - -label :: String -> String -> String -label l o = " " ++ l ++ ": " ++ o ++ "\n" - -showAccount :: L.Account -> String -showAccount = - X.unpack - . X.intercalate (X.singleton ':') - . map L.unSubAccount - . L.unAccount - -showFitAcct :: Y.FitAcct -> String -showFitAcct c = - label "Database location" - (X.unpack . Y.unDbLocation . Y.dbLocation $ c) - - ++ label "Penny account" - (showAccount . Y.unPennyAcct . Y.pennyAcct $ c) - - ++ label "Account for new offsetting postings" - (showAccount . Y.unDefaultAcct . Y.defaultAcct $ c) - - ++ label "Currency" - (X.unpack . L.unCommodity . Y.unCurrency . Y.currency $ c) - - ++ "\n" - - ++ "More information about the parser:\n" - ++ (fst . Y.parser $ c) - ++ "\n\n" - - --- | Information to configure a single financial institution account. -data FitAcct = FitAcct - { dbLocation :: String - -- ^ Path and filename to where the database is kept. You can use - -- an absolute or relative path (if it is relative, it will be - -- resolved relative to the current directory at runtime.) - - , pennyAcct :: String - -- ^ The account that you use in your Penny file to hold - -- transactions for this card. Separate each sub-account with - -- colons (as you do in the Penny file.) - - , defaultAcct :: String - -- ^ When new transactions are created, one of the postings will - -- be in the amexAcct given above. The other posting will be in - -- this account. - - , currency :: String - -- ^ The commodity for the currency of your card (e.g. @$@). - - , groupSpecs :: R.GroupSpecs - -- ^ How to group digits when printing the resulting ledger. All - -- quantities (not just those affected by this program) will be - -- formatted using this specification. - - , translator :: Y.Translator - -- ^ See the documentation under the 'Translator' type for - -- details. - - , side :: L.Side - -- ^ When creating new transactions, the commodity will be on this - -- side - - , spaceBetween :: L.SpaceBetween - -- ^ When creating new transactions, is there a space between the - -- commodity and the quantity - - , parser :: ( String - , Y.FitFileLocation -> IO (Ex.Exceptional String [Y.Posting])) - -- ^ Parses a file of transactions from the financial - -- institution. The function must open the file and parse it. This - -- is in the IO monad not only because the function must open the - -- file itself, but also so the function can perform arbitrary IO - -- (run pdftotext, maybe?) If there is failure, the function can - -- return an Exceptional String, which is the error - -- message. Alternatively the function can raise an exception in the - -- IO monad (currently Brenner makes no attempt to catch these) so - -- if any of the IO functions throw you can simply not handle the - -- exceptions. - -- - -- The first element of the pair is a help string which should - -- indicate how to download the data, as a helpful reminder. - - , toLincolnPayee :: Y.Desc -> Y.Payee -> L.Payee - -- ^ Sometimes the financial institution provides Payee information, - -- sometimes it does not. Sometimes the Desc might have additional - -- information that you might want to remove. This function can be - -- used to do that. The resulting Lincoln Payee is used for any - -- transactions that are created by the merge command. The resulting - -- payee is also used when comparing new financial institution - -- postings to already existing ledger transactions in order to - -- guess at which payee and accounts to create in the transactions - -- created by the merge command. - - - } deriving Show - -convertFitAcct :: FitAcct -> Y.FitAcct -convertFitAcct (FitAcct db ax df cy gs tl sd sb ps tlp) = Y.FitAcct - { Y.dbLocation = Y.DbLocation . X.pack $ db - , Y.pennyAcct = Y.PennyAcct . Bd.account . X.pack $ ax - , Y.defaultAcct = Y.DefaultAcct . Bd.account . X.pack $ df - , Y.currency = Y.Currency . L.Commodity . X.pack $ cy - , Y.groupSpecs = gs - , Y.translator = tl - , Y.side = sd - , Y.spaceBetween = sb - , Y.parser = ps - , Y.toLincolnPayee = tlp - } - -data Config = Config - { defaultFitAcct :: Maybe FitAcct - , moreFitAccts :: [(String, FitAcct)] - } deriving Show - -convertConfig :: Config -> Y.Config -convertConfig (Config d m) = Y.Config - { Y.defaultFitAcct = fmap convertFitAcct d - , Y.moreFitAccts = - let f (n, c) = (Y.Name (X.pack n), convertFitAcct c) - in map f m - } - --- | A simple function to use for 'toLincolnPayee'. Uses the financial --- institution payee if it is available; otherwise, uses the financial --- institution description. -usePayeeOrDesc :: Y.Desc -> Y.Payee -> L.Payee -usePayeeOrDesc (Y.Desc d) (Y.Payee p) = L.Payee $ - if X.null p then d else p diff --git a/Penny/Brenner/Amex.hs b/Penny/Brenner/Amex.hs deleted file mode 100644 --- a/Penny/Brenner/Amex.hs +++ /dev/null @@ -1,121 +0,0 @@ --- | Parses Amex credit card data. See the help text in the 'help' --- function for more details. Also, the file format is documented in --- the file @doc\/amex-file-format.org@. -module Penny.Brenner.Amex (parser) where - -import Control.Applicative ((<$>), (<*>), (<$), (<*), (*>), pure, - (<|>), optional) -import qualified Data.Time as Time -import qualified Penny.Brenner.Types as Y -import Text.Parsec.Text (Parser) -import qualified Text.Parsec as P -import Text.Parsec (many1, char, many, satisfy) -import qualified Data.Text as X -import qualified Data.Text.IO as TIO -import qualified Control.Monad.Exception.Synchronous as Ex - -parser :: (String, Y.FitFileLocation - -> IO (Ex.Exceptional String [Y.Posting])) -parser = (help, loadIncoming) - -help :: String -help = unlines - [ "Parses American Express transaction data in CSV format." - , "Not tested with American Express deposit accounts." - , "To download, click the \"Download\" link which is visible" - , "above and to the right of the transaction list. Under" - , "\"Download Current View\" Select \"CSV\"" - , "and be sure to click" - , "\"Include all additional Transaction Details.\"" - ] - --- | Loads incoming Amex transactions. -loadIncoming :: Y.FitFileLocation - -> IO (Ex.Exceptional String [Y.Posting]) -loadIncoming (Y.FitFileLocation loc) = do - txt <- TIO.readFile loc - let parsed = P.parse (P.many posting <* P.eof) "" txt - err s = "could not parse incoming postings: " ++ show s - return (Ex.mapException err . Ex.fromEither $ parsed) - -skipThrough :: Char -> Parser () -skipThrough c = () <$ many (satisfy (/= c)) <* char c - -readThrough :: Char -> Parser String -readThrough c = many (satisfy (/= c)) <* char c - -date :: Parser Y.Date -date = p >>= failOnErr - where - p = (,,) - <$> fmap read (many1 P.digit) - <* char '/' - <*> fmap read (many1 P.digit) - <* char '/' - <*> fmap read (many1 P.digit) - <* skipThrough ',' - failOnErr (m, d, y) = maybe (fail "could not parse date") - (return . Y.Date) - $ Time.fromGregorianValid y m d - -incDecAmount :: Parser (Y.IncDec, Y.Amount) -incDecAmount = do - incDec <- (Y.Decrease <$ char '-') <|> pure Y.Increase - amtStr <- readThrough ',' - case Y.mkAmount amtStr of - Nothing -> fail $ "could not parse amount: " ++ amtStr - Just a -> return (incDec, a) - -doubleQuoted :: Parser String -doubleQuoted = char '"' *> readThrough '"' - -desc :: Parser Y.Desc -desc = fmap (Y.Desc . X.pack) $ doubleQuoted <* char ',' - -payee :: Parser Y.Payee -payee = fmap (Y.Payee . X.pack) $ doubleQuoted <* char ',' - -amexId :: Parser Y.FitId -amexId = fmap (Y.FitId . X.pack) - $ char '"' *> char '\'' *> readThrough '\'' - <* char '"' <* char ',' - - --- | Skips a field. Will skip a quoted field or, --- alternatively, skip everything through to the next comma. Do not --- use for the last field, as it looks for a trailing comma. -skipField :: Parser () -skipField = - () - <$ skipper - <* char ',' - where - skipper = (() <$ optional doubleQuoted) - <|> (() <$ many (satisfy (/= ','))) - - --- | Parses last field (currently unknown). Parsers the EOL character. -skipLast :: Parser () -skipLast = skipThrough '\n' - -posting :: Parser Y.Posting -posting = - f - <$> date -- 1 - <* skipField -- 2 Unknown - <*> desc -- 3 Description - <* skipField -- 4 Unknown - <* skipField -- 5 Unknown - <* skipField -- 6 Unknown - <* skipField -- 7 Unknown - <*> incDecAmount -- 8 - <* skipField -- 9 Unknown - <* skipField -- 10 Category - <*> payee -- 11 D.B.A. - <* skipField -- 12 Address - <* skipField -- 13 Postcode - <*> amexId -- 14 - <* skipField -- 15 Unknown - <* skipLast -- 16 - where - f dt ds (t, a) p i = Y.Posting dt ds t a p i diff --git a/Penny/Brenner/BofA.hs b/Penny/Brenner/BofA.hs deleted file mode 100644 --- a/Penny/Brenner/BofA.hs +++ /dev/null @@ -1,226 +0,0 @@ --- | Parses statements for Bank of America deposit accounts. See the --- help text in the 'help' function for more details. Also, the file --- format is documented in the file @doc\/bofa-file-format.org@. -module Penny.Brenner.BofA (parser, getPayee) where - -import Control.Applicative ((<$>), (<*), (<$), (<*>)) -import qualified Control.Monad.Exception.Synchronous as Ex -import Data.Char (isUpper) -import qualified Data.Time as T -import qualified Text.Parsec as P -import Text.Parsec (char, string, many, many1, satisfy, manyTill, - (), try) -import Text.Parsec.String (Parser) -import qualified Data.Tree as T -import Data.Tree (Tree(Node)) -import qualified Penny.Brenner.Types as Y -import qualified Penny.Lincoln as L -import qualified Data.Text as X - -newtype TagName = TagName { unTagName :: String } - deriving (Eq, Show) - -newtype TagData = TagData { unTagData :: String } - deriving (Eq, Show) - -data Label - = Parent TagName - | Terminal TagName TagData - deriving (Eq, Show) - -type ExS = Ex.Exceptional String - -bOfAFile :: Parser ([(TagName, TagData)], Tree Label) -bOfAFile = - (,) - <$> many headerLine - <* string "\r\n" - <*> node - -notReturn :: Parser Char -notReturn = satisfy (/= '\r') - -headerLine :: Parser (TagName, TagData) -headerLine = - (,) - <$> (TagName <$> manyTill (satisfy isUpper) (char ':')) - <*> (TagData <$> manyTill notReturn (char '\r') - <* char '\n') - -openTag :: Parser String -openTag = do - { let pc = (satisfy (\c -> c /= '/' && c /= '>')) - ; c <- try (char '<' >> pc) - ; cs <- many pc - ; _ <- char '>' - ; return (c:cs) - } "open tag" - -closeTag :: String -> Parser () -closeTag s = () <$ string "' - "close tag named " ++ s - --- | Reads in a tag, then examine what's next. If a backslash-r is --- next, then this is the end of the line. That means it a nested --- tag. Parse some more child nodes, then parse a closing node. If --- anything else is next, this is a data node. Parse the data, then --- return that node. -node :: Parser (Tree Label) -node = do - tagName <- openTag - next <- P.anyChar - case next of - '\r' -> do - _ <- char '\n' - kids <- many1 node - closeTag tagName - _ <- string "\r\n" - return $ T.Node (Parent (TagName tagName)) kids - o -> do - rs <- manyTill notReturn (char '\r') - _ <- char '\n' - return $ - T.Node (Terminal (TagName tagName) (TagData $ o:rs)) [] - -findNodes :: Eq a => a -> Tree a -> [Tree a] -findNodes a = findNodesBy (== a) - - -findNodesBy :: (a -> Bool) -> Tree a -> [Tree a] -findNodesBy f t@(Node l cs) - | f l = [t] - | otherwise = concatMap (findNodesBy f) cs - -safeRead :: (Read r) => String -> Maybe r -safeRead s = case reads s of - (i,""):[] -> Just i - _ -> Nothing - --- | Parses a B of A date-time. The format is YYYYMMDDHHMMSS. Discards --- the HHMMSS. -parseDateStr :: String -> ExS Y.Date -parseDateStr s = - let (yr, r1) = splitAt 4 s - (mo, r2) = splitAt 2 r1 - (da, _) = splitAt 2 r2 - in Ex.fromMaybe ("could not parse date: " ++ s) $ do - yi <- safeRead yr - ym <- safeRead mo - yd <- safeRead da - Y.Date <$> T.fromGregorianValid yi ym yd - -parseAmountStr :: String -> ExS (Y.IncDec, Y.Amount) -parseAmountStr s = do - (f, rs) <- case s of - "" -> Ex.throw "empty string for amount" - x:xs -> return (x, xs) - let (amtStr, incDec) = case f of - '-' -> (rs, Y.Decrease) - _ -> (s, Y.Increase) - amt <- Ex.fromMaybe ("could not parse amount: " ++ s) - $ Y.mkAmount amtStr - return (incDec, amt) - -postings :: Tree Label -> ExS [Y.Posting] -postings t = - let match = Parent (TagName "STMTTRN") - in mapM posting .findNodes match $ t - -posting :: Tree Label -> ExS Y.Posting -posting (Node l cs) = do - tag <- case l of - Parent n -> return n - _ -> Ex.throw "did not find posting tree" - Ex.assert "did not find STMTTRN tag" $ unTagName tag == "STMTTRN" - tPosted <- findTerminal "DTPOSTED" cs - tAmt <- findTerminal "TRNAMT" cs - tId <- findTerminal "FITID" cs - tName <- findTerminal "NAME" cs - pPosted <- parseDateStr (X.unpack tPosted) - (amtIncDec, pAmt) <- parseAmountStr (X.unpack tAmt) - let pId = Y.FitId tId - pName = Y.Desc tName - pPayee = Y.Payee (X.empty) - return $ Y.Posting pPosted pName amtIncDec pAmt pPayee pId - --- | Removes the TagData from a tree, after ensuring that the TagName --- is correct and that the tree has no children. -terminalData - :: String - -- ^ The name of the terminal - - -> Tree Label - - -> ExS X.Text - -- ^ Returns the data from the tag, or an error if this is not a - -- terminal or if the terminal has children. -terminalData n (Node l cs) = do - (tn, td) <- case l of - Parent _ -> Ex.throw $ "looking for data tag named " ++ n - ++ ", but that tag does not have data" - Terminal x y -> return (x, y) - let tagErr = "looking for tag named " ++ n - ++ ", but found tag named " ++ unTagName tn - Ex.assert tagErr $ tn == TagName n - let kidsErr = "data tag " ++ n ++ " should have no children," - ++ " but does" - Ex.assert kidsErr $ null cs - return . X.pack . unTagData $ td - --- | Finds a terminal amongst a list of Trees; returns the data. Fails --- if there is no terminal by the given name or of the terminal has --- children (in which case it is not a terminal!) -findTerminal - :: String - -- ^ The name of the terminal - - -> [Tree Label] - -> ExS X.Text - -- ^ Returns the data from the terminal, or an error if there is no - -- tag by this name or if it has chlidren. - -findTerminal n ts = do - let pdct lbl = case lbl of - Terminal (TagName x) _ -> x == n - _ -> False - t <- case concatMap (findNodesBy pdct) ts of - [] -> Ex.throw $ "looking for terminal named " - ++ n ++ "; none found" - x:[] -> return x - _ -> Ex.throw $ "looking for terminal named " - ++ n ++ "; multiple matches found" - terminalData n t - -help :: String -help = unlines - [ "Parses Bank of America postings for deposit accounts, like checking" - , "or savings. This parser is not tested with credit card accounts." - , "To download the data, from the account activity screen click on" - , "\"Download\", which is just above all the transaction information." - , "Then download the \"WEB Connect for Quicken 2010 and above.\"" - ] - -parser :: (String, Y.FitFileLocation - -> IO (Ex.Exceptional String [Y.Posting])) -parser = (help, psr) - where - psr (Y.FitFileLocation path) = do - str <- readFile path - return $ case P.parse bOfAFile "" str of - Left e -> Ex.throw - $ "could not parse Bank of America transactions: " - ++ show e - Right (_, t) -> postings t - --- | For check card transactions, Bank of America changes the --- description so that it begins with @CHECKCARD MMDD@, where MM is --- the two-digit month of the transaction date, and DD is the --- two-digit day of the transaction date. (The posting date is used as --- the main date, and it is typically two days later than the --- transaction date.) This function strips off the @CHECKCARD MMDD@ --- portion. -getPayee :: Y.Desc -> L.Payee -getPayee (Y.Desc d) = L.Payee $ - if X.isPrefixOf (X.pack "CHECKCARD") d - then X.drop (length "CHECKCARD XXXX ") d - else d diff --git a/Penny/Brenner/Clear.hs b/Penny/Brenner/Clear.hs deleted file mode 100644 --- a/Penny/Brenner/Clear.hs +++ /dev/null @@ -1,175 +0,0 @@ -module Penny.Brenner.Clear (mode) where - -import qualified Control.Monad.Exception.Synchronous as Ex -import Control.Applicative (pure) -import Control.Monad (guard, mzero, when) -import Data.Maybe (mapMaybe, fromMaybe) -import Data.Monoid (mconcat, First(..)) -import qualified Data.Set as Set -import qualified Data.Map as M -import qualified Data.Text as X -import qualified Data.Text.IO as TIO -import qualified System.Console.MultiArg as MA -import qualified Penny.Lincoln as L -import qualified Control.Monad.Trans.State as St -import qualified Control.Monad.Trans.Maybe as MT -import Control.Monad.Trans.Class (lift) -import qualified Penny.Copper.Types as Y -import qualified Penny.Copper as C -import qualified Penny.Copper.Render as R -import Text.Show.Pretty (ppShow) -import qualified Penny.Brenner.Types as Y -import qualified Penny.Brenner.Util as U - - -help :: String -> String -help pn = unlines - [ "usage: " ++ pn ++ " clear clear [options] FIT_FILE LEDGER_FILE..." - , "Parses all postings that are in FIT_FILE. Then marks all" - , "postings that are in the FILEs given that correspond to one" - , "of the postings in the FIT_FILE as being cleared." - , "Quits if one of the postings found in FIT_FILE is not found" - , "in the database, if one of the postings in the database" - , "is not found in one of the FILEs, or if any of the postings found" - , "in one of the FILEs already has a flag." - , "" - , "Results are printed to standard output. If no FILE, or FILE is \"-\"," - , "read standard input." - , "" - , "Options:" - , " -h, --help - show help and exit" - ] - -data Arg - = APosArg String - deriving (Eq, Show) - -toPosArg :: Arg -> Maybe String -toPosArg a = case a of { APosArg s -> Just s } - -data Opts = Opts - { csvLocation :: Y.FitFileLocation - , ledgerLocations :: [String] - } deriving Show - - -mode :: Maybe Y.FitAcct -> MA.Mode (IO ()) -mode c = MA.Mode - { MA.mName = "clear" - , MA.mIntersperse = MA.Intersperse - , MA.mOpts = [ ] - , MA.mPosArgs = APosArg - , MA.mProcess = process c - , MA.mHelp = help - } - -process :: Maybe Y.FitAcct -> [Arg] -> IO () -process mayC as = do - c <- case mayC of - Just cd -> return cd - Nothing -> fail $ "no financial institution account given" - ++ " on command line, and no default financial" - ++ " institution configured." - (csv, ls) <- case mapMaybe toPosArg as of - [] -> fail "clear: you must provide a postings file." - x:xs -> return (Y.FitFileLocation x, xs) - let os = Opts csv ls - runClear c os - -runClear :: Y.FitAcct -> Opts -> IO () -runClear c os = do - dbList <- U.loadDb (Y.AllowNew False) (Y.dbLocation c) - let db = M.fromList dbList - (_, prsr) = Y.parser c - txns <- fmap (Ex.switch fail return) $ prsr (csvLocation os) - leds <- C.open (ledgerLocations os) - toClear <- case mapM (findUNumber db) (concat txns) of - Nothing -> fail $ "at least one posting was not found in the" - ++ " database. Ensure all postings have " - ++ "been imported and merged." - Just ls -> return $ Set.fromList ls - let (led', left) = changeLedger (Y.pennyAcct c) toClear leds - when (not (Set.null left)) - (fail $ "some postings were not cleared. " - ++ "Those not cleared:\n" ++ ppShow left) - case R.ledger (Y.groupSpecs c) led' of - Nothing -> - fail "could not render resulting ledger." - Just txt -> TIO.putStr txt - - --- | Examines an financial institution transaction and the DbMap to --- find a matching UNumber. Fails if the financial institution --- transaction is not in the Db. -findUNumber :: Y.DbMap -> Y.Posting -> Maybe Y.UNumber -findUNumber m pstg = - let atn = Y.fitId pstg - p ap = Y.fitId ap == atn - filteredMap = M.filter p m - ls = M.toList filteredMap - in case ls of - (n, _):[] -> Just n - _ -> Nothing - - -clearedFlag :: L.Flag -clearedFlag = L.Flag . X.singleton $ 'C' - --- | Changes a ledger to clear postings. Returns postings still not --- cleared. -changeLedger - :: Y.PennyAcct - -> Set.Set Y.UNumber - -> Y.Ledger - -> (Y.Ledger, Set.Set Y.UNumber) -changeLedger ax s l = St.runState k s - where - k = Y.mapLedgerA f l - f = Y.mapItemA pure pure (changeTxn ax) - -changeTxn - :: Y.PennyAcct - -> L.Transaction - -> St.State (Set.Set Y.UNumber) L.Transaction -changeTxn ax t = do - let fam = L.unTransaction t - fam' = L.mapParent (const L.emptyTopLineChangeData) fam - fam'' <- L.mapChildrenA (changePstg ax) fam' - return $ L.changeTransaction fam'' t - - --- | Sees if this posting is a posting in the right account and has a --- UNumber that needs to be cleared. If so, clears it. If this posting --- already has a flag, skips it. -changePstg - :: Y.PennyAcct - -> L.Posting - -> St.State (Set.Set Y.UNumber) L.PostingChangeData -changePstg ax p = - fmap (fromMaybe L.emptyPostingChangeData) . MT.runMaybeT $ do - guard (L.pAccount p == (Y.unPennyAcct ax)) - let tags = L.pTags p - un <- maybe mzero return $ parseUNumberFromTags tags - guard (L.pFlag p == Nothing) - set <- lift St.get - guard (Set.member un set) - lift $ St.put (Set.delete un set) - return $ L.emptyPostingChangeData - { L.pcFlag = Just (Just clearedFlag) } - -parseUNumberFromTags :: L.Tags -> Maybe Y.UNumber -parseUNumberFromTags = - getFirst - . mconcat - . map First - . map parseUNumberFromTag - . L.unTags - -parseUNumberFromTag :: L.Tag -> Maybe Y.UNumber -parseUNumberFromTag (L.Tag x) = do - (f, xs) <- X.uncons x - guard (f == 'U') - case reads . X.unpack $ xs of - (u, ""):[] -> Just (Y.UNumber u) - _ -> Nothing - diff --git a/Penny/Brenner/Database.hs b/Penny/Brenner/Database.hs deleted file mode 100644 --- a/Penny/Brenner/Database.hs +++ /dev/null @@ -1,49 +0,0 @@ -module Penny.Brenner.Database (mode) where - -import qualified Penny.Brenner.Types as Y -import qualified Penny.Brenner.Util as U -import qualified System.Console.MultiArg as MA - -help :: String -> String -help pn = unlines - [ "usage: " ++ pn ++ " [global-options] database [local-options]" - , "Shows the database of financial institution transactions." - , "Does not accept any non-option arguments." - , "" - , "Local options:" - , " --help, -h Show this help and exit." - ] - -data Arg = ArgPos String deriving (Eq, Show) - -mode - :: Maybe Y.FitAcct - -> MA.Mode (IO ()) -mode mayFa = MA.Mode - { MA.mName = "database" - , MA.mIntersperse = MA.Intersperse - , MA.mOpts = [ ] - , MA.mPosArgs = ArgPos - , MA.mProcess = processor mayFa - , MA.mHelp = help - } - -processor - :: Maybe Y.FitAcct - -> [Arg] - -> IO () -processor mayFa ls - | any isArgPos ls = fail $ - "penny-fit database: error: this command does" - ++ " not accept non-option arguments." - | otherwise = case mayFa of - Nothing -> fail $ "no financial institution account" - ++ " selected on command line, and no default" - ++ " financial instititution account configured." - Just fa -> do - let dbLoc = Y.dbLocation fa - db <- U.loadDb (Y.AllowNew False) dbLoc - mapM_ putStr . map U.showDbPair $ db - -isArgPos :: Arg -> Bool -isArgPos (ArgPos _) = True diff --git a/Penny/Brenner/Import.hs b/Penny/Brenner/Import.hs deleted file mode 100644 --- a/Penny/Brenner/Import.hs +++ /dev/null @@ -1,106 +0,0 @@ -module Penny.Brenner.Import (mode) where - -import Control.Monad.Exception.Synchronous as Ex -import Data.Maybe (mapMaybe) -import qualified System.Console.MultiArg as MA -import qualified Penny.Brenner.Types as Y -import qualified Penny.Brenner.Util as U - - -data Arg - = AFitFile String - | AAllowNew - deriving (Eq, Show) - -toFitFile :: Arg -> Maybe String -toFitFile a = case a of - AFitFile s -> Just s - _ -> Nothing - -data ImportOpts = ImportOpts - { fitFile :: Y.FitFileLocation - , allowNew :: Y.AllowNew - , parser :: Y.FitFileLocation - -> IO (Ex.Exceptional String [Y.Posting]) - } - -mode - :: Maybe Y.FitAcct - -> MA.Mode (IO ()) -mode mayFa = MA.Mode - { MA.mName = "import" - , MA.mIntersperse = MA.Intersperse - , MA.mOpts = - [ MA.OptSpec ["new"] "n" (MA.NoArg AAllowNew) ] - , MA.mPosArgs = AFitFile - , MA.mProcess = processor mayFa - , MA.mHelp = help - } - -processor - :: Maybe Y.FitAcct - -> [Arg] - -> IO () -processor mayFa as = do - (dbLoc, prsr) <- case mayFa of - Nothing -> fail $ "no financial institution account provided" - ++ " on command line, and no default financial institution" - ++ " account is configured." - Just fa -> return (Y.dbLocation fa, snd . Y.parser $ fa) - loc <- case mapMaybe toFitFile as of - [] -> fail "you must provide a postings file to read" - x:[] -> return (Y.FitFileLocation x) - _ -> fail "you cannot provide more than one postings file to read" - let aNew = Y.AllowNew $ any (== AAllowNew) as - doImport dbLoc (ImportOpts loc aNew prsr) - - --- | Appends new Amex transactions to the existing list. -appendNew - :: [(Y.UNumber, Y.Posting)] - -- ^ Existing transactions - - -> [Y.Posting] - -- ^ New transactions - - -> ([(Y.UNumber, Y.Posting)], Int) - -- ^ New list, and number of transactions added - -appendNew db new = (db ++ newWithU, length newWithU) - where - nextUNum = if null db - then 0 - else (Y.unUNumber . maximum . map fst $ db) + 1 - currFitIds = map (Y.fitId . snd) db - isNew p = not (any (== Y.fitId p) currFitIds) - newPstgs = filter isNew new - mkPair i p = (Y.UNumber i, p) - newWithU = zipWith mkPair [nextUNum..] newPstgs - - -doImport :: Y.DbLocation -> ImportOpts -> IO () -doImport dbLoc os = do - txnsOld <- U.loadDb (allowNew os) dbLoc - parseResult <- parser os (fitFile os) - ins <- case parseResult of - Ex.Exception e -> fail e - Ex.Success g -> return g - let (new, len) = appendNew txnsOld ins - U.saveDb dbLoc new - putStrLn $ "imported " ++ show len ++ " new transactions." - -help :: String -> String -help pn = unlines - [ "usage: " ++ pn ++ " [global-options] import [local-options] FIT_FILE" - , "where FIT_FILE is the file downloaded from the financial" - , "institution." - , "" - , "Local Options:" - , "" - , "-n, --new - Allows creation of new database. Without this option," - , "if the database file is not found, quits with an error." - , "" - , "-h, --help - Show this help." - , "" - ] - diff --git a/Penny/Brenner/Merge.hs b/Penny/Brenner/Merge.hs deleted file mode 100644 --- a/Penny/Brenner/Merge.hs +++ /dev/null @@ -1,347 +0,0 @@ -module Penny.Brenner.Merge (mode) where - -import Control.Applicative (pure) -import Control.Monad (guard) -import qualified Control.Monad.Trans.State as St -import Data.List (find, sortBy, foldl') -import qualified Data.Map as M -import Data.Maybe (mapMaybe, isNothing, fromMaybe) -import Data.Monoid (First(..), mconcat) -import qualified Data.Text as X -import qualified Data.Text.IO as TIO -import qualified System.Console.MultiArg as MA -import qualified Penny.Copper as C -import qualified Penny.Copper.Render as R -import qualified Penny.Lincoln as L -import qualified Penny.Lincoln.Transaction.Unverified as U -import qualified Penny.Lincoln.Queries as Q -import qualified Penny.Brenner.Types as Y -import qualified Penny.Brenner.Util as U - -type NoAuto = Bool - -data Arg - = APos String - | ANoAuto - deriving (Eq, Show) - -toPosArg :: Arg -> Maybe String -toPosArg a = case a of { APos s -> Just s; _ -> Nothing } - -mode :: Maybe Y.FitAcct -> MA.Mode (IO ()) -mode maybeC = MA.Mode - { MA.mName = "merge" - , MA.mIntersperse = MA.Intersperse - , MA.mOpts = [MA.OptSpec ["no-auto"] "n" (MA.NoArg ANoAuto)] - , MA.mPosArgs = APos - , MA.mProcess = processor maybeC - , MA.mHelp = help - } - -processor :: Maybe Y.FitAcct -> [Arg] -> IO () -processor maybeC as = - doMerge maybeC (ANoAuto `elem` as) (mapMaybe toPosArg as) - -doMerge :: Maybe Y.FitAcct -> NoAuto -> [String] -> IO () -doMerge maybeAcct noAuto ss = do - acct <- case maybeAcct of - Nothing -> do - fail $ "no financial" - ++ " institution account provided on command line, and" - ++ " no default account configured." - Just ac -> return ac - dbLs <- U.loadDb (Y.AllowNew False) (Y.dbLocation acct) - l <- C.open ss - let dbWithEntry = fmap (pairWithEntry acct) . M.fromList $ dbLs - (l', db') = changeItems acct - l (filterDb (Y.pennyAcct acct) dbWithEntry l) - newTxns = createTransactions noAuto acct l dbLs db' - final = C.Ledger (C.unLedger l' ++ newTxns) - case R.ledger (Y.groupSpecs acct) final of - Nothing -> fail "Could not render final ledger." - Just x -> TIO.putStr x - - -help :: String -> String -help pn = unlines - [ "usage: " ++ pn ++ " merge: merges new transactions from database" - , "to ledger file." - , "usage: penny-fit merge [options] FILE..." - , "Results are printed to standard output. If no FILE, or if FILE is -," - , "read standard input." - , "" - , "Options:" - , " -h, --help - show help and exit" - , " -n, --no-auto - do not automatically assign payees and accounts" - ] - --- | Removes all Brenner postings that already have a Penny posting --- with the correct uNumber. -filterDb :: Y.PennyAcct -> DbWithEntry -> C.Ledger -> DbWithEntry -filterDb ax m l = M.difference m ml - where - ml = M.fromList - . flip zip (repeat ()) - . mapMaybe toUNum - . filter inPennyAcct - . concatMap L.postFam - . mapMaybe toTxn - . C.unLedger - $ l - toTxn t = case t of - C.Transaction x -> Just x - _ -> Nothing - inPennyAcct p = Q.account p == (Y.unPennyAcct ax) - toUNum p = getUNumberFromTags . Q.tags $ p - --- | Gets the first UNumber from a list of Tags. -getUNumberFromTags :: L.Tags -> Maybe Y.UNumber -getUNumberFromTags = - getFirst - . mconcat - . map First - . map getUNumberFromTag - . L.unTags - --- | Examines a tag to see if it is a uNumber. If so, returns the --- UNumber. Otherwise, returns Nothing. -getUNumberFromTag :: L.Tag -> Maybe Y.UNumber -getUNumberFromTag (L.Tag x) = do - (f, r) <- X.uncons x - guard (f == 'U') - case reads . X.unpack $ r of - (y, ""):[] -> return $ Y.UNumber y - _ -> Nothing - - --- | Changes a single Item. -changeItem - :: Y.FitAcct - -> C.Item - -> St.State DbWithEntry C.Item -changeItem acct = - C.mapItemA pure pure (changeTransaction acct) - - --- | Changes all postings that match an AmexTxn to assign them the --- proper UNumber. Returns a list of changed items, and the DbMap of --- still-unassigned AmexTxns. -changeItems - :: Y.FitAcct - -> C.Ledger - -> DbWithEntry - -> (C.Ledger, DbWithEntry) -changeItems acct l = - St.runState (C.mapLedgerA (changeItem acct) l) - - -changeTransaction - :: Y.FitAcct - -> L.Transaction - -> St.State DbWithEntry L.Transaction -changeTransaction acct txn = do - let fam = L.unTransaction txn - fam' = L.mapParent (const L.emptyTopLineChangeData) fam - fam'' <- L.mapChildrenA (inspectAndChange acct txn) fam' - return $ L.changeTransaction fam'' txn - --- | Inspects a posting to see if it is an Amex posting and, if so, --- whether it matches one of the remaining AmexTxns. If so, then --- changes the transaction's UNumber, and remove that UNumber from the --- DbMap. If the posting alreay has a Number (UNumber or otherwise) --- skips it. -inspectAndChange - :: Y.FitAcct - -> L.Transaction - -> L.Posting - -> St.State DbWithEntry L.PostingChangeData -inspectAndChange acct t p = do - m <- St.get - case findMatch acct t p m of - Nothing -> return L.emptyPostingChangeData - Just (n, m') -> - let L.Tags oldTags = L.pTags p - tags' = L.Tags (oldTags ++ [newLincolnUNumber n]) - pcd = L.emptyPostingChangeData - { L.pcTags = Just tags' } - in St.put m' >> return pcd - -newLincolnUNumber :: Y.UNumber -> L.Tag -newLincolnUNumber a = - L.Tag ('U' `X.cons` (X.pack . show . Y.unUNumber $ a)) - - --- | Searches a DbMap for an AmexTxn that matches a given posting. If --- a match is found, returns the matching UNumber and a new DbMap that --- has the match removed. -findMatch - :: Y.FitAcct - -> L.Transaction - -> L.Posting - -> DbWithEntry - -> Maybe (Y.UNumber, DbWithEntry) -findMatch acct t p m = fmap toResult findResult - where - findResult = find (pennyTxnMatches acct t p) - . M.toList $ m - toResult (u, (_, _)) = (u, M.delete u m) - --- | Pairs each association in a DbMap with an Entry representing the --- transaction's entry in the ledger. -pairWithEntry :: Y.FitAcct -> Y.Posting -> (Y.Posting, L.Entry) -pairWithEntry acct p = (p, en) - where - en = L.Entry dc (L.Amount qty cty (Just (Y.side acct)) - (Just (Y.spaceBetween acct))) - dc = Y.translate (Y.incDec p) (Y.translator acct) - qty = U.parseQty (Y.amount p) - cty = Y.unCurrency . Y.currency $ acct - -type DbWithEntry = M.Map Y.UNumber (Y.Posting, L.Entry) - --- | Does the given Penny transaction match this posting? Makes sure --- that the account, quantity, date, commodity, and DrCr match, and --- that the posting does not have a number (it's OK if the transaction --- has a number.) -pennyTxnMatches - :: Y.FitAcct - -> L.Transaction - -> L.Posting - -> (a, (Y.Posting, L.Entry)) - -> Bool -pennyTxnMatches acct t p (_, (a, e)) = - mA && noFlag && mQ && mDC && mDate && mCmdty - where - mA = L.pAccount p == (Y.unPennyAcct . Y.pennyAcct $ acct) - mQ = L.equivalent (L.qty . L.amount . L.pEntry $ p) - (L.qty . L.amount $ e) - mDC = (L.drCr e) == (L.drCr . L.pEntry $ p) - (L.Family tl _ _ _) = L.unTransaction t - mDate = (L.day . L.tDateTime $ tl) == (Y.unDate . Y.date $ a) - noFlag = isNothing . L.pNumber $ p - mCmdty = (L.commodity . L.amount $ e) - == (Y.unCurrency . Y.currency $ acct) - - --- | Creates a new transaction corresponding to a given AmexTxn. Uses --- the Amex payee if that string is non empty; otherwise, uses the --- Amex description for the payee. -newTransaction - :: NoAuto - -> Y.FitAcct - -> UNumberLookupMap - -> PyeLookupMap - -> (Y.UNumber, (Y.Posting, L.Entry)) - -> L.Transaction -newTransaction noAuto acct mu mp (u, (a, e)) = L.rTransaction rt - where - rt = L.RTransaction - { L.rtCommodity = Y.unCurrency . Y.currency $ acct - , L.rtSide = Just . Y.side $ acct - , L.rtSpaceBetween = Just . Y.spaceBetween $ acct - , L.rtDrCr = L.drCr e - , L.rtTopLine = tl - , L.rtPosting = p1 - , L.rtMorePostings = [] - , L.rtIPosting = p2 - } - tl = (U.emptyTopLine ( L.dateTimeMidnightUTC . Y.unDate - . Y.date $ a)) - { U.tPayee = Just pa } - getPye = Y.toLincolnPayee acct - (guessedPye, guessedAcct) = guessInfo getPye mu mp a - dfltPye = getPye (Y.desc a) (Y.payee a) - dfltAcct = Y.unDefaultAcct . Y.defaultAcct $ acct - (pa, ac) = - if noAuto - then (dfltPye, dfltAcct) - else ( fromMaybe dfltPye guessedPye, - fromMaybe dfltAcct guessedAcct) - pennyAcct = Y.unPennyAcct . Y.pennyAcct $ acct - p1 = (U.emptyRPosting pennyAcct (L.qty . L.amount $ e)) - { U.rTags = L.Tags [newLincolnUNumber u] } - p2 = U.emptyIPosting ac - --- | Creates new transactions for all the items remaining in the --- DbMap. Appends a blank line after each one. -createTransactions - :: NoAuto - -> Y.FitAcct - -> C.Ledger - -> Y.DbList - -> DbWithEntry - -> [C.Item] -createTransactions noAuto acct led dbLs db = - concatMap (\i -> [i, C.BlankLine]) - . map C.Transaction - . map (newTransaction noAuto acct mu mp) - . M.assocs - $ db - where - mu = makeUNumberLookup (Y.toLincolnPayee acct) dbLs - mp = makePyeLookupMap (Y.pennyAcct acct) led - --- | Maps financial institution postings to UNumbers. The key is the --- Lincoln Payee of the financial institution posting, which is --- computed using the toLincolnPayee function in the FitAcct. The --- UNumbers are in a list, with UNumbers from most recent financial --- institution postings first. -type UNumberLookupMap = M.Map L.Payee [Y.UNumber] - --- | Create a UNumberLookupMap from a DbWithEntry. Financial --- institution postings with higher U-numbers will come first. -makeUNumberLookup - :: (Y.Desc -> Y.Payee -> L.Payee) - -> Y.DbList - -> UNumberLookupMap -makeUNumberLookup toPye = foldl' ins M.empty . map f . sortBy g - where - ins m (k, v) = M.alter alterer k m - where alterer Nothing = Just [v] - alterer (Just ls) = Just $ v:ls - f (u, p) = (toPye (Y.desc p) (Y.payee p), u) - g (_, p1) (_, p2) = compare (Y.date p1) (Y.date p2) - --- | Given a list of keys, find the first key that is in the --- map. Returns Nothing if no key is in the map. -findFirstKey :: Ord k => M.Map k v -> [k] -> Maybe v -findFirstKey _ [] = Nothing -findFirstKey m (k:ks) = case M.lookup k m of - Nothing -> findFirstKey m ks - Just v -> Just v - --- | Maps UNumbers to payees and accounts from the ledger. -type PyeLookupMap = M.Map Y.UNumber (Maybe L.Payee, Maybe L.Account) - --- | Makes a payee lookup map. Puts those postings which match the --- PennyAcct and have a UNumber into the map. (If two postings match --- the PennyAcct and have the same UNumber, the one that appears later --- in the ledger file will be in the map.) -makePyeLookupMap :: Y.PennyAcct -> C.Ledger -> PyeLookupMap -makePyeLookupMap a l - = M.fromList . mapMaybe f . concatMap L.postFam . mapMaybe toPstg - . C.unLedger $ l - where - f pstg = do - guard $ (Q.account pstg) == Y.unPennyAcct a - u <- getUNumberFromTags . Q.tags $ pstg - let (L.Child _ sib sibs _) = L.unPostFam pstg - ac = if null sibs - then Just (L.pAccount sib) - else Nothing - return (u, (Q.payee pstg, ac)) - toPstg i = case i of { C.Transaction t -> Just t; _ -> Nothing } - --- | Given a UNumber and the maps, looks up the payee and account --- information from previous transactions if this information is --- available. -guessInfo - :: (Y.Desc -> Y.Payee -> L.Payee) - -> UNumberLookupMap - -> PyeLookupMap - -> Y.Posting - -> (Maybe L.Payee, Maybe L.Account) -guessInfo getPye mu mp p = fromMaybe (Nothing, Nothing) $ do - let pstgPayee = getPye (Y.desc p) (Y.payee p) - unums <- M.lookup pstgPayee mu - findFirstKey mp unums diff --git a/Penny/Brenner/Print.hs b/Penny/Brenner/Print.hs deleted file mode 100644 --- a/Penny/Brenner/Print.hs +++ /dev/null @@ -1,65 +0,0 @@ --- | Prints parsed transactions. --- --- TODO add support to this and other Brenner components for reading --- from stdin. -module Penny.Brenner.Print (mode) where - -import qualified Penny.Brenner.Types as Y -import qualified Penny.Brenner.Util as U -import qualified System.Console.MultiArg as MA -import qualified Control.Monad.Exception.Synchronous as Ex -import Data.Maybe (mapMaybe) - -help :: String -> String -help pn = unlines - [ "usage: " ++ pn ++ " [global-options] print [local-options] FILE..." - , "Parses the transactions in each FILE using the appropriate parser" - , "and prints the parse result to standard output." - , "" - , "Local options:" - , " --help, -h Show this help and exit." - ] - -data Arg - = ArgFile String - deriving (Eq, Show) - -mode - :: Maybe Y.FitAcct - -> MA.Mode (IO ()) -mode mayFa = MA.Mode - { MA.mName = "print" - , MA.mIntersperse = MA.Intersperse - , MA.mOpts = [] - , MA.mPosArgs = ArgFile - , MA.mProcess = processor mayFa - , MA.mHelp = help - } - -processor - :: Maybe Y.FitAcct - -> [Arg] - -> IO () -processor mayFa ls = - case mayFa of - Nothing -> fail $ - "no financial institution account" - ++ " provided on command line, and no account" - ++ " configured by default." - Just fa -> doPrint (snd . Y.parser $ fa) ls - -doPrint - :: (Y.FitFileLocation -> IO (Ex.Exceptional String [Y.Posting])) - -> [Arg] - -> IO () -doPrint prsr ls = mapM_ f . mapMaybe toFile $ ls - where - f file = do - r <- prsr file - case r of - Ex.Exception s -> do - fail $ "penny-fit print: error: " ++ s - Ex.Success ps -> mapM putStr . map U.showPosting $ ps - toFile a = case a of - ArgFile s -> Just (Y.FitFileLocation s) - diff --git a/Penny/Brenner/Types.hs b/Penny/Brenner/Types.hs deleted file mode 100644 --- a/Penny/Brenner/Types.hs +++ /dev/null @@ -1,298 +0,0 @@ -module Penny.Brenner.Types - ( Date(..) - , IncDec(..) - , UNumber(..) - , FitId(..) - , Payee(..) - , Desc(..) - , Amount(unAmount) - , mkAmount - , translate - , DbMap - , DbList - , Posting(..) - , DbLocation(..) - , Name(..) - , PennyAcct(..) - , Translator(..) - , DefaultAcct(..) - , Currency(..) - , FitAcct(..) - , Config(..) - , FitFileLocation(..) - , AllowNew(..) - ) where - -import Control.Applicative ((<$>), (<*>)) -import qualified Control.Monad.Exception.Synchronous as Ex -import qualified Data.Map as M -import qualified Data.Time as Time -import qualified Penny.Copper.Render as R -import qualified Penny.Lincoln as L -import Data.Text (Text, pack, unpack) -import qualified Data.Text.Encoding as E -import qualified Data.Serialize as S - --- | The date reported by the financial institution. -newtype Date = Date { unDate :: Time.Day } - deriving (Eq, Show, Ord, Read) - -instance S.Serialize Date where - put = S.put . show . unDate - get = Date <$> (read <$> S.get) - --- | Reports changes in account balances. Avoids using /debit/ and --- /credit/ as these terms are used differently by the bank than in --- your ledger (that is, the bank reports it from their perspective, --- not yours) so instead the terms /increase/ and /decrease/ are --- used. IncDec is used to record the bank's transactions so --- /increase/ and /decrease/ are used in the same way you would see --- them on a bank statement, whether it's a credit card, loan, --- checking account, etc. -data IncDec - = Increase - -- ^ Increases the account balance. For a checking or savings - -- account, this is a deposit. For a credit card, this is a purchase. - - | Decrease - -- ^ Decreases the account balance. On a credit card, this is a - -- payment. On a checking account, this is a withdrawal. - deriving (Eq, Show, Read) - -instance S.Serialize IncDec where - put x = case x of - Increase -> S.putWord8 0 - Decrease -> S.putWord8 1 - get = S.getWord8 >>= f - where - f x = case x of - 0 -> return Increase - 1 -> return Decrease - _ -> fail "read IncDec error" - --- | A unique number assigned by Brenner to identify each --- posting. This is unique within a particular financial institution --- account only. -newtype UNumber = UNumber { unUNumber :: Integer } - deriving (Eq, Show, Ord, Read) - -instance S.Serialize UNumber where - put = S.put . unUNumber - get = UNumber <$> S.get - -putText :: Text -> S.Put -putText = S.put . E.encodeUtf8 - -getText :: S.Get Text -getText = S.get >>= f - where - f bs = case E.decodeUtf8' bs of - Left _ -> fail "text reading failed" - Right x -> return x - - --- | For Brenner to work, the bank has to assign unique identifiers to --- each transaction that it gives you for download. This is the --- easiest reliable way to ensure duplicates are not processed --- multiple times. (There are other ways to accomplish this, but they --- are much harder and less reliable.) If the bank does not do this, --- you can't use Brenner. -newtype FitId = FitId { unFitId :: Text } - deriving (Eq, Show, Ord, Read) - -instance S.Serialize FitId where - put = putText . unFitId - get = FitId <$> getText - --- | Some financial institutions assign a separate Payee in addition --- to a description. Others just have a single Description field. If --- this institution uses both, put something here. Brenner will prefer --- the Payee if it is not zero length; then it will use the Desc. -newtype Payee = Payee { unPayee :: Text } - deriving (Eq, Show, Ord, Read) - -instance S.Serialize Payee where - put = putText . unPayee - get = Payee <$> getText - --- | The transaction description. Some institutions assign only a --- description (sometimes muddling a payee with long codes, some --- dates, etc). Brenner prefers the Payee if there is one, and uses a --- Desc otherwise. -newtype Desc = - Desc { unDesc :: Text } - deriving (Eq, Show, Ord, Read) - -instance S.Serialize Desc where - put = putText . unDesc - get = Desc <$> getText - --- | The amount of the transaction. Do not include any leading plus or --- minus signs; this should be only digits and a decimal point. -newtype Amount = Amount { unAmount :: Text } - deriving (Eq, Show, Ord, Read) - -instance S.Serialize Amount where - put = putText . unAmount - get = getText >>= f - where - f x = case mkAmount . unpack $ x of - Nothing -> fail $ "failed to load amount: " ++ unpack x - Just a -> return a - --- | Ensures that incoming Amounts have only digits and (up to) one --- decimal point. -mkAmount :: String -> Maybe Amount -mkAmount s = - let isDigit c = c >= '0' && c <= '9' - (_, rs) = span isDigit s - in case rs of - "" -> if not . null $ s - then return . Amount . pack $ s - else Nothing - '.':rest -> if all isDigit rest - then return . Amount . pack $ s - else Nothing - _ -> Nothing - -translate - :: IncDec - -> Translator - -> L.DrCr -translate Increase IncreaseIsDebit = L.Debit -translate Increase IncreaseIsCredit = L.Credit -translate Decrease IncreaseIsDebit = L.Credit -translate Decrease IncreaseIsCredit = L.Debit - -type DbMap = M.Map UNumber Posting -type DbList = [(UNumber, Posting)] - -data Posting = Posting - { date :: Date - , desc :: Desc - , incDec :: IncDec - , amount :: Amount - , payee :: Payee - , fitId :: FitId - } deriving (Read, Show) - - -instance S.Serialize Posting where - put x = S.put (date x) - >> S.put (desc x) - >> S.put (incDec x) - >> S.put (amount x) - >> S.put (payee x) - >> S.put (fitId x) - get = Posting - <$> S.get - <*> S.get - <*> S.get - <*> S.get - <*> S.get - <*> S.get - --- | Where is the database of postings? -newtype DbLocation = DbLocation { unDbLocation :: Text } - deriving (Eq, Show) - --- | A name used to refer to a batch of settings. -newtype Name = Name { unName :: Text } - deriving (Eq, Show) - --- | The Penny account holding postings for this financial --- institution. For instance it might be @Assets:Checking@ if this is --- your checking account, @Liabilities:Credit Card@, or whatever. -newtype PennyAcct = PennyAcct { unPennyAcct :: L.Account } - deriving (Eq, Show) - --- | What the financial institution shows as an increase or decrease --- has to be recorded as a debit or credit in the PennyAcct. -data Translator - = IncreaseIsDebit - -- ^ That is, when the financial institution shows a posting that - -- increases your account balance, you record a debit. You will - -- probably use this for deposit accounts, like checking and - -- savings. These are asset accounts so if the balance goes up you - -- record a debit in your ledger. - - | IncreaseIsCredit - -- ^ That is, when the financial institution shows a posting that - -- increases your account balance, you record a credit. You will - -- probably use this for liabilities, such as credit cards and other - -- loans. - - deriving (Eq, Show) - --- | The default account to place unclassified postings in. For --- instance @Expenses:Unclassified@. -newtype DefaultAcct = DefaultAcct { unDefaultAcct :: L.Account } - deriving (Eq, Show) - --- | The currency for all transactions, e.g. @$@. -newtype Currency = Currency { unCurrency :: L.Commodity } - deriving (Eq, Show) - --- | A batch of settings representing a single financial institution --- account. -data FitAcct = FitAcct - { dbLocation :: DbLocation - , pennyAcct :: PennyAcct - , defaultAcct :: DefaultAcct - , currency :: Currency - , groupSpecs :: R.GroupSpecs - , translator :: Translator - - , side :: L.Side - -- ^ When creating new transactions, the commodity will be on this - -- side - - , spaceBetween :: L.SpaceBetween - -- ^ When creating new transactions, is there a space between the - -- commodity and the quantity - - , parser :: ( String - , FitFileLocation -> IO (Ex.Exceptional String [Posting])) - -- ^ Parses a file of transactions from the financial - -- institution. The function must open the file and parse it. This - -- is in the IO monad not only because the function must open the - -- file itself, but also so the function can perform arbitrary IO - -- (run pdftotext, maybe?) If there is failure, the function can - -- return an Exceptional String, which is the error - -- message. Alternatively the function can raise an exception in the - -- IO monad (currently Brenner makes no attempt to catch these) so - -- if any of the IO functions throw you can simply not handle the - -- exceptions. - -- - -- The first element of the pair is a help string which should - -- indicate how to download the data, as a helpful reminder. - - , toLincolnPayee :: Desc -> Payee -> L.Payee - -- ^ Sometimes the financial institution provides Payee information, - -- sometimes it does not. Sometimes the Desc might have additional - -- information that you might want to remove. This function can be - -- used to do that. The resulting Lincoln Payee is used for any - -- transactions that are created by the merge command. The resulting - -- payee is also used when comparing new financial institution - -- postings to already existing ledger transactions in order to - -- guess at which payee and accounts to create in the transactions - -- created by the merge command. - - } - --- | Configuration for the Brenner program. You can optionally have --- a default FitAcct, which is used if you do not specify any FitAcct on the --- command line. You can also name any number of additional FitAccts. If --- you do not specify a default FitAcct, you must specify a FitAcct on the --- command line. - -data Config = Config - { defaultFitAcct :: Maybe FitAcct - , moreFitAccts :: [(Name, FitAcct)] - } - -newtype FitFileLocation = FitFileLocation { unFitFileLocation :: String } - deriving (Show, Eq) - -newtype AllowNew = AllowNew { unAllowNew :: Bool } - deriving (Show, Eq) diff --git a/Penny/Brenner/Util.hs b/Penny/Brenner/Util.hs deleted file mode 100644 --- a/Penny/Brenner/Util.hs +++ /dev/null @@ -1,87 +0,0 @@ -module Penny.Brenner.Util where - -import Control.Monad.Exception.Synchronous as Ex -import qualified Penny.Brenner.Types as Y -import qualified Data.ByteString as BS -import qualified System.IO.Error as IOE -import qualified Data.Serialize as S -import qualified Data.Text as X -import qualified Penny.Copper.Parsec as CP -import qualified Text.Parsec as P -import qualified Penny.Lincoln as L - --- | Loads the database from disk. If allowNew is True, then does not --- fail if the file was not found. -loadDb - :: Y.AllowNew - -- ^ Is a new file allowed? - - -> Y.DbLocation - -- ^ DB location - - -> IO Y.DbList -loadDb (Y.AllowNew allowNew) (Y.DbLocation dbLoc) = do - eiStr <- IOE.tryIOError (BS.readFile . X.unpack $ dbLoc) - case eiStr of - Left e -> - if allowNew && IOE.isDoesNotExistError e - then return [] - else IOE.ioError e - Right g -> case readDbTuple g of - Ex.Exception e -> fail e - Ex.Success good -> return good - --- | File version. Increment this when anything in the file format --- changes. -version :: Int -version = 0 - -brenner :: String -brenner = "penny.brenner" - -readDbTuple - :: BS.ByteString - -> Ex.Exceptional String Y.DbList -readDbTuple bs = do - (s, v, ls) <- Ex.fromEither $ S.decode bs - Ex.assert "database file format not recognized." $ s == brenner - Ex.assert "wrong database version." $ v == version - return ls - -saveDbTuple :: Y.DbList -> BS.ByteString -saveDbTuple ls = S.encode (brenner, version, ls) - --- | Writes a new database to disk. -saveDb :: Y.DbLocation -> Y.DbList -> IO () -saveDb (Y.DbLocation p) = BS.writeFile (X.unpack p) . saveDbTuple - --- | Parses quantities from amounts. All amounts should be verified as --- having only digits, optionally followed by a point and then more --- digits. All these values should parse. So if there is a problem it --- is a programmer error. Apply error. -parseQty :: Y.Amount -> L.Qty -parseQty a = case P.parse CP.quantity "" (Y.unAmount a) of - Left e -> error $ "could not parse quantity from string: " - ++ (X.unpack . Y.unAmount $ a) ++ ": " ++ show e - Right g -> g - -label :: String -> X.Text -> String -label s x = s ++ ": " ++ X.unpack x ++ "\n" - --- | Shows a Posting in human readable format. -showPosting :: Y.Posting -> String -showPosting (Y.Posting dt dc nc am py fd) = - label "Date" (X.pack . show . Y.unDate $ dt) - ++ label "Description" (Y.unDesc dc) - ++ label "Type" (X.pack $ case nc of - Y.Increase -> "increase" - Y.Decrease -> "decrease") - ++ label "Amount" (Y.unAmount am) - ++ label "Payee" (Y.unPayee py) - ++ label "Financial institution ID" (Y.unFitId fd) - ++ "\n" - -showDbPair :: (Y.UNumber, Y.Posting) -> String -showDbPair (Y.UNumber u, p) = - label "U number" (X.pack . show $ u) - ++ showPosting p diff --git a/Penny/Cabin.hs b/Penny/Cabin.hs deleted file mode 100644 --- a/Penny/Cabin.hs +++ /dev/null @@ -1,7 +0,0 @@ --- | Cabin - Penny reports --- --- Cabin contains reports, or functions that take a list of postings --- and return a formatted Text to display data in a human-readable --- format. -module Penny.Cabin where - diff --git a/Penny/Cabin/Balance.hs b/Penny/Cabin/Balance.hs deleted file mode 100644 --- a/Penny/Cabin/Balance.hs +++ /dev/null @@ -1,21 +0,0 @@ --- | Penny balance reports. Currently there are two balance reports: --- the MultiCommodity report, which cannot convert commodities and --- which therefore might show more than one commodity in a single --- report, and the Convert report, which uses price data in the Penny --- file to convert all commodities to a single commodity. The Convert --- report always displays only one commodity per account and this one --- commodity for the whole report. -module Penny.Cabin.Balance where - -import qualified Penny.Cabin.Balance.MultiCommodity as MC -import qualified Penny.Cabin.Interface as I -import qualified Penny.Cabin.Balance.Convert as C -import qualified Penny.Cabin.Balance.Convert.Options as ConvOpts - --- | The default multi-commodity balance report. -multiCommodity :: I.Report -multiCommodity = MC.defaultReport - --- | The default converting balance report. -convert :: I.Report -convert = C.cmdLineReport ConvOpts.defaultOptions diff --git a/Penny/Cabin/Balance/Convert.hs b/Penny/Cabin/Balance/Convert.hs deleted file mode 100644 --- a/Penny/Cabin/Balance/Convert.hs +++ /dev/null @@ -1,334 +0,0 @@ --- | The Convert report. This report converts all account balances to --- a single commodity, which must be specified. - -module Penny.Cabin.Balance.Convert ( - Opts(..) - , Sorter - , report - , cmdLineReport - , getSorter - ) where - -import Control.Applicative ((<$>), (<*>)) -import qualified Control.Monad.Exception.Synchronous as Ex -import qualified Data.Tree as E -import qualified Data.Traversable as Tvbl -import qualified Penny.Cabin.Options as CO -import qualified Penny.Cabin.Parsers as CP -import qualified Penny.Cabin.Scheme as Scheme -import qualified Penny.Cabin.Balance.Util as U -import qualified Penny.Cabin.Balance.Convert.Chunker as K -import qualified Penny.Cabin.Balance.Convert.Options as O -import qualified Penny.Cabin.Balance.Convert.Parser as P -import qualified Penny.Cabin.Interface as I -import qualified Penny.Lincoln as L -import qualified Penny.Lincoln.Balance as Bal -import qualified Penny.Liberty as Ly -import qualified Penny.Shield as S -import qualified Data.Either as Ei -import qualified Data.Map as M -import qualified Data.Text as X -import Data.Monoid (mempty, mappend, mconcat) -import qualified System.Console.MultiArg as MA -import qualified System.Console.Rainbow as Rb - --- | Options for the Convert report. These are the only options you --- need to use if you are supplying options programatically (as --- opposed to parsing them in from the command line.) -data Opts = Opts - { balanceFormat :: L.Commodity -> L.Qty -> X.Text - , showZeroBalances :: CO.ShowZeroBalances - , sorter :: Sorter - , target :: L.To - , dateTime :: L.DateTime - , textFormats :: Scheme.Changers - } - --- | How to sort each line of the report. Each subaccount has only one --- BottomLine (unlike in the MultiCommodity report, where each --- subaccount may have more than one BottomLine, one for each --- commodity.) -type Sorter = - (L.SubAccount, L.BottomLine) - -> (L.SubAccount, L.BottomLine) - -> Ordering - --- | Converts all commodities in a Balance to a single commodity and --- combines all the BottomLines into one. Fails with an error message --- if no conversion data is available. -convertBalance :: - L.PriceDb - -> L.DateTime - -> L.To - -> L.Balance - -> Ex.Exceptional X.Text L.BottomLine -convertBalance db dt to bal = fmap mconcat r - where - r = mapM (convertOne db dt to) . M.assocs . L.unBalance $ bal - --- | Converts a single BottomLine to a new commodity. Fails with an --- error message if no conversion data is available. -convertOne :: - L.PriceDb - -> L.DateTime - -> L.To - -> (L.Commodity, L.BottomLine) - -> Ex.Exceptional X.Text L.BottomLine -convertOne db dt to (cty, bl) = - case bl of - L.Zero -> return L.Zero - L.NonZero (L.Column dc qt) -> Ex.mapExceptional e g ex - where - ex = L.convert db dt to am - am = L.Amount qt cty Nothing Nothing - e = convertError to (L.From cty) - g r = L.NonZero (L.Column dc r) - --- | Creates an error message for conversion errors. -convertError :: - L.To - -> L.From - -> L.PriceDbError - -> X.Text -convertError (L.To to) (L.From fr) e = - let fromErr = L.unCommodity fr - toErr = L.unCommodity to - in case e of - L.FromNotFound -> - X.pack "no data to convert from commodity " - `X.append` fromErr - L.ToNotFound -> - X.pack "no data to convert to commodity " - `X.append` toErr - L.CpuNotFound -> - X.pack "no data to convert from commodity " - `X.append` fromErr - `X.append` (X.pack " to commodity ") - `X.append` toErr - `X.append` (X.pack " at given date and time") - - --- | Create a price database. -buildDb :: [L.PricePoint] -> L.PriceDb -buildDb = foldl f L.emptyDb where - f db pb = L.addPrice db pb - --- | All data for the report after all balances have been converted to --- a single commodity and all the sums of the child accounts have been --- added to the parent accounts. -data ForestAndBL = ForestAndBL { - _tbForest :: E.Forest (L.SubAccount, L.BottomLine) - , _tbTotal :: L.BottomLine - , _tbTo :: L.To - } - --- | Converts the balance data in preparation for screen rendering. -rows :: ForestAndBL -> ([K.Row], L.To) -rows (ForestAndBL f tot to) = (first:second:rest, to) - where - first = K.ROneCol $ K.OneColRow 0 desc - desc = X.pack "All amounts reported in commodity: " - `X.append` (L.unCommodity - . L.unTo - $ to) - second = K.RMain $ K.MainRow 0 (X.pack "Total") tot - rest = map mainRow - . concatMap E.flatten - . map U.labelLevels - $ f - - -mainRow :: (Int, (L.SubAccount, L.BottomLine)) -> K.Row -mainRow (l, (a, b)) = K.RMain $ K.MainRow l x b - where - x = L.text a - --- | The function for the Convert report. Use this function if you are --- setting the options from a program (as opposed to parsing them in --- from the command line.) Will fail if the balance conversions fail. -report - :: Opts - -> [L.PricePoint] - -> [L.Box a] - -> Ex.Exceptional X.Text [Rb.Chunk] -report os@(Opts getFmt _ _ _ _ txtFormats) ps bs = do - fstBl <- sumConvertSort os ps bs - let (rs, L.To cy) = rows fstBl - fmt = getFmt cy - return $ K.rowsToChunks txtFormats fmt rs - - --- | Creates a report respecting the standard interface for reports --- whose options are parsed in from the command line. -cmdLineReport - :: O.DefaultOpts - -> I.Report -cmdLineReport o rt = (help o, mkMode) - where - mkMode _ _ chgrs _ fsf = MA.Mode - { MA.mName = "convert" - , MA.mIntersperse = MA.Intersperse - , MA.mOpts = map (fmap Right) P.allOptSpecs - , MA.mPosArgs = Left - , MA.mProcess = process rt chgrs o fsf - , MA.mHelp = const (help o) - } - -process - :: S.Runtime - -> Scheme.Changers - -> O.DefaultOpts - -> ([L.Transaction] -> [L.Box Ly.LibertyMeta]) - -> [Either String (P.Opts -> Ex.Exceptional String P.Opts)] - -> Ex.Exceptional X.Text I.ArgsAndReport -process rt chgrs defaultOpts fsf ls = do - let (posArgs, parsed) = Ei.partitionEithers ls - op' = foldl (>>=) (return (O.toParserOpts defaultOpts rt)) parsed - case op' of - Ex.Exception s -> Ex.throw . X.pack $ s - Ex.Success g -> return $ - let noDefault = X.pack "no default price found" - f = fromParsedOpts chgrs g - pr ts pps = do - rptOpts <- Ex.fromMaybe noDefault $ - f pps (O.format defaultOpts) - let boxes = fsf ts - report rptOpts pps boxes - in (posArgs, pr) - - --- | Sums the balances from the bottom to the top of the tree (so that --- parent accounts have the sum of the balances of all their --- children.) Then converts the commodities to a single commodity, and --- sorts the accounts as requested. Fails if the conversion fails. -sumConvertSort - :: Opts - -> [L.PricePoint] - -> [L.Box a] - -> Ex.Exceptional X.Text ForestAndBL -sumConvertSort os ps bs = mkResult <$> convertedFrst <*> convertedTot - where - (Opts _ szb str tgt dt _) = os - bals = U.balances szb bs - (frst, tot) = U.sumForest mempty mappend bals - convertBal (a, bal) = - (\bl -> (a, bl)) <$> convertBalance db dt tgt bal - db = buildDb ps - convertedFrst = mapM (Tvbl.mapM convertBal) frst - convertedTot = convertBalance db dt tgt tot - mkResult f t = ForestAndBL (U.sortForest str f) t tgt - --- | Determine the most frequent To commodity. -mostFrequent :: [L.PricePoint] -> Maybe L.To -mostFrequent = U.lastMode . map (L.to . L.price) - - -type DoReport = [L.PricePoint] - -> (L.Commodity -> L.Qty -> X.Text) - -> (Maybe Opts) - --- | Get options for the report, depending on what options were parsed --- from the command line. Fails if the user did not specify a --- commodity and mostFrequent fails. -fromParsedOpts - :: Scheme.Changers - -> P.Opts - -> DoReport -fromParsedOpts chgrs (P.Opts szb tgt dt so sb) = - \pps fmt -> case tgt of - P.ManualTarget to -> - Just $ Opts fmt szb (getSorter so sb) to dt chgrs - P.AutoTarget -> - case mostFrequent pps of - Nothing -> Nothing - Just to -> - Just $ Opts fmt szb (getSorter so sb) to dt chgrs - --- | Returns a function usable to sort pairs of SubAccount and --- BottomLine depending on how you want them sorted. -getSorter :: CP.SortOrder -> P.SortBy -> Sorter -getSorter o b = flipper f - where - flipper = case o of - CP.Ascending -> id - CP.Descending -> - \g p1 p2 -> case g p1 p2 of - LT -> GT - GT -> LT - EQ -> EQ - f p1@(a1, _) p2@(a2, _) = case b of - P.SortByName -> compare a1 a2 - P.SortByQty -> cmpBottomLine p1 p2 - -cmpBottomLine :: Sorter -cmpBottomLine (n1, bl1) (n2, bl2) = - case (bl1, bl2) of - (L.Zero, L.Zero) -> EQ - (L.NonZero _, L.Zero) -> LT - (L.Zero, L.NonZero _) -> GT - (L.NonZero c1, L.NonZero c2) -> - mconcat [dc, qt, na] - where - dc = case (Bal.drCr c1, Bal.drCr c2) of - (L.Debit, L.Debit) -> EQ - (L.Debit, L.Credit) -> LT - (L.Credit, L.Debit) -> GT - (L.Credit, L.Credit) -> EQ - qt = compare (Bal.qty c1) (Bal.qty c2) - na = compare n1 n2 - ------------------------------------------------------------- --- ## Help ------------------------------------------------------------- -ifDefault :: Bool -> String -ifDefault b = if b then " (default)" else "" - -help :: O.DefaultOpts -> String -help o = unlines $ - [ "convert" - , " Show account balances, after converting all amounts" - , " to a single commodity. Accepts ONLY the following options:" - , "" - , "--show-zero-balances" - , " Show balances that are zero" - ++ ifDefault (CO.unShowZeroBalances . O.showZeroBalances $ o) - , "--hide-zero-balances" - , " Hide balances that are zero" - ++ ifDefault (not . CO.unShowZeroBalances . O.showZeroBalances $ o) - , "" - , "--commodity TARGET-COMMMODITY, -c TARGET-COMMODITY" - , " Convert all commodities to TARGET-COMMODITY." - ] ++ case O.target o of - P.ManualTarget (L.To cy) -> - [ " default: " ++ (X.unpack . L.unCommodity $ cy) ] - _ -> [] - ++ - [ "--auto-commodity" - , " convert all commodities to the commodity that appears most" - , " often as the target commodity in your price data. If" - , " there is a tie, the price closest to the end of your list" - , " of prices is used." - ++ case O.target o of - P.AutoTarget -> " (default)" - _ -> "" - , "" - , "--date DATE-TIME, -d DATE-TIME" - , " Convert prices as of the date and time given" - , " (by default, the current date and time is used.)" - , "" - , "--sort qty|name, -s qty|name" - , " Sort balances by sub-account name" - ++ ifDefault (O.sortBy o == P.SortByName) - ++ " or by quantity" - ++ ifDefault (O.sortBy o == P.SortByQty) - , "--ascending" - , " Sort in ascending order" - ++ ifDefault (O.sortOrder o == CP.Ascending) - , "--descending" - , " Sort in descending order" - ++ ifDefault (O.sortOrder o == CP.Descending) - , "" - , "--help, -h" - , " Show this help and exit" - ] - diff --git a/Penny/Cabin/Balance/Convert/Chunker.hs b/Penny/Cabin/Balance/Convert/Chunker.hs deleted file mode 100644 --- a/Penny/Cabin/Balance/Convert/Chunker.hs +++ /dev/null @@ -1,239 +0,0 @@ --- | Creates the output Chunks for the Balance report for --- multi-commodity reports only. - -module Penny.Cabin.Balance.Convert.Chunker ( - MainRow(..), - OneColRow(..), - Row(..), - rowsToChunks - ) where - - -import Control.Applicative - (Applicative (pure), (<$>), (<*>)) -import qualified Penny.Cabin.Scheme as E -import qualified Penny.Cabin.Meta as Meta -import qualified Penny.Cabin.Row as R -import qualified Penny.Lincoln as L -import qualified Data.Foldable as Fdbl -import qualified Data.Text as X -import qualified System.Console.Rainbow as Rb - -type IsEven = Bool - -data Columns a = Columns { - acct :: a - , drCr :: a - , quantity :: a - } deriving Show - -instance Functor Columns where - fmap f c = Columns { - acct = f (acct c) - , drCr = f (drCr c) - , quantity = f (quantity c) - } - -instance Applicative Columns where - pure a = Columns a a a - fn <*> fa = Columns { - acct = (acct fn) (acct fa) - , drCr = (drCr fn) (drCr fa) - , quantity = (quantity fn) (quantity fa) - } - -data PreSpec = PreSpec { - _justification :: R.Justification - , _padSpec :: (E.Label, E.EvenOdd) - , bits :: Rb.Chunk } - --- | When given a list of columns, determine the widest row in each --- column. -maxWidths :: [Columns PreSpec] -> Columns R.Width -maxWidths = Fdbl.foldl' maxWidthPerColumn (pure (R.Width 0)) - --- | Applied to a Columns of PreSpec and a Colums of widths, return a --- Columns that has the wider of the two values. -maxWidthPerColumn :: - Columns R.Width - -> Columns PreSpec - -> Columns R.Width -maxWidthPerColumn w p = f <$> w <*> p where - f old new = max old (R.Width . X.length . Rb.chunkText . bits $ new) - --- | Changes a single set of Columns to a set of ColumnSpec of the --- given width. -preSpecToSpec :: - Columns R.Width - -> Columns PreSpec - -> Columns R.ColumnSpec -preSpecToSpec ws p = f <$> ws <*> p where - f width (PreSpec j ps bs) = R.ColumnSpec j width ps [bs] - -resizeColumnsInList :: [Columns PreSpec] -> [Columns R.ColumnSpec] -resizeColumnsInList cs = map (preSpecToSpec w) cs where - w = maxWidths cs - - -widthSpacerAcct :: Int -widthSpacerAcct = 4 - -widthSpacerDrCr :: Int -widthSpacerDrCr = 1 - -colsToBits - :: E.Changers - -> IsEven - -> Columns R.ColumnSpec - -> [Rb.Chunk] -colsToBits chgrs isEven (Columns a dc q) = let - fillSpec = if isEven - then (E.Other, E.Even) - else (E.Other, E.Odd) - spacer w = R.ColumnSpec j (R.Width w) fillSpec [] - j = R.LeftJustify - cs = a - : spacer widthSpacerAcct - : dc - : spacer widthSpacerDrCr - : q - : [] - in R.row chgrs cs - -colsListToBits - :: E.Changers - -> [Columns R.ColumnSpec] - -> [[Rb.Chunk]] -colsListToBits chgrs = zipWith f bools where - f b c = colsToBits chgrs b c - bools = iterate not True - -preSpecsToBits - :: E.Changers - -> [Columns PreSpec] - -> [Rb.Chunk] -preSpecsToBits chgrs = - concat - . colsListToBits chgrs - . resizeColumnsInList - -data Row = RMain MainRow | ROneCol OneColRow - --- | Displays a one-column row. -data OneColRow = OneColRow { - ocIndentation :: Int - -- ^ Indent the text by this many levels (not by this many - -- spaces; this number is multiplied by another number in the - -- Chunker source to arrive at the final indentation amount) - - , ocText :: X.Text - -- ^ Text for the left column - } - --- | Displays a single account in a Balance report. In a --- single-commodity report, this account will only be one screen line --- long. In a multi-commodity report, it might be multiple lines long, --- with one screen line for each commodity. -data MainRow = MainRow { - mrIndentation :: Int - -- ^ Indent the account name by this many levels (not by this many - -- spaces; this number is multiplied by another number in the - -- Chunker source to arrive at the final indentation amount) - - , mrText :: X.Text - -- ^ Text for the name of the account - - , mrBottomLine :: L.BottomLine - -- ^ Commodity balances. If this list is empty, dashes are - -- displayed for the DrCr and Qty. - } - - -rowsToChunks - :: E.Changers - -> (L.Qty -> X.Text) - -- ^ How to format a balance to allow for digit grouping - -> [Row] - -> [Rb.Chunk] -rowsToChunks chgrs fmt = - preSpecsToBits chgrs - . rowsToColumns chgrs fmt - -rowsToColumns - :: E.Changers - -> (L.Qty -> X.Text) - -- ^ How to format a balance to allow for digit grouping - - -> [Row] - -> [Columns PreSpec] -rowsToColumns chgrs fmt rs = map (mkRow chgrs fmt) pairs - where - pairs = Meta.visibleNums (,) rs - - -mkRow - :: E.Changers - -> (L.Qty -> X.Text) - -> (Meta.VisibleNum, Row) - -> Columns PreSpec -mkRow chgrs fmt (vn, r) = case r of - RMain m -> mkMainRow chgrs fmt (vn, m) - ROneCol c -> mkOneColRow chgrs (vn, c) - -mkOneColRow - :: E.Changers - -> (Meta.VisibleNum, OneColRow) - -> Columns PreSpec -mkOneColRow chgrs (vn, (OneColRow i t)) = Columns ca cd cq - where - txt = X.append indents t - indents = X.replicate (indentAmount * max 0 i) - (X.singleton ' ') - eo = E.fromVisibleNum vn - lbl = E.Other - ca = PreSpec R.LeftJustify (lbl, eo) - (E.getEvenOddLabelValue lbl eo chgrs $ Rb.plain txt) - cd = PreSpec R.LeftJustify (lbl, eo) - (E.getEvenOddLabelValue lbl eo chgrs $ Rb.plain X.empty) - cq = cd - -mkMainRow - :: E.Changers - -> (L.Qty -> X.Text) - -> (Meta.VisibleNum, MainRow) - -> Columns PreSpec -mkMainRow chgrs fmt (vn, (MainRow i acctTxt b)) = Columns ca cd cq - where - applyFmt = E.getEvenOddLabelValue lbl eo chgrs - eo = E.fromVisibleNum vn - lbl = E.Other - ca = PreSpec R.LeftJustify (lbl, eo) (applyFmt (Rb.plain txt)) - where - txt = X.append indents acctTxt - indents = X.replicate (indentAmount * max 0 i) - (X.singleton ' ') - cd = PreSpec R.LeftJustify (lbl, eo) (applyFmt cksDrCr) - cq = PreSpec R.LeftJustify (lbl, eo) (applyFmt cksQty) - (cksDrCr, cksQty) = balanceChunks chgrs fmt vn b - - -balanceChunks - :: E.Changers - -> (L.Qty -> X.Text) - -> Meta.VisibleNum - -> L.BottomLine - -> (Rb.Chunk, Rb.Chunk) -balanceChunks chgrs fmt vn bl = (chkDc, chkQt) - where - eo = E.fromVisibleNum vn - chkDc = E.bottomLineToDrCr bl eo chgrs - qtFmt = E.getEvenOddLabelValue lbl eo chgrs - chkQt = qtFmt $ Rb.plain t - (lbl, t) = case bl of - L.Zero -> (E.Zero, X.pack "--") - L.NonZero (L.Column dc qt) -> (E.dcToLbl dc, fmt qt) - - -indentAmount :: Int -indentAmount = 2 - diff --git a/Penny/Cabin/Balance/Convert/Options.hs b/Penny/Cabin/Balance/Convert/Options.hs deleted file mode 100644 --- a/Penny/Cabin/Balance/Convert/Options.hs +++ /dev/null @@ -1,43 +0,0 @@ --- | Default options for the Convert report when used from the command --- line. -module Penny.Cabin.Balance.Convert.Options where - -import qualified Penny.Cabin.Balance.Convert.Parser as P -import qualified Penny.Cabin.Parsers as CP -import qualified Penny.Cabin.Options as CO -import qualified Penny.Lincoln as L -import qualified Penny.Shield as S -import qualified Data.Text as X - --- | Default options for the Convert report. This record is used as --- the starting point when parsing in options from the command --- line. You don't need to use it if you are setting the options for --- the Convert report directly from your own code. - -data DefaultOpts = DefaultOpts - { showZeroBalances :: CO.ShowZeroBalances - , target :: P.Target - , sortOrder :: CP.SortOrder - , sortBy :: P.SortBy - , format :: L.Commodity -> L.Qty -> X.Text - } - -toParserOpts :: DefaultOpts -> S.Runtime -> P.Opts -toParserOpts d rt = P.Opts - { P.showZeroBalances = showZeroBalances d - , P.target = target d - , P.dateTime = S.currentTime rt - , P.sortOrder = sortOrder d - , P.sortBy = sortBy d - } - -defaultOptions :: DefaultOpts -defaultOptions = DefaultOpts - { showZeroBalances = CO.ShowZeroBalances False - , target = P.AutoTarget - , sortOrder = CP.Ascending - , sortBy = P.SortByName - , format = \_ q -> X.pack . show $ q - } - - diff --git a/Penny/Cabin/Balance/Convert/Parser.hs b/Penny/Cabin/Balance/Convert/Parser.hs deleted file mode 100644 --- a/Penny/Cabin/Balance/Convert/Parser.hs +++ /dev/null @@ -1,87 +0,0 @@ --- | Parsing options for the Convert report from the command line. -module Penny.Cabin.Balance.Convert.Parser ( - Opts(..) - , Target(..) - , SortBy(..) - , allOptSpecs - ) where - - -import qualified Control.Monad.Exception.Synchronous as Ex -import qualified Data.Text as X -import qualified Penny.Cabin.Options as CO -import qualified Penny.Cabin.Parsers as P -import qualified Penny.Lincoln as L -import qualified Penny.Copper.Parsec as Pc -import qualified System.Console.MultiArg.Combinator as C -import qualified Text.Parsec as Parsec - - --- | Is the target commodity determined by the user or automatically? -data Target = AutoTarget | ManualTarget L.To - -data SortBy = SortByQty | SortByName deriving (Eq, Show, Ord) - --- | Default starting options for the Convert report. After --- considering what is parsed in from the command line and price data, --- a Convert.Opts will be generated. -data Opts = Opts - { showZeroBalances :: CO.ShowZeroBalances - , target :: Target - , dateTime :: L.DateTime - , sortOrder :: P.SortOrder - , sortBy :: SortBy - } - --- | Do not be tempted to change the setup in this module so that the --- individual functions such as parseColor and parseBackground return --- parsers rather than OptSpec. Such an arrangement breaks the correct --- parsing of abbreviated long options. -allOptSpecs :: [C.OptSpec (Opts -> Ex.Exceptional String Opts)] -allOptSpecs = - [ fmap toExc parseZeroBalances - , parseCommodity - , fmap toExc parseAuto - , parseDate - , fmap toExc parseSort - , fmap toExc parseOrder ] - where - toExc f = return . f - -parseZeroBalances :: C.OptSpec (Opts -> Opts) -parseZeroBalances = fmap f P.zeroBalances - where - f x o = o { showZeroBalances = x } - - -parseCommodity :: C.OptSpec (Opts -> Ex.Exceptional String Opts) -parseCommodity = C.OptSpec ["commodity"] "c" (C.OneArg f) - where - f a1 os = - case Parsec.parse Pc.lvl1Cmdty "" (X.pack a1) of - Left _ -> Ex.throw $ "invalid commodity: " ++ a1 - Right g -> return $ os { target = ManualTarget . L.To $ g } - -parseAuto :: C.OptSpec (Opts -> Opts) -parseAuto = C.OptSpec ["auto-commodity"] "" (C.NoArg f) - where - f os = os { target = AutoTarget } - -parseDate :: C.OptSpec (Opts -> Ex.Exceptional String Opts) -parseDate = C.OptSpec ["date"] "d" (C.OneArg f) - where - f a1 os = - case Parsec.parse Pc.dateTime "" (X.pack a1) of - Left _ -> Ex.throw $ "invalid date: " ++ a1 - Right g -> return $ os { dateTime = g } - -parseSort :: C.OptSpec (Opts -> Opts) -parseSort = C.OptSpec ["sort"] "s" (C.ChoiceArg ls) - where - ls = [ ("qty", (\os -> os { sortBy = SortByQty })) - , ("name", (\os -> os { sortBy = SortByName })) ] - -parseOrder :: C.OptSpec (Opts -> Opts) -parseOrder = fmap f P.order - where - f x o = o { sortOrder = x } diff --git a/Penny/Cabin/Balance/MultiCommodity.hs b/Penny/Cabin/Balance/MultiCommodity.hs deleted file mode 100644 --- a/Penny/Cabin/Balance/MultiCommodity.hs +++ /dev/null @@ -1,177 +0,0 @@ --- | The multi-commodity Balance report. This is the simpler balance --- report because it does not allow for commodities to be converted. - -module Penny.Cabin.Balance.MultiCommodity ( - Opts(..), - defaultOpts, - defaultParseOpts, - defaultFormat, - parseReport, - defaultReport, - report - ) where - -import Control.Applicative (Applicative, pure) -import qualified Penny.Cabin.Balance.Util as U -import qualified Penny.Cabin.Scheme as E -import qualified Penny.Cabin.Scheme.Schemes as Schemes -import qualified Penny.Lincoln as L -import qualified Penny.Liberty as Ly -import qualified Data.Either as Ei -import qualified Data.Map as M -import qualified Penny.Cabin.Options as CO -import Data.Monoid (mappend, mempty) -import qualified Data.Text as X -import qualified Data.Tree as E -import qualified Penny.Cabin.Balance.MultiCommodity.Chunker as K -import qualified Penny.Cabin.Balance.MultiCommodity.Parser as P -import qualified Penny.Cabin.Interface as I -import qualified Penny.Cabin.Parsers as CP -import qualified System.Console.MultiArg as MA -import qualified System.Console.Rainbow as R - --- | Options for making the balance report. These are the only options --- needed to make the report if the options are not being parsed in --- from the command line. -data Opts = Opts - { balanceFormat :: L.Commodity -> L.Qty -> X.Text - , showZeroBalances :: CO.ShowZeroBalances - , order :: L.SubAccount -> L.SubAccount -> Ordering - , textFormats :: E.Changers - } - -defaultOpts :: Opts -defaultOpts = Opts - { balanceFormat = defaultFormat - , showZeroBalances = CO.ShowZeroBalances True - , order = compare - , textFormats = Schemes.darkLabels - } - -defaultParseOpts :: P.ParseOpts -defaultParseOpts = P.ParseOpts - { P.showZeroBalances = CO.ShowZeroBalances False - , P.order = CP.Ascending - } - -fromParseOpts - :: E.Changers - -> (L.Commodity -> L.Qty -> X.Text) - -> P.ParseOpts - -> Opts -fromParseOpts chgrs fmt (P.ParseOpts szb o) = Opts fmt szb o' chgrs - where - o' = case o of - CP.Ascending -> compare - CP.Descending -> CO.descending compare - -defaultFormat :: a -> L.Qty -> X.Text -defaultFormat _ = X.pack . show - -summedSortedBalTree :: - CO.ShowZeroBalances - -> (L.SubAccount -> L.SubAccount -> Ordering) - -> [L.Box a] - -> (E.Forest (L.SubAccount, L.Balance), L.Balance) -summedSortedBalTree szb o = - U.sumForest mempty mappend - . U.sortForest o' - . U.balances szb - where - o' x y = o (fst x) (fst y) - -rows :: - (E.Forest (L.SubAccount, L.Balance), L.Balance) - -> [K.Row] -rows (o, b) = first:rest - where - first = K.Row 0 (X.pack "Total") (M.assocs . L.unBalance $ b) - rest = map row . concatMap E.flatten . map U.labelLevels $ o - row (l, (s, ib)) = - K.Row l (L.text s) (M.assocs . L.unBalance $ ib) - --- | This report is what to use if you already have your options (that --- is, you are not parsing them in from the command line.) -report :: Opts -> [L.Box a] -> [R.Chunk] -report (Opts bf szb o chgrs) = - K.rowsToChunks chgrs bf - . rows - . summedSortedBalTree szb o - --- | The MultiCommodity report with configurable options that have --- been parsed from the command line. -parseReport :: - (L.Commodity -> L.Qty -> X.Text) - -- ^ How to format balances. For instance you can use this to - -- perform commodity-sensitive digit grouping. - - -> P.ParseOpts - -- ^ Default options for the report. These can be overriden on the - -- command line. - - -> I.Report -parseReport fmt o rt = (help o, makeMode) - where - makeMode _ _ chgrs _ fsf = MA.Mode - { MA.mName = "balance" - , MA.mIntersperse = MA.Intersperse - , MA.mOpts = map (fmap Right) P.allSpecs - , MA.mPosArgs = Left - , MA.mProcess = process chgrs fmt o rt fsf - , MA.mHelp = const (help o) - } - -process - :: Applicative f - => E.Changers - -> (L.Commodity -> L.Qty -> X.Text) - -> P.ParseOpts - -> a - -> ([L.Transaction] -> [L.Box Ly.LibertyMeta]) - -> [Either String (P.ParseOpts -> P.ParseOpts)] - -> f I.ArgsAndReport -process chgrs fmt o _ fsf ls = - let (posArgs, fns) = Ei.partitionEithers ls - mkParsedOpts = foldl (flip (.)) id fns - os' = mkParsedOpts o - mcOpts = fromParseOpts chgrs fmt os' - pr txns _ = return $ report mcOpts (fsf txns) - in pure (posArgs, pr) - - --- | The MultiCommodity report, with default options. -defaultReport :: I.Report -defaultReport = parseReport defaultFormat defaultParseOpts - ------------------------------------------------------------- --- ## Help ------------------------------------------------------------- -ifDefault :: Bool -> String -ifDefault b = if b then " (default)" else "" - -help :: P.ParseOpts -> String -help o = unlines - [ "balance" - , " Show account balances. Accepts ONLY the following options:" - , "" - , "--show-zero-balances" - , " Show balances that are zero" - ++ ifDefault (CO.unShowZeroBalances . P.showZeroBalances $ o) - , "--hide-zero-balances" - , " Hide balances that are zero" - ++ ifDefault ( not . CO.unShowZeroBalances - . P.showZeroBalances $ o) - , "" - , "--ascending" - , " Sort in ascending order by account name" - ++ ifDefault (P.order o == CP.Ascending) - - , "--descending" - , " Sort in descending order by account name" - ++ ifDefault (P.order o == CP.Descending) - - , "" - , "--help, -h" - , " Show this help and exit" - ] - diff --git a/Penny/Cabin/Balance/MultiCommodity/Chunker.hs b/Penny/Cabin/Balance/MultiCommodity/Chunker.hs deleted file mode 100644 --- a/Penny/Cabin/Balance/MultiCommodity/Chunker.hs +++ /dev/null @@ -1,222 +0,0 @@ --- | Creates the output Chunks for the Balance report for both --- multi-commodity reports. - -module Penny.Cabin.Balance.MultiCommodity.Chunker ( - Row(..), - rowsToChunks - ) where - - -import Control.Applicative - (Applicative (pure), (<$>), (<*>)) -import qualified Penny.Cabin.Meta as Meta -import qualified Penny.Cabin.Row as R -import qualified Penny.Cabin.Scheme as E -import qualified Penny.Lincoln as L -import qualified Data.Foldable as Fdbl -import qualified Data.Text as X -import qualified System.Console.Rainbow as Rb - -type IsEven = Bool - -data Columns a = Columns { - acct :: a - , drCr :: a - , commodity :: a - , quantity :: a - } deriving Show - -instance Functor Columns where - fmap f c = Columns { - acct = f (acct c) - , drCr = f (drCr c) - , commodity = f (commodity c) - , quantity = f (quantity c) - } - -instance Applicative Columns where - pure a = Columns a a a a - fn <*> fa = Columns { - acct = (acct fn) (acct fa) - , drCr = (drCr fn) (drCr fa) - , commodity = (commodity fn) (commodity fa) - , quantity = (quantity fn) (quantity fa) - } - -data PreSpec = PreSpec { - _justification :: R.Justification - , _padSpec :: (E.Label, E.EvenOdd) - , bits :: [Rb.Chunk] } - --- | When given a list of columns, determine the widest row in each --- column. -maxWidths :: [Columns PreSpec] -> Columns R.Width -maxWidths = Fdbl.foldl' maxWidthPerColumn (pure (R.Width 0)) - --- | Applied to a Columns of PreSpec and a Colums of widths, return a --- Columns that has the wider of the two values. -maxWidthPerColumn :: - Columns R.Width - -> Columns PreSpec - -> Columns R.Width -maxWidthPerColumn w p = f <$> w <*> p where - f old new = max old ( safeMaximum (R.Width 0) - . map (R.Width . X.length . Rb.chunkText) - . bits $ new) - safeMaximum d ls = if null ls then d else maximum ls - --- | Changes a single set of Columns to a set of ColumnSpec of the --- given width. -preSpecToSpec :: - Columns R.Width - -> Columns PreSpec - -> Columns R.ColumnSpec -preSpecToSpec ws p = f <$> ws <*> p where - f width (PreSpec j ps bs) = R.ColumnSpec j width ps bs - -resizeColumnsInList :: [Columns PreSpec] -> [Columns R.ColumnSpec] -resizeColumnsInList cs = map (preSpecToSpec w) cs where - w = maxWidths cs - - --- Step 9 -widthSpacerAcct :: Int -widthSpacerAcct = 4 - -widthSpacerDrCr :: Int -widthSpacerDrCr = 1 - -widthSpacerCommodity :: Int -widthSpacerCommodity = 1 - -colsToBits - :: E.Changers - -> IsEven - -> Columns R.ColumnSpec - -> [Rb.Chunk] -colsToBits chgrs isEven (Columns a dc c q) = let - fillSpec = if isEven - then (E.Other, E.Even) - else (E.Other, E.Odd) - spacer w = R.ColumnSpec j (R.Width w) fillSpec [] - j = R.LeftJustify - cs = a - : spacer widthSpacerAcct - : dc - : spacer widthSpacerDrCr - : c - : spacer widthSpacerCommodity - : q - : [] - in R.row chgrs cs - -colsListToBits - :: E.Changers - -> [Columns R.ColumnSpec] - -> [[Rb.Chunk]] -colsListToBits chgrs = zipWith f bools where - f b c = colsToBits chgrs b c - bools = iterate not True - -preSpecsToBits - :: E.Changers - -> [Columns PreSpec] - -> [Rb.Chunk] -preSpecsToBits chgrs = - concat - . colsListToBits chgrs - . resizeColumnsInList - --- | Displays a single account in a Balance report. In a --- single-commodity report, this account will only be one screen line --- long. In a multi-commodity report, it might be multiple lines long, --- with one screen line for each commodity. -data Row = Row - { indentation :: Int - -- ^ Indent the account name by this many levels (not by this many - -- spaces; this number is multiplied by another number in the - -- Chunker source to arrive at the final indentation amount) - - , accountTxt :: X.Text - -- ^ Text for the name of the account - - , balances :: [(L.Commodity, L.BottomLine)] - -- ^ Commodity balances. If this list is empty, dashes are - -- displayed for the DrCr, Commodity, and Qty. - } - -rowsToChunks - :: E.Changers - -> (L.Commodity -> L.Qty -> X.Text) - -- ^ How to format a balance to allow for digit grouping - -> [Row] - -> [Rb.Chunk] -rowsToChunks chgrs fmt = - preSpecsToBits chgrs - . rowsToColumns chgrs fmt - -rowsToColumns - :: E.Changers - -> (L.Commodity -> L.Qty -> X.Text) - -- ^ How to format a balance to allow for digit grouping - - -> [Row] - -> [Columns PreSpec] -rowsToColumns chgrs fmt rs = map (mkColumn chgrs fmt) pairs - where - pairs = Meta.visibleNums (,) rs - - -mkColumn - :: E.Changers - -> (L.Commodity -> L.Qty -> X.Text) - -> (Meta.VisibleNum, Row) - -> Columns PreSpec -mkColumn chgrs fmt (vn, (Row i acctTxt bs)) = Columns ca cd cc cq - where - lbl = E.Other - eo = E.fromVisibleNum vn - applyFmt = E.getEvenOddLabelValue lbl eo chgrs - ca = PreSpec R.LeftJustify (lbl, eo) [applyFmt $ Rb.plain txt] - where - txt = X.append indents acctTxt - indents = X.replicate (indentAmount * max 0 i) - (X.singleton ' ') - cd = PreSpec R.LeftJustify (lbl, eo) cksDrCr - cc = PreSpec R.RightJustify (lbl, eo) cksCmdty - cq = PreSpec R.LeftJustify (lbl, eo) cksQty - (cksDrCr, cksCmdty, cksQty) = - if null bs - then balanceChunksEmpty chgrs eo - else - let balChks = map (balanceChunks chgrs fmt eo) bs - cDrCr = map (\(a, _, _) -> a) balChks - cCmdty = map (\(_, a, _) -> a) balChks - cQty = map (\(_, _, a) -> a) balChks - in (cDrCr, cCmdty, cQty) - - -balanceChunksEmpty - :: E.Changers - -> E.EvenOdd - -> ([Rb.Chunk], [Rb.Chunk], [Rb.Chunk]) -balanceChunksEmpty chgrs eo = (dash, dash, dash) - where - dash = [E.getEvenOddLabelValue E.Other eo chgrs $ Rb.plain (X.pack "--")] - -balanceChunks - :: E.Changers - -> (L.Commodity -> L.Qty -> X.Text) - -> E.EvenOdd - -> (L.Commodity, L.BottomLine) - -> (Rb.Chunk, Rb.Chunk, Rb.Chunk) -balanceChunks chgrs fmt eo (cty, bl) = (chkDc, chkCt, chkQt) - where - chkDc = E.bottomLineToDrCr bl eo chgrs - chkCt = E.bottomLineToCmdty chgrs eo (cty, bl) - chkQt = E.bottomLineToQty chgrs fmt eo (cty, bl) - - -indentAmount :: Int -indentAmount = 2 - diff --git a/Penny/Cabin/Balance/MultiCommodity/Parser.hs b/Penny/Cabin/Balance/MultiCommodity/Parser.hs deleted file mode 100644 --- a/Penny/Cabin/Balance/MultiCommodity/Parser.hs +++ /dev/null @@ -1,29 +0,0 @@ -module Penny.Cabin.Balance.MultiCommodity.Parser ( - ParseOpts(..) - , allSpecs - ) where - -import qualified Penny.Cabin.Options as CO -import qualified Penny.Cabin.Parsers as P -import qualified System.Console.MultiArg as MA - --- | Options for the Balance report that have been parsed from the --- command line. -data ParseOpts = ParseOpts - { showZeroBalances :: CO.ShowZeroBalances - , order :: P.SortOrder - } - - -zeroBalances :: MA.OptSpec (ParseOpts -> ParseOpts) -zeroBalances = fmap toResult P.zeroBalances - where - toResult szb o = o { showZeroBalances = szb } - -parseOrder :: MA.OptSpec (ParseOpts -> ParseOpts) -parseOrder = fmap toResult P.order - where - toResult x o = o { order = x } - -allSpecs :: [MA.OptSpec (ParseOpts -> ParseOpts)] -allSpecs = [zeroBalances, parseOrder] diff --git a/Penny/Cabin/Balance/Util.hs b/Penny/Cabin/Balance/Util.hs deleted file mode 100644 --- a/Penny/Cabin/Balance/Util.hs +++ /dev/null @@ -1,228 +0,0 @@ --- | Grab bag of utility functions. - -module Penny.Cabin.Balance.Util - ( tieredForest - , tieredPostings - , filterForest - , balances - , flatten - , treeWithParents - , forestWithParents - , sumForest - , sumTree - , boxesBalance - , labelLevels - , sortForest - , sortTree - , lastMode - ) where - -import qualified Penny.Cabin.Options as CO -import qualified Penny.Lincoln as L -import qualified Penny.Steel.NestedMap as NM -import qualified Data.Foldable as Fdbl -import qualified Data.Map as M -import Data.Ord (comparing) -import Data.List (sortBy, maximumBy, groupBy) -import Data.Monoid (mconcat, Monoid) -import Data.Maybe (mapMaybe) -import qualified Data.Tree as T -import qualified Penny.Lincoln.Queries as Q - --- | Constructs a forest sorted into tiers based on lists of keys that --- are extracted from the elements. -tieredForest :: - Ord k - => (a -> [k]) - -- ^ Extracts a key from the elements we are putting in the tree. If - -- this function returns an empty list for any element, the element - -- will not appear in the tiered forest. - -> [a] - -> T.Forest (k, [a]) -tieredForest getKeys ls = fmap (fmap revSnd) . NM.toForest $ nm - where - revSnd (a, xs) = (a, reverse xs) - nm = foldr f NM.empty ls - f a m = NM.relabel m ps - where - ps = case getKeys a of - [] -> [] - ks -> - let mkInitPair k = (k, maybe [] id) - mkLastPair k = (k, maybe [a] (a:)) - in (map mkInitPair . init $ ks) - ++ [(mkLastPair (last ks))] - --- | Takes a list of postings and puts them into a Forest. Each level --- of each of the trees corresponds to a sub account. The label of the --- node tells you the sub account name and gives you a list of the --- postings at that level. -tieredPostings :: [L.Box a] -> T.Forest (L.SubAccount, [L.Box a]) -tieredPostings = tieredForest e - where - e = Fdbl.toList . L.unAccount . Q.account . L.boxPostFam - --- | Keeps only Trees that match a given condition. First examines --- child trees to determine whether they should be retained. If a --- child tree is retained, does not delete the parent tree. -filterForest :: (a -> Bool) -> T.Forest a -> T.Forest a -filterForest f = mapMaybe pruneTree - where - pruneTree (T.Node a fs) = - case filterForest f fs of - [] -> if not (f a) then Nothing else Just (T.Node a []) - cs -> Just (T.Node a cs) - - --- | Puts all Boxes into a Tree and sums the balances. Removes --- accounts that have empty balances if requested. Does NOT sum --- balances from the bottom up. -balances :: - CO.ShowZeroBalances - -> [L.Box a] - -> T.Forest (L.SubAccount, L.Balance) -balances (CO.ShowZeroBalances szb) = - remover - . map (fmap (mapSnd boxesBalance)) - . tieredPostings - where - remover = - if szb - then id - else filterForest (not . M.null . L.unBalance . snd) - . map (fmap (mapSnd L.removeZeroCommodities)) - - --- | Takes a tree of Balances (like what is produced by the 'balances' --- function) and produces a flat list of accounts with the balance of --- each account. -flatten - :: T.Forest (L.SubAccount, L.Balance) - -> [(L.Account, L.Balance)] -flatten = - concatMap T.flatten - . map (fmap toPair) . forestWithParents - where - toPair ((s, b), ls) = - case reverse . map fst $ ls of - [] -> (L.Account [s], b) - s1:sr -> (L.Account (s1 : (sr ++ [s])), b) - --- | Takes a Tree and returns a Tree where each node has information --- about its parent Nodes. The list of parent nodes has the most --- immediate parent first and the most distant parent last. -treeWithParents :: T.Tree a -> T.Tree (a, [a]) -treeWithParents = treeWithParentsR [] - --- | Given a list of the parents seen so far, return a Tree where each --- node contains information about its parents. -treeWithParentsR :: [a] -> T.Tree a -> T.Tree (a, [a]) -treeWithParentsR ls (T.Node n cs) = T.Node (n, ls) cs' - where - cs' = map (treeWithParentsR (n:ls)) cs - --- | Takes a Forest and returns a Forest where each node has --- information about its parent Nodes. -forestWithParents :: T.Forest a -> T.Forest (a, [a]) -forestWithParents = map (treeWithParentsR []) - --- | Sums a forest from the bottom up. Returns a pair, where the first --- element is the forest, but with the second element of each node --- replaced with the sum of that node and all its children. The second --- element is the sum of all the second elements in the forest. -sumForest :: - s - -- ^ Zero - - -> (s -> s -> s) - -- ^ Combiner - - -> T.Forest (a, s) - -> (T.Forest (a, s), s) -sumForest z f ts = (ts', s) - where - ts' = map (sumTree z f) ts - s = foldr f z . map (snd . T.rootLabel) $ ts' - --- | Sums a tree from the bottom up. -sumTree :: - s - -- ^ Zero - - -> (s -> s -> s) - -- ^ Combiner - - -> T.Tree (a, s) - -> T.Tree (a, s) -sumTree z f (T.Node (a, s) cs) = T.Node (a, f s cSum) cs' - where - (cs', cSum) = sumForest z f cs - - -boxesBalance :: [L.Box a] -> L.Balance -boxesBalance = mconcat . map L.entryToBalance . map Q.entry - . map L.boxPostFam - -mapSnd :: (a -> b) -> (f, a) -> (f, b) -mapSnd f (x, a) = (x, f a) - --- | Label each level of a Tree with an integer indicating how deep it --- is. The top node of the tree is level 0. -labelLevels :: T.Tree a -> T.Tree (Int, a) -labelLevels = go 0 - where - go l (T.Node x xs) = T.Node (l, x) (map (go (l + 1)) xs) - --- | Sorts each level of a Forest. -sortForest :: - (a -> a -> Ordering) - -> T.Forest a - -> T.Forest a -sortForest o f = sortBy o' (map (sortTree o) f) - where - o' x y = o (T.rootLabel x) (T.rootLabel y) - --- | Sorts each level of a Tree. -sortTree :: - (a -> a -> Ordering) - -> T.Tree a - -> T.Tree a -sortTree o (T.Node l f) = T.Node l (sortForest o f) - --- | Like lastModeBy but using Ord. -lastMode :: Ord a => [a] -> Maybe a -lastMode = lastModeBy compare - --- | Finds the mode of a list. Takes the mode that is located last in --- the list. Returns Nothing if there is no mode (that is, if the list --- is empty). -lastModeBy :: - (a -> a -> Ordering) - -> [a] - -> Maybe a -lastModeBy o ls = - case modesBy o' ls' of - [] -> Nothing - ms -> Just . fst . maximumBy fx $ ms - where - fx = comparing snd - ls' = zip ls ([0..] :: [Int]) - o' x y = o (fst x) (fst y) - --- | Finds the modes of a list. -modesBy :: (a -> a -> Ordering) -> [a] -> [a] -modesBy o = - concat - . longestLists - . groupBy (\x y -> o x y == EQ) - . sortBy o - - --- | Returns the longest lists. This function is partial. It is bottom --- if the argument list is empty. Therefore, do not export this --- function. -longestLists :: [[a]] -> [[a]] -longestLists as = - let lengths = map (\ls -> (ls, length ls)) as - maxLen = maximum . map snd $ lengths - in map fst . filter (\(_, len) -> len == maxLen) $ lengths diff --git a/Penny/Cabin/Interface.hs b/Penny/Cabin/Interface.hs deleted file mode 100644 --- a/Penny/Cabin/Interface.hs +++ /dev/null @@ -1,77 +0,0 @@ --- | An interface for other Penny components to use. A report is --- anything that is a 'Report'. -module Penny.Cabin.Interface where - -import qualified Data.Prednote.Expressions as Exp -import qualified Penny.Cabin.Scheme as S -import Control.Monad.Exception.Synchronous (Exceptional) -import qualified Data.Text as X -import Text.Matchers (CaseSensitive) -import qualified Text.Matchers as TM -import qualified System.Console.MultiArg as MA -import qualified System.Console.Rainbow as R - -import qualified Penny.Lincoln as L -import qualified Penny.Liberty as Ly -import Penny.Shield (Runtime) - --- | The function that will print the report, and the positional --- arguments. If there was a problem parsing the command line options, --- return an Exception with an error message. - --- | Parsing the filter options can have one of two results: a help --- string, or a list of positional arguments and a function that --- prints a report. Or, the parse might fail. - -type PosArg = String -type HelpStr = String -type ArgsAndReport = ([PosArg], PrintReport) - --- | The result of parsing the arguments to a report. Failures are --- indicated with a Text. The name of the executable and the word --- @error@ will be prepended to this Text; otherwise, it is printed --- as-is, so be sure to include any trailing newline if needed. -type ParseResult = Exceptional X.Text ArgsAndReport - -type PrintReport - = [L.Transaction] - -- ^ All transactions; the report must sort and filter them - - -> [L.PricePoint] - -- ^ PricePoints to be included in the report - - - -> Exceptional X.Text [R.Chunk] - -- ^ The exception type is a strict Text, containing the error --- message. The success type is a list of either a Chunk or a PreChunk --- containing the resulting report. This allows for errors after the --- list of transactions has been seen. The name of the executable and --- the word @error@ will be prepended to this Text; otherwise, it is --- printed as-is, so be sure to include any trailing newline if --- needed. - - -type Report = Runtime -> (HelpStr, MkReport) -type MkReport - = CaseSensitive - -- ^ Result from previous parses indicating whether the user desires - -- case sensitivity (this may have been changed in the filtering - -- options) - - -> (CaseSensitive -> X.Text -> Exceptional X.Text TM.Matcher) - -- ^ Result from previous parsers indicating the matcher factory the - -- user wishes to use - - -> S.Changers - -- ^ Result from previous parsers indicating which color scheme to - -- use. - - -> Exp.ExprDesc - -- ^ Result from previous parsers indicating whether the user wants - -- RPN or infix - - -> ([L.Transaction] -> [L.Box Ly.LibertyMeta]) - -- ^ Result from previous parsers that will sort and filter incoming - -- transactions - - -> MA.Mode ParseResult diff --git a/Penny/Cabin/Meta.hs b/Penny/Cabin/Meta.hs deleted file mode 100644 --- a/Penny/Cabin/Meta.hs +++ /dev/null @@ -1,38 +0,0 @@ --- | Metadata that is specific to Cabin. -module Penny.Cabin.Meta (VisibleNum, unVisibleNum, - visibleNumBoxes, visibleNums ) where - -import Control.Applicative ((*>)) -import qualified Data.Traversable as Tr -import qualified Penny.Lincoln as L - --- | Each row that is visible on screen is assigned a VisibleNum. This --- is used to number the rows in the report for the user's benefit. It --- is also used to determine whether the row is even or odd for the --- purpose of assigning the background color (this way the background --- colors can alternate, like a checkbook register.) -newtype VisibleNum = VisibleNum { unVisibleNum :: L.Serial } - deriving (Eq, Show) - --- | Assigns VisibleNum to a list of boxes. -visibleNumBoxes :: - (VisibleNum -> a -> b) - -> [L.Box a] - -> [L.Box b] -visibleNumBoxes f bs = L.makeSerials k - where - k = Tr.sequenceA (replicate (length bs) L.incrementBack) - *> mapM assign bs - assign (L.Box m pf) = fmap g L.getSerial - where - g ser = L.Box (f (VisibleNum ser) m) pf - - --- | Assigns VisibleNum to a list. -visibleNums :: (VisibleNum -> a -> b) -> [a] -> [b] -visibleNums f as = L.makeSerials k - where - k = Tr.sequenceA (replicate (length as) L.incrementBack) - *> mapM assign as - assign a = fmap (\ser -> f (VisibleNum ser) a) L.getSerial - diff --git a/Penny/Cabin/Options.hs b/Penny/Cabin/Options.hs deleted file mode 100644 --- a/Penny/Cabin/Options.hs +++ /dev/null @@ -1,16 +0,0 @@ --- | Options applicable to multiple Cabin reports. - -module Penny.Cabin.Options where - --- | Whether to show zero balances in reports. -newtype ShowZeroBalances = - ShowZeroBalances { unShowZeroBalances :: Bool } - deriving (Show, Eq) - --- | Converts an ordering to a descending order. -descending :: (a -> a -> Ordering) - -> a -> a -> Ordering -descending f x y = case f x y of - LT -> GT - GT -> LT - EQ -> EQ diff --git a/Penny/Cabin/Parsers.hs b/Penny/Cabin/Parsers.hs deleted file mode 100644 --- a/Penny/Cabin/Parsers.hs +++ /dev/null @@ -1,24 +0,0 @@ --- | Command line parsers that are common to various Cabin reports. - -module Penny.Cabin.Parsers where - -import qualified Penny.Cabin.Options as CO -import qualified System.Console.MultiArg.Combinator as C - - -zeroBalances :: C.OptSpec CO.ShowZeroBalances -zeroBalances = C.OptSpec ["zero-balances"] "" (C.ChoiceArg ls) - where - ls = [ ("show", CO.ShowZeroBalances True) - , ("hide", CO.ShowZeroBalances False) ] - -data SortOrder = Ascending | Descending deriving (Eq, Ord, Show) - -order :: C.OptSpec SortOrder -order = C.OptSpec ["order"] "" (C.ChoiceArg ls) - where - ls = [ ("ascending", Ascending) - , ("descending", Descending) ] - -help :: C.OptSpec () -help = C.OptSpec ["help"] "h" (C.NoArg ()) diff --git a/Penny/Cabin/Posts.hs b/Penny/Cabin/Posts.hs deleted file mode 100644 --- a/Penny/Cabin/Posts.hs +++ /dev/null @@ -1,622 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | The Penny Postings report --- --- The Postings report displays postings in a tabular format designed --- to be read by humans. Some terminology used in the Postings report: --- --- [@row@] The smallest unit that spans from left to right. A row, --- however, might consist of more than one screen line. For example, --- the running balance is shown on the far right side of the Postings --- report. The running balance might consist of more than one --- commodity. Each commodity is displayed on its own screen --- line. However, all these lines put together are displayed in a --- single row. --- --- [@column@] The smallest unit that spans from top to bottom. --- --- [@tranche@] Each posting is displayed in several rows. The group of --- rows that is displayed for a single posting is called a tranche. --- --- [@tranche row@] Each tranche has a particular number of rows --- (currently four); each of these rows is known as a tranche row. --- --- [@field@] Corresponds to a particular element of the posting, such --- as whether it is a debit or credit or its payee. The user can --- select which fields to see. --- --- [@allocation@] The width of the Payee and Account fields is --- variable. Generally their width will adjust to fill the entire --- width of the screen. The allocations of the Payee and Account --- fields determine how much of the remaining space each field will --- receive. --- --- The Postings report is easily customized from the command line to --- show various fields. However, the order of the fields is not --- configurable without editing the source code (sorry). - -module Penny.Cabin.Posts - ( postsReport - , zincReport - , defaultOptions - , ZincOpts(..) - , A.Alloc - , A.SubAccountLength(..) - , A.alloc - , yearMonthDay - , qtyAsIs - , balanceAsIs - , defaultWidth - , columnsVarToWidth - , widthFromRuntime - , defaultFields - , defaultSpacerWidth - , T.ReportWidth(..) - ) where - -import Control.Applicative ((<$>), (<*>)) -import qualified Control.Monad.Exception.Synchronous as Ex -import Data.List.Split (chunksOf) -import qualified Data.Either as Ei -import Data.Monoid ((<>)) -import qualified Data.Text as X -import qualified Penny.Cabin.Interface as I -import qualified Penny.Cabin.Options as CO -import qualified Penny.Cabin.Posts.Allocated as A -import qualified Penny.Cabin.Posts.Chunk as C -import qualified Penny.Cabin.Posts.Fields as F -import qualified Penny.Cabin.Posts.Meta as M -import Penny.Cabin.Posts.Meta (Box) -import qualified Penny.Cabin.Posts.Parser as P -import qualified Penny.Cabin.Posts.Spacers as S -import qualified Penny.Cabin.Posts.Types as T -import qualified Penny.Cabin.Scheme as E - -import qualified Penny.Lincoln as L -import qualified Penny.Lincoln.Queries as Q -import qualified Penny.Liberty as Ly -import qualified Penny.Shield as Sh -import qualified Data.Prednote.Expressions as Exp -import qualified Data.Prednote.Pdct as Pe -import qualified System.Console.Rainbow as Rb - -import Data.List (intersperse) -import Data.Maybe (catMaybes) -import qualified Data.Foldable as Fdbl -import Data.Time as Time -import qualified System.Console.MultiArg as MA -import System.Locale (defaultTimeLocale) -import Text.Matchers (CaseSensitive) - --- | All information needed to make a Posts report. This function --- never fails. -postsReport - :: E.Changers - -> CO.ShowZeroBalances - -> (Pe.Pdct (L.Box Ly.LibertyMeta)) - -- ^ Removes posts from the report if applying this function to the - -- post returns False. Posts removed still affect the running - -- balance. - - -> [Ly.PostFilterFn] - -- ^ Applies these post-filters to the list of posts that results - -- from applying the predicate above. Might remove more - -- postings. Postings removed still affect the running balance. - - -> C.ChunkOpts - -> [L.Box Ly.LibertyMeta] - -> [Rb.Chunk] - -postsReport ch szb pdct pff co = - C.makeChunk ch co - . M.toBoxList szb pdct pff - - -zincReport :: ZincOpts -> I.Report -zincReport opts rt = (helpStr opts, md) - where - md cs fty ch expr fsf = MA.Mode - { MA.mName = "postings" - , MA.mIntersperse = MA.Intersperse - , MA.mOpts = specs rt - , MA.mPosArgs = Left - , MA.mProcess = process opts cs fty ch expr fsf - , MA.mHelp = const (helpStr opts) - } - -specs - :: Sh.Runtime - -> [MA.OptSpec (Either String (P.State -> Ex.Exceptional X.Text P.State))] -specs = map (fmap Right) . P.allSpecs - - -process - :: ZincOpts - -> CaseSensitive - -> L.Factory - -> E.Changers - -> Exp.ExprDesc - -> ([L.Transaction] -> [L.Box Ly.LibertyMeta]) - -> [Either String (P.State -> Ex.Exceptional X.Text P.State)] - -> Ex.Exceptional X.Text I.ArgsAndReport -process os cs fty ch expr fsf ls = - let (posArgs, clOpts) = Ei.partitionEithers ls - pState = newParseState cs fty expr os - exState' = foldl (>>=) (return pState) clOpts - in fmap (mkPrintReport posArgs os ch fsf) exState' - -mkPrintReport - :: [String] - -> ZincOpts - -> E.Changers - -> ([L.Transaction] -> [L.Box Ly.LibertyMeta]) - -> P.State - -> I.ArgsAndReport -mkPrintReport posArgs zo ch fsf st = (posArgs, f) - where - f txns _ = do - pdct <- getPredicate (P.exprDesc st) (P.tokens st) - let boxes = fsf txns - rptChks = postsReport ch (P.showZeroBalances st) pdct - (P.postFilter st) (chunkOpts st zo) boxes - expChks = showExpression (P.showExpression st) pdct - verbChks = showVerboseFilter (P.verboseFilter st) pdct boxes - chks = expChks - ++ verbChks - ++ rptChks - return chks - -indentAmt :: Pe.IndentAmt -indentAmt = 4 - -blankLine :: Rb.Chunk -blankLine = Rb.plain (X.singleton '\n') - -showExpression - :: P.ShowExpression - -> Pe.Pdct (L.Box Ly.LibertyMeta) - -> [Rb.Chunk] -showExpression (P.ShowExpression b) pdct = - if not b then [] else info : blankLine : (chks ++ [blankLine]) - where - info = Rb.plain (X.pack "Postings filter expression:\n") - chks = Pe.showPdct indentAmt 0 pdct - -showVerboseFilter - :: P.VerboseFilter - -> Pe.Pdct (L.Box Ly.LibertyMeta) - -> [L.Box Ly.LibertyMeta] - -> [Rb.Chunk] -showVerboseFilter (P.VerboseFilter b) pdct bs = - if not b then [] else info : blankLine : (chks ++ [blankLine]) - where - pdcts = map (makeLabeledPdct pdct) bs - chks = concat . map snd $ zipWith doEval bs pdcts - doEval subj pd = Pe.evaluate indentAmt False subj 0 pd - info = Rb.plain (X.pack "Postings report filter:\n") - --- | Creates a Pdct and prepends a one-line description of the PostFam --- to the Pdct's label so it can be easily identified in the output. -makeLabeledPdct - :: Pe.Pdct (L.Box Ly.LibertyMeta) - -> L.Box Ly.LibertyMeta - -> Pe.Pdct (L.Box Ly.LibertyMeta) -makeLabeledPdct pd box = Pe.rename f pd - where - f old = old <> " - " <> L.display pf - pf = L.boxPostFam box - -defaultOptions - :: Sh.Runtime - -> ZincOpts -defaultOptions rt = ZincOpts - { fields = defaultFields - , width = widthFromRuntime rt - , showZeroBalances = CO.ShowZeroBalances False - , dateFormat = yearMonthDay - , qtyFormat = qtyAsIs - , balanceFormat = balanceAsIs - , subAccountLength = A.SubAccountLength 2 - , payeeAllocation = A.alloc 60 - , accountAllocation = A.alloc 40 - , spacers = defaultSpacerWidth - } - - -type Error = X.Text - -getPredicate - :: Exp.ExprDesc - -> [Exp.Token (L.Box Ly.LibertyMeta)] - -> Ex.Exceptional Error (Pe.Pdct (L.Box Ly.LibertyMeta)) -getPredicate d ts = - case ts of - [] -> return $ Pe.always - _ -> Exp.parseExpression d ts - - --- | All the information to configure the postings report if the --- options will be parsed in from the command line. -data ZincOpts = ZincOpts - { fields :: F.Fields Bool - -- ^ Default fields to show in the report. - - , width :: T.ReportWidth - -- ^ Gives the default report width. This can be - -- overridden on the command line. You can use the - -- information from the Runtime to make this as wide as - -- the current terminal. - - , showZeroBalances :: CO.ShowZeroBalances - -- ^ Are commodities that have no balance shown in the Total fields - -- of the report? - - , dateFormat :: Box -> X.Text - -- ^ How to display dates. This function is applied to the - -- a PostingInfo so it has lots of information, but it - -- should return a date for use in the Date field. - - , qtyFormat :: Box -> X.Text - -- ^ How to display the quantity of the posting. This - -- function is applied to a Box so it has lots of - -- information, but it should return a formatted string of - -- the quantity. Allows you to format digit grouping, - -- radix points, perform rounding, etc. - - , balanceFormat :: L.Commodity -> L.Qty -> X.Text - -- ^ How to display balance totals. Similar to - -- balanceFormat. - - , subAccountLength :: A.SubAccountLength - -- ^ When shortening the names of sub accounts to make - -- them fit, they will be this long. - - , payeeAllocation :: A.Alloc - -- ^ This and accountAllocation determine how much space - -- payees and accounts receive. They divide up the - -- remaining space after everything else is displayed. For - -- instance if payeeAllocation is 60 and accountAllocation - -- is 40, the payee takes about 60 percent of the - -- remaining space and the account takes about 40 percent. - - , accountAllocation :: A.Alloc - -- ^ See payeeAllocation above - - , spacers :: S.Spacers Int - -- ^ Default width for spacer fields. If any of these Ints are - -- less than or equal to zero, there will be no spacer. There is - -- never a spacer for fields that do not appear in the report. - - } - -chunkOpts :: - P.State - -> ZincOpts - -> C.ChunkOpts -chunkOpts s z = C.ChunkOpts - { C.dateFormat = dateFormat z - , C.qtyFormat = qtyFormat z - , C.balanceFormat = balanceFormat z - , C.fields = P.fields s - , C.subAccountLength = subAccountLength z - , C.payeeAllocation = payeeAllocation z - , C.accountAllocation = accountAllocation z - , C.spacers = spacers z - , C.reportWidth = P.width s - } - - -newParseState :: - CaseSensitive - -> L.Factory - -> Exp.ExprDesc - -> ZincOpts - -> P.State -newParseState cs fty expr o = P.State - { P.sensitive = cs - , P.factory = fty - , P.tokens = [] - , P.postFilter = [] - , P.fields = fields o - , P.width = width o - , P.showZeroBalances = showZeroBalances o - , P.exprDesc = expr - , P.verboseFilter = P.VerboseFilter False - , P.showExpression = P.ShowExpression False - } - --- | Shows the date of a posting in YYYY-MM-DD format. -yearMonthDay :: Box -> X.Text -yearMonthDay p = X.pack (Time.formatTime defaultTimeLocale fmt d) - where - d = L.day - . Q.dateTime - . L.boxPostFam - $ p - fmt = "%Y-%m-%d" - --- | Shows the quantity of a posting. Does no rounding or --- prettification; simply uses show on the underlying Decimal. -qtyAsIs :: Box -> X.Text -qtyAsIs p = X.pack . show . Q.qty . L.boxPostFam $ p - --- | Shows the quantity of a balance. If there is no quantity, shows --- two dashes. -balanceAsIs :: a -> L.Qty -> X.Text -balanceAsIs _ = X.pack . show - --- | The default width for the report. -defaultWidth :: T.ReportWidth -defaultWidth = T.ReportWidth 80 - --- | Applied to the value of the COLUMNS environment variable, returns --- an appropriate ReportWidth. -columnsVarToWidth :: Maybe String -> T.ReportWidth -columnsVarToWidth ms = case ms of - Nothing -> defaultWidth - Just str -> case reads str of - [] -> defaultWidth - (i, []):[] -> if i > 0 then T.ReportWidth i else defaultWidth - _ -> defaultWidth - --- | Given the Runtime, use the defaultWidth given above to calculate --- the report's width if COLUMNS does not yield a value. Otherwise, --- use what is in COLUMNS. -widthFromRuntime :: Sh.Runtime -> T.ReportWidth -widthFromRuntime rt = case Sh.screenWidth rt of - Nothing -> defaultWidth - Just w -> T.ReportWidth . Sh.unScreenWidth $ w - --- | Default fields to show in the Postings report. -defaultFields :: F.Fields Bool -defaultFields = - F.Fields { F.globalTransaction = False - , F.revGlobalTransaction = False - , F.globalPosting = False - , F.revGlobalPosting = False - , F.fileTransaction = False - , F.revFileTransaction = False - , F.filePosting = False - , F.revFilePosting = False - , F.filtered = False - , F.revFiltered = False - , F.sorted = False - , F.revSorted = False - , F.visible = False - , F.revVisible = False - , F.lineNum = False - , F.date = True - , F.flag = False - , F.number = False - , F.payee = True - , F.account = True - , F.postingDrCr = True - , F.postingCmdty = True - , F.postingQty = True - , F.totalDrCr = True - , F.totalCmdty = True - , F.totalQty = True - , F.tags = False - , F.memo = False - , F.filename = False } - --- | Default width of spacers; most are one character wide, but the --- spacer after payee is 4 characters wide. -defaultSpacerWidth :: S.Spacers Int -defaultSpacerWidth = - S.Spacers { S.globalTransaction = 1 - , S.revGlobalTransaction = 1 - , S.globalPosting = 1 - , S.revGlobalPosting = 1 - , S.fileTransaction = 1 - , S.revFileTransaction = 1 - , S.filePosting = 1 - , S.revFilePosting = 1 - , S.filtered = 1 - , S.revFiltered = 1 - , S.sorted = 1 - , S.revSorted = 1 - , S.visible = 1 - , S.revVisible = 1 - , S.lineNum = 1 - , S.date = 1 - , S.flag = 1 - , S.number = 1 - , S.payee = 4 - , S.account = 1 - , S.postingDrCr = 1 - , S.postingCmdty = 1 - , S.postingQty = 1 - , S.totalDrCr = 1 - , S.totalCmdty = 1 } - ------------------------------------------------------------- --- ## Help ------------------------------------------------------------- - -ifDefault :: Bool -> String -ifDefault b = if b then " (default)" else "" - -helpStr :: ZincOpts -> String -helpStr o = unlines $ - [ "postings" - , " Show postings in order with a running balance." - , " Accepts the following options:" - , "" - , "Posting filters" - , "===============" - , "These options affect which postings are shown in the report." - , "Postings not shown still affect the running balance." - , "" - , "Dates" - , "-----" - , "" - , "--date cmp timespec, -d cmp timespec" - , " Date must be within the time frame given. timespec" - , " is a day or a day and a time. Valid values for cmp:" - , " <, >, <=, >=, ==, /=, !=" - , "--current" - , " Same as \"--date <= (right now) \"" - , "" - , "Serials" - , "-------" - , "These options take the form --option cmp num; the given" - , "sequence number must fall within the given range. \"rev\"" - , "in the option name indicates numbering is from end to beginning." - , "" - , "--globalTransaction, --revGlobalTransaction" - , " All transactions, after reading the ledger files" - , "--globalPosting, --revGlobalPosting" - , " All postings, after reading the leder files" - , "--fileTransaction, --revFileTransaction" - , " Transactions in each ledger file, after reading the files" - , " (numbering restarts with each file)" - , "--filePosting, --revFilePosting" - , " Postings in each ledger file, after reading the files" - , " (numbering restarts with each file)" - , "--filtered, --revFiltered" - , " All postings, after filters given in the filter" - , " specification portion of the command line are" - , " applied" - , "--sorted, --revSorted" - , " All postings remaining after filtering and after" - , " postings have been sorted" - , "" - , "Pattern matching" - , "----------------" - , "" - , "-a pattern, --account pattern" - , " Pattern must match colon-separated account name" - , "--account-level num pat" - , " Pattern must match sub account at given level" - , "--account-any pat" - , " Pattern must match sub account at any level" - , "-p pattern, --payee pattern" - , " Payee must match pattern" - , "-t pattern, --tag pattern" - , " Tag must match pattern" - , "--number pattern" - , " Number must match pattern" - , "--flag pattern" - , " Flag must match pattern" - , "--commodity pattern" - , " Pattern must match colon-separated commodity name" - , "--posting-memo pattern" - , " Posting memo must match pattern" - , "--transaction-memo pattern" - , " Transaction memo must match pattern" - , "" - , "Other posting characteristics" - , "-----------------------------" - , "--debit" - , " Entry must be a debit" - , "--credit" - , " Entry must be a credit" - , "--qty cmp number" - , " Entry quantity must fall within given range" - , "" - , "Infix or RPN selection" - , "----------------------" - , "--infix - use infix notation" - , "--rpn - use reverse polish notation" - , " (default: use what was used in the filtering options)" - , "" - , "Infix Operators - from highest to lowest precedence" - , "(all are left associative)" - , "--------------------------" - , "--open expr --close" - , " Force precedence (as in \"open\" and \"close\" parentheses)" - , "--not expr" - , " True if expr is false" - , "expr1 --and expr2 " - , " True if expr and expr2 are both true" - , "expr1 --or expr2" - , " True if either expr1 or expr2 is true" - , "" - , "RPN Operators" - , "-------------" - , "expr --not" - , " True if expr is false" - , "expr1 expr2 --and" - , " True if expr and expr2 are both true" - , "expr1 expr2 --or" - , " True if either expr1 or expr2 is true" - , "" - , "Options affecting patterns" - , "==========================" - , "" - , "-i, --case-insensitive" - , " Be case insensitive" - , "-I, --case-sensitive" - , " Be case sensitive" - , "" - , "--within" - , " Use \"within\" matcher" - , "--pcre" - , " Use \"pcre\" matcher" - , "--posix" - , " Use \"posix\" matcher" - , "--exact" - , " Use \"exact\" matcher" - , "" - , "Removing postings after sorting and filtering" - , "=============================================" - , "--head n" - , " Keep only the first n postings" - , "--tail n" - , " Keep only the last n postings" - , "" - , "Other options" - , "=============" - , "--width num" - , " Hint for roughly how wide the report should be in columns" - , " (currently: " ++ (show . T.unReportWidth . width $ o) ++ ")" - , "--show field, --hide field" - , " show or hide this field, where field is one of:" - , " globalTransaction, revGlobalTransaction," - , " globalPosting, revGlobalPosting," - , " fileTransaction, revFileTransaction," - , " filePosting, revFilePosting," - , " filtered, revFiltered," - , " sorted, revSorted," - , " visible, revVisible," - , " lineNum," - , " date, flag, number, payee, account," - , " postingDrCr, postingCommodity, postingQty," - , " totalDrCr, totalCommodity, totalQty," - , " tags, memo, filename" - , "--show-all" - , " Show all fields" - , "--hide-all" - , " Hide all fields" - , "" - ] ++ showDefaultFields (fields o) ++ - [ "" - , "--show-zero-balances" - , " Show balances that are zero" - ++ ifDefault (CO.unShowZeroBalances . showZeroBalances $ o) - , "--hide-zero-balances" - , " Hide balances that are zero" - ++ ifDefault (not . CO.unShowZeroBalances . showZeroBalances $ o) - , "" - , "--help, -h" - , " Show this help and exit" - ] - --- | Shows which fields are on by default. -showDefaultFields :: F.Fields Bool -> [String] -showDefaultFields i = hdr : rest - where - hdr = "Fields shown by default:" - ++ if null rest then " (none)" else "" - rest = - map (" " ++) - . map concat - . map (intersperse ", ") - . chunksOf 3 - . catMaybes - . Fdbl.toList - . toMaybes - $ i - toMaybes flds = f <$> flds <*> F.fieldNames - f b n = if b then Just n else Nothing diff --git a/Penny/Cabin/Posts/Allocated.hs b/Penny/Cabin/Posts/Allocated.hs deleted file mode 100644 --- a/Penny/Cabin/Posts/Allocated.hs +++ /dev/null @@ -1,402 +0,0 @@ --- | Calculates the allocated cells -- the Payee cell and the Account --- cell. Here is the logic for this process: --- --- 1. If neither Payee nor Account appears, do nothing. --- --- 2. Obtain the width of the growing cells, including the --- spacers. One of the spacers attached to a field might be omitted: --- --- a. If the rightmost growing field is TotalQty, include all spacers. --- --- b. If the rightmost growing field is to the left of Payee, include --- all spacers. --- --- c. If the rightmost growing field is to the right of Account but is --- not TotalQty, omit its spacer. --- --- 2. Obtain the width of the Payee and Account spacers. Include each --- spacer if its corresponding field appears in the report. --- --- 3. Subtract from the total report width the width of the the --- growing cells and the width of the Payee and Account spacers. This --- gives the total width available for the Payee and Account --- fields. If there are not at least two columns available, return --- without including the Payee and Account fields. --- --- 4. Determine the total width that the Payee and Account fields --- would obtain if they had all the space they could ever need. This --- is the "requested width". --- --- 5. Split up the available width for the Payee and Account fields --- depending on which fields appear: --- --- a. If only the one field appears, then it shall be as wide as the --- total available width or the its requested width, whichever is --- smaller. --- --- b. If both fields appear, then calculate the allocated width for --- each field. If either field's requested width is less than its --- allocated width, then that field is only as wide as its requested --- width. The other field is then as wide as (the sum of its allocated --- width and the leftover width from the other field) or its requested --- width, whichever is smaller. If neither field's requested width is --- less than its allocated width, then each field gets ts allocated --- width. --- --- 6. Fill cell contents; return filled cells. - -module Penny.Cabin.Posts.Allocated ( - payeeAndAcct - , AllocatedOpts(..) - , Fields(..) - , SubAccountLength(..) - , Alloc - , alloc - , unAlloc - ) where - -import Control.Applicative(Applicative((<*>), pure), (<$>)) -import Control.Arrow (second) -import Data.Maybe (catMaybes, isJust) -import Data.List (intersperse) -import qualified Data.Foldable as Fdbl -import qualified Data.Sequence as Seq -import qualified Data.Traversable as T -import qualified Data.Text as X -import qualified System.Console.Rainbow as Rb -import qualified Penny.Cabin.Row as R -import qualified Penny.Cabin.Posts.Growers as G -import qualified Penny.Cabin.Posts.Meta as M -import Penny.Cabin.Posts.Meta (Box) -import qualified Penny.Cabin.Posts.Spacers as S -import qualified Penny.Cabin.Posts.Types as Ty -import qualified Penny.Cabin.Scheme as E -import qualified Penny.Cabin.TextFormat as TF -import qualified Penny.Lincoln as L -import qualified Penny.Lincoln.Bits.Qty as Qty -import qualified Penny.Lincoln.Queries as Q -import qualified Penny.Lincoln.HasText as HT - -data Fields a = Fields { - payee :: a - , account :: a - } deriving (Eq, Show) - -newtype SubAccountLength = - SubAccountLength { unSubAccountLength :: Int } - deriving Show - -newtype Alloc = Alloc { unAlloc :: Int } - deriving Show - -alloc :: Int -> Alloc -alloc i = - if i < 1 - then error $ "allocations must be greater than zero." - ++ " supplied allocation: " ++ show i - else Alloc i - - --- | All the information needed for allocated cells. -data AllocatedOpts = AllocatedOpts - { fields :: Fields Bool - , subAccountLength :: SubAccountLength - , allocations :: Fields Alloc - , spacers :: S.Spacers Int - , growerWidths :: G.Fields (Maybe Int) - , reportWidth :: Ty.ReportWidth - } - --- | Creates Payee and Account cells. The user must have requested the --- cells. In addition, no cells are created if there is not enough --- space for them in the report. Returns a Fields; each element of the --- Fields is Nothing if no cells were created (either because the user --- did not ask for them, or because there was no room) or Just cs i, --- where cs is a list of all the cells, and i is the width of all the --- cells. -payeeAndAcct - :: E.Changers - -> AllocatedOpts - -> [Box] - -> Fields (Maybe ([R.ColumnSpec], Int)) -payeeAndAcct ch ao bs = - let allBuilders = - T.traverse (builders ch (subAccountLength ao)) bs - availWidth = availableWidthForAllocs (growerWidths ao) - (spacers ao) (fields ao) (reportWidth ao) - finals = divideAvailableWidth availWidth (fields ao) - (allocations ao) - ( fmap (safeMaximum (Request 0)) - . fmap (fmap fst) $ allBuilders) - in fmap (fmap (second unFinal)) - . buildSpecs finals - . fmap (fmap snd) - $ allBuilders - - -safeMaximum :: Ord a => a -> [a] -> a -safeMaximum d ls = case ls of - [] -> d - xs -> maximum xs - -payeeAndAccountSpacerWidth - :: Fields Bool - -> S.Spacers Int - -> Int -payeeAndAccountSpacerWidth flds ss = pye + act - where - pye = if payee flds then abs (S.payee ss) else 0 - act = if account flds then abs (S.account ss) else 0 - -newtype AvailableWidth = AvailableWidth Int - deriving (Eq, Ord, Show) - -availableWidthForAllocs - :: G.Fields (Maybe Int) - -> S.Spacers Int - -> Fields Bool - -> Ty.ReportWidth - -> AvailableWidth -availableWidthForAllocs growers ss flds (Ty.ReportWidth w) = - AvailableWidth $ max 0 diff - where - tot = sumGrowersAndSpacers growers ss - + payeeAndAccountSpacerWidth flds ss - diff = w - tot - --- | Sums spacers for growing cells. This function is intended for use --- only by the functions that allocate cells for the report, so it --- assumes that either the Payee or the Account field is showing. Sums --- all spacers, UNLESS the rightmost field is from PostingDrCr to --- TotalCmdty, in which case the rightmost spacer is omitted. Apply to --- the second element of the tuple returned by growCells (which --- reflects which fields actually have width) and to the accompanying --- Spacers. -sumSpacers :: - G.Fields (Maybe a) - -> S.Spacers Int - -> Int -sumSpacers fs = - sum - . map fst - . appearingSpacers - . catMaybes - . Fdbl.toList - . fmap toWidth - . pairedWithSpacers fs - - --- | Takes a triple: --- --- * The first element is Just _ if the field appears in the report; --- Nothing if not --- --- * The second element is Maybe Int for the width of the spacer --- (TotalQty has no spacer, so it will be Nothing) --- --- * The third element is the EFields tag --- --- Returns Nothing if the field does not appear in the report. Returns --- Just a pair if the field does appear in the report, where the first --- element is the width of the spacer, and the second element is the --- EFields tag. -toWidth :: (Maybe a, Maybe Int, t) -> Maybe (Int, t) -toWidth (maybeShowing, maybeWidth, tag) = - if isJust maybeShowing - then case maybeWidth of - Just w -> Just (w, tag) - Nothing -> Just (0, tag) - else Nothing - - --- | Given a list of all spacers that are attached to the fields that --- are present in a report, return a list of the spacers that will --- actually appear in the report. The rightmost spacer does not appear --- if it is to the right of Account (unless there is a TotalQty field, --- in which case, all spacers appear because TotalQty has no spacer.) -appearingSpacers :: [(Int, G.EFields)] -> [(Int, G.EFields)] -appearingSpacers ss = case ss of - [] -> [] - l -> case snd $ last l of - G.ETotalQty -> l - t -> if t > G.ENumber - then init l - else l - --- | Applied to two arguments: first, a Fields, and second, a --- Spacers. Combines each Field with its corresponding Spacer and with --- the GFields, which indicates each particular field. -pairedWithSpacers :: - G.Fields a - -> S.Spacers b - -> G.Fields (a, Maybe b, G.EFields) -pairedWithSpacers f s = - (\(a, b) c -> (a, b, c)) - <$> G.pairWithSpacer f s - <*> G.eFields - --- | Sums the widths of growing cells and their accompanying --- spacers; makes the adjustments described in sumSpacers. -sumGrowersAndSpacers :: - G.Fields (Maybe Int) - -> S.Spacers Int - -> Int -sumGrowersAndSpacers fs ss = spcrs + flds where - spcrs = sumSpacers fs ss - flds = Fdbl.foldr f 0 fs where - f maybeI acc = case maybeI of - Nothing -> acc - Just i -> acc + i - -newtype Request = Request { unRequest :: Int } - deriving (Eq, Ord, Show) - -newtype Final = Final { unFinal :: Int } - deriving (Eq, Ord, Show) - - -buildSpecs - :: Fields (Maybe Final) - -> Fields ([Final -> R.ColumnSpec]) - -> Fields (Maybe ([R.ColumnSpec], Final)) -buildSpecs finals bs = f <$> finals <*> bs - where - f mayFinal gs = case mayFinal of - Nothing -> Nothing - Just fin -> Just ((gs <*> pure fin), fin) - - --- | Divide the total available width between the two fields. -divideAvailableWidth - :: AvailableWidth - -> Fields Bool - -> Fields Alloc - -> Fields Request - -> Fields (Maybe Final) -divideAvailableWidth (AvailableWidth aw) appear allocs rws = Fields pye act - where - minFinal i1 i2 = - let m = min i1 i2 - in if m > 0 then Just . Final $ m else Nothing - pairAtLeast i1 i2 = (atLeast i1, atLeast i2) - where atLeast i = if i > 0 then Just . Final $ i else Nothing - reqP = unRequest . payee $ rws - reqA = unRequest . account $ rws - (pye, act) = case (payee appear, account appear) of - (False, False) -> (Nothing, Nothing) - (True, False) -> (minFinal reqP aw, Nothing) - (False, True) -> (Nothing, minFinal reqA aw) - (True, True) -> - let votes = [unAlloc . payee $ allocs, unAlloc . account $ allocs] - allocRslt = Qty.largestRemainderMethod (fromIntegral aw) - (map fromIntegral votes) - (allocP, allocA) = case allocRslt of - x:y:[] -> (fromIntegral x, fromIntegral y) - _ -> error "divideAvailableWidth error" - in case (allocP > reqP, allocA > reqA) of - (True, True) -> pairAtLeast reqP reqA - (True, False) -> - pairAtLeast reqP $ (min (allocA + (allocP - reqP))) reqA - (False, True) -> - pairAtLeast (min reqP (allocP + (allocA - reqA))) reqA - (False, False) -> pairAtLeast allocP allocA - - -builders - :: E.Changers - -> SubAccountLength - -> Box - -> Fields (Request, Final -> R.ColumnSpec) -builders ch sl b = Fields (buildPayee ch b) (buildAcct ch sl b) - -buildPayee - :: E.Changers - -> Box - -> (Request, Final -> R.ColumnSpec) - -- ^ Returns a tuple. The first element is the maximum width that - -- this cell needs to display its value perfectly. The second - -- element is a function that, when applied to an actual width, - -- returns a ColumnSpec. - -buildPayee ch i = (maxW, mkSpec) - where - pb = L.boxPostFam i - eo = E.fromVisibleNum . M.visibleNum . L.boxMeta $ i - j = R.LeftJustify - ps = (E.Other, eo) - md = E.getEvenOddLabelValue E.Other eo ch - mayPye = Q.payee pb - maxW = Request $ maybe 0 (X.length . HT.text) mayPye - mkSpec (Final w) = R.ColumnSpec j (R.Width w) ps sq - where - sq = case mayPye of - Nothing -> [] - Just pye -> - let wrapped = - Fdbl.toList - . TF.unLines - . TF.wordWrap w - . TF.txtWords - . HT.text - $ pye - toBit (TF.Words seqTxts) = - md - . Rb.plain - . X.unwords - . Fdbl.toList - $ seqTxts - in fmap toBit wrapped - - -buildAcct - :: E.Changers - -> SubAccountLength - -> Box - -> (Request, Final -> R.ColumnSpec) - -- ^ Returns a tuple. The first element is the maximum width that - -- this cell needs to display its value perfectly. The second - -- element is a function that, when applied to an actual width, - -- returns a ColumnSpec. - -buildAcct ch sl i = (maxW, mkSpec) - where - pb = L.boxPostFam i - eo = E.fromVisibleNum . M.visibleNum . L.boxMeta $ i - ps = (E.Other, eo) - aList = L.unAccount . Q.account $ pb - maxW = Request - $ (sum . map (X.length . L.unSubAccount) $ aList) - + max 0 (length aList - 1) - md = E.getEvenOddLabelValue E.Other eo ch - mkSpec (Final aw) = R.ColumnSpec R.LeftJustify (R.Width aw) ps sq - where - target = TF.Target aw - shortest = TF.Shortest . unSubAccountLength $ sl - ws = TF.Words . Seq.fromList . map L.unSubAccount $ aList - (TF.Words shortened) = TF.shorten shortest target ws - sq = [ md - . Rb.plain - . X.concat - . intersperse (X.singleton ':') - . Fdbl.toList - $ shortened ] - -instance Functor Fields where - fmap f i = Fields { - payee = f (payee i) - , account = f (account i) } - -instance Applicative Fields where - pure a = Fields a a - ff <*> fa = Fields { - payee = payee ff (payee fa) - , account = account ff (account fa) } - -instance Fdbl.Foldable Fields where - foldr f z flds = - f (payee flds) (f (account flds) z) - -instance T.Traversable Fields where - traverse f flds = - Fields <$> f (payee flds) <*> f (account flds) - diff --git a/Penny/Cabin/Posts/BottomRows.hs b/Penny/Cabin/Posts/BottomRows.hs deleted file mode 100644 --- a/Penny/Cabin/Posts/BottomRows.hs +++ /dev/null @@ -1,649 +0,0 @@ --- | Fills the bottom rows, which contain the tags, memo, and --- filename. These rows are formatted as follows: --- --- * If the columns for TotalDrCr, TotalCmdty, and TotalQty are all --- present, AND if there are at least TWO other columns present, then --- there will be a hanging indent. The bottom rows will begin at the --- SECOND column and end with the last column to the left of --- TotalDrCr. In this case, each bottom row will have three cells: one --- padding on the left, one main content, and one padding on the --- right. --- --- * Otherwise, if there are NO columns in the top row, these rows --- will take the entire width of the report. Each bottom row will have --- one cell. --- --- * Otherwise, the bottom rows are as wide as all the top cells --- combined. Each bottom row will have one cell. - -module Penny.Cabin.Posts.BottomRows ( - BottomOpts(..), - bottomRows, Fields(..), TopRowCells(..), mergeWithSpacers, - topRowCells) where - -import Control.Applicative((<$>), Applicative(pure, (<*>))) -import qualified Data.Foldable as Fdbl -import Control.Monad (guard) -import Data.List (intersperse, find) -import qualified Data.List.NonEmpty as NE -import Data.Maybe (catMaybes) -import Data.Monoid (mappend, mempty, First(First, getFirst)) -import qualified Data.Sequence as Seq -import qualified Data.Text as X -import qualified Data.Traversable as T -import qualified System.Console.Rainbow as Rb -import qualified Penny.Cabin.Scheme as E -import qualified Penny.Cabin.Row as R -import qualified Penny.Cabin.TextFormat as TF -import qualified Penny.Cabin.Posts.Allocated as A -import qualified Penny.Cabin.Posts.Fields as F -import qualified Penny.Cabin.Posts.Growers as G -import qualified Penny.Cabin.Posts.Meta as M -import Penny.Cabin.Posts.Meta (Box) -import qualified Penny.Cabin.Posts.Spacers as S -import qualified Penny.Cabin.Posts.Types as Ty -import qualified Penny.Lincoln as L -import qualified Penny.Lincoln.HasText as HT -import qualified Penny.Lincoln.Queries as Q - -data BottomOpts = BottomOpts - { growingWidths :: G.Fields (Maybe Int) - , allocatedWidths :: A.Fields (Maybe Int) - , fields :: F.Fields Bool - , reportWidth :: Ty.ReportWidth - , spacers :: S.Spacers Int - } - -bottomRows - :: E.Changers - -> BottomOpts - -> [Box] - -> Fields (Maybe [[Rb.Chunk]]) -bottomRows ch os bs = makeRows bs pcs where - pcs = infoProcessors ch topSpecs (reportWidth os) wanted - wanted = requestedMakers ch (fields os) - topSpecs = topCellSpecs (growingWidths os) (allocatedWidths os) - (spacers os) - - -data Fields a = Fields { - tags :: a - , memo :: a - , filename :: a - } deriving (Show, Eq) - -instance Fdbl.Foldable Fields where - foldr f z d = - f (tags d) - (f (memo d) - (f (filename d) z)) - -instance Functor Fields where - fmap f (Fields t m fn) = - Fields (f t) (f m) (f fn) - -instance Applicative Fields where - pure a = Fields a a a - ff <*> fa = Fields { - tags = (tags ff) (tags fa) - , memo = (memo ff) (memo fa) - , filename = (filename ff) (filename fa) - } - -bottomRowsFields :: F.Fields a -> Fields a -bottomRowsFields f = Fields { - tags = F.tags f - , memo = F.memo f - , filename = F.filename f } - - -data Hanging a = Hanging { - leftPad :: a - , mainCell :: a - , rightPad :: a - } deriving (Show, Eq) - - -newtype SpacerWidth = SpacerWidth Int deriving (Show, Eq) -newtype ContentWidth = ContentWidth Int deriving (Show, Eq) - - -hanging - :: E.Changers - -> [TopCellSpec] - -> Maybe ((Box -> Int -> ((E.Label, E.EvenOdd), R.ColumnSpec)) - -> Box -> [Rb.Chunk]) -hanging ch specs = hangingWidths specs - >>= return . hangingInfoProcessor ch - -hangingInfoProcessor - :: E.Changers - -> Hanging Int - -> (Box -> Int -> ((E.Label, E.EvenOdd), R.ColumnSpec)) - -> Box - -> [Rb.Chunk] -hangingInfoProcessor ch widths mkr info = row where - row = R.row ch [left, mid, right] - (ts, mid) = mkr info (mainCell widths) - mkPad w = R.ColumnSpec R.LeftJustify (R.Width w) ts [] - left = mkPad (leftPad widths) - right = mkPad (rightPad widths) - -widthOfTopColumns - :: E.Changers - -> [TopCellSpec] - -> Maybe ((Box -> Int -> ((E.Label, E.EvenOdd), R.ColumnSpec)) - -> Box -> [Rb.Chunk]) -widthOfTopColumns ch ts = - if null ts - then Nothing - else Just $ makeSpecificWidth ch w where - w = Fdbl.foldl' f 0 ts - f acc (_, maySpcWidth, (ContentWidth cw)) = - acc + cw + maybe 0 (\(SpacerWidth sw) -> sw) maySpcWidth - - -widthOfReport - :: E.Changers - -> Ty.ReportWidth - -> (Box -> Int -> ((E.Label, E.EvenOdd), R.ColumnSpec)) - -> Box - -> [Rb.Chunk] -widthOfReport ch (Ty.ReportWidth rw) fn info = - makeSpecificWidth ch rw fn info - -chooseProcessor - :: E.Changers - -> [TopCellSpec] - -> Ty.ReportWidth - -> (Box -> Int -> ((E.Label, E.EvenOdd), R.ColumnSpec)) - -> Box - -> [Rb.Chunk] -chooseProcessor ch specs rw fn = let - firstTwo = First (hanging ch specs) - `mappend` First (widthOfTopColumns ch specs) - in case getFirst firstTwo of - Nothing -> widthOfReport ch rw fn - Just r -> r fn - -infoProcessors - :: E.Changers - -> [TopCellSpec] - -> Ty.ReportWidth - -> Fields (Maybe (Box -> Int -> ((E.Label, E.EvenOdd), R.ColumnSpec))) - -> Fields (Maybe (Box -> [Rb.Chunk])) -infoProcessors ch specs rw flds = let - chooser = chooseProcessor ch specs rw - mkProcessor mayFn = case mayFn of - Nothing -> Nothing - Just fn -> Just $ chooser fn - in mkProcessor <$> flds - - -makeRows :: - [Box] - -> Fields (Maybe (Box -> [Rb.Chunk])) - -> Fields (Maybe [[Rb.Chunk]]) -makeRows is flds = let - mkRow fn = map fn is - in fmap (fmap mkRow) flds - - --- | Calculates column widths for a Hanging report. If it cannot --- calculate the widths (because these cells do not support hanging), --- returns Nothing. -hangingWidths :: [TopCellSpec] - -> Maybe (Hanging Int) -hangingWidths ls = do - let len = length ls - guard (len > 4) - let matchColumn x (c, _, _) = x == c - totDrCr <- find (matchColumn ETotalDrCr) ls - totCmdty <- find (matchColumn ETotalCmdty) ls - totQty <- find (matchColumn ETotalQty) ls - let (first:middle) = take (len - 3) ls - mid <- NE.nonEmpty middle - return $ calcHangingWidths first mid (totDrCr, totCmdty, totQty) - -type TopCellSpec = (ETopRowCells, Maybe SpacerWidth, ContentWidth) - --- | Given the first column in the top row, at least one middle --- column, and the last three columns, calculate the width of the --- three columns in the hanging report. -calcHangingWidths :: - TopCellSpec - -> NE.NonEmpty TopCellSpec - -> (TopCellSpec, TopCellSpec, TopCellSpec) - -> Hanging Int -calcHangingWidths l m r = Hanging left middle right where - calcWidth (_, maybeSp, (ContentWidth c)) = - c + maybe 0 (\(SpacerWidth w) -> abs w) maybeSp - left = calcWidth l - middle = Fdbl.foldl' f 0 m where - f acc c = acc + calcWidth c - (totDrCr, totCmdty, totQty) = r - right = calcWidth totDrCr + calcWidth totCmdty - + calcWidth totQty - - -topCellSpecs :: G.Fields (Maybe Int) - -> A.Fields (Maybe Int) - -> S.Spacers Int - -> [TopCellSpec] -topCellSpecs gFlds aFlds spcs = let - allFlds = topRowCells gFlds aFlds - cws = fmap (fmap ContentWidth) allFlds - merged = mergeWithSpacers cws spcs - tripler e (cw, maybeSpc) = (e, (fmap SpacerWidth maybeSpc), cw) - list = Fdbl.toList $ tripler <$> eTopRowCells <*> merged - toMaybe (e, maybeS, maybeC) = case maybeC of - Nothing -> Nothing - Just c -> Just (e, maybeS, c) - in catMaybes (map toMaybe list) - - --- | Merges a TopRowCells with a Spacers. Returns Maybes because --- totalQty has no spacer. -mergeWithSpacers :: - TopRowCells a - -> S.Spacers b - -> TopRowCells (a, Maybe b) -mergeWithSpacers t s = TopRowCells { - globalTransaction = (globalTransaction t, Just (S.globalTransaction s)) - , revGlobalTransaction = (revGlobalTransaction t, Just (S.revGlobalTransaction s)) - , globalPosting = (globalPosting t, Just (S.globalPosting s)) - , revGlobalPosting = (revGlobalPosting t, Just (S.revGlobalPosting s)) - , fileTransaction = (fileTransaction t, Just (S.fileTransaction s)) - , revFileTransaction = (revFileTransaction t, Just (S.revFileTransaction s)) - , filePosting = (filePosting t, Just (S.filePosting s)) - , revFilePosting = (revFilePosting t, Just (S.revFilePosting s)) - , filtered = (filtered t, Just (S.filtered s)) - , revFiltered = (revFiltered t, Just (S.revFiltered s)) - , sorted = (sorted t, Just (S.sorted s)) - , revSorted = (revSorted t, Just (S.revSorted s)) - , visible = (visible t, Just (S.visible s)) - , revVisible = (revVisible t, Just (S.revVisible s)) - , lineNum = (lineNum t, Just (S.lineNum s)) - , date = (date t, Just (S.date s)) - , flag = (flag t, Just (S.flag s)) - , number = (number t, Just (S.number s)) - , payee = (payee t, Just (S.payee s)) - , account = (account t, Just (S.account s)) - , postingDrCr = (postingDrCr t, Just (S.postingDrCr s)) - , postingCmdty = (postingCmdty t, Just (S.postingCmdty s)) - , postingQty = (postingQty t, Just (S.postingQty s)) - , totalDrCr = (totalDrCr t, Just (S.totalDrCr s)) - , totalCmdty = (totalCmdty t, Just (S.totalCmdty s)) - , totalQty = (totalQty t, Nothing) } - - --- | Applied to a function that, when applied to the width of a cell, --- returns a cell filled with data, returns a Row with that cell. -makeSpecificWidth - :: E.Changers -> Int -> (Box -> Int -> (a, R.ColumnSpec)) - -> Box -> [Rb.Chunk] -makeSpecificWidth ch w f i = R.row ch [c] where - (_, c) = f i w - - -type Maker - = E.Changers - -> Box - -> Int - -> ((E.Label, E.EvenOdd), R.ColumnSpec) - -makers :: Fields Maker -makers = Fields tagsCell memoCell filenameCell - --- | Applied to an Options, indicating which reports the user wants, --- returns a Fields (Maybe Maker) with a Maker in each respective --- field that the user wants to see. -requestedMakers - :: E.Changers - -> F.Fields Bool - -> Fields (Maybe (Box -> Int -> ((E.Label, E.EvenOdd), R.ColumnSpec))) -requestedMakers ch allFlds = - let flds = bottomRowsFields allFlds - filler b mkr = if b then Just $ mkr ch else Nothing - in filler <$> flds <*> makers - -tagsCell - :: E.Changers - -> Box - -> Int - -> ((E.Label, E.EvenOdd), R.ColumnSpec) -tagsCell ch info w = (ts, cell) where - vn = M.visibleNum . L.boxMeta $ info - cell = R.ColumnSpec R.LeftJustify (R.Width w) ts cs - eo = E.fromVisibleNum vn - ts = (E.Other, eo) - cs = - Fdbl.toList - . fmap toBit - . TF.unLines - . TF.wordWrap w - . TF.Words - . Seq.fromList - . map (X.cons '*') - . HT.textList - . Q.tags - . L.boxPostFam - $ info - md = E.getEvenOddLabelValue E.Other eo ch - toBit (TF.Words ws) = md . Rb.plain $ t where - t = X.concat . intersperse (X.singleton ' ') . Fdbl.toList $ ws - - -memoBits - :: E.Changers -> (E.Label, E.EvenOdd) -> L.Memo -> R.Width -> [Rb.Chunk] -memoBits ch (lbl, eo) m (R.Width w) = cs where - cs = Fdbl.toList - . fmap toBit - . TF.unLines - . TF.wordWrap w - . TF.Words - . Seq.fromList - . X.words - . X.intercalate (X.singleton ' ') - . L.unMemo - $ m - md = E.getEvenOddLabelValue lbl eo ch - toBit (TF.Words ws) = md . Rb.plain $ (X.unwords . Fdbl.toList $ ws) - - -memoCell - :: E.Changers -> Box -> Int -> ((E.Label, E.EvenOdd), R.ColumnSpec) -memoCell ch info width = (ts, cell) where - w = R.Width width - vn = M.visibleNum . L.boxMeta $ info - eo = E.fromVisibleNum vn - ts = (E.Other, eo) - cell = R.ColumnSpec R.LeftJustify w ts cs - mayPm = Q.postingMemo . L.boxPostFam $ info - mayTm = Q.transactionMemo . L.boxPostFam $ info - cs = case (mayPm, mayTm) of - (Nothing, Nothing) -> mempty - (Nothing, Just tm) -> memoBits ch ts tm w - (Just pm, Nothing) -> memoBits ch ts pm w - (Just pm, Just tm) -> memoBits ch ts pm w `mappend` memoBits ch ts tm w - - -filenameCell - :: E.Changers -> Box -> Int -> ((E.Label, E.EvenOdd), R.ColumnSpec) -filenameCell ch info width = (ts, cell) where - w = R.Width width - vn = M.visibleNum . L.boxMeta $ info - eo = E.fromVisibleNum vn - ts = (E.Other, eo) - cell = R.ColumnSpec R.LeftJustify w ts cs - md = E.getEvenOddLabelValue E.Other eo ch - toBit n = md . Rb.plain - . X.drop (max 0 (X.length n - width)) $ n - cs = case Q.filename . L.boxPostFam $ info of - Nothing -> [] - Just fn -> [toBit . L.unFilename $ fn] - - -data TopRowCells a = TopRowCells - { globalTransaction :: a - , revGlobalTransaction :: a - , globalPosting :: a - , revGlobalPosting :: a - , fileTransaction :: a - , revFileTransaction :: a - , filePosting :: a - , revFilePosting :: a - , filtered :: a - , revFiltered :: a - , sorted :: a - , revSorted :: a - , visible :: a - , revVisible :: a - , lineNum :: a - -- ^ The line number from the posting's metadata - , date :: a - , flag :: a - , number :: a - , payee :: a - , account :: a - , postingDrCr :: a - , postingCmdty :: a - , postingQty :: a - , totalDrCr :: a - , totalCmdty :: a - , totalQty :: a } - deriving (Show, Eq) - -topRowCells :: G.Fields a -> A.Fields a -> TopRowCells a -topRowCells g a = TopRowCells - { globalTransaction = G.globalTransaction g - , revGlobalTransaction = G.revGlobalTransaction g - , globalPosting = G.globalPosting g - , revGlobalPosting = G.revGlobalPosting g - , fileTransaction = G.fileTransaction g - , revFileTransaction = G.revFileTransaction g - , filePosting = G.filePosting g - , revFilePosting = G.revFilePosting g - , filtered = G.filtered g - , revFiltered = G.revFiltered g - , sorted = G.sorted g - , revSorted = G.revSorted g - , visible = G.visible g - , revVisible = G.revVisible g - , lineNum = G.lineNum g - , date = G.date g - , flag = G.flag g - , number = G.number g - , payee = A.payee a - , account = A.account a - , postingDrCr = G.postingDrCr g - , postingCmdty = G.postingCmdty g - , postingQty = G.postingQty g - , totalDrCr = G.totalDrCr g - , totalCmdty = G.totalCmdty g - , totalQty = G.totalQty g } - - -data ETopRowCells = - EGlobalTransaction - | ERevGlobalTransaction - | EGlobalPosting - | ERevGlobalPosting - | EFileTransaction - | ERevFileTransaction - | EFilePosting - | ERevFilePosting - | EFiltered - | ERevFiltered - | ESorted - | ERevSorted - | EVisible - | ERevVisible - | ELineNum - | EDate - | EFlag - | ENumber - | EPayee - | EAccount - | EPostingDrCr - | EPostingCmdty - | EPostingQty - | ETotalDrCr - | ETotalCmdty - | ETotalQty - deriving (Show, Eq, Enum) - -eTopRowCells :: TopRowCells ETopRowCells -eTopRowCells = TopRowCells - { globalTransaction = EGlobalTransaction - , revGlobalTransaction = ERevGlobalTransaction - , globalPosting = EGlobalPosting - , revGlobalPosting = ERevGlobalPosting - , fileTransaction = EFileTransaction - , revFileTransaction = ERevFileTransaction - , filePosting = EFilePosting - , revFilePosting = ERevFilePosting - , filtered = EFiltered - , revFiltered = ERevFiltered - , sorted = ESorted - , revSorted = ERevSorted - , visible = EVisible - , revVisible = ERevVisible - , lineNum = ELineNum - , date = EDate - , flag = EFlag - , number = ENumber - , payee = EPayee - , account = EAccount - , postingDrCr = EPostingDrCr - , postingCmdty = EPostingCmdty - , postingQty = EPostingQty - , totalDrCr = ETotalDrCr - , totalCmdty = ETotalCmdty - , totalQty = ETotalQty } - -instance Functor TopRowCells where - fmap f t = TopRowCells - { globalTransaction = f (globalTransaction t) - , revGlobalTransaction = f (revGlobalTransaction t) - , globalPosting = f (globalPosting t) - , revGlobalPosting = f (revGlobalPosting t) - , fileTransaction = f (fileTransaction t) - , revFileTransaction = f (revFileTransaction t) - , filePosting = f (filePosting t) - , revFilePosting = f (revFilePosting t) - , filtered = f (filtered t) - , revFiltered = f (revFiltered t) - , sorted = f (sorted t) - , revSorted = f (revSorted t) - , visible = f (visible t) - , revVisible = f (revVisible t) - , lineNum = f (lineNum t) - , date = f (date t) - , flag = f (flag t) - , number = f (number t) - , payee = f (payee t) - , account = f (account t) - , postingDrCr = f (postingDrCr t) - , postingCmdty = f (postingCmdty t) - , postingQty = f (postingQty t) - , totalDrCr = f (totalDrCr t) - , totalCmdty = f (totalCmdty t) - , totalQty = f (totalQty t) } - -instance Applicative TopRowCells where - pure a = TopRowCells - { globalTransaction = a - , revGlobalTransaction = a - , globalPosting = a - , revGlobalPosting = a - , fileTransaction = a - , revFileTransaction = a - , filePosting = a - , revFilePosting = a - , filtered = a - , revFiltered = a - , sorted = a - , revSorted = a - , visible = a - , revVisible = a - , lineNum = a - , date = a - , flag = a - , number = a - , payee = a - , account = a - , postingDrCr = a - , postingCmdty = a - , postingQty = a - , totalDrCr = a - , totalCmdty = a - , totalQty = a } - - ff <*> fa = TopRowCells - { globalTransaction = globalTransaction ff (globalTransaction fa) - , revGlobalTransaction = revGlobalTransaction ff (revGlobalTransaction fa) - , globalPosting = globalPosting ff (globalPosting fa) - , revGlobalPosting = revGlobalPosting ff (revGlobalPosting fa) - , fileTransaction = fileTransaction ff (fileTransaction fa) - , revFileTransaction = revFileTransaction ff (revFileTransaction fa) - , filePosting = filePosting ff (filePosting fa) - , revFilePosting = revFilePosting ff (revFilePosting fa) - , filtered = filtered ff (filtered fa) - , revFiltered = revFiltered ff (revFiltered fa) - , sorted = sorted ff (sorted fa) - , revSorted = revSorted ff (revSorted fa) - , visible = visible ff (visible fa) - , revVisible = revVisible ff (revVisible fa) - , lineNum = lineNum ff (lineNum fa) - , date = date ff (date fa) - , flag = flag ff (flag fa) - , number = number ff (number fa) - , payee = payee ff (payee fa) - , account = account ff (account fa) - , postingDrCr = postingDrCr ff (postingDrCr fa) - , postingCmdty = postingCmdty ff (postingCmdty fa) - , postingQty = postingQty ff (postingQty fa) - , totalDrCr = totalDrCr ff (totalDrCr fa) - , totalCmdty = totalCmdty ff (totalCmdty fa) - , totalQty = totalQty ff (totalQty fa) } - -instance Fdbl.Foldable TopRowCells where - foldr f z o = - f (globalTransaction o) - (f (revGlobalTransaction o) - (f (globalPosting o) - (f (revGlobalPosting o) - (f (fileTransaction o) - (f (revFileTransaction o) - (f (filePosting o) - (f (revFilePosting o) - (f (filtered o) - (f (revFiltered o) - (f (sorted o) - (f (revSorted o) - (f (visible o) - (f (revVisible o) - (f (lineNum o) - (f (date o) - (f (flag o) - (f (number o) - (f (payee o) - (f (account o) - (f (postingDrCr o) - (f (postingCmdty o) - (f (postingQty o) - (f (totalDrCr o) - (f (totalCmdty o) - (f (totalQty o) z))))))))))))))))))))))))) - -instance T.Traversable TopRowCells where - traverse f t = - TopRowCells - <$> f (globalTransaction t) - <*> f (revGlobalTransaction t) - <*> f (globalPosting t) - <*> f (revGlobalPosting t) - <*> f (fileTransaction t) - <*> f (revFileTransaction t) - <*> f (filePosting t) - <*> f (revFilePosting t) - <*> f (filtered t) - <*> f (revFiltered t) - <*> f (sorted t) - <*> f (revSorted t) - <*> f (visible t) - <*> f (revVisible t) - <*> f (lineNum t) - <*> f (date t) - <*> f (flag t) - <*> f (number t) - <*> f (payee t) - <*> f (account t) - <*> f (postingDrCr t) - <*> f (postingCmdty t) - <*> f (postingQty t) - <*> f (totalDrCr t) - <*> f (totalCmdty t) - <*> f (totalQty t) - diff --git a/Penny/Cabin/Posts/Chunk.hs b/Penny/Cabin/Posts/Chunk.hs deleted file mode 100644 --- a/Penny/Cabin/Posts/Chunk.hs +++ /dev/null @@ -1,152 +0,0 @@ -module Penny.Cabin.Posts.Chunk (ChunkOpts(..), makeChunk) where - -import qualified Data.Foldable as Fdbl -import Data.List (transpose) -import Data.Maybe (isNothing, catMaybes) -import qualified Penny.Cabin.Posts.Fields as F -import qualified Penny.Cabin.Posts.Growers as G -import qualified Penny.Cabin.Posts.Allocated as A -import qualified Penny.Cabin.Posts.BottomRows as B -import qualified Penny.Cabin.Posts.Spacers as S -import qualified Penny.Cabin.Row as R -import qualified Penny.Cabin.Scheme as E -import qualified System.Console.Rainbow as Rb -import Penny.Cabin.Posts.Meta (Box) -import qualified Penny.Lincoln as L -import qualified Data.Text as X -import qualified Penny.Cabin.Posts.Types as Ty - -data ChunkOpts = ChunkOpts - { dateFormat :: Box -> X.Text - , qtyFormat :: Box -> X.Text - , balanceFormat :: L.Commodity -> L.Qty -> X.Text - , fields :: F.Fields Bool - , subAccountLength :: A.SubAccountLength - , payeeAllocation :: A.Alloc - , accountAllocation :: A.Alloc - , spacers :: S.Spacers Int - , reportWidth :: Ty.ReportWidth - } - -growOpts :: ChunkOpts -> G.GrowOpts -growOpts c = G.GrowOpts - { G.dateFormat = dateFormat c - , G.qtyFormat = qtyFormat c - , G.balanceFormat = balanceFormat c - , G.fields = fields c - } - -allocatedOpts :: ChunkOpts -> G.Fields (Maybe Int) -> A.AllocatedOpts -allocatedOpts c g = A.AllocatedOpts - { A.fields = let f = fields c - in A.Fields { A.payee = F.payee f - , A.account = F.account f } - , A.subAccountLength = subAccountLength c - , A.allocations = A.Fields { A.payee = payeeAllocation c - , A.account = accountAllocation c } - , A.spacers = spacers c - , A.growerWidths = g - , A.reportWidth = reportWidth c - } - -bottomOpts :: - ChunkOpts - -> G.Fields (Maybe Int) - -> A.Fields (Maybe Int) - -> B.BottomOpts -bottomOpts c g a = B.BottomOpts { - B.growingWidths = g - , B.allocatedWidths = a - , B.fields = fields c - , B.reportWidth = reportWidth c - , B.spacers = spacers c - } - -makeChunk - :: E.Changers - -> ChunkOpts - -> [Box] - -> [Rb.Chunk] -makeChunk ch c bs = - let fmapSnd = fmap (fmap snd) - fmapFst = fmap (fmap fst) - gFldW = fmap (fmap snd) gFlds - aFldW = fmapSnd aFlds - gFlds = G.growCells ch (growOpts c) bs - aFlds = A.payeeAndAcct ch (allocatedOpts c gFldW) bs - bFlds = B.bottomRows ch (bottomOpts c gFldW aFldW) bs - topCells = B.topRowCells (fmapFst gFlds) (fmap (fmap fst) aFlds) - withSpacers = B.mergeWithSpacers topCells (spacers c) - topRows = makeTopRows ch withSpacers - bottomRows = makeBottomRows bFlds - in makeAllRows topRows bottomRows - - -topRowsCells - :: B.TopRowCells (Maybe [R.ColumnSpec], Maybe Int) - -> [[(R.ColumnSpec, Maybe R.ColumnSpec)]] -topRowsCells t = let - toWithSpc (mayCs, maySp) = case mayCs of - Nothing -> Nothing - Just cs -> Just (makeSpacers cs maySp) - f mayPairList acc = case mayPairList of - Nothing -> acc - (Just pairList) -> pairList : acc - in transpose $ Fdbl.foldr f [] (fmap toWithSpc t) - -makeRow :: E.Changers -> [(R.ColumnSpec, Maybe R.ColumnSpec)] -> [Rb.Chunk] -makeRow ch = R.row ch . foldr f [] where - f (c, mayC) acc = case mayC of - Nothing -> c:acc - Just spcr -> c:spcr:acc - - -makeSpacers - :: [R.ColumnSpec] - -> Maybe Int - -> [(R.ColumnSpec, Maybe R.ColumnSpec)] -makeSpacers cs mayI = case mayI of - Nothing -> map (\c -> (c, Nothing)) cs - Just i -> makeEvenOddSpacers cs i - -makeEvenOddSpacers - :: [R.ColumnSpec] - -> Int - -> [(R.ColumnSpec, Maybe R.ColumnSpec)] -makeEvenOddSpacers cs i = let absI = abs i in - if absI == 0 - then map (\c -> (c, Nothing)) cs - else let - spcrs = cycle [Just $ mkSpcr evenTs, Just $ mkSpcr oddTs] - mkSpcr ts = R.ColumnSpec R.LeftJustify (R.Width absI) ts [] - evenTs = (E.Other, E.Even) - oddTs = (E.Other, E.Odd) - in zip cs spcrs - -makeTopRows - :: E.Changers - -> B.TopRowCells (Maybe [R.ColumnSpec], Maybe Int) - -> Maybe [[Rb.Chunk]] -makeTopRows ch trc = - if Fdbl.all (isNothing . fst) trc - then Nothing - else Just $ map (makeRow ch) . topRowsCells $ trc - - -makeBottomRows :: - B.Fields (Maybe [[Rb.Chunk]]) - -> Maybe [[[Rb.Chunk]]] -makeBottomRows flds = - if Fdbl.all isNothing flds - then Nothing - else Just . transpose . catMaybes . Fdbl.toList $ flds - -makeAllRows :: Maybe [[Rb.Chunk]] -> Maybe [[[Rb.Chunk]]] -> [Rb.Chunk] -makeAllRows mayrs mayrrs = case (mayrs, mayrrs) of - (Nothing, Nothing) -> [] - (Just rs, Nothing) -> concat rs - (Nothing, Just rrs) -> concat . concat $ rrs - (Just rs, Just rrs) -> concat $ zipWith f rs rrs where - f topRow botRows = concat [topRow, concat botRows] - - diff --git a/Penny/Cabin/Posts/Fields.hs b/Penny/Cabin/Posts/Fields.hs deleted file mode 100644 --- a/Penny/Cabin/Posts/Fields.hs +++ /dev/null @@ -1,199 +0,0 @@ --- | Fields that can appear in the Posts report. -module Penny.Cabin.Posts.Fields where - -import Control.Applicative(Applicative(pure, (<*>))) -import qualified Data.Foldable as F - -data Fields a = Fields - { globalTransaction :: a - , revGlobalTransaction :: a - , globalPosting :: a - , revGlobalPosting :: a - , fileTransaction :: a - , revFileTransaction :: a - , filePosting :: a - , revFilePosting :: a - , filtered :: a - , revFiltered :: a - , sorted :: a - , revSorted :: a - , visible :: a - , revVisible :: a - , lineNum :: a - , date :: a - , flag :: a - , number :: a - , payee :: a - , account :: a - , postingDrCr :: a - , postingCmdty :: a - , postingQty :: a - , totalDrCr :: a - , totalCmdty :: a - , totalQty :: a - , tags :: a - , memo :: a - , filename :: a - } deriving (Show, Eq) - -instance Functor Fields where - fmap f fa = Fields { - globalTransaction = f (globalTransaction fa) - , revGlobalTransaction = f (revGlobalTransaction fa) - , globalPosting = f (globalPosting fa) - , revGlobalPosting = f (revGlobalPosting fa) - , fileTransaction = f (fileTransaction fa) - , revFileTransaction = f (revFileTransaction fa) - , filePosting = f (filePosting fa) - , revFilePosting = f (revFilePosting fa) - , filtered = f (filtered fa) - , revFiltered = f (revFiltered fa) - , sorted = f (sorted fa) - , revSorted = f (revSorted fa) - , visible = f (visible fa) - , revVisible = f (revVisible fa) - , lineNum = f (lineNum fa) - , date = f (date fa) - , flag = f (flag fa) - , number = f (number fa) - , payee = f (payee fa) - , account = f (account fa) - , postingDrCr = f (postingDrCr fa) - , postingCmdty = f (postingCmdty fa) - , postingQty = f (postingQty fa) - , totalDrCr = f (totalDrCr fa) - , totalCmdty = f (totalCmdty fa) - , totalQty = f (totalQty fa) - , tags = f (tags fa) - , memo = f (memo fa) - , filename = f (filename fa) } - -instance Applicative Fields where - pure a = Fields { - globalTransaction = a - , revGlobalTransaction = a - , globalPosting = a - , revGlobalPosting = a - , fileTransaction = a - , revFileTransaction = a - , filePosting = a - , revFilePosting = a - , filtered = a - , revFiltered = a - , sorted = a - , revSorted = a - , visible = a - , revVisible = a - , lineNum = a - , date = a - , flag = a - , number = a - , payee = a - , account = a - , postingDrCr = a - , postingCmdty = a - , postingQty = a - , totalDrCr = a - , totalCmdty = a - , totalQty = a - , tags = a - , memo = a - , filename = a } - - ff <*> fa = Fields { - globalTransaction = globalTransaction ff (globalTransaction fa) - , revGlobalTransaction = revGlobalTransaction ff - (revGlobalTransaction fa) - , globalPosting = globalPosting ff (globalPosting fa) - , revGlobalPosting = revGlobalPosting ff (revGlobalPosting fa) - , fileTransaction = fileTransaction ff (fileTransaction fa) - , revFileTransaction = revFileTransaction ff (revFileTransaction fa) - , filePosting = filePosting ff (filePosting fa) - , revFilePosting = revFilePosting ff (revFilePosting fa) - , filtered = filtered ff (filtered fa) - , revFiltered = revFiltered ff (revFiltered fa) - , sorted = sorted ff (sorted fa) - , revSorted = revSorted ff (revSorted fa) - , visible = visible ff (visible fa) - , revVisible = revVisible ff (revVisible fa) - , lineNum = lineNum ff (lineNum fa) - , date = date ff (date fa) - , flag = flag ff (flag fa) - , number = number ff (number fa) - , payee = payee ff (payee fa) - , account = account ff (account fa) - , postingDrCr = postingDrCr ff (postingDrCr fa) - , postingCmdty = postingCmdty ff (postingCmdty fa) - , postingQty = postingQty ff (postingQty fa) - , totalDrCr = totalDrCr ff (totalDrCr fa) - , totalCmdty = totalCmdty ff (totalCmdty fa) - , totalQty = totalQty ff (totalQty fa) - , tags = tags ff (tags fa) - , memo = memo ff (memo fa) - , filename = filename ff (filename fa) } - -instance F.Foldable Fields where - foldr f z t = - f (globalTransaction t) - (f (revGlobalTransaction t) - (f (globalPosting t) - (f (revGlobalPosting t) - (f (fileTransaction t) - (f (revFileTransaction t) - (f (filePosting t) - (f (revFilePosting t) - (f (filtered t) - (f (revFiltered t) - (f (sorted t) - (f (revSorted t) - (f (visible t) - (f (revVisible t) - (f (lineNum t) - (f (date t) - (f (flag t) - (f (number t) - (f (payee t) - (f (account t) - (f (postingDrCr t) - (f (postingCmdty t) - (f (postingQty t) - (f (totalDrCr t) - (f (totalCmdty t) - (f (totalQty t) - (f (tags t) - (f (memo t) - (f (filename t) z)))))))))))))))))))))))))))) - - -fieldNames :: Fields String -fieldNames = Fields - { globalTransaction = "globalTransaction" - , revGlobalTransaction = "revGlobalTransaction" - , globalPosting = "globalPosting" - , revGlobalPosting = "revGlobalPosting" - , fileTransaction = "fileTransaction" - , revFileTransaction = "revFileTransaction" - , filePosting = "filePosting" - , revFilePosting = "revFilePosting" - , filtered = "filtered" - , revFiltered = "revFiltered" - , sorted = "sorted" - , revSorted = "revSorted" - , visible = "visible" - , revVisible = "revVisible" - , lineNum = "lineNum" - , date = "date" - , flag = "flag" - , number = "number" - , payee = "payee" - , account = "account" - , postingDrCr = "postingDrCr" - , postingCmdty = "postingCmdty" - , postingQty = "postingQty" - , totalDrCr = "totalDrCr" - , totalCmdty = "totalCmdty" - , totalQty = "totalQty" - , tags = "tags" - , memo = "memo" - , filename = "filename" - } diff --git a/Penny/Cabin/Posts/Growers.hs b/Penny/Cabin/Posts/Growers.hs deleted file mode 100644 --- a/Penny/Cabin/Posts/Growers.hs +++ /dev/null @@ -1,596 +0,0 @@ --- | Calculates cells that "grow to fit." These cells grow to fit the --- widest cell in the column. No information is ever truncated from --- these cells (what use is a truncated dollar amount?) -module Penny.Cabin.Posts.Growers ( - GrowOpts(..), - growCells, Fields(..), grownWidth, - eFields, EFields(..), pairWithSpacer) where - -import Control.Applicative((<$>), Applicative(pure, (<*>))) -import qualified Data.Foldable as Fdbl -import Data.Map (elems) -import qualified Data.Map as Map -import qualified Data.Semigroup as Semi -import Data.Semigroup ((<>)) -import Data.Text (Text, pack, empty) -import qualified Data.Text as X -import qualified Penny.Cabin.Posts.Fields as F -import qualified Penny.Cabin.Posts.Meta as M -import Penny.Cabin.Posts.Meta (Box) -import qualified Penny.Cabin.Posts.Spacers as S -import qualified Penny.Cabin.Row as R -import qualified Penny.Cabin.Scheme as E -import qualified Penny.Liberty as Ly -import qualified Penny.Lincoln as L -import qualified Penny.Lincoln.Queries as Q -import qualified System.Console.Rainbow as Rb - - --- | All the options needed to grow the cells. -data GrowOpts = GrowOpts - { dateFormat :: Box -> X.Text - , qtyFormat :: Box -> X.Text - , balanceFormat :: L.Commodity -> L.Qty -> X.Text - , fields :: F.Fields Bool - } - --- | Grows the cells that will be GrowToFit cells in the report. First --- this function fills in all visible cells with text, but leaves the --- width undetermined. Then it determines the widest line in each --- column. Finally it adjusts each cell in the column so that it is --- that maximum width. --- --- Returns a list of rows, and a Fields holding the width of each --- cell. Each of these widths will be at least 1; fields that were in --- the report but that ended up having no width are changed to --- Nothing. -growCells - :: E.Changers - -> GrowOpts - -> [Box] - -> Fields (Maybe ([R.ColumnSpec], Int)) -growCells ch o infos = toPair <$> wanted <*> growers where - toPair b gwr - | b = - let cs = map (gwr o ch) infos - w = Fdbl.foldl' f 0 cs where - f acc c = max acc (widestLine c) - cs' = map (sizer (R.Width w)) cs - in if w > 0 then Just (cs', w) else Nothing - | otherwise = Nothing - wanted = growingFields . fields $ o - -widestLine :: PreSpec -> Int -widestLine (PreSpec _ _ bs) = - case bs of - [] -> 0 - xs -> maximum . map (X.length . Rb.chunkText) $ xs - -data PreSpec = PreSpec { - _justification :: R.Justification - , _padSpec :: (E.Label, E.EvenOdd) - , _bits :: [Rb.Chunk] } - - --- | Given a PreSpec and a width, create a ColumnSpec of the right --- size. -sizer :: R.Width -> PreSpec -> R.ColumnSpec -sizer w (PreSpec j ts bs) = R.ColumnSpec j w ts bs - --- | Makes a left justified cell that is only one line long. The width --- is unset. -oneLine :: E.Changers -> Text -> E.Label -> Box -> PreSpec -oneLine chgrs t lbl b = - let eo = E.fromVisibleNum . M.visibleNum . L.boxMeta $ b - j = R.LeftJustify - md = E.getEvenOddLabelValue lbl eo chgrs - ck = [md $ Rb.plain t] - in PreSpec j (lbl, eo) ck - - --- | Gets a Fields with each field filled with the function that fills --- the cells for that field. -growers :: Fields (GrowOpts -> E.Changers -> Box -> PreSpec) -growers = Fields - { globalTransaction = const getGlobalTransaction - , revGlobalTransaction = const getRevGlobalTransaction - , globalPosting = const getGlobalPosting - , revGlobalPosting = const getRevGlobalPosting - , fileTransaction = const getFileTransaction - , revFileTransaction = const getRevFileTransaction - , filePosting = const getFilePosting - , revFilePosting = const getRevFilePosting - , filtered = const getFiltered - , revFiltered = const getRevFiltered - , sorted = const getSorted - , revSorted = const getRevSorted - , visible = const getVisible - , revVisible = const getRevVisible - , lineNum = const getLineNum - , date = \o ch -> getDate ch (dateFormat o) - , flag = const getFlag - , number = const getNumber - , postingDrCr = const getPostingDrCr - , postingCmdty = const getPostingCmdty - , postingQty = \o ch -> getPostingQty ch (qtyFormat o) - , totalDrCr = const getTotalDrCr - , totalCmdty = const getTotalCmdty - , totalQty = \o ch -> getTotalQty ch (balanceFormat o) - } - --- | Make a left justified cell one line long that shows a serial. -serialCellMaybe - :: E.Changers - -> (L.PostFam -> Maybe Int) - -- ^ When applied to a Box, this function returns Just Int if the - -- box has a serial, or Nothing if not. - - -> Box -> PreSpec -serialCellMaybe chgrs f b = oneLine chgrs t E.Other b - where - t = case f (L.boxPostFam b) of - Nothing -> X.empty - Just i -> X.pack . show $ i - -serialCell - :: E.Changers - -> (M.PostMeta -> Int) - -> Box -> PreSpec -serialCell chgrs f b = oneLine chgrs t E.Other b - where - t = pack . show . f . L.boxMeta $ b - -getGlobalTransaction :: E.Changers -> Box -> PreSpec -getGlobalTransaction chgrs = - serialCellMaybe chgrs (fmap (L.forward . L.unGlobalTransaction) - . Q.globalTransaction) - -getRevGlobalTransaction :: E.Changers -> Box -> PreSpec -getRevGlobalTransaction chgrs = - serialCellMaybe chgrs (fmap (L.backward . L.unGlobalTransaction) - . Q.globalTransaction) - -getGlobalPosting :: E.Changers -> Box -> PreSpec -getGlobalPosting chgrs = - serialCellMaybe chgrs (fmap (L.forward . L.unGlobalPosting) - . Q.globalPosting) - -getRevGlobalPosting :: E.Changers -> Box -> PreSpec -getRevGlobalPosting chgrs = - serialCellMaybe chgrs (fmap (L.backward . L.unGlobalPosting) - . Q.globalPosting) - -getFileTransaction :: E.Changers -> Box -> PreSpec -getFileTransaction chgrs = - serialCellMaybe chgrs (fmap (L.forward . L.unFileTransaction) - . Q.fileTransaction) - -getRevFileTransaction :: E.Changers -> Box -> PreSpec -getRevFileTransaction chgrs = - serialCellMaybe chgrs (fmap (L.backward . L.unFileTransaction) - . Q.fileTransaction) - -getFilePosting :: E.Changers -> Box -> PreSpec -getFilePosting chgrs = - serialCellMaybe chgrs (fmap (L.forward . L.unFilePosting) - . Q.filePosting) - -getRevFilePosting :: E.Changers -> Box -> PreSpec -getRevFilePosting chgrs = - serialCellMaybe chgrs (fmap (L.backward . L.unFilePosting) - . Q.filePosting) - -getSorted :: E.Changers -> Box -> PreSpec -getSorted chgrs = - serialCell chgrs (L.forward . Ly.unSortedNum . M.sortedNum) - -getRevSorted :: E.Changers -> Box -> PreSpec -getRevSorted chgrs = - serialCell chgrs (L.backward . Ly.unSortedNum . M.sortedNum) - -getFiltered :: E.Changers -> Box -> PreSpec -getFiltered chgrs = - serialCell chgrs (L.forward . Ly.unFilteredNum . M.filteredNum) - -getRevFiltered :: E.Changers -> Box -> PreSpec -getRevFiltered chgrs = - serialCell chgrs (L.backward . Ly.unFilteredNum . M.filteredNum) - -getVisible :: E.Changers -> Box -> PreSpec -getVisible chgrs = - serialCell chgrs (L.forward . M.unVisibleNum . M.visibleNum) - -getRevVisible :: E.Changers -> Box -> PreSpec -getRevVisible chgrs = - serialCell chgrs (L.backward . M.unVisibleNum . M.visibleNum) - - -getLineNum :: E.Changers -> Box -> PreSpec -getLineNum chgrs b = oneLine chgrs t E.Other b where - lineTxt = pack . show . L.unPostingLine - t = maybe empty lineTxt (Q.postingLine . L.boxPostFam $ b) - -getDate :: E.Changers -> (Box -> X.Text) -> Box -> PreSpec -getDate chgrs gd b = oneLine chgrs (gd b) E.Other b - -getFlag :: E.Changers -> Box -> PreSpec -getFlag chgrs i = oneLine chgrs t E.Other i where - t = maybe empty L.text (Q.flag . L.boxPostFam $ i) - -getNumber :: E.Changers -> Box -> PreSpec -getNumber chgrs i = oneLine chgrs t E.Other i where - t = maybe empty L.text (Q.number . L.boxPostFam $ i) - -dcTxt :: L.DrCr -> Text -dcTxt L.Debit = X.singleton '<' -dcTxt L.Credit = X.singleton '>' - --- | Gives a one-line cell that is colored according to whether the --- posting is a debit or credit. -coloredPostingCell :: E.Changers -> Text -> Box -> PreSpec -coloredPostingCell chgrs t i = PreSpec j (lbl, eo) [bit] where - j = R.LeftJustify - lbl = case Q.drCr . L.boxPostFam $ i of - L.Debit -> E.Debit - L.Credit -> E.Credit - eo = E.fromVisibleNum . M.visibleNum . L.boxMeta $ i - md = E.getEvenOddLabelValue lbl eo chgrs - bit = md $ Rb.plain t - - -getPostingDrCr :: E.Changers -> Box -> PreSpec -getPostingDrCr ch i = coloredPostingCell ch t i where - t = dcTxt . Q.drCr . L.boxPostFam $ i - -getPostingCmdty :: E.Changers -> Box -> PreSpec -getPostingCmdty ch i = coloredPostingCell ch t i where - t = L.unCommodity . Q.commodity . L.boxPostFam $ i - -getPostingQty :: E.Changers -> (Box -> X.Text) -> Box -> PreSpec -getPostingQty ch qf i = coloredPostingCell ch (qf i) i - -getTotalDrCr :: E.Changers -> Box -> PreSpec -getTotalDrCr ch i = - let vn = M.visibleNum . L.boxMeta $ i - ps = (lbl, eo) - dc = Q.drCr . L.boxPostFam $ i - lbl = E.dcToLbl dc - eo = E.fromVisibleNum vn - bal = L.unBalance . M.balance . L.boxMeta $ i - md = E.getEvenOddLabelValue lbl eo ch - bits = - if Map.null bal - then [md . Rb.plain $ pack "--"] - else let mkChk e = E.bottomLineToDrCr e eo ch - in fmap mkChk . elems $ bal - j = R.LeftJustify - in PreSpec j ps bits - -getTotalCmdty :: E.Changers -> Box -> PreSpec -getTotalCmdty ch i = - let vn = M.visibleNum . L.boxMeta $ i - j = R.RightJustify - ps = (lbl, eo) - dc = Q.drCr . L.boxPostFam $ i - eo = E.fromVisibleNum vn - lbl = E.dcToLbl dc - bal = Map.toList . L.unBalance . M.balance . L.boxMeta $ i - preChunks = E.balancesToCmdtys ch eo bal - in PreSpec j ps preChunks - -getTotalQty - :: E.Changers - -> (L.Commodity -> L.Qty -> X.Text) - -> Box - -> PreSpec -getTotalQty ch balFmt i = - let vn = M.visibleNum . L.boxMeta $ i - j = R.LeftJustify - dc = Q.drCr . L.boxPostFam $ i - ps = (E.dcToLbl dc, eo) - eo = E.fromVisibleNum vn - bal = Map.toList . L.unBalance . M.balance . L.boxMeta $ i - preChunks = E.balanceToQtys ch balFmt eo bal - in PreSpec j ps preChunks - -growingFields :: F.Fields Bool -> Fields Bool -growingFields f = Fields - { globalTransaction = F.globalTransaction f - , revGlobalTransaction = F.revGlobalTransaction f - , globalPosting = F.globalPosting f - , revGlobalPosting = F.revGlobalPosting f - , fileTransaction = F.fileTransaction f - , revFileTransaction = F.revFileTransaction f - , filePosting = F.filePosting f - , revFilePosting = F.revFilePosting f - , filtered = F.filtered f - , revFiltered = F.revFiltered f - , sorted = F.sorted f - , revSorted = F.revSorted f - , visible = F.visible f - , revVisible = F.revVisible f - , lineNum = F.lineNum f - , date = F.date f - , flag = F.flag f - , number = F.number f - , postingDrCr = F.postingDrCr f - , postingCmdty = F.postingCmdty f - , postingQty = F.postingQty f - , totalDrCr = F.totalDrCr f - , totalCmdty = F.totalCmdty f - , totalQty = F.totalQty f } - --- | All growing fields, as an ADT. -data EFields = - EGlobalTransaction - | ERevGlobalTransaction - | EGlobalPosting - | ERevGlobalPosting - | EFileTransaction - | ERevFileTransaction - | EFilePosting - | ERevFilePosting - | EFiltered - | ERevFiltered - | ESorted - | ERevSorted - | EVisible - | ERevVisible - | ELineNum - | EDate - | EFlag - | ENumber - | EPostingDrCr - | EPostingCmdty - | EPostingQty - | ETotalDrCr - | ETotalCmdty - | ETotalQty - deriving (Show, Eq, Ord, Enum) - --- | Returns a Fields where each record has its corresponding EField. -eFields :: Fields EFields -eFields = Fields - { globalTransaction = EGlobalTransaction - , revGlobalTransaction = ERevGlobalTransaction - , globalPosting = EGlobalPosting - , revGlobalPosting = ERevGlobalPosting - , fileTransaction = EFileTransaction - , revFileTransaction = ERevFileTransaction - , filePosting = EFilePosting - , revFilePosting = ERevFilePosting - , filtered = EFiltered - , revFiltered = ERevFiltered - , sorted = ESorted - , revSorted = ERevSorted - , visible = EVisible - , revVisible = ERevVisible - , lineNum = ELineNum - , date = EDate - , flag = EFlag - , number = ENumber - , postingDrCr = EPostingDrCr - , postingCmdty = EPostingCmdty - , postingQty = EPostingQty - , totalDrCr = ETotalDrCr - , totalCmdty = ETotalCmdty - , totalQty = ETotalQty } - --- | All growing fields. -data Fields a = Fields - { globalTransaction :: a - , revGlobalTransaction :: a - , globalPosting :: a - , revGlobalPosting :: a - , fileTransaction :: a - , revFileTransaction :: a - , filePosting :: a - , revFilePosting :: a - , filtered :: a - , revFiltered :: a - , sorted :: a - , revSorted :: a - , visible :: a - , revVisible :: a - , lineNum :: a - -- ^ The line number from the posting's metadata - , date :: a - , flag :: a - , number :: a - , postingDrCr :: a - , postingCmdty :: a - , postingQty :: a - , totalDrCr :: a - , totalCmdty :: a - , totalQty :: a } - deriving (Show, Eq) - -instance Fdbl.Foldable Fields where - foldr f z i = - f (globalTransaction i) - (f (revGlobalTransaction i) - (f (globalPosting i) - (f (revGlobalPosting i) - (f (fileTransaction i) - (f (revFileTransaction i) - (f (filePosting i) - (f (revFilePosting i) - (f (filtered i) - (f (revFiltered i) - (f (sorted i) - (f (revSorted i) - (f (visible i) - (f (revVisible i) - (f (lineNum i) - (f (date i) - (f (flag i) - (f (number i) - (f (postingDrCr i) - (f (postingCmdty i) - (f (postingQty i) - (f (totalDrCr i) - (f (totalCmdty i) - (f (totalQty i) z))))))))))))))))))))))) - -instance Functor Fields where - fmap f i = Fields - { globalTransaction = f (globalTransaction i) - , revGlobalTransaction = f (revGlobalTransaction i) - , globalPosting = f (globalPosting i) - , revGlobalPosting = f (revGlobalPosting i) - , fileTransaction = f (fileTransaction i) - , revFileTransaction = f (revFileTransaction i) - , filePosting = f (filePosting i) - , revFilePosting = f (revFilePosting i) - , filtered = f (filtered i) - , revFiltered = f (revFiltered i) - , sorted = f (sorted i) - , revSorted = f (revSorted i) - , visible = f (visible i) - , revVisible = f (revVisible i) - , lineNum = f (lineNum i) - , date = f (date i) - , flag = f (flag i) - , number = f (number i) - , postingDrCr = f (postingDrCr i) - , postingCmdty = f (postingCmdty i) - , postingQty = f (postingQty i) - , totalDrCr = f (totalDrCr i) - , totalCmdty = f (totalCmdty i) - , totalQty = f (totalQty i) } - -instance Applicative Fields where - pure a = Fields - { globalTransaction = a - , revGlobalTransaction = a - , globalPosting = a - , revGlobalPosting = a - , fileTransaction = a - , revFileTransaction = a - , filePosting = a - , revFilePosting = a - , filtered = a - , revFiltered = a - , sorted = a - , revSorted = a - , visible = a - , revVisible = a - , lineNum = a - , date = a - , flag = a - , number = a - , postingDrCr = a - , postingCmdty = a - , postingQty = a - , totalDrCr = a - , totalCmdty = a - , totalQty = a } - - fl <*> fa = Fields - { globalTransaction = globalTransaction fl (globalTransaction fa) - , revGlobalTransaction = revGlobalTransaction fl (revGlobalTransaction fa) - , globalPosting = globalPosting fl (globalPosting fa) - , revGlobalPosting = revGlobalPosting fl (revGlobalPosting fa) - , fileTransaction = fileTransaction fl (fileTransaction fa) - , revFileTransaction = revFileTransaction fl (revFileTransaction fa) - , filePosting = filePosting fl (filePosting fa) - , revFilePosting = revFilePosting fl (revFilePosting fa) - , filtered = filtered fl (filtered fa) - , revFiltered = revFiltered fl (revFiltered fa) - , sorted = sorted fl (sorted fa) - , revSorted = revSorted fl (revSorted fa) - , visible = visible fl (visible fa) - , revVisible = revVisible fl (revVisible fa) - , lineNum = lineNum fl (lineNum fa) - , date = date fl (date fa) - , flag = flag fl (flag fa) - , number = number fl (number fa) - , postingDrCr = postingDrCr fl (postingDrCr fa) - , postingCmdty = postingCmdty fl (postingCmdty fa) - , postingQty = postingQty fl (postingQty fa) - , totalDrCr = totalDrCr fl (totalDrCr fa) - , totalCmdty = totalCmdty fl (totalCmdty fa) - , totalQty = totalQty fl (totalQty fa) } - --- | Pairs data from a Fields with its matching spacer field. The --- spacer field is returned in a Maybe because the TotalQty field does --- not have a spacer. -pairWithSpacer :: Fields a -> S.Spacers b -> Fields (a, Maybe b) -pairWithSpacer f s = Fields { - globalTransaction = (globalTransaction f, Just (S.globalTransaction s)) - , revGlobalTransaction = (revGlobalTransaction f, Just (S.revGlobalTransaction s)) - , globalPosting = (globalPosting f, Just (S.globalPosting s)) - , revGlobalPosting = (revGlobalPosting f, Just (S.revGlobalPosting s)) - , fileTransaction = (fileTransaction f, Just (S.fileTransaction s)) - , revFileTransaction = (revFileTransaction f, Just (S.revFileTransaction s)) - , filePosting = (filePosting f, Just (S.filePosting s)) - , revFilePosting = (revFilePosting f, Just (S.revFilePosting s)) - , filtered = (filtered f, Just (S.filtered s)) - , revFiltered = (revFiltered f, Just (S.revFiltered s)) - , sorted = (sorted f, Just (S.sorted s)) - , revSorted = (revSorted f, Just (S.revSorted s)) - , visible = (visible f, Just (S.visible s)) - , revVisible = (revVisible f, Just (S.revVisible s)) - , lineNum = (lineNum f, Just (S.lineNum s)) - , date = (date f, Just (S.date s)) - , flag = (flag f, Just (S.flag s)) - , number = (number f, Just (S.number s)) - , postingDrCr = (postingDrCr f, Just (S.postingDrCr s)) - , postingCmdty = (postingCmdty f, Just (S.postingCmdty s)) - , postingQty = (postingQty f, Just (S.postingQty s)) - , totalDrCr = (totalDrCr f, Just (S.totalDrCr s)) - , totalCmdty = (totalCmdty f, Just (S.totalCmdty s)) - , totalQty = (totalQty f, Nothing ) } - --- | Reduces a set of Fields to a single value. -reduce :: Semi.Semigroup s => Fields s -> s -reduce f = - globalTransaction f - <> revGlobalTransaction f - <> globalPosting f - <> revGlobalPosting f - <> fileTransaction f - <> revFileTransaction f - <> filePosting f - <> revFilePosting f - <> filtered f - <> revFiltered f - <> sorted f - <> revSorted f - <> visible f - <> revVisible f - <> lineNum f - <> date f - <> flag f - <> number f - <> postingDrCr f - <> postingCmdty f - <> postingQty f - <> totalDrCr f - <> totalCmdty f - <> totalQty f - --- | Compute the width of all Grown cells, including any applicable --- spacer cells. -grownWidth :: - Fields (Maybe Int) - -> S.Spacers Int - -> Int -grownWidth fs ss = - Semi.getSum - . reduce - . fmap Semi.Sum - . fmap fieldWidth - $ pairWithSpacer fs ss - --- | Compute the field width of a single field and its spacer. The --- first element of the tuple is the field width, if present; the --- second element of the tuple is the width of the spacer. If there is --- no field, returns 0. -fieldWidth :: (Maybe Int, Maybe Int) -> Int -fieldWidth (m1, m2) = case m1 of - Nothing -> 0 - Just i1 -> case m2 of - Just i2 -> if i2 > 0 then i1 + i2 else i1 - Nothing -> i1 - diff --git a/Penny/Cabin/Posts/Meta.hs b/Penny/Cabin/Posts/Meta.hs deleted file mode 100644 --- a/Penny/Cabin/Posts/Meta.hs +++ /dev/null @@ -1,79 +0,0 @@ -module Penny.Cabin.Posts.Meta ( - M.VisibleNum(M.unVisibleNum) - , PostMeta(filteredNum, sortedNum, visibleNum, balance) - , Box - , toBoxList - ) where - -import Data.List (mapAccumL) -import qualified Penny.Lincoln as L -import qualified Penny.Lincoln.Queries as Q -import qualified Penny.Liberty as Ly -import qualified Penny.Cabin.Meta as M -import qualified Penny.Cabin.Options as CO -import qualified Data.Prednote.Pdct as Pe -import Data.Monoid (mempty, mappend) - --- | The Box type that is used throughout the Posts modules. -type Box = L.Box PostMeta - -data PostMeta = - PostMeta { filteredNum :: Ly.FilteredNum - , sortedNum :: Ly.SortedNum - , visibleNum :: M.VisibleNum - , balance :: L.Balance } - deriving Show - - -addMetadata :: - [(L.Box (Ly.LibertyMeta, L.Balance))] - -> [Box] -addMetadata = M.visibleNumBoxes f where - f vn (lm, b) = - PostMeta (Ly.filteredNum lm) (Ly.sortedNum lm) vn b - --- | Adds appropriate metadata, including the running balance, to a --- list of Box. Because all posts are incorporated into the running --- balance, first calculates the running balance for all posts. Then, --- removes posts we're not interested in by applying the predicate and --- the post-filter. Finally, adds on the metadata, which will include --- the VisibleNum. -toBoxList :: - CO.ShowZeroBalances - -> Pe.Pdct (L.Box Ly.LibertyMeta) - -- ^ Removes posts from the report if applying this function to the - -- post returns a value other than Just True. Posts removed still - -- affect the running balance. - - -> [Ly.PostFilterFn] - -- ^ Applies these post-filters to the list of posts that results - -- from applying the predicate above. Might remove more - -- postings. Postings removed still affect the running balance. - - -> [L.Box Ly.LibertyMeta] - -> [Box] -toBoxList szb pdct pff = - addMetadata - . Ly.processPostFilters pff - . filter (maybe False id . Pe.eval pdct . fmap fst) - . addBalances szb - -addBalances :: - CO.ShowZeroBalances - -> [L.Box Ly.LibertyMeta] - -> [(L.Box (Ly.LibertyMeta, L.Balance))] -addBalances szb = snd . mapAccumL (balanceAccum szb) mempty - -balanceAccum :: - CO.ShowZeroBalances - -> L.Balance - -> L.Box Ly.LibertyMeta - -> (L.Balance, (L.Box (Ly.LibertyMeta, L.Balance))) -balanceAccum (CO.ShowZeroBalances szb) balOld po = - let balThis = L.entryToBalance . Q.entry . L.boxPostFam $ po - balNew = mappend balOld balThis - balNoZeroes = L.removeZeroCommodities balNew - bal' = if szb then balNew else balNoZeroes - po' = L.Box (L.boxMeta po, bal') (L.boxPostFam po) - in (bal', po') - diff --git a/Penny/Cabin/Posts/Parser.hs b/Penny/Cabin/Posts/Parser.hs deleted file mode 100644 --- a/Penny/Cabin/Posts/Parser.hs +++ /dev/null @@ -1,285 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Penny.Cabin.Posts.Parser - ( State(..) - , allSpecs - , VerboseFilter(..) - , ShowExpression(..) - ) where - -import Control.Applicative ((<$>), pure, (<*>), - Applicative) -import qualified Control.Monad.Exception.Synchronous as Ex -import Data.Char (toLower) -import qualified Data.Foldable as Fdbl -import Data.Monoid ((<>)) -import Data.Text (Text) -import qualified Data.Text as X -import qualified System.Console.MultiArg.Combinator as C -import qualified System.Console.MultiArg as MA - -import qualified Penny.Cabin.Parsers as P -import qualified Penny.Cabin.Posts.Fields as F -import qualified Penny.Cabin.Posts.Types as Ty -import qualified Penny.Cabin.Options as CO -import qualified Penny.Liberty as Ly -import qualified Data.Prednote.Expressions as Exp -import qualified Data.Prednote.Pdct as Pt -import qualified Penny.Lincoln as L -import qualified Penny.Shield as S -import qualified Text.Matchers as M - -newtype VerboseFilter = VerboseFilter { unVerboseFilter :: Bool } - deriving (Eq, Show) - -newtype ShowExpression = ShowExpression { unShowExpression :: Bool } - deriving (Eq, Show) - -data State = State - { sensitive :: M.CaseSensitive - , factory :: L.Factory - , tokens :: [Exp.Token (L.Box Ly.LibertyMeta)] - , postFilter :: [Ly.PostFilterFn] - , fields :: F.Fields Bool - , width :: Ty.ReportWidth - , showZeroBalances :: CO.ShowZeroBalances - , exprDesc :: Exp.ExprDesc - , verboseFilter :: VerboseFilter - , showExpression :: ShowExpression - } - -type Error = X.Text - -allSpecs - :: S.Runtime -> [MA.OptSpec (State -> Ex.Exceptional Error State)] -allSpecs rt = - operand rt - ++ boxFilters - ++ parsePostFilter - ++ (map (fmap (pure .)) matcherSelect) - ++ (map (fmap (pure .)) caseSelect) - ++ (map (fmap (pure .)) operator) - ++ map (fmap (pure .)) parseExprType - ++ [ parseWidth - , showField - , hideField - , fmap (pure .) showAllFields - , fmap (pure .) hideAllFields - , fmap (pure .) parseZeroBalances - , fmap (pure .) parseShowExpression - , fmap (pure .) parseVerboseFilter - ] - - -operand - :: S.Runtime - -> [MA.OptSpec (State -> Ex.Exceptional Error State)] -operand rt = map (fmap f) (Ly.operandSpecs (S.currentTime rt)) - where - f lyFn st = do - let cs = sensitive st - fty = factory st - g <- lyFn cs fty - let g' = Pt.boxPdct L.boxPostFam g - ts' = tokens st ++ [Exp.operand g'] - return $ st { tokens = ts' } - - --- | Processes a option for box-level serials. -optBoxSerial - :: String - -- ^ Serial name - - -> (Ly.LibertyMeta -> Int) - -- ^ Pulls the serial from the PostMeta - - -> C.OptSpec (State -> Ex.Exceptional Error State) - -optBoxSerial nm f = C.OptSpec [nm] "" (C.TwoArg g) - where - g a1 a2 st = do - i <- Ly.parseInt a2 - let getPd = Pt.compareBy (X.pack . show $ i) - ("serial " <> X.pack nm) cmp - cmp l = compare (f . L.boxMeta $ l) i - pd <- Ly.parseComparer a1 getPd - let tok = Exp.operand pd - return $ st { tokens = tokens st ++ [tok] } - -optFilteredNum :: C.OptSpec (State -> Ex.Exceptional Error State) -optFilteredNum = optBoxSerial "filtered" f - where - f = L.forward . Ly.unFilteredNum . Ly.filteredNum - -optRevFilteredNum :: C.OptSpec (State -> Ex.Exceptional Error State) -optRevFilteredNum = optBoxSerial "revFiltered" f - where - f = L.backward . Ly.unFilteredNum . Ly.filteredNum - -optSortedNum :: C.OptSpec (State -> Ex.Exceptional Error State) -optSortedNum = optBoxSerial "sorted" f - where - f = L.forward . Ly.unSortedNum . Ly.sortedNum - -optRevSortedNum :: C.OptSpec (State -> Ex.Exceptional Error State) -optRevSortedNum = optBoxSerial "revSorted" f - where - f = L.backward . Ly.unSortedNum . Ly.sortedNum - -boxFilters :: [C.OptSpec (State -> Ex.Exceptional Error State)] -boxFilters = - [ optFilteredNum - , optRevFilteredNum - , optSortedNum - , optRevSortedNum - ] - - -parsePostFilter :: [C.OptSpec (State -> Ex.Exceptional Error State)] -parsePostFilter = [fmap f optH, fmap f optT] - where - (optH, optT) = Ly.postFilterSpecs - f exc st = fmap g exc - where - g pff = st { postFilter = postFilter st ++ [pff] } - - -matcherSelect :: [C.OptSpec (State -> State)] -matcherSelect = map (fmap f) Ly.matcherSelectSpecs - where - f mf st = st { factory = mf } - - -caseSelect :: [C.OptSpec (State -> State)] -caseSelect = map (fmap f) Ly.caseSelectSpecs - where - f cs st = st { sensitive = cs } - -operator :: [C.OptSpec (State -> State)] -operator = map (fmap f) Ly.operatorSpecs - where - f oo st = st { tokens = tokens st ++ [oo] } - -parseWidth :: C.OptSpec (State -> Ex.Exceptional Error State) -parseWidth = C.OptSpec ["width"] "" (C.OneArg f) - where - f a1 st = do - i <- Ly.parseInt a1 - return $ st { width = Ty.ReportWidth i } - -parseField :: String -> Ex.Exceptional Error (F.Fields Bool) -parseField str = - let lower = map toLower str - checkField s = - if (map toLower s) == lower - then (s, True) - else (s, False) - flds = checkField <$> F.fieldNames - in case checkFields flds of - Ex.Exception e -> case e of - NoMatchingFields -> Ex.throw - $ "no field matches the name \"" <> X.pack str <> "\"\n" - MultipleMatchingFields ts -> Ex.throw - $ "multiple fields match the name \"" <> X.pack str - <> "\" matches: " <> mtchs <> "\n" - where - mtchs = X.intercalate " " - . map (\x -> "\"" <> x <> "\"") - $ ts - Ex.Success g -> return g - - --- | Turns a field on if it is True. -fieldOn :: - F.Fields Bool - -- ^ Fields as seen so far - - -> F.Fields Bool - -- ^ Record that should have one True element indicating a field - -- name seen on the command line; other elements should be False - - -> F.Fields Bool - -- ^ Fields as seen so far, with new field added - -fieldOn old new = (||) <$> old <*> new - --- | Turns off a field if it is True. -fieldOff :: - F.Fields Bool - -- ^ Fields seen so far - - -> F.Fields Bool - -- ^ Record that should have one True element indicating a field - -- name seen on the command line; other elements should be False - - -> F.Fields Bool - -- ^ Fields as seen so far, with new field added - -fieldOff old new = f <$> old <*> new - where - f o False = o - f _ True = False - -showField :: C.OptSpec (State -> Ex.Exceptional Error State) -showField = C.OptSpec ["show"] "" (C.OneArg f) - where - f a1 st = do - fl <- parseField a1 - let newFl = fieldOn (fields st) fl - return $ st { fields = newFl } - -hideField :: C.OptSpec (State -> Ex.Exceptional Error State) -hideField = C.OptSpec ["hide"] "" (C.OneArg f) - where - f a1 st = do - fl <- parseField a1 - let newFl = fieldOff (fields st) fl - return $ st { fields = newFl } - -showAllFields :: C.OptSpec (State -> State) -showAllFields = C.OptSpec ["show-all"] "" (C.NoArg f) - where - f st = st {fields = pure True} - -hideAllFields :: C.OptSpec (State -> State) -hideAllFields = C.OptSpec ["hide-all"] "" (C.NoArg f) - where - f st = st {fields = pure False} - -parseZeroBalances :: C.OptSpec (State -> State) -parseZeroBalances = fmap f P.zeroBalances - where - f szb st = st { showZeroBalances = szb } - -parseExprType :: [C.OptSpec (State -> State)] -parseExprType = map (fmap f) [Ly.parseInfix, Ly.parseRPN] - where - f d st = st { exprDesc = d } - -parseShowExpression :: C.OptSpec (State -> State) -parseShowExpression = fmap f Ly.showExpression - where - f _ st = st { showExpression = ShowExpression True } - -parseVerboseFilter :: C.OptSpec (State -> State) -parseVerboseFilter = fmap f Ly.verboseFilter - where - f _ st = st { verboseFilter = VerboseFilter True } - -data BadFieldError - = NoMatchingFields - | MultipleMatchingFields [Text] - deriving Show - --- | Checks the fields with the True value to ensure there is only one. -checkFields :: - F.Fields (String, Bool) - -> Ex.Exceptional BadFieldError (F.Fields Bool) -checkFields fs = - let f (s, b) ls = if b then s:ls else ls - in case Fdbl.foldr f [] fs of - [] -> Ex.throw NoMatchingFields - _:[] -> return (snd <$> fs) - ms -> Ex.throw . MultipleMatchingFields . map X.pack $ ms - - diff --git a/Penny/Cabin/Posts/Spacers.hs b/Penny/Cabin/Posts/Spacers.hs deleted file mode 100644 --- a/Penny/Cabin/Posts/Spacers.hs +++ /dev/null @@ -1,32 +0,0 @@ --- | Spacer fields in the report. They don't contain any data; they --- just provide whitespace. Each spacer immediately follows the named --- field. -module Penny.Cabin.Posts.Spacers where - -data Spacers a = Spacers - { globalTransaction :: a - , revGlobalTransaction :: a - , globalPosting :: a - , revGlobalPosting :: a - , fileTransaction :: a - , revFileTransaction :: a - , filePosting :: a - , revFilePosting :: a - , filtered :: a - , revFiltered :: a - , sorted :: a - , revSorted :: a - , visible :: a - , revVisible :: a - , lineNum :: a - , date :: a - , flag :: a - , number :: a - , payee :: a - , account :: a - , postingDrCr :: a - , postingCmdty :: a - , postingQty :: a - , totalDrCr :: a - , totalCmdty :: a - } deriving (Show, Eq) diff --git a/Penny/Cabin/Posts/Types.hs b/Penny/Cabin/Posts/Types.hs deleted file mode 100644 --- a/Penny/Cabin/Posts/Types.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Penny.Cabin.Posts.Types where - -newtype ReportWidth = ReportWidth { unReportWidth :: Int } - deriving (Eq, Show, Ord) diff --git a/Penny/Cabin/Row.hs b/Penny/Cabin/Row.hs deleted file mode 100644 --- a/Penny/Cabin/Row.hs +++ /dev/null @@ -1,138 +0,0 @@ --- | Displays a single on-screen row. A row may contain multiple --- screen lines and multiple columns. --- --- This module only deals with a single row at a time. Each cell in --- the row can have more than one screen line; this module will make --- sure that the cells have appropriate padding on the bottom so that --- the row appears nicely. This module will also justify each cell so --- that its left side or right side is ragged; however, you first have --- to specify how wide you want the cell to be. --- --- This module is a little dumber than you might first think it could --- be. For instance it would be possible to write a function that --- takes a number of rows and automatically justifies all the cells by --- finding the widest cell in a column. Indeed I might eventually --- write such a function because it might be useful in, for example, --- the multi-commodity balance report. However, such a function would --- not be useful in all cases; in particular, the Posts report is very --- complicated to lay out, and the automatic function described above --- would not do the right thing. --- --- So this module offers some useful automation, even if it is at a --- level that is apparently lower that what is possible. Thus the --- present 'row' function likely will not change, even if eventually I --- add a 'table' function that automatically justifies many rows. -module Penny.Cabin.Row ( - Justification(LeftJustify, RightJustify), - ColumnSpec(ColumnSpec, justification, width, padSpec, bits), - Width(Width, unWidth), - row ) where - -import Data.List (transpose) -import qualified Data.Text as X -import qualified Penny.Cabin.Scheme as E -import qualified System.Console.Rainbow as R - --- | How to justify cells. LeftJustify leaves the right side --- ragged. RightJustify leaves the left side ragged. -data Justification = - LeftJustify - | RightJustify - deriving Show - --- | A cell of text output. You tell the cell how to justify itself --- and how wide it is. You also tell it the background colors to --- use. The cell will be appropriately justified (that is, text --- aligned between left and right margins) and padded (with lines of --- blank text added on the bottom as needed) when joined with other --- cells into a Row. -data ColumnSpec = - ColumnSpec { justification :: Justification - , width :: Width - , padSpec :: (E.Label, E.EvenOdd) - , bits :: [R.Chunk] } - -newtype JustifiedCell = JustifiedCell (R.Chunk, R.Chunk) - -data JustifiedColumn = JustifiedColumn { - justifiedCells :: [JustifiedCell] - , _justifiedWidth :: Width - , _justifiedPadSpec :: (E.Label, E.EvenOdd) } - -newtype PaddedColumns = PaddedColumns [[JustifiedCell]] -newtype CellsByRow = CellsByRow [[JustifiedCell]] -newtype CellRowsWithNewlines = CellRowsWithNewlines [[JustifiedCell]] -newtype Width = Width { unWidth :: Int } - deriving (Eq, Ord, Show) - -justify - :: Width - -> Justification - -> E.Label - -> E.EvenOdd - -> E.Changers - -> R.Chunk - -> JustifiedCell -justify (Width w) j l eo chgrs pc = JustifiedCell (left, right) - where - origWidth = X.length . R.chunkText $ pc - pad = E.getEvenOddLabelValue l eo chgrs $ R.plain t - t = X.replicate (max 0 (w - origWidth)) (X.singleton ' ') - (left, right) = case j of - LeftJustify -> (pc, pad) - RightJustify -> (pad, pc) - -newtype Height = Height Int - deriving (Show, Eq, Ord) - -height :: [[a]] -> Height -height xs = case xs of - [] -> Height 0 - ls -> Height . maximum . map length $ ls - -row :: E.Changers -> [ColumnSpec] -> [R.Chunk] -row chgrs = - concat - . concat - . toBits - . toCellRowsWithNewlines - . toCellsByRow - . bottomPad chgrs - . map (justifiedColumn chgrs) - -justifiedColumn :: E.Changers -> ColumnSpec -> JustifiedColumn -justifiedColumn chgrs (ColumnSpec j w (l, eo) bs) - = JustifiedColumn cs w (l, eo) - where - cs = map (justify w j l eo chgrs) bs - -bottomPad :: E.Changers -> [JustifiedColumn] -> PaddedColumns -bottomPad chgrs jcs = PaddedColumns pcs where - justCells = map justifiedCells jcs - (Height h) = height justCells - pcs = map toPaddedColumn jcs - toPaddedColumn (JustifiedColumn cs (Width w) (lbl, eo)) = - let l = length cs - nPads = max 0 $ h - l - pad = E.getEvenOddLabelValue lbl eo chgrs $ R.plain t - t = X.replicate w (X.singleton ' ') - pads = replicate nPads $ JustifiedCell (R.plain X.empty, pad) - in cs ++ pads - - -toCellsByRow :: PaddedColumns -> CellsByRow -toCellsByRow (PaddedColumns cs) = CellsByRow (transpose cs) - - -toCellRowsWithNewlines :: CellsByRow -> CellRowsWithNewlines -toCellRowsWithNewlines (CellsByRow bs) = - CellRowsWithNewlines bs' where - bs' = foldr f [] bs - newline = JustifiedCell (R.plain X.empty, R.plain (X.singleton '\n')) - f cells acc = (cells ++ [newline]) : acc - - -toBits :: CellRowsWithNewlines -> [[[R.Chunk]]] -toBits (CellRowsWithNewlines cs) = map (map toB) cs where - toB (JustifiedCell (c1, c2)) = [c1, c2] - diff --git a/Penny/Cabin/Scheme.hs b/Penny/Cabin/Scheme.hs deleted file mode 100644 --- a/Penny/Cabin/Scheme.hs +++ /dev/null @@ -1,140 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} --- | Cabin color schemes --- --- Each element of a Cabin report identifies what it is--a debit on an --- even line, a credit on an odd line, etc. The user can have several --- color schemes; the scheme contains color assignments for 8 and 256 --- color terminals. This allows the use of different schemes for light --- and dark terminals or for any other reason. - -module Penny.Cabin.Scheme where - -import qualified Penny.Cabin.Meta as M -import qualified Penny.Lincoln as L -import qualified Data.Text as X -import qualified System.Console.Rainbow as R - -data Label - = Debit - | Credit - | Zero - | Other - deriving (Eq, Ord, Show) - -data EvenOdd = Even | Odd deriving (Eq, Ord, Show) - -data Labels a = Labels - { debit :: a - , credit :: a - , zero :: a - , other :: a - } deriving Show - -getLabelValue :: Label -> Labels a -> a -getLabelValue l ls = case l of - Debit -> debit ls - Credit -> credit ls - Zero -> zero ls - Other -> other ls - -data EvenAndOdd a = EvenAndOdd - { eoEven :: a - , eoOdd :: a - } deriving Show - -type Changers = Labels (EvenAndOdd (R.Chunk -> R.Chunk)) - -data Scheme = Scheme - { name :: String - -- ^ The name of this scheme. How it will be identified on the - -- command line. - - , description :: String - -- ^ A brief (one-line) description of what this scheme is, such - -- as @for dark background terminals@ - - , changers :: Changers - } deriving Show - - -getEvenOdd :: EvenOdd -> EvenAndOdd a -> a -getEvenOdd eo eao = case eo of - Even -> eoEven eao - Odd -> eoOdd eao - -getEvenOddLabelValue - :: Label - -> EvenOdd - -> Labels (EvenAndOdd a) - -> a -getEvenOddLabelValue l eo ls = - getEvenOdd eo (getLabelValue l ls) - -fromVisibleNum :: M.VisibleNum -> EvenOdd -fromVisibleNum vn = - let s = M.unVisibleNum vn in - if even . L.forward $ s then Even else Odd - -dcToLbl :: L.DrCr -> Label -dcToLbl L.Debit = Debit -dcToLbl L.Credit = Credit - -bottomLineToDrCr :: L.BottomLine -> EvenOdd -> Changers -> R.Chunk -bottomLineToDrCr bl eo chgrs = md c - where - (c, md) = case bl of - L.Zero -> (R.plain "--", getEvenOddLabelValue Zero eo chgrs) - L.NonZero (L.Column clmDrCr _) -> case clmDrCr of - L.Debit -> (R.plain "<", getEvenOddLabelValue Debit eo chgrs) - L.Credit -> (R.plain ">", getEvenOddLabelValue Credit eo chgrs) - - -balancesToCmdtys - :: Changers - -> EvenOdd - -> [(L.Commodity, L.BottomLine)] - -> [R.Chunk] -balancesToCmdtys chgrs eo ls = - if null ls - then [getEvenOddLabelValue Zero eo chgrs $ R.plain "--"] - else map (bottomLineToCmdty chgrs eo) ls - -bottomLineToCmdty - :: Changers - -> EvenOdd - -> (L.Commodity, L.BottomLine) - -> R.Chunk -bottomLineToCmdty chgrs eo (cy, bl) = md c - where - c = R.plain . L.unCommodity $ cy - lbl = case bl of - L.Zero -> Zero - L.NonZero (L.Column clmDrCr _) -> dcToLbl clmDrCr - md = getEvenOddLabelValue lbl eo chgrs - -balanceToQtys - :: Changers - -> (L.Commodity -> L.Qty -> X.Text) - -> EvenOdd - -> [(L.Commodity, L.BottomLine)] - -> [R.Chunk] -balanceToQtys chgrs getTxt eo ls = - if null ls - then let md = getEvenOddLabelValue Zero eo chgrs - in [md (R.plain "--")] - else map (bottomLineToQty chgrs getTxt eo) ls - - -bottomLineToQty - :: Changers - -> (L.Commodity -> L.Qty -> X.Text) - -> EvenOdd - -> (L.Commodity, L.BottomLine) - -> R.Chunk -bottomLineToQty chgrs getTxt eo (cy, bl) = md (R.plain t) - where - (lbl, t) = case bl of - L.Zero -> (Zero, X.pack "--") - L.NonZero (L.Column clmDrCr qt) -> (dcToLbl clmDrCr, getTxt cy qt) - md = getEvenOddLabelValue lbl eo chgrs - diff --git a/Penny/Cabin/Scheme/Schemes.hs b/Penny/Cabin/Scheme/Schemes.hs deleted file mode 100644 --- a/Penny/Cabin/Scheme/Schemes.hs +++ /dev/null @@ -1,87 +0,0 @@ --- | Some schemes you can use. - -module Penny.Cabin.Scheme.Schemes where - -import qualified Penny.Cabin.Scheme as E -import qualified System.Console.Rainbow as R -import System.Console.Rainbow ((.+.)) - --- | The light color scheme. You can change various values below to --- affect the color scheme. -light :: E.Scheme -light = E.Scheme "light" "for light background terminals" - lightLabels - -lightLabels :: E.Labels (E.EvenAndOdd (R.Chunk -> R.Chunk)) -lightLabels = E.Labels - { E.debit = E.EvenAndOdd { E.eoEven = lightDebit lightEvenTextSpec - , E.eoOdd = lightDebit lightOddTextSpec } - , E.credit = E.EvenAndOdd { E.eoEven = lightCredit lightEvenTextSpec - , E.eoOdd = lightCredit lightOddTextSpec } - , E.zero = E.EvenAndOdd { E.eoEven = lightZero lightEvenTextSpec - , E.eoOdd = lightZero lightOddTextSpec } - , E.other = E.EvenAndOdd { E.eoEven = lightEvenTextSpec - , E.eoOdd = lightOddTextSpec } - } - -lightEvenTextSpec :: R.Chunk -> R.Chunk -lightEvenTextSpec = id - -lightOddTextSpec :: R.Chunk -> R.Chunk -lightOddTextSpec = id .+. R.color8_b_default .+. R.color256_b_255 - -lightDebit :: (R.Chunk -> R.Chunk) -> R.Chunk -> R.Chunk -lightDebit f = f .+. R.color8_f_magenta .+. R.color256_f_52 - -lightCredit :: (R.Chunk -> R.Chunk) -> R.Chunk -> R.Chunk -lightCredit f = f .+. R.color8_f_cyan .+. R.color256_f_21 - -lightZero :: (R.Chunk -> R.Chunk) -> R.Chunk -> R.Chunk -lightZero f = f .+. R.color8_f_black .+. R.color256_f_0 - --- | The dark color scheme. You can change various values below to --- affect the color scheme. -dark :: E.Scheme -dark = E.Scheme "dark" "for dark background terminals" - darkLabels - -darkLabels :: E.Labels (E.EvenAndOdd (R.Chunk -> R.Chunk)) -darkLabels = E.Labels - { E.debit = E.EvenAndOdd { E.eoEven = darkDebit darkEvenTextSpec - , E.eoOdd = darkDebit darkOddTextSpec } - , E.credit = E.EvenAndOdd { E.eoEven = darkCredit darkEvenTextSpec - , E.eoOdd = darkCredit darkOddTextSpec } - , E.zero = E.EvenAndOdd { E.eoEven = darkZero darkEvenTextSpec - , E.eoOdd = darkZero darkOddTextSpec } - , E.other = E.EvenAndOdd { E.eoEven = darkEvenTextSpec - , E.eoOdd = darkOddTextSpec } - } - -darkEvenTextSpec :: R.Chunk -> R.Chunk -darkEvenTextSpec = id - -darkOddTextSpec :: R.Chunk -> R.Chunk -darkOddTextSpec = id .+. R.color8_b_default .+. R.color256_b_235 - -darkDebit :: (R.Chunk -> R.Chunk) -> R.Chunk -> R.Chunk -darkDebit f = f .+. R.color8_f_magenta .+. R.color256_f_208 - -darkCredit :: (R.Chunk -> R.Chunk) -> R.Chunk -> R.Chunk -darkCredit f = f .+. R.color8_f_cyan .+. R.color256_f_45 - -darkZero :: (R.Chunk -> R.Chunk) -> R.Chunk -> R.Chunk -darkZero f = f .+. R.color8_f_white .+. R.color256_f_15 - --- | Plain scheme has no colors at all. -plain :: E.Scheme -plain = E.Scheme "plain" "uses default terminal colors" - plainLabels - -plainLabels :: E.Labels (E.EvenAndOdd (R.Chunk -> R.Chunk)) -plainLabels = E.Labels - { E.debit = E.EvenAndOdd id id - , E.credit = E.EvenAndOdd id id - , E.zero = E.EvenAndOdd id id - , E.other = E.EvenAndOdd id id - } - diff --git a/Penny/Cabin/TextFormat.hs b/Penny/Cabin/TextFormat.hs deleted file mode 100644 --- a/Penny/Cabin/TextFormat.hs +++ /dev/null @@ -1,173 +0,0 @@ -module Penny.Cabin.TextFormat ( - Lines(Lines, unLines), - Words(Words, unWords), - CharsPerLine(unCharsPerLine), - txtWords, - wordWrap, - Target(Target, unTarget), - Shortest(Shortest, unShortest), - shorten) where - -import qualified Control.Monad.Trans.State as St -import qualified Data.Foldable as F -import Data.Sequence ((|>), ViewR((:>)), ViewL((:<))) -import qualified Data.Sequence as S -import qualified Data.Text as X -import qualified Data.Traversable as T - -data Lines = Lines { unLines :: S.Seq Words } deriving Show -data Words = Words { unWords :: S.Seq X.Text } deriving Show -newtype CharsPerLine = - CharsPerLine { unCharsPerLine :: Int } deriving Show - --- | Splits a blank-separated text into words. -txtWords :: X.Text -> Words -txtWords = Words . S.fromList . X.words - --- | Wraps a sequence of words into a sequence of lines, where each --- line is no more than a given maximum number of characters long. --- --- If the maximum number of characters per line is less than 1, --- returns a Lines that is empty. --- --- An individual word will be split across multiple lines only if that --- word is too long to fit into a single line. No hyphenation is done; --- the word is simply broken across two lines. -wordWrap :: Int -> Words -> Lines -wordWrap l (Words wsq) = - if l < 1 - then Lines (S.empty) - else F.foldl f (Lines S.empty) wsq where - f (Lines sws) w = let - (back, ws) = case S.viewr sws of - S.EmptyR -> (S.empty, Words S.empty) - (b :> x) -> (b, x) - in case addWord l ws w of - (Just ws') -> Lines $ back |> ws' - Nothing -> - if X.length w > l - then addPartialWords l (Lines sws) w - else Lines (back |> ws |> (Words (S.singleton w))) - -lenWords :: Words -> Int -lenWords (Words s) = case S.length s of - 0 -> 0 - l -> (F.sum . fmap X.length $ s) + (l - 1) - --- | Adds a word to a Words, but only if it will not make the Words --- exceed the given length. -addWord :: Int -> Words -> X.Text -> Maybe Words -addWord l (Words ws) w = - let words' = Words (ws |> w) - in if lenWords words' > l - then Nothing - else Just words' - --- | Adds a word to a Words. If the word is too long to fit, breaks it --- and adds the longest portion possible. Returns the new Words, and a --- Text with the part of the word that was not added (if any; if all --- of the word was added, return an empty Text.) -addPartialWord :: Int -> Words -> X.Text -> (Words, X.Text) -addPartialWord l (Words ws) t = case addWord l (Words ws) t of - (Just ws') -> (ws', X.empty) - Nothing -> - let maxChars = - if S.null ws then l - else max 0 (l - lenWords (Words ws) - 1) - (begin, end) = X.splitAt maxChars t - in (Words (if X.null begin then ws else ws |> begin), end) - -addPartialWords :: Int -> Lines -> X.Text -> Lines -addPartialWords l (Lines wsq) t = let - (back, ws) = case S.viewr wsq of - S.EmptyR -> (S.empty, Words S.empty) - (b :> x) -> (b, x) - (rw, rt) = addPartialWord l ws t - in if X.null rt - then Lines (back |> rw) - else addPartialWords l (Lines (back |> rw |> Words (S.empty))) rt - -newtype Target = Target { unTarget :: Int } deriving Show -newtype Shortest = Shortest { unShortest :: Int } deriving Show - --- | Takes a list of words and shortens it so that it fits in the --- space allotted. You specify the minimum length for each word, x. It --- will shorten the farthest left word first, until it is only x --- characters long; then it will shorten the next word until it is --- only x characters long, etc. This proceeds until all words are just --- x characters long. Then words are shortened to one --- character. Then the leftmost words are deleted as necessary. --- --- Assumes that the words will be printed with a separator, which --- matters when lengths are calculated. -shorten :: Shortest -> Target -> Words -> Words -shorten (Shortest s) (Target t) wsa@(Words wsq) = let - nToRemove = max (lenWords wsa - t) 0 - (allWords, _) = shortenUntilOne s nToRemove wsq - in stripWordsUntil t (Words allWords) - --- | Shorten a word by x characters or until it is y characters long, --- whichever comes first. Returns the word and the number of --- characters removed. -shortenUntil :: Int -> Int -> X.Text -> (X.Text, Int) -shortenUntil by shortest t = let - removable = max (X.length t - shortest) 0 - toRemove = min removable (max by 0) - prefix = X.length t - toRemove - in (X.take prefix t, toRemove) - --- | Shortens a word until it is x characters long or by the number of --- characters indicated in the state, whichever is less. Subtracts the --- number of characters removed from the state. -shortenSt :: Int -> X.Text -> St.State Int X.Text -shortenSt shortest t = do - by <- St.get - let (r, nRemoved) = shortenUntil by shortest t - St.put (by - nRemoved) - return r - --- | Shortens each word in a list, from left to right, until a --- particular number of characters have been reduced or until each --- word is x characters long, whichever happens first. Returns the new --- list and the number of characters that still need to be reduced. -shortenEachInList :: - T.Traversable t - => Int -- ^ Shortest word length - -> Int -- ^ Total number to remove - -> t X.Text - -> (t X.Text, Int) -shortenEachInList shortest by ts = (r, left) where - k = T.mapM (shortenSt shortest) ts - (r, left) = St.runState k by - -shortenUntilOne :: - T.Traversable t - => Int -- ^ Shortest word length to start with - -> Int -- ^ Total number of characters to remove - -> t X.Text - -> (t X.Text, Int) -shortenUntilOne shortest by ts = let - r@(ts', left) = shortenEachInList shortest by ts - in if shortest == 1 || left == 0 - then r - else shortenUntilOne (pred shortest) left ts' - --- | Eliminates words until the length of the words, as indicated by --- lenWords, is less than or equal to the value given. -stripWordsUntil :: Int -> Words -> Words -stripWordsUntil i wsa@(Words ws) = case S.viewl ws of - S.EmptyL -> Words (S.empty) - (_ :< rest) -> - if lenWords wsa <= (max i 0) - then wsa - else stripWordsUntil (max i 0) (Words rest) - - --- --- Testing --- -_words :: Words -_words = Words . S.fromList . map X.pack $ ws where - ws = [ "these", "are", "fragilisticwonderfulgood", - "good", "", "x", "xy", "xyza", - "longlonglongword" ] diff --git a/Penny/Copper.hs b/Penny/Copper.hs deleted file mode 100644 --- a/Penny/Copper.hs +++ /dev/null @@ -1,211 +0,0 @@ --- | Copper - the Penny parser. --- --- The parse functions in this module only accept lists of files --- rather than individual files because in order to correctly assign --- the global serials a single function must be able to see all the --- transactions, not just the transactions in a single file. -module Penny.Copper - ( - -- * Convenience functions to read and parse files - parse - , open - - -- * Types for things found in ledger files - , Y.Item(BlankLine, IComment, PricePoint, Transaction) - , Y.mapItem - , Y.mapItemA - , Y.Ledger(Ledger, unLedger) - , Y.mapLedger - , Y.mapLedgerA - , Y.Comment(Comment, unComment) - , FileContents(FileContents, unFileContents) - , ErrorMsg (unErrorMsg) - - -- * Rendering - , R.GroupSpec(..) - , R.GroupSpecs(..) - , R.ledger - - ) where - -import Control.Monad (when, replicateM_) -import Control.Applicative (pure, (*>), (<$>)) -import Data.Functor.Compose (Compose(Compose, getCompose)) -import Data.Maybe (mapMaybe) -import Data.Monoid (mconcat) -import qualified Control.Monad.Exception.Synchronous as Ex -import qualified Data.Foldable as F -import qualified Data.Text as X -import qualified Data.Text.IO as TIO -import qualified Text.Parsec as Parsec -import qualified Penny.Copper.Parsec as CP - -import qualified Penny.Lincoln as L -import qualified Penny.Copper.Render as R -import qualified Penny.Copper.Types as Y -import System.Console.MultiArg.GetArgs (getProgName) -import qualified System.Exit as Exit -import qualified System.IO as IO - -newtype FileContents = FileContents { unFileContents :: X.Text } - deriving (Eq, Show) - -newtype ErrorMsg = ErrorMsg { unErrorMsg :: X.Text } - deriving (Eq, Show) - -parseFile :: - (L.Filename, FileContents) - -> Ex.Exceptional ErrorMsg Y.Ledger -parseFile (fn, (FileContents c)) = - let p = fmap (addFileMetadata fn) CP.ledger - fnStr = X.unpack . L.unFilename $ fn - in case Parsec.parse p fnStr c of - Left err -> Ex.throw (ErrorMsg . X.pack . show $ err) - Right g -> return g - -addFileTransaction - :: L.Filename - -> L.Transaction - -> L.GenSerial L.Transaction -addFileTransaction fn t = f <$> L.getSerial - where - f ser = L.changeTransaction fam t - where - fam = L.Family tl e e [] - e = L.emptyPostingChangeData - tl = L.emptyTopLineChangeData - { L.tcFileTransaction = - Just (Just $ L.FileTransaction ser) - , L.tcFilename = - Just (Just fn) } - -addFilePosting - :: L.Transaction - -> L.GenSerial L.Transaction -addFilePosting t = f <$> (L.mapChildrenA g (L.unTransaction t)) - where - f fam = L.changeTransaction - (L.mapParent (const L.emptyTopLineChangeData) fam) t - g = const $ fmap h L.getSerial - where h ser = L.emptyPostingChangeData - { L.pcFilePosting = Just (Just (L.FilePosting ser)) } - -addFileMetadataTxn - :: L.Filename - -> L.Transaction - -> Compose L.GenSerial L.GenSerial L.Transaction -addFileMetadataTxn fn t = Compose $ do - t' <- addFileTransaction fn t - return (addFilePosting t') - -toPostings :: L.Transaction -> [L.Posting] -toPostings = F.toList . L.orphans . L.unTransaction - -initCntTxn :: [a] -> L.GenSerial () -initCntTxn ts = replicateM_ (length ts) L.incrementBack - -initCntPstg :: [Y.Item] -> L.GenSerial () -initCntPstg fs = replicateM_ (length ls) L.incrementBack - where - ls = concatMap toPostings . mapMaybe toTxn $ fs - -toTxn :: Y.Item -> Maybe L.Transaction -toTxn i = case i of - Y.Transaction t -> Just t - _ -> Nothing - -addFileMetadata :: L.Filename -> Y.Ledger -> Y.Ledger -addFileMetadata fn a@(Y.Ledger ls) = - (L.makeSerials . (initCntPstg ls *>)) - . (L.makeSerials . (initCntTxn ls *>)) - . getCompose - . Y.mapLedgerA (Y.mapItemA pure pure (addFileMetadataTxn fn)) - $ a - - -addGlobalTransaction - :: L.Transaction - -> L.GenSerial L.Transaction -addGlobalTransaction t = f <$> L.getSerial - where - f ser = L.changeTransaction fam t - where - fam = L.Family tl e e [] - e = L.emptyPostingChangeData - tl = L.emptyTopLineChangeData - { L.tcGlobalTransaction = - Just (Just $ L.GlobalTransaction ser) } - -addGlobalPosting - :: L.Transaction - -> L.GenSerial L.Transaction -addGlobalPosting t = f <$> (L.mapChildrenA g (L.unTransaction t)) - where - f fam = L.changeTransaction - (L.mapParent (const L.emptyTopLineChangeData) fam) t - g = const $ fmap h L.getSerial - where - h ser = L.emptyPostingChangeData - { L.pcGlobalPosting = Just (Just (L.GlobalPosting ser)) } - -addGlobalMetadataTxn :: - L.Transaction - -> Compose L.GenSerial L.GenSerial L.Transaction -addGlobalMetadataTxn t = Compose $ do - t' <- addGlobalTransaction t - return (addGlobalPosting t') - -addGlobalMetadata :: [Y.Ledger] -> Y.Ledger -addGlobalMetadata ls = - (L.makeSerials . (initCntPstg ls' *>)) - . (L.makeSerials . (initCntTxn ls' *>)) - . getCompose - . Y.mapLedgerA (Y.mapItemA pure pure addGlobalMetadataTxn) - $ a - where - a@(Y.Ledger ls') = mconcat ls - -parse :: - [(L.Filename, FileContents)] - -> Ex.Exceptional ErrorMsg Y.Ledger -parse ps = fmap addGlobalMetadata $ mapM parseFile ps - - -parseAndResolve :: (L.Filename, FileContents) -> IO Y.Ledger -parseAndResolve p@(L.Filename fn, _) = - Ex.switch err return $ parseFile p - where - err (ErrorMsg x) = do - pn <- getProgName - let msg = pn ++ ": error: could not parse file " - ++ X.unpack fn ++ "\n" - ++ X.unpack x - IO.hPutStr IO.stderr msg - Exit.exitFailure - - --- | Reads and parses the given files. If any of the files is @-@, --- reads standard input. If the list of files is empty, reads standard --- input. IO errors are not caught. Parse errors are printed to --- standard error and the program will exit with a failure. -open :: [String] -> IO Y.Ledger -open ss = - let ls = if null ss - then fmap (:[]) (getFileContentsStdin "-") - else mapM getFileContentsStdin ss - in fmap addGlobalMetadata (ls >>= mapM parseAndResolve) - -getFileContentsStdin :: String -> IO (L.Filename, FileContents) -getFileContentsStdin s = do - pn <- getProgName - txt <- if s == "-" - then do - isTerm <- IO.hIsTerminalDevice IO.stdin - when isTerm - (IO.hPutStrLn IO.stderr $ - pn ++ ": warning: reading from standard input, which" - ++ "is a terminal.") - TIO.hGetContents IO.stdin - else TIO.readFile s - let fn = L.Filename . X.pack $ if s == "-" then "" else s - return (fn, FileContents txt) diff --git a/Penny/Copper/Parsec.hs b/Penny/Copper/Parsec.hs deleted file mode 100644 --- a/Penny/Copper/Parsec.hs +++ /dev/null @@ -1,418 +0,0 @@ --- | Parsec parsers for the ledger file format. The format is --- documented in EBNF in the file @doc\/ledger-grammar.org@. -module Penny.Copper.Parsec where - -import qualified Penny.Copper.Terminals as T -import qualified Penny.Copper.Types as Y -import Text.Parsec.Text (Parser) -import Text.Parsec (many, many1, satisfy) -import qualified Text.Parsec as P -import qualified Text.Parsec.Pos as Pos -import Control.Arrow (first, second) -import Control.Applicative ((<$>), (<$), (<*>), (*>), (<*), - (<|>), optional) -import Control.Monad (replicateM) -import qualified Control.Monad.Exception.Synchronous as Ex -import qualified Penny.Lincoln as L -import qualified Penny.Lincoln.Transaction.Unverified as U -import Data.Maybe (fromMaybe) -import Data.Text (Text, pack) -import qualified Data.Time as Time - -lvl1SubAcct :: Parser L.SubAccount -lvl1SubAcct = - (L.SubAccount . pack) <$> many1 (satisfy T.lvl1AcctChar) - -lvl1FirstSubAcct :: Parser L.SubAccount -lvl1FirstSubAcct = lvl1SubAcct - -lvl1OtherSubAcct :: Parser L.SubAccount -lvl1OtherSubAcct = satisfy T.colon *> lvl1SubAcct - -lvl1Acct :: Parser L.Account -lvl1Acct = f <$> lvl1FirstSubAcct <*> many lvl1OtherSubAcct - where - f a as = L.Account (a:as) - -quotedLvl1Acct :: Parser L.Account -quotedLvl1Acct = - satisfy T.openCurly *> lvl1Acct <* satisfy T.closeCurly - -lvl2FirstSubAcct :: Parser L.SubAccount -lvl2FirstSubAcct = - (\c cs -> L.SubAccount (pack (c:cs))) - <$> satisfy T.letter - <*> many (satisfy T.lvl2AcctOtherChar) - -lvl2OtherSubAcct :: Parser L.SubAccount -lvl2OtherSubAcct = - (L.SubAccount . pack) - <$ satisfy T.colon - <*> many1 (satisfy T.lvl2AcctOtherChar) - -lvl2Acct :: Parser L.Account -lvl2Acct = - (\a as -> L.Account (a:as)) - <$> lvl2FirstSubAcct - <*> many lvl2OtherSubAcct - -ledgerAcct :: Parser L.Account -ledgerAcct = quotedLvl1Acct <|> lvl2Acct - -lvl1Cmdty :: Parser L.Commodity -lvl1Cmdty = (L.Commodity . pack) <$> many1 (satisfy T.lvl1CmdtyChar) - -quotedLvl1Cmdty :: Parser L.Commodity -quotedLvl1Cmdty = - satisfy T.doubleQuote *> lvl1Cmdty <* satisfy (T.doubleQuote) - -lvl2Cmdty :: Parser L.Commodity -lvl2Cmdty = - (\c cs -> L.Commodity (pack (c:cs))) - <$> satisfy T.lvl2CmdtyFirstChar - <*> many (satisfy T.lvl2CmdtyOtherChar) - -lvl3Cmdty :: Parser L.Commodity -lvl3Cmdty = (L.Commodity . pack) <$> many1 (satisfy T.lvl3CmdtyChar) - -digitGroup :: Parser [Char] -digitGroup = satisfy T.thinSpace *> many1 (satisfy T.digit) - -digitSequence :: Parser [Char] -digitSequence = - (++) <$> many1 (satisfy T.digit) - <*> (concat <$> (many digitGroup)) - -digitPostSequence :: Parser (Maybe [Char]) -digitPostSequence = satisfy T.period *> optional digitSequence - -quantity :: Parser L.Qty -quantity = p >>= failOnErr - where - p = (L.RadFrac <$> (satisfy T.period *> digitSequence)) - <|> (f <$> digitSequence <*> optional digitPostSequence) - f digSeq maybePostSeq = case maybePostSeq of - Nothing -> L.Whole digSeq - Just ps -> - maybe (L.WholeRad digSeq) (L.WholeRadFrac digSeq) ps - failOnErr = maybe (fail msg) return . L.toQty - msg = "could not read quantity; zero quantities not allowed" - -spaceBetween :: Parser L.SpaceBetween -spaceBetween = f <$> optional (many1 (satisfy T.white)) - where - f = maybe L.NoSpaceBetween (const L.SpaceBetween) - -leftCmdtyLvl1Amt :: Parser L.Amount -leftCmdtyLvl1Amt = - f <$> quotedLvl1Cmdty <*> spaceBetween <*> quantity - where - f c s q = L.Amount q c (Just L.CommodityOnLeft) (Just s) - -leftCmdtyLvl3Amt :: Parser L.Amount -leftCmdtyLvl3Amt = f <$> lvl3Cmdty <*> spaceBetween <*> quantity - where - f c s q = L.Amount q c (Just L.CommodityOnLeft) (Just s) - -leftSideCmdtyAmt :: Parser L.Amount -leftSideCmdtyAmt = leftCmdtyLvl1Amt <|> leftCmdtyLvl3Amt - -rightSideCmdty :: Parser L.Commodity -rightSideCmdty = quotedLvl1Cmdty <|> lvl2Cmdty - -rightSideCmdtyAmt :: Parser L.Amount -rightSideCmdtyAmt = - f <$> quantity <*> spaceBetween <*> rightSideCmdty - where - f q s c = L.Amount q c (Just L.CommodityOnRight) (Just s) - - -amount :: Parser L.Amount -amount = leftSideCmdtyAmt <|> rightSideCmdtyAmt - -comment :: Parser Y.Comment -comment = - (Y.Comment . pack) - <$ satisfy T.hash - <*> many (satisfy T.nonNewline) - <* satisfy T.newline - <* many (satisfy T.white) - -year :: Parser Integer -year = read <$> replicateM 4 P.digit - -month :: Parser Int -month = read <$> replicateM 2 P.digit - -day :: Parser Int -day = read <$> replicateM 2 P.digit - -date :: Parser Time.Day -date = p >>= failOnErr - where - p = Time.fromGregorianValid - <$> year <* satisfy T.dateSep - <*> month <* satisfy T.dateSep - <*> day - failOnErr = maybe (fail "could not parse date") return - -hours :: Parser L.Hours -hours = p >>= (maybe (fail "could not parse hours") return) - where - p = f <$> satisfy T.digit <*> satisfy T.digit - f d1 d2 = L.intToHours . read $ [d1,d2] - - -minutes :: Parser L.Minutes -minutes = p >>= maybe (fail "could not parse minutes") return - where - p = f <$ satisfy T.colon <*> satisfy T.digit <*> satisfy T.digit - f d1 d2 = L.intToMinutes . read $ [d1, d2] - -seconds :: Parser L.Seconds -seconds = p >>= maybe (fail "could not parse seconds") return - where - p = f <$ satisfy T.colon <*> satisfy T.digit <*> satisfy T.digit - f d1 d2 = L.intToSeconds . read $ [d1, d2] - -time :: Parser (L.Hours, L.Minutes, Maybe L.Seconds) -time = (,,) <$> hours <*> minutes <*> optional seconds - -tzSign :: Parser (Int -> Int) -tzSign = (id <$ satisfy T.plus) <|> (negate <$ satisfy T.minus) - -tzNumber :: Parser Int -tzNumber = read <$> replicateM 4 (satisfy T.digit) - -timeZone :: Parser L.TimeZoneOffset -timeZone = p >>= maybe (fail "could not parse time zone") return - where - p = f <$> tzSign <*> tzNumber - f s = L.minsToOffset . s - -timeWithZone - :: Parser (L.Hours, L.Minutes, - Maybe L.Seconds, Maybe L.TimeZoneOffset) -timeWithZone = - f <$> time <* many (satisfy T.white) <*> optional timeZone - where - f (h, m, s) tz = (h, m, s, tz) - -dateTime :: Parser L.DateTime -dateTime = - f <$> date <* many (satisfy T.white) <*> optional timeWithZone - where - f d mayTwithZ = L.DateTime d h m s tz - where - ((h, m, s), tz) = case mayTwithZ of - Nothing -> (L.midnight, L.noOffset) - Just (hr, mn, mayS, mayTz) -> - let sec = fromMaybe L.zeroSeconds mayS - z = fromMaybe L.noOffset mayTz - in ((hr, mn, sec), z) - -debit :: Parser L.DrCr -debit = L.Debit <$ satisfy T.lessThan - -credit :: Parser L.DrCr -credit = L.Credit <$ satisfy T.greaterThan - -drCr :: Parser L.DrCr -drCr = debit <|> credit - -entry :: Parser L.Entry -entry = f <$> drCr <* (many (satisfy T.white)) <*> amount - where - f dc am = L.Entry dc am - -flag :: Parser L.Flag -flag = (L.Flag . pack) <$ satisfy T.openSquare - <*> many (satisfy T.flagChar) <* satisfy (T.closeSquare) - -postingMemoLine :: Parser Text -postingMemoLine = - pack - <$ satisfy T.apostrophe - <*> many (satisfy T.nonNewline) - <* satisfy T.newline <* many (satisfy T.white) - -postingMemo :: Parser L.Memo -postingMemo = L.Memo <$> many1 postingMemoLine - -transactionMemoLine :: Parser Text -transactionMemoLine = - pack - <$ satisfy T.semicolon <*> many (satisfy T.nonNewline) - <* satisfy T.newline <* skipWhite - -transactionMemo :: Parser (L.TopMemoLine, L.Memo) -transactionMemo = f <$> lineNum <*> many1 transactionMemoLine - where - f tml ls = (L.TopMemoLine tml - , L.Memo ls) - - -number :: Parser L.Number -number = - L.Number . pack <$ satisfy T.openParen - <*> many (satisfy T.numberChar) <* satisfy T.closeParen - -lvl1Payee :: Parser L.Payee -lvl1Payee = L.Payee . pack <$> many (satisfy T.quotedPayeeChar) - -quotedLvl1Payee :: Parser L.Payee -quotedLvl1Payee = satisfy T.tilde *> lvl1Payee <* satisfy T.tilde - -lvl2Payee :: Parser L.Payee -lvl2Payee = (\c cs -> L.Payee (pack (c:cs))) <$> satisfy T.letter - <*> many (satisfy T.nonNewline) - -fromCmdty :: Parser L.From -fromCmdty = L.From <$> (quotedLvl1Cmdty <|> lvl2Cmdty) - -lineNum :: Parser Int -lineNum = Pos.sourceLine <$> P.getPosition - -price :: Parser L.PricePoint -price = p >>= maybe (fail msg) return - where - f li dt fr (L.Amount qt to sd sb) = - let cpu = L.CountPerUnit qt - in case L.newPrice fr (L.To to) cpu of - Nothing -> Nothing - Just pr -> Just $ L.PricePoint dt pr - sd sb (Just $ L.PriceLine li) - p = f <$> lineNum <* satisfy T.atSign <* skipWhite - <*> dateTime <* skipWhite - <*> fromCmdty <* skipWhite - <*> amount <* satisfy T.newline <* skipWhite - msg = "could not parse price, make sure the from and to commodities " - ++ "are different" - -tag :: Parser L.Tag -tag = L.Tag . pack <$ satisfy T.asterisk <*> many (satisfy T.tagChar) - <* many (satisfy T.white) - -tags :: Parser L.Tags -tags = (\t ts -> L.Tags (t:ts)) <$> tag <*> many tag - -topLinePayee :: Parser L.Payee -topLinePayee = quotedLvl1Payee <|> lvl2Payee - -topLineFlagNum :: Parser (Maybe L.Flag, Maybe L.Number) -topLineFlagNum = p1 <|> p2 - where - p1 = ( (,) <$> optional flag - <* many (satisfy T.white) <*> optional number) - p2 = ( flip (,) - <$> optional number - <* many (satisfy T.white) <*> optional flag) - -skipWhite :: Parser () -skipWhite = () <$ many (satisfy T.white) - -topLine :: Parser U.TopLine -topLine = - f <$> optional transactionMemo - <*> lineNum - <*> dateTime - <* skipWhite - <*> topLineFlagNum - <* skipWhite - <*> optional topLinePayee - <* satisfy T.newline - <* skipWhite - where - f mayMe lin dt (mayFl, mayNum) mayPy = - U.TopLine dt mayFl mayNum mayPy me tll tml Nothing - Nothing Nothing - where - (tml, me) = case mayMe of - Nothing -> (Nothing, Nothing) - Just (l, m) -> (Just l, Just m) - tll = Just (L.TopLineLine lin) - -pairedMaybes - :: Parser (a, Maybe b) - -> Parser (Maybe a, b) - -> Parser (Maybe a, Maybe b) -pairedMaybes p1 p2 = - (fmap (first Just) p1) <|> (fmap (second Just) p2) - -parsePair - :: Parser a - -> Parser b - -> Parser (Maybe a, Maybe b) -parsePair a b = pairedMaybes aFirst bFirst - where - aFirst = (,) <$> a <* skipWhite <*> optional b - bFirst = flip (,) <$> b <* skipWhite <*> optional a - -parseTriple - :: Parser a - -> Parser b - -> Parser c - -> Parser (a, Maybe b, Maybe c) -parseTriple a b c = - f - <$> a - <* skipWhite - <*> optional (parsePair b c) - where - f ra mayRbc = case mayRbc of - Nothing -> (ra, Nothing, Nothing) - Just (rb, rc) -> (ra, rb, rc) - - -flagFirst :: Parser (L.Flag, Maybe L.Number, Maybe L.Payee) -flagFirst = parseTriple flag number quotedLvl1Payee - -numberFirst :: Parser (L.Number, Maybe L.Flag, Maybe L.Payee) -numberFirst = parseTriple number flag quotedLvl1Payee - -payeeFirst :: Parser (L.Payee, Maybe L.Flag, Maybe L.Number) -payeeFirst = parseTriple quotedLvl1Payee flag number - -flagNumPayee :: Parser (Maybe L.Flag, Maybe L.Number, Maybe L.Payee) -flagNumPayee = - ((\(f, n, p) -> (Just f, n, p)) <$> flagFirst) - <|> ((\(n, f, p) -> (f, Just n, p)) <$> numberFirst) - <|> ((\(p, f, n) -> (f, n, Just p)) <$> payeeFirst) - - -postingAcct :: Parser L.Account -postingAcct = quotedLvl1Acct <|> lvl2Acct - -posting :: Parser U.Posting -posting = f <$> lineNum <* skipWhite - <*> optional flagNumPayee <* skipWhite - <*> postingAcct <* skipWhite - <*> optional tags <* skipWhite - <*> optional entry <* skipWhite - <* satisfy T.newline <* skipWhite - <*> optional postingMemo <* skipWhite - where - f li mayFnp ac ta mayEn me = - U.Posting pa nu fl ac tgs mayEn me pl Nothing Nothing - where - tgs = fromMaybe (L.Tags []) ta - pl = Just . L.PostingLine $ li - (fl, nu, pa) = fromMaybe (Nothing, Nothing, Nothing) mayFnp - -transaction :: Parser L.Transaction -transaction = p >>= Ex.switch (fail . show) return - where - p = L.transaction <$> - (L.Family <$> topLine <*> posting - <*> posting <*> many posting) - - -blankLine :: Parser Y.Item -blankLine = Y.BlankLine <$ satisfy T.newline <* skipWhite - -item :: Parser Y.Item -item = fmap Y.IComment comment <|> fmap Y.PricePoint price - <|> fmap Y.Transaction transaction <|> blankLine - -ledger :: Parser Y.Ledger -ledger = Y.Ledger <$ skipWhite <*> many item <* P.eof diff --git a/Penny/Copper/Render.hs b/Penny/Copper/Render.hs deleted file mode 100644 --- a/Penny/Copper/Render.hs +++ /dev/null @@ -1,523 +0,0 @@ --- | Renders Penny data in a format that can be parsed by --- "Penny.Copper.Parsec". These functions render text that is --- compliant with the EBNF grammar which is at --- @doc\/ledger-grammar.org@. -module Penny.Copper.Render where - -import Control.Monad (guard) -import Control.Applicative ((<$>), (<|>), (<*>)) -import Data.List (intersperse, intercalate) -import Data.List.Split (chunksOf, splitOn) -import qualified Data.Text as X -import Data.Text (Text, cons, snoc) -import qualified Penny.Copper.Terminals as T -import qualified Penny.Lincoln.Transaction as LT -import qualified Data.Time as Time -import qualified Penny.Copper.Types as Y -import qualified Penny.Lincoln as L - --- * Helpers - --- | Merges a list of words into one Text; however, if any given Text --- is empty, that Text is first dropped from the list. -txtWords :: [X.Text] -> X.Text -txtWords xs = case filter (not . X.null) xs of - [] -> X.empty - rs -> X.unwords rs - --- | Takes a field that may or may not be present and a function that --- renders it. If the field is not present at all, returns an empty --- Text. Otherwise will succeed or fail depending upon whether the --- rendering function succeeds or fails. -renMaybe :: Maybe a -> (a -> Maybe X.Text) -> Maybe X.Text -renMaybe mx f = case mx of - Nothing -> Just X.empty - Just a -> f a - - --- * Accounts - --- | Is True if a sub account can be rendered at Level 1; --- False otherwise. -isSubAcctLvl1 :: L.SubAccount -> Bool -isSubAcctLvl1 (L.SubAccount x) = - X.all T.lvl1AcctChar x && not (X.null x) - -isAcctLvl1 :: L.Account -> Bool -isAcctLvl1 (L.Account ls) = - (not . null $ ls) - && (all isSubAcctLvl1 ls) - -quotedLvl1Acct :: L.Account -> Maybe Text -quotedLvl1Acct a@(L.Account ls) = do - guard (isAcctLvl1 a) - let txt = X.concat . intersperse (X.singleton ':') - . map L.unSubAccount $ ls - return $ '{' `X.cons` txt `X.snoc` '}' - -isFirstSubAcctLvl2 :: L.SubAccount -> Bool -isFirstSubAcctLvl2 (L.SubAccount x) = case X.uncons x of - Nothing -> False - Just (c, r) -> T.letter c && (X.all T.lvl2AcctOtherChar r) - -isOtherSubAcctLvl2 :: L.SubAccount -> Bool -isOtherSubAcctLvl2 (L.SubAccount x) = - (not . X.null $ x) - && (X.all T.lvl2AcctOtherChar x) - -isAcctLvl2 :: L.Account -> Bool -isAcctLvl2 (L.Account ls) = case ls of - [] -> False - x:xs -> isFirstSubAcctLvl2 x && all isOtherSubAcctLvl2 xs - -lvl2Acct :: L.Account -> Maybe Text -lvl2Acct a@(L.Account ls) = do - guard $ isAcctLvl2 a - return . X.concat . intersperse (X.singleton ':') - . map L.unSubAccount $ ls - --- | Shows an account, with the minimum level of quoting --- possible. Fails with an error if any one of the characters in the --- account name does not satisfy the 'lvl1Char' predicate. Otherwise --- returns a rendered account, quoted if necessary. -ledgerAcct :: L.Account -> Maybe Text -ledgerAcct a = lvl2Acct a <|> quotedLvl1Acct a - --- * Commodities - --- | Render a quoted Level 1 commodity. Fails if any character does --- not satisfy lvl1Char. -quotedLvl1Cmdty :: L.Commodity -> Maybe Text -quotedLvl1Cmdty (L.Commodity c) = - if X.all T.lvl1CmdtyChar c - then Just $ '"' `cons` c `snoc` '"' - else Nothing - - --- | Render a Level 2 commodity. Fails if the first character is not a --- letter or a symbol, or if any other character is a space. -lvl2Cmdty :: L.Commodity -> Maybe Text -lvl2Cmdty (L.Commodity c) = do - (f, rs) <- X.uncons c - guard $ T.lvl2CmdtyFirstChar f - guard . X.all T.lvl2CmdtyOtherChar $ rs - return c - - --- | Render a Level 3 commodity. Fails if any character is not a --- letter or a symbol. -lvl3Cmdty :: L.Commodity -> Maybe Text -lvl3Cmdty (L.Commodity c) = - if (not . X.null $ c) && (X.all T.lvl3CmdtyChar c) - then return c - else Nothing - - --- * Quantities - --- | Specifies how to perform digit grouping when rendering a --- quantity. All grouping groups into groups of 3 digits. -data GroupSpec = - NoGrouping - -- ^ Do not perform any digit grouping - | GroupLarge - -- ^ Group digits, but only if the number to be grouped is greater - -- than 9,999 (if grouping the whole part) or if there are more - -- than 4 decimal places (if grouping the fractional part). - | GroupAll - -- ^ Group digits whenever there are at least four decimal places. - deriving (Eq, Show) - - -data GroupSpecs = GroupSpecs - { left :: GroupSpec - , right :: GroupSpec - } deriving Show - - -grouper :: String -grouper = "\x2009" - -radix :: String -radix = "." - --- | Performs grouping for amounts to the left of the radix point. -groupWhole :: GroupSpec -> String -> String -groupWhole gs o = let - grouped = intercalate grouper - . reverse - . map reverse - . chunksOf 3 - . reverse - $ o - in case gs of - NoGrouping -> o - GroupLarge -> if length o > 4 then grouped else o - GroupAll -> grouped - --- | Performs grouping for amounts to the right of the radix point. -groupDecimal :: GroupSpec -> String -> String -groupDecimal gs o = let - grouped = intercalate grouper - . chunksOf 3 - $ o - in case gs of - NoGrouping -> o - GroupLarge -> if length o > 4 then grouped else o - GroupAll -> grouped - --- | Renders an unquoted Qty. Performs digit grouping as requested. -quantity - :: GroupSpecs - -- ^ Group for the portion to the left and right of the radix point? - - -> L.Qty - -> X.Text -quantity gs q = - let qs = show q - in X.pack $ case splitOn "." qs of - w:[] -> groupWhole (left gs) w - w:d:[] -> - groupWhole (left gs) w ++ radix ++ groupDecimal (right gs) d - _ -> error "Qty.hs: rendering error" - --- * Amounts - --- | Render an Amount. The Format is required so that the commodity --- can be displayed in the right place. -amount :: - GroupSpecs - -> L.Amount - -> Maybe X.Text -amount gs (L.Amount qt c maySd maySb) = - let q = quantity gs qt - in do - sd <- maySd - sb <- maySb - let ws = case sb of - L.SpaceBetween -> X.singleton ' ' - L.NoSpaceBetween -> X.empty - (l, r) <- case sd of - L.CommodityOnLeft -> do - cx <- lvl3Cmdty c <|> quotedLvl1Cmdty c - return (cx, q) - L.CommodityOnRight -> do - cx <- lvl2Cmdty c <|> quotedLvl1Cmdty c - return (q, cx) - return $ X.concat [l, ws, r] - --- * Comments - -comment :: Y.Comment -> Maybe X.Text -comment (Y.Comment x) = - if (not . X.all T.nonNewline $ x) - then Nothing - else Just $ '#' `cons` x `snoc` '\n' - --- * DateTime - --- | Render a DateTime. The day is always printed. If the time zone --- offset is not zero, then the time and time zone offset are both --- printed. If the time zone offset is zero, then the hours and --- minutes are printed, but only if the time is not midnight. If the --- seconds are not zero, they are also printed. - -dateTime :: L.DateTime -> X.Text -dateTime (L.DateTime d h m s z) = X.append xd xr - where - (iYr, iMo, iDy) = Time.toGregorian d - xr = hoursMinsSecsZone h m s z - dash = X.singleton '-' - xd = X.concat [ showX iYr, dash, pad2 . showX $ iMo, dash, - pad2 . showX $ iDy ] - -pad2 :: X.Text -> X.Text -pad2 = X.justifyRight 2 '0' - -pad4 :: X.Text -> X.Text -pad4 = X.justifyRight 4 '0' - -showX :: Show a => a -> X.Text -showX = X.pack . show - -hoursMinsSecsZone - :: L.Hours -> L.Minutes -> L.Seconds -> L.TimeZoneOffset -> X.Text -hoursMinsSecsZone h m s z = - if z == L.noOffset && (h, m, s) == L.midnight - then X.empty - else let xhms = X.concat [xh, colon, xm, xs] - xh = pad2 . showX . L.unHours $ h - xm = pad2 . showX . L.unMinutes $ m - xs = let secs = L.unSeconds s - in if secs == 0 - then X.empty - else ':' `X.cons` (pad2 . showX $ secs) - off = L.offsetToMins z - sign = X.singleton $ if off < 0 then '-' else '+' - padded = pad4 . showX . abs $ off - xz = if off == 0 - then X.empty - else ' ' `X.cons` sign `X.append` padded - colon = X.singleton ':' - in ' ' `X.cons` xhms `X.append` xz - --- * Entries - -entry - :: GroupSpecs - -> L.Entry - -> Maybe X.Text -entry gs (L.Entry dc a) = do - amt <- amount gs a - let dcTxt = X.pack $ case dc of - L.Debit -> "<" - L.Credit -> ">" - return $ X.append (X.snoc dcTxt ' ') amt - --- * Flags - -flag :: L.Flag -> Maybe X.Text -flag (L.Flag fl) = - if X.all T.flagChar fl - then Just $ '[' `cons` fl `snoc` ']' - else Nothing - --- * Memos - --- | Renders a postingMemoLine, optionally with trailing --- whitespace. The trailing whitespace allows the next line to be --- indented properly if is also a postingMemoLine. This is handled --- using trailing whitespace rather than leading whitespace because --- leading whitespace is inconsistent with the grammar. -postingMemoLine - :: Int - -- ^ Pad the end of the output with this many spaces - -> X.Text - -> Maybe X.Text -postingMemoLine p x = - if X.all T.nonNewline x - then let trailing = X.replicate p (X.singleton ' ') - ls = [X.singleton '\'', x, X.singleton '\n', trailing] - in Just $ X.concat ls - else Nothing - --- | Renders a postingMemo. Fails if the postingMemo is empty, as the --- grammar requires that they have at least one line. --- --- If the boolean is True, inserts padding after the last --- postingMemoLine so that the next line is indented by four --- columns. Use this if the posting memo is followed by another --- posting. If the last boolean if False, there is no indenting after --- the last postingMemoLine. -postingMemo :: Bool -> L.Memo -> Maybe X.Text -postingMemo iLast (L.Memo ls) = - if null ls - then Nothing - else let bs = replicate (length ls - 1) 8 ++ [if iLast then 4 else 0] - in fmap X.concat . sequence $ zipWith postingMemoLine bs ls - - -transactionMemoLine :: X.Text -> Maybe X.Text -transactionMemoLine x = - if X.all T.nonNewline x - then Just $ ';' `cons` x `snoc` '\n' - else Nothing - -transactionMemo :: L.Memo -> Maybe X.Text -transactionMemo (L.Memo ls) = - if null ls - then Nothing - else fmap X.concat . mapM transactionMemoLine $ ls - --- * Numbers - -number :: L.Number -> Maybe Text -number (L.Number t) = - if X.all T.numberChar t - then Just $ '(' `cons` t `snoc` ')' - else Nothing - --- * Payees - -quotedLvl1Payee :: L.Payee -> Maybe Text -quotedLvl1Payee (L.Payee p) = do - guard (X.all T.quotedPayeeChar p) - return $ '~' `X.cons` p `X.snoc` '~' - -lvl2Payee :: L.Payee -> Maybe Text -lvl2Payee (L.Payee p) = do - (c1, cs) <- X.uncons p - guard (T.letter c1) - guard (X.all T.nonNewline cs) - return p - -payee :: L.Payee -> Maybe Text -payee p = lvl2Payee p <|> quotedLvl1Payee p - --- * Prices - -price :: - GroupSpecs - -> L.PricePoint - -> Maybe X.Text -price gs pp = let - dateTxt = dateTime (L.dateTime pp) - (L.From from) = L.from . L.price $ pp - (L.To to) = L.to . L.price $ pp - (L.CountPerUnit q) = L.countPerUnit . L.price $ pp - mayFromTxt = lvl3Cmdty from <|> quotedLvl1Cmdty from - in do - amtTxt <- amount gs - (L.Amount q to (L.ppSide pp) (L.ppSpaceBetween pp)) - fromTxt <- mayFromTxt - return $ - (X.intercalate (X.singleton ' ') - [X.singleton '@', dateTxt, fromTxt, amtTxt]) - `snoc` '\n' - --- * Tags - -tag :: L.Tag -> Maybe X.Text -tag (L.Tag t) = - if X.all T.tagChar t - then Just $ X.cons '*' t - else Nothing - -tags :: L.Tags -> Maybe X.Text -tags (L.Tags ts) = - X.intercalate (X.singleton ' ') - <$> mapM tag ts - --- * TopLine - --- | Renders the TopLine. Emits trailing whitespace after the newline --- so that the first posting is properly indented. -topLine :: LT.TopLine -> Maybe X.Text -topLine tl = - f - <$> renMaybe (LT.tMemo tl) transactionMemo - <*> renMaybe (LT.tFlag tl) flag - <*> renMaybe (LT.tNumber tl) number - <*> renMaybe (LT.tPayee tl) payee - where - f meX flX nuX paX = - X.concat [ meX, txtWords [dtX, flX, nuX, paX], - X.singleton '\n', - X.replicate 4 (X.singleton ' ') ] - dtX = dateTime (LT.tDateTime tl) - --- * Posting - --- | Renders a Posting. Fails if any of the components --- fail to render. In addition, if the unverified Posting has an --- Entry, a Format must be provided, otherwise render fails. --- --- The columns look like this. Column numbers begin with 0 (like they --- do in Emacs) rather than with column 1 (like they do in --- Vim). (Really Emacs is the strange one; most CLI utilities seem to --- start with column 1 too...) --- --- > ID COLUMN WIDTH WHAT --- > --------------------------------------------------- --- > A 0 4 Blank spaces for indentation --- > B 4 50 Flag, Number, Payee, Account, Tags --- > C 54 2 Blank spaces for padding --- > D 56 NA Entry --- --- Omit the padding after column B if there is no entry; also omit --- columns C and D entirely if there is no Entry. (It is annoying to --- have extraneous blank space in a file). --- --- This table is a bit of a lie, because the blank spaces for --- indentation are emitted either by the posting previous to this one --- (either after the posting itself or after its postingMemo) or by --- the TopLine. --- --- Also emits an additional eight spaces after the trailing newline if --- the posting has a memo. That way the memo will be indented --- properly. (There are trailing spaces here, as opposed to leading --- spaces in the posting memo, because the latter would be --- inconsistent with the grammar.) --- --- Emits an extra four spaces after the first line if the first --- paramter is True. However, this is overriden if there is a memo, in --- which case eight spaces will be emitted. (This allows the next --- posting to be indented properly.) -posting :: - GroupSpecs - -> Bool - -- ^ If True, emit four spaces after the trailing newline. - -> L.Posting - -> Maybe X.Text -posting gs pad p = do - fl <- renMaybe (LT.pFlag p) flag - nu <- renMaybe (LT.pNumber p) number - pa <- renMaybe (LT.pPayee p) quotedLvl1Payee - ac <- ledgerAcct (LT.pAccount p) - ta <- tags (LT.pTags p) - me <- renMaybe (LT.pMemo p) (postingMemo pad) - mayEn <- case LT.pInferred p of - LT.Inferred -> return Nothing - LT.NotInferred -> return (Just . L.pEntry $ p) - en <- renMaybe mayEn (entry gs) - return $ formatter pad fl nu pa ac ta en me - -formatter :: - Bool -- ^ If True, emit four trailing spaces if no memo or - -- eight trailing spaces if there is a memo. - -> X.Text -- ^ Flag - -> X.Text -- ^ Number - -> X.Text -- ^ Payee - -> X.Text -- ^ Account - -> X.Text -- ^ Tags - -> X.Text -- ^ Entry - -> X.Text -- ^ Memo - -> X.Text -formatter pad fl nu pa ac ta en me = let - colBnoPad = txtWords [fl, nu, pa, ac, ta] - colD = en - colB = if X.null en - then colBnoPad - else X.justifyLeft 50 ' ' colBnoPad - colC = if X.null en - then X.empty - else X.pack (replicate 2 ' ') - rtn = '\n' `X.cons` trailingWhite - trailingWhite = case (X.null me, pad) of - (True, False) -> X.empty - (True, True) -> X.replicate 4 (X.singleton ' ') - (False, _) -> X.replicate 8 (X.singleton ' ') - in X.concat [colB, colC, colD, rtn, me] - - --- * Transaction - -transaction :: - GroupSpecs - -> L.Transaction - -> Maybe X.Text -transaction gs txn = do - let (L.Family tl p1 p2 ps) = LT.unTransaction txn - tlX <- topLine tl - p1X <- posting gs True p1 - p2X <- posting gs (not . null $ ps) p2 - psX <- if null ps - then return X.empty - else let bs = replicate (length ps - 1) True ++ [False] - in fmap X.concat . sequence - $ zipWith (posting gs) bs ps - return $ X.concat [tlX, p1X, p2X, psX] - --- * Item - -item :: GroupSpecs -> Y.Item -> Maybe X.Text -item gs i = case i of - Y.BlankLine -> Just . X.singleton $ '\n' - Y.IComment x -> comment x - Y.PricePoint pp -> price gs pp - Y.Transaction t -> transaction gs t - --- * Ledger - -ledger :: GroupSpecs -> Y.Ledger -> Maybe X.Text -ledger gs (Y.Ledger is) = fmap X.concat . mapM (item gs) $ is diff --git a/Penny/Copper/Terminals.hs b/Penny/Copper/Terminals.hs deleted file mode 100644 --- a/Penny/Copper/Terminals.hs +++ /dev/null @@ -1,145 +0,0 @@ -module Penny.Copper.Terminals where - -invalid :: Char -> Bool -invalid c = c >= '\xD800' && c <= '\xDFFF' - -unicode :: Char -> Bool -unicode = not . invalid - -newline :: Char -> Bool -newline = (== '\x0A') - -space :: Char -> Bool -space = (== '\x20') - -tab :: Char -> Bool -tab = (== '\x09') - -white :: Char -> Bool -white c = space c || tab c - -nonNewline :: Char -> Bool -nonNewline c = unicode c && (not . newline $ c) - -nonNewlineNonSpace :: Char -> Bool -nonNewlineNonSpace c = nonNewline c && (not . white $ c) - -upperCaseAscii :: Char -> Bool -upperCaseAscii c = c >= 'A' && c <= 'Z' - -lowerCaseAscii :: Char -> Bool -lowerCaseAscii c = c >= 'a' && c <= 'z' - -digit :: Char -> Bool -digit c = c >= '0' && c <= '9' - -nonAscii :: Char -> Bool -nonAscii c = nonNewline c && c > '\x7F' - -letter :: Char -> Bool -letter c = upperCaseAscii c || lowerCaseAscii c || nonAscii c - -dollar :: Char -> Bool -dollar = (== '$') - -colon :: Char -> Bool -colon = (== ':') - -openCurly :: Char -> Bool -openCurly = (== '{') - -closeCurly :: Char -> Bool -closeCurly = (== '}') - -openSquare :: Char -> Bool -openSquare = (== '[') - -closeSquare :: Char -> Bool -closeSquare = (== ']') - -doubleQuote :: Char -> Bool -doubleQuote = (== '"') - -period :: Char -> Bool -period = (== '.') - -hash :: Char -> Bool -hash = (== '#') - -thinSpace :: Char -> Bool -thinSpace = (== '\x2009') - -dateSep :: Char -> Bool -dateSep c = c == '/' || c == '-' - -plus :: Char -> Bool -plus = (== '+') - -minus :: Char -> Bool -minus = (== '-') - -lessThan :: Char -> Bool -lessThan = (== '<') - -greaterThan :: Char -> Bool -greaterThan = (== '>') - -openParen :: Char -> Bool -openParen = (== '(') - -closeParen :: Char -> Bool -closeParen = (== ')') - -semicolon :: Char -> Bool -semicolon = (== ';') - -apostrophe :: Char -> Bool -apostrophe = (== '\x27') - -tilde :: Char -> Bool -tilde = (== '~') - -underscore :: Char -> Bool -underscore = (== '_') - -asterisk :: Char -> Bool -asterisk = (== '*') - -lvl1AcctChar :: Char -> Bool -lvl1AcctChar c = nonNewline c && (not . closeCurly $ c) - && (not . colon $ c) - -lvl2AcctOtherChar :: Char -> Bool -lvl2AcctOtherChar c = - nonNewline c && (not . white $ c) && (not . colon $ c) - && (not . asterisk $ c) && (not . greaterThan $ c) - && (not . lessThan $ c) - -lvl1CmdtyChar :: Char -> Bool -lvl1CmdtyChar c = - nonNewline c && (not . doubleQuote $ c) - -lvl2CmdtyFirstChar :: Char -> Bool -lvl2CmdtyFirstChar c = letter c || dollar c - -lvl2CmdtyOtherChar :: Char -> Bool -lvl2CmdtyOtherChar c = nonNewline c && (not . white $ c) - -lvl3CmdtyChar :: Char -> Bool -lvl3CmdtyChar c = letter c || dollar c - -flagChar :: Char -> Bool -flagChar c = nonNewline c && (not . closeSquare $ c) - -numberChar :: Char -> Bool -numberChar c = nonNewline c && (not . closeParen $ c) - -quotedPayeeChar :: Char -> Bool -quotedPayeeChar c = nonNewline c && (not . tilde $ c) - -tagChar :: Char -> Bool -tagChar c = nonNewlineNonSpace c && (not . asterisk $ c) - && (not . greaterThan $ c) && (not . lessThan $ c) - -atSign :: Char -> Bool -atSign = (== '@') diff --git a/Penny/Copper/Types.hs b/Penny/Copper/Types.hs deleted file mode 100644 --- a/Penny/Copper/Types.hs +++ /dev/null @@ -1,59 +0,0 @@ -module Penny.Copper.Types where - -import Control.Applicative (Applicative (pure)) -import Data.Functor ((<$>)) -import qualified Data.Text as X -import qualified Data.Traversable as T -import qualified Penny.Lincoln as L -import qualified Data.Monoid as M - -newtype Comment = Comment { unComment :: X.Text } - deriving (Eq, Show) - -data Item = BlankLine - | IComment Comment - | PricePoint L.PricePoint - | Transaction L.Transaction - deriving Show - -mapItem - :: (Comment -> Comment) - -> (L.PricePoint -> L.PricePoint) - -> (L.Transaction -> L.Transaction) - -> Item - -> Item -mapItem fc fp ft i = case i of - BlankLine -> BlankLine - IComment c -> IComment $ fc c - PricePoint p -> PricePoint $ fp p - Transaction t -> Transaction $ ft t - -mapItemA - :: Applicative a - => (Comment -> a Comment) - -> (L.PricePoint -> a L.PricePoint) - -> (L.Transaction -> a L.Transaction) - -> Item - -> a Item -mapItemA fc fp ft i = case i of - BlankLine -> pure BlankLine - IComment c -> IComment <$> fc c - PricePoint p -> PricePoint <$> fp p - Transaction t -> Transaction <$> ft t - -newtype Ledger = Ledger { unLedger :: [Item] } - deriving Show - -mapLedger :: (Item -> Item) -> Ledger -> Ledger -mapLedger f (Ledger is) = Ledger $ map f is - -mapLedgerA - :: Applicative a - => (Item -> a Item) - -> Ledger - -> a Ledger -mapLedgerA f (Ledger is) = Ledger <$> T.traverse f is - -instance M.Monoid Ledger where - mempty = Ledger [] - mappend (Ledger x) (Ledger y) = Ledger (x ++ y) diff --git a/Penny/Liberty.hs b/Penny/Liberty.hs deleted file mode 100644 --- a/Penny/Liberty.hs +++ /dev/null @@ -1,788 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | Liberty - Penny command line parsing utilities --- --- Both Cabin and Zinc share various functions that aid in parsing --- command lines. For instance both the Postings report and the Zinc --- postings filter use common command-line options. However, Zinc --- already depends on Cabin. To avoid a cyclic dependency whereby --- Cabin would also depend on Zinc, functions formerly in Zinc that --- Cabin will also find useful are relocated here, to Liberty. - -module Penny.Liberty ( - MatcherFactory, - FilteredNum(FilteredNum, unFilteredNum), - SortedNum(SortedNum, unSortedNum), - LibertyMeta(filteredNum, sortedNum), - xactionsToFiltered, - ListLength(ListLength, unListLength), - ItemIndex(ItemIndex, unItemIndex), - PostFilterFn, - parseComparer, - processPostFilters, - parsePredicate, - parseInt, - parseInfix, - parseRPN, - exprDesc, - showExpression, - verboseFilter, - - -- * Parsers - Operand, - operandSpecs, - postFilterSpecs, - matcherSelectSpecs, - caseSelectSpecs, - operatorSpecs, - - -- * Version - version, - - -- * Errors - Error - - ) where - -import Control.Applicative ((<*>), (<$>), pure, Applicative) -import qualified Control.Monad.Exception.Synchronous as Ex -import Data.Char (toUpper) -import Data.Maybe (mapMaybe) -import Data.Monoid ((<>)) -import Data.List (sortBy) -import Data.Text (Text, pack) -import qualified Data.Time as Time -import qualified System.Console.MultiArg as MA -import qualified System.Console.MultiArg.Combinator as C -import System.Console.MultiArg.Combinator (OptSpec) -import Text.Parsec (parse) - -import qualified Penny.Copper.Parsec as Pc - -import Penny.Lincoln.Family.Child (Child(Child), child, parent) -import qualified Penny.Lincoln.Predicates as P -import qualified Penny.Lincoln.Predicates.Siblings as PS -import qualified Data.Prednote.Pdct as E -import qualified Penny.Lincoln as L -import qualified System.Console.Rainbow as C -import qualified Data.Prednote.Expressions as X - -import Text.Matchers ( - CaseSensitive(Sensitive, Insensitive)) -import qualified Text.Matchers as TM - -import qualified Paths_penny_lib as PPL -import qualified Data.Version as V -import qualified System.Exit as Exit - --- | A multiline Text that holds an error message. -type Error = Text - --- | A serial indicating how a post relates to all other postings that --- made it through the filtering phase. -newtype FilteredNum = FilteredNum { unFilteredNum :: L.Serial } - deriving Show - --- | A serial indicating how a posting relates to all other postings --- that have been sorted. -newtype SortedNum = SortedNum { unSortedNum :: L.Serial } - deriving Show - --- | All metadata from Liberty. -data LibertyMeta = - LibertyMeta { filteredNum :: FilteredNum - , sortedNum :: SortedNum } - deriving Show - - --- | Parses a list of tokens to obtain a predicate. Deals with an --- empty list of tokens by returning a predicate that is always --- True. Fails if the list of tokens is not empty and the parse fails. -parsePredicate - :: X.ExprDesc - -> [X.Token a] - -> Ex.Exceptional Error (E.Pdct a) -parsePredicate d ls = case ls of - [] -> return E.always - _ -> X.parseExpression d ls - --- | Takes a list of transactions, splits them into PostingChild --- instances, filters them, post-filters them, sorts them, and places --- them in Box instances with Filtered serials. Also returns a Text --- containing a description of the evalutation process. -xactionsToFiltered :: - - P.LPdct - -- ^ The predicate to filter the transactions - - -> [PostFilterFn] - -- ^ Post filter specs - - -> (L.PostFam -> L.PostFam -> Ordering) - -- ^ The sorter - - -> [L.Transaction] - -- ^ The transactions to work on (probably parsed in from Copper) - - -> ([C.Chunk], [L.Box LibertyMeta]) - -- ^ Sorted, filtered postings - -xactionsToFiltered pdct postFilts s txns = - let pdcts = map (makeLabeledPdct pdct) pfs - evaluator subj pd = E.evaluate indentAmt True subj 0 pd - pairMaybes = zipWith evaluator pfs pdcts - pairs = mapMaybe rmMaybe pairMaybes - rmMaybe (mayB, x) = case mayB of - Nothing -> Nothing - Just b -> Just (b, x) - pfs = concatMap L.postFam txns - txt = concatMap snd pairs - filtered = map snd . filter fst $ zipWith zipper pairs pfs - zipper (bool, _) pf = (bool, pf) - resultLs = addSortedNum - . processPostFilters postFilts - . sortBy (sorter s) - . addFilteredNum - . map toBox - $ filtered - in (txt, resultLs) - - --- | Creates a Pdct and prepends a one-line description of the PostFam --- to the Pdct's label so it can be easily identified in the output. -makeLabeledPdct :: E.Pdct L.PostFam -> L.PostFam -> E.Pdct L.PostFam -makeLabeledPdct pd pf = E.rename f pd - where - f old = old <> " - " <> L.display pf - -indentAmt :: E.IndentAmt -indentAmt = 4 - --- | Transforms a PostingChild into a Box. -toBox :: L.PostFam -> L.Box () -toBox = L.Box () - --- | Takes a list of filtered boxes and adds the Filtered serials. - -addFilteredNum :: [L.Box a] -> [L.Box FilteredNum] -addFilteredNum = L.serialItems f where - f ser = fmap (const (FilteredNum ser)) - --- | Wraps a PostingChild sorter to change it to a Box sorter. -sorter :: (L.PostFam -> L.PostFam -> Ordering) - -> L.Box a - -> L.Box b - -> Ordering -sorter f b1 b2 = f (L.boxPostFam b1) (L.boxPostFam b2) - --- | Takes a list of Boxes with metadata and adds a Serial for the --- Sorted. -addSortedNum :: - [L.Box FilteredNum] - -> [L.Box LibertyMeta] -addSortedNum = L.serialItems f where - f ser = fmap g where - g filtNum = LibertyMeta filtNum (SortedNum ser) - -type MatcherFactory = - CaseSensitive - -> Text - -> Ex.Exceptional Text TM.Matcher - -newtype ListLength = ListLength { unListLength :: Int } - deriving (Eq, Ord, Show) -newtype ItemIndex = ItemIndex { unItemIndex :: Int } - deriving (Eq, Ord, Show) - --- | Specifies options for the post-filter stage. -type PostFilterFn = ListLength -> ItemIndex -> Bool - - -processPostFilters :: [PostFilterFn] -> [a] -> [a] -processPostFilters pfs ls = foldl processPostFilter ls pfs - - -processPostFilter :: [a] -> PostFilterFn -> [a] -processPostFilter as fn = map fst . filter fn' $ zipped where - len = ListLength $ length as - fn' (_, idx) = fn len (ItemIndex idx) - zipped = zip as [0..] - - ------------------------------------------------------------- --- Operands ------------------------------------------------------------- - --- | Given a String from the command line which represents a pattern, --- the current case sensitivity, and a MatcherFactory, return a --- Matcher. Fails if the pattern is bad (e.g. it is not a valid --- regular expression). -getMatcher :: - String - -> CaseSensitive - -> MatcherFactory - -> Ex.Exceptional Error TM.Matcher - -getMatcher s cs f - = Ex.mapException mkError - $ f cs (pack s) - where - mkError eMsg = "bad pattern: \"" <> pack s <> " - " <> eMsg - <> "\n" - - --- | Parses comparers given on command line to a function. Fails if --- the string given is invalid. -parseComparer - :: String - -> (Ordering -> E.Pdct a) - -> Ex.Exceptional Error (E.Pdct a) -parseComparer s f = Ex.fromMaybe ("bad comparer: " <> pack s <> "\n") - $ E.parseComparer (pack s) f - --- | Parses a date from the command line. On failure, throws back the --- error message from the failed parse. -parseDate :: String -> Ex.Exceptional Error Time.UTCTime -parseDate arg = - Ex.mapExceptional err L.toUTC - . Ex.fromEither - . parse Pc.dateTime "" - . pack - $ arg - where - err msg = "bad date: \"" <> pack arg <> "\" - " <> (pack . show $ msg) - -type Operand = E.Pdct L.PostFam - --- | OptSpec for a date. -date :: OptSpec (Ex.Exceptional Error Operand) -date = C.OptSpec ["date"] ['d'] (C.TwoArg f) - where - f a1 a2 = do - utct <- parseDate a2 - parseComparer a1 (flip P.date utct) - - -current :: L.DateTime -> OptSpec Operand -current dt = C.OptSpec ["current"] [] (C.NoArg f) - where - f = E.or [P.date LT (L.toUTC dt), P.date EQ (L.toUTC dt)] - --- | Parses exactly one integer; fails if it cannot read exactly one. -parseInt :: String -> Ex.Exceptional Error Int -parseInt t = - case reads t of - ((i, ""):[]) -> return i - _ -> Ex.throw $ "could not parse integer: \"" <> pack t <> "\"\n" - - --- | Creates options that add an operand that matches the posting if a --- particluar field matches the pattern given. -patternOption :: - String - -- ^ Long option - - -> Maybe Char - -- ^ Short option, if included - - -> (TM.Matcher -> P.LPdct) - -- ^ When applied to a Matcher, this function returns a predicate. - - -> OptSpec ( CaseSensitive - -> MatcherFactory - -> Ex.Exceptional Error Operand ) -patternOption str mc f = C.OptSpec [str] so (C.OneArg g) - where - so = maybe [] (:[]) mc - g a1 cs fty = f <$> getMatcher a1 cs fty - - --- | The account option; matches if the pattern given matches the --- colon-separated account name. -account :: OptSpec ( CaseSensitive - -> MatcherFactory - -> Ex.Exceptional Error Operand ) -account = C.OptSpec ["account"] "a" (C.OneArg f) - where - f a1 cs fty - = fmap P.account - $ getMatcher a1 cs fty - - --- | The account-level option; matches if the account at the given --- level matches. -accountLevel :: OptSpec ( CaseSensitive - -> MatcherFactory - -> Ex.Exceptional Error Operand) -accountLevel = C.OptSpec ["account-level"] "" (C.TwoArg f) - where - f a1 a2 cs fty - = P.accountLevel <$> parseInt a1 <*> getMatcher a2 cs fty - - --- | The accountAny option; returns True if the matcher given matches --- a single sub-account name at any level. -accountAny :: OptSpec ( CaseSensitive - -> MatcherFactory - -> Ex.Exceptional Error Operand ) -accountAny = patternOption "account-any" Nothing P.accountAny - --- | The payee option; returns True if the matcher matches the payee --- name. -payee :: OptSpec ( CaseSensitive - -> MatcherFactory - -> Ex.Exceptional Error Operand ) -payee = patternOption "payee" (Just 'p') P.payee - -tag :: OptSpec ( CaseSensitive - -> MatcherFactory - -> Ex.Exceptional Error Operand) -tag = patternOption "tag" (Just 't') P.tag - -number :: OptSpec ( CaseSensitive - -> MatcherFactory - -> Ex.Exceptional Error Operand ) -number = patternOption "number" (Just 'n') P.number - -flag :: OptSpec ( CaseSensitive - -> MatcherFactory - -> Ex.Exceptional Error Operand) -flag = patternOption "flag" (Just 'f') P.flag - -commodity :: OptSpec ( CaseSensitive - -> MatcherFactory - -> Ex.Exceptional Error Operand) -commodity = patternOption "commodity" (Just 'y') P.commodity - -filename :: OptSpec ( CaseSensitive - -> MatcherFactory - -> Ex.Exceptional Error Operand ) -filename = patternOption "filename" Nothing P.filename - -postingMemo :: OptSpec ( CaseSensitive - -> MatcherFactory - -> Ex.Exceptional Error Operand) -postingMemo = patternOption "posting-memo" Nothing P.postingMemo - -transactionMemo :: OptSpec ( CaseSensitive - -> MatcherFactory - -> Ex.Exceptional Error Operand) -transactionMemo = patternOption "transaction-memo" - Nothing P.transactionMemo - -debit :: OptSpec Operand -debit = C.OptSpec ["debit"] [] (C.NoArg P.debit) - -credit :: OptSpec Operand -credit = C.OptSpec ["credit"] [] (C.NoArg P.credit) - -qtyOption :: OptSpec (Ex.Exceptional Error Operand) -qtyOption = C.OptSpec ["qty"] "q" (C.TwoArg f) - where - f a1 a2 = do - qt <- parseQty a2 - parseComparer a1 (flip P.qty qt) - parseQty a = case parse Pc.quantity "" (pack a) of - Left e -> Ex.throw $ "could not parse quantity: " - <> pack a <> " - " - <> (pack . show $ e) - Right g -> pure g - - --- | Creates two options suitable for comparison of serial numbers, --- one for ascending, one for descending. -serialOption :: - - (L.PostFam -> Maybe L.Serial) - -- ^ Function that, when applied to a PostingChild, returns the serial - -- you are interested in. - - -> String - -- ^ Name of the command line option, such as @global-transaction@ - - -> ( OptSpec (Ex.Exceptional Error Operand) - , OptSpec (Ex.Exceptional Error Operand) ) - -- ^ Parses both descending and ascending serial options. - -serialOption getSerial n = (osA, osD) - where - osA = C.OptSpec [n] [] - (C.TwoArg (f n L.forward)) - osD = let name = addPrefix "rev" n - in C.OptSpec [name] [] - (C.TwoArg (f name L.backward)) - f name getInt a1 a2 = do - num <- parseInt a2 - let getPdct = E.compareByMaybe (pack . show $ num) (pack name) cmp - cmp l = case getSerial l of - Nothing -> Nothing - Just ser -> Just $ compare (getInt ser) num - parseComparer a1 getPdct - - --- | Creates two options suitable for comparison of sibling serial --- numbers. Similar to 'serialOption'. -siblingSerialOption - - :: (L.Posting -> Maybe L.Serial) - -- ^ Function that, when applied to a PostFam, returns the serial - -- you are interested in. - - -> String - -- ^ Name of the command line option, such as @global-posting@ - - -> ( OptSpec (Ex.Exceptional Error Operand) - , OptSpec (Ex.Exceptional Error Operand) ) - -- ^ Parses both descending and ascending serial options. - -siblingSerialOption getSerial n = (osA, osD) - where - osA = C.OptSpec ["s-" ++ n] [] - (C.TwoArg (f n L.forward)) - osD = let name = addPrefix "rev" n - in C.OptSpec ["s-" ++ name] [] - (C.TwoArg (f name L.backward)) - f name getInt a1 a2 = do - num <- parseInt a2 - let getPdct ord = E.operand desc fn - where - desc = "any sibling serial " <> pack name - <> " is " <> descCmp ord - <> " " <> (pack . show $ num) - fn = any doCmp . getSiblings . L.unPostFam - doCmp p = case getSerial p of - Nothing -> False - Just ser -> compare (getInt ser) num == ord - parseComparer a1 getPdct - - -getSiblings :: Child p c -> [c] -getSiblings (Child _ s1 ss _) = s1:ss - -descCmp :: Ordering -> Text -descCmp o = case o of - LT -> "less than" - EQ -> "equal to" - GT -> "greater than" - --- | Takes a string, adds a prefix and capitalizes the first letter of --- the old string. e.g. applied to "rev" and "globalTransaction", --- returns "revGlobalTransaction". -addPrefix :: String -> String -> String -addPrefix pre suf = pre ++ suf' where - suf' = case suf of - "" -> "" - x:xs -> toUpper x : xs - -globalTransaction :: ( OptSpec (Ex.Exceptional Error Operand) - , OptSpec (Ex.Exceptional Error Operand) ) -globalTransaction = - let f = fmap L.unGlobalTransaction - . L.tGlobalTransaction - . parent - . L.unPostFam - in serialOption f "globalTransaction" - -globalPosting :: ( OptSpec (Ex.Exceptional Error Operand) - , OptSpec (Ex.Exceptional Error Operand) ) -globalPosting = - let f = fmap L.unGlobalPosting - . L.pGlobalPosting - . child - . L.unPostFam - in serialOption f "globalPosting" - -filePosting :: ( OptSpec (Ex.Exceptional Error Operand) - , OptSpec (Ex.Exceptional Error Operand) ) -filePosting = - let f = fmap L.unFilePosting - . L.pFilePosting - . child - . L.unPostFam - in serialOption f "filePosting" - -fileTransaction :: ( OptSpec (Ex.Exceptional Error Operand) - , OptSpec (Ex.Exceptional Error Operand) ) -fileTransaction = - let f = fmap L.unFileTransaction - . L.tFileTransaction - . parent - . L.unPostFam - in serialOption f "fileTransaction" - --- | All operand OptSpec. -operandSpecs - :: L.DateTime - -> [OptSpec (CaseSensitive - -> MatcherFactory - -> Ex.Exceptional Error Operand)] - -operandSpecs dt = - [ fmap (const . const) date - , fmap (const . const . pure) (current dt) - , account - , accountLevel - , accountAny - , payee - , tag - , number - , flag - , commodity - , postingMemo - , transactionMemo - , filename - , fmap (const . const . pure) debit - , fmap (const . const . pure) credit - , fmap (const . const) qtyOption - - , sAccount - , sAccountLevel - , sAccountAny - , sPayee - , sTag - , sNumber - , sFlag - , sCommodity - , sPostingMemo - , fmap (const . const . pure) sDebit - , fmap (const . const. pure) sCredit - , fmap (const . const) sQtyOption - ] - ++ serialSpecs - -serialSpecs :: [OptSpec (CaseSensitive - -> MatcherFactory - -> Ex.Exceptional Error Operand)] -serialSpecs - = concat - $ [unDouble] - <*> [ globalTransaction, globalPosting, - filePosting, fileTransaction, - sGlobalPosting, sFilePosting ] - -unDouble - :: Functor f - => (f (Ex.Exceptional Error a), - f (Ex.Exceptional Error a )) - -> [ f (x -> y -> Ex.Exceptional Error a) ] -unDouble (o1, o2) = [fmap (const . const) o1, fmap (const . const) o2] - - ------------------------------------------------------------- --- Post filters ------------------------------------------------------------- - --- | The user passed a bad number for the head or tail option. The --- argument is the bad number passed. -data BadHeadTailError = BadHeadTailError Text - deriving Show - -optHead :: OptSpec (Ex.Exceptional Error PostFilterFn) -optHead = C.OptSpec ["head"] [] (C.OneArg f) - where - f a = do - num <- parseInt a - let g _ ii = ii < (ItemIndex num) - return g - -optTail :: OptSpec (Ex.Exceptional Error PostFilterFn) -optTail = C.OptSpec ["tail"] [] (C.OneArg f) - where - f a = do - num <- parseInt a - let g (ListLength len) (ItemIndex ii) = ii >= len - num - return g - - -postFilterSpecs :: ( OptSpec (Ex.Exceptional Error PostFilterFn) - , OptSpec (Ex.Exceptional Error PostFilterFn) ) -postFilterSpecs = (optHead, optTail) - ------------------------------------------------------------- --- Matcher control ------------------------------------------------------------- - -parseInsensitive :: OptSpec CaseSensitive -parseInsensitive = - C.OptSpec ["case-insensitive"] ['i'] (C.NoArg Insensitive) - - -parseSensitive :: OptSpec CaseSensitive -parseSensitive = - C.OptSpec ["case-sensitive"] ['I'] (C.NoArg Sensitive) - - -within :: OptSpec MatcherFactory -within = - C.OptSpec ["within"] "w" . C.NoArg $ \c t -> - return (TM.within c t) - -pcre :: OptSpec MatcherFactory -pcre = C.OptSpec ["pcre"] "r" (C.NoArg TM.pcre) - -posix :: OptSpec MatcherFactory -posix = C.OptSpec ["posix"] "" (C.NoArg TM.tdfa) - -exact :: OptSpec MatcherFactory -exact = C.OptSpec ["exact"] "x" . C.NoArg $ \c t -> - return (TM.exact c t) - -matcherSelectSpecs :: [OptSpec MatcherFactory] -matcherSelectSpecs = [within, pcre, posix, exact] - -caseSelectSpecs :: [OptSpec CaseSensitive] -caseSelectSpecs = [parseInsensitive, parseSensitive] - ------------------------------------------------------------- --- Operators ------------------------------------------------------------- - --- | Open parentheses -open :: OptSpec (X.Token a) -open = C.OptSpec ["open"] "(" (C.NoArg X.openParen) - --- | Close parentheses -close :: OptSpec (X.Token a) -close = C.OptSpec ["close"] ")" (C.NoArg X.closeParen) - --- | and operator -parseAnd :: OptSpec (X.Token a) -parseAnd = C.OptSpec ["and"] "A" (C.NoArg X.opAnd) - --- | or operator -parseOr :: OptSpec (X.Token a) -parseOr = C.OptSpec ["or"] "O" (C.NoArg X.opOr) - --- | not operator -parseNot :: OptSpec (X.Token a) -parseNot = C.OptSpec ["not"] "N" (C.NoArg X.opNot) - -operatorSpecs :: [OptSpec (X.Token a)] -operatorSpecs = - [open, close, parseAnd, parseOr, parseNot] - --- Infix and RPN expression selectors - -parseInfix :: OptSpec X.ExprDesc -parseInfix = C.OptSpec ["infix"] "" (C.NoArg X.Infix) - -parseRPN :: OptSpec X.ExprDesc -parseRPN = C.OptSpec ["rpn"] "" (C.NoArg X.RPN) - --- | Both Infix and RPN options. -exprDesc :: [OptSpec X.ExprDesc] -exprDesc = [ parseInfix, parseRPN ] - -showExpression :: OptSpec () -showExpression = C.OptSpec ["show-expression"] "" (C.NoArg ()) - -verboseFilter :: OptSpec () -verboseFilter = C.OptSpec ["verbose-filter"] "" (C.NoArg ()) - --- --- Siblings --- - -sGlobalPosting :: ( OptSpec (Ex.Exceptional Error Operand) - , OptSpec (Ex.Exceptional Error Operand) ) -sGlobalPosting = - siblingSerialOption (fmap (fmap L.unGlobalPosting) L.pGlobalPosting) - "globalPosting" - -sFilePosting :: ( OptSpec (Ex.Exceptional Error Operand) - , OptSpec (Ex.Exceptional Error Operand) ) -sFilePosting = - siblingSerialOption (fmap (fmap L.unFilePosting) L.pFilePosting) - "filePosting" - -sAccount :: OptSpec ( CaseSensitive - -> MatcherFactory - -> Ex.Exceptional Error Operand ) -sAccount = C.OptSpec ["s-account"] "" (C.OneArg f) - where - f a1 cs fty = fmap PS.account - $ getMatcher a1 cs fty - -sAccountLevel :: OptSpec ( CaseSensitive - -> MatcherFactory - -> Ex.Exceptional Error Operand ) -sAccountLevel = C.OptSpec ["s-account-level"] "" (C.TwoArg f) - where - f a1 a2 cs fty - = PS.accountLevel <$> parseInt a1 <*> getMatcher a2 cs fty - -sAccountAny :: OptSpec ( CaseSensitive - -> MatcherFactory - -> Ex.Exceptional Error Operand ) -sAccountAny = patternOption "s-account-any" Nothing PS.accountAny - --- | The payee option; returns True if the matcher matches the payee --- name. -sPayee :: OptSpec ( CaseSensitive - -> MatcherFactory - -> Ex.Exceptional Error Operand ) -sPayee = patternOption "s-payee" (Just 'p') PS.payee - -sTag :: OptSpec ( CaseSensitive - -> MatcherFactory - -> Ex.Exceptional Error Operand) -sTag = patternOption "s-tag" (Just 't') PS.tag - -sNumber :: OptSpec ( CaseSensitive - -> MatcherFactory - -> Ex.Exceptional Error Operand ) -sNumber = patternOption "s-number" Nothing PS.number - -sFlag :: OptSpec ( CaseSensitive - -> MatcherFactory - -> Ex.Exceptional Error Operand) -sFlag = patternOption "s-flag" Nothing PS.flag - -sCommodity :: OptSpec ( CaseSensitive - -> MatcherFactory - -> Ex.Exceptional Error Operand) -sCommodity = patternOption "s-commodity" Nothing PS.commodity - -sPostingMemo :: OptSpec ( CaseSensitive - -> MatcherFactory - -> Ex.Exceptional Error Operand) -sPostingMemo = patternOption "s-posting-memo" Nothing PS.postingMemo - -sDebit :: OptSpec Operand -sDebit = C.OptSpec ["s-debit"] [] (C.NoArg PS.debit) - -sCredit :: OptSpec Operand -sCredit = C.OptSpec ["s-credit"] [] (C.NoArg PS.credit) - -sQtyOption :: OptSpec (Ex.Exceptional Error Operand) -sQtyOption = C.OptSpec ["s-qty"] [] (C.TwoArg f) - where - f a1 a2 = do - qt <- parseQty a2 - parseComparer a1 (flip PS.qty qt) - parseQty a = case parse Pc.quantity "" (pack a) of - Left e -> Ex.throw $ "could not parse quantity: " - <> pack a <> " - " - <> (pack . show $ e) - Right g -> pure g - --- --- Versions --- - --- | Parses the @--version@ option and returns an IO action that --- prints it and exits successfully. You supply the version of the --- executable, as there is no easy way to get that automatically. - -version - :: V.Version - -- ^ Version of binary - -> OptSpec (IO a) -version v = C.OptSpec ["version"] [] (C.NoArg f) - where - f = do - pn <- MA.getProgName - putStrLn $ pn ++ " version " ++ V.showVersion v - putStrLn $ "using version " ++ V.showVersion PPL.version - ++ " of penny-lib" - Exit.exitSuccess diff --git a/Penny/Lincoln.hs b/Penny/Lincoln.hs deleted file mode 100644 --- a/Penny/Lincoln.hs +++ /dev/null @@ -1,272 +0,0 @@ --- | Lincoln - the Penny core --- --- Penny's core types and classes are here. This module re-exports the --- most useful things. For more details you will want to look at the --- sub-modules. Also, not all types and functions are re-exported due --- to naming conflicts. In particular, neither --- "Penny.Lincoln.Predicates" nor "Penny.Lincoln.Queries" is exported --- from here due to the blizzard of name conflicts that would result. -module Penny.Lincoln ( - -- * Balances - B.Balance - , B.unBalance - , B.Balanced(Balanced, Inferable, NotInferable) - , B.isBalanced - , B.entryToBalance - , B.addBalances - , B.removeZeroCommodities - , B.BottomLine (Zero, NonZero) - , B.Column (Column) - - -- * Bits - -- ** Accounts - , I.SubAccount (SubAccount, unSubAccount) - , I.Account(Account, unAccount) - - -- ** Amounts - , I.Amount (Amount, qty, commodity, side, spaceBetween) - - -- ** Commodities - , I.Commodity (Commodity, unCommodity) - - -- ** DateTime - , I.TimeZoneOffset ( offsetToMins ) - , I.minsToOffset - , I.noOffset - , I.Hours ( unHours ) - , I.intToHours - , I.Minutes ( unMinutes ) - , I.intToMinutes - , I.Seconds ( unSeconds ) - , I.intToSeconds - , I.zeroSeconds - , I.midnight - , I.DateTime ( .. ) - , I.dateTimeMidnightUTC - , I.toUTC - , I.toZonedTime - , I.fromZonedTime - , I.sameInstant - , I.showDateTime - - -- ** Debits and credits - , I.DrCr(Debit, Credit) - , I.opposite - - -- ** Entries - , I.Entry (Entry, drCr, amount) - - -- ** Flag - , I.Flag (Flag, unFlag) - - -- ** Memos - , I.Memo (Memo, unMemo) - - -- ** Number - , I.Number (Number, unNumber) - - -- ** Payee - , I.Payee (Payee, unPayee) - - -- ** Prices and price points - , I.From(From, unFrom) - , I.To(To, unTo) - , I.CountPerUnit(CountPerUnit, unCountPerUnit) - , I.Price(from, to, countPerUnit) - , I.newPrice - , I.PricePoint ( PricePoint, dateTime, price, ppSide, - ppSpaceBetween, priceLine) - - -- ** Quantities - , I.Qty - , I.NumberStr(..) - , I.toQty - , I.mantissa - , I.places - , I.add - , I.mult - , I.difference - , I.equivalent - , I.newQty - , I.Mantissa, I.Places - , I.Difference(..) - , I.allocate - - -- ** Tags - , I.Tag(Tag, unTag) - , I.Tags(Tags, unTags) - - - -- * Builders - , Bd.account - - -- * Families - -- ** Family types - , F.Family(Family) - , F.Child(Child) - , F.Siblings(Siblings) - - -- ** Manipulating families - , F.children - , F.orphans - , F.adopt - , F.marryWith - , F.marry - , F.divorceWith - , F.divorce - , F.filterChildren - , F.find - , F.mapChildren - , F.mapChildrenA - , F.mapParent - , F.mapParentA - - -- * HasText - , HT.HasText(text) - , HT.HasTextList(textList) - - -- * Transactions - -- ** Postings and transactions - , T.Posting - , T.Transaction - , T.PostFam - - -- ** Making and deconstructing transactions - , T.transaction - , T.RTransaction(..) - , T.rTransaction - , T.Error ( UnbalancedError, CouldNotInferError) - , T.toUnverified - - -- ** Querying postings - , T.Inferred(Inferred, NotInferred) - , T.pPayee - , T.pNumber - , T.pFlag - , T.pAccount - , T.pTags - , T.pEntry - , T.pMemo - , T.pInferred - , T.pPostingLine - , T.pGlobalPosting - , T.pFilePosting - - -- ** Querying transactions - , T.TopLine - , T.tDateTime - , T.tFlag - , T.tNumber - , T.tPayee - , T.tMemo - , T.tTopLineLine - , T.tTopMemoLine - , T.tFilename - , T.tGlobalTransaction - , T.tFileTransaction - , T.postFam - - -- ** Unwrapping Transactions - , T.unTransaction - , T.unPostFam - - -- ** Transaction boxes - , T.Box (Box, boxMeta, boxPostFam) - - -- ** Changing transactions - , T.TopLineChangeData(..) - , T.emptyTopLineChangeData - , T.PostingChangeData(..) - , T.emptyPostingChangeData - , T.changeTransaction - - -- * Metadata - , I.TopLineLine(..) - , I.TopMemoLine(..) - , I.Side(CommodityOnLeft, CommodityOnRight) - , I.SpaceBetween(SpaceBetween, NoSpaceBetween) - , I.Filename(Filename, unFilename) - , I.PriceLine(PriceLine, unPriceLine) - , I.PostingLine(PostingLine, unPostingLine) - , I.GlobalPosting(GlobalPosting, unGlobalPosting) - , I.FilePosting(FilePosting, unFilePosting) - , I.GlobalTransaction(GlobalTransaction, unGlobalTransaction) - , I.FileTransaction(FileTransaction, unFileTransaction) - - -- * PriceDb - , DB.PriceDb - , DB.emptyDb - , DB.addPrice - , DB.getPrice - , DB.PriceDbError(FromNotFound, ToNotFound, CpuNotFound) - , DB.convert - - -- * Serials - , S.Serial - , S.forward - , S.backward - , S.GenSerial - , S.incrementBack - , S.getSerial - , S.makeSerials - , S.serialItems - , S.nSerials - - -- * Matchers - , Matchers.Factory - - -- * Showing postFam in one line - , display - - ) where - -import qualified Penny.Lincoln.Balance as B -import qualified Penny.Lincoln.Bits as I -import qualified Penny.Lincoln.Builders as Bd -import qualified Penny.Lincoln.Family as F -import qualified Penny.Lincoln.HasText as HT -import qualified Penny.Lincoln.Matchers as Matchers -import qualified Penny.Lincoln.PriceDb as DB -import qualified Penny.Lincoln.Serial as S -import qualified Penny.Lincoln.Transaction as T - -import Data.List (intersperse) -import Data.Text (Text) -import qualified Data.Text as X -import qualified Penny.Lincoln.Queries as Q -import qualified Data.Time as Time -import System.Locale (defaultTimeLocale) - --- --- Display --- - --- | Displays a PostFam in a one line format. --- --- Format: --- --- File LineNo Date Payee Acct DrCr Cmdty Qty -display :: T.PostFam -> Text -display p = X.pack $ concat (intersperse " " ls) - where - ls = [file, lineNo, dt, pye, acct, dc, cmdty, qt] - file = maybe (labelNo "filename") (X.unpack . I.unFilename) - (Q.filename p) - lineNo = maybe (labelNo "line number") - (show . I.unPostingLine) (Q.postingLine p) - dateFormat = "%Y-%m-%d %T %z" - dt = Time.formatTime defaultTimeLocale dateFormat - . Time.utctDay - . I.toUTC - . Q.dateTime - $ p - pye = maybe (labelNo "payee") - (X.unpack . HT.text) (Q.payee p) - acct = X.unpack . X.intercalate (X.singleton ':') - . map I.unSubAccount . I.unAccount . Q.account $ p - dc = case Q.drCr p of - I.Debit -> "Dr" - I.Credit -> "Cr" - cmdty = X.unpack . I.unCommodity . Q.commodity $ p - qt = show . Q.qty $ p - labelNo s = "(no " ++ s ++ ")" diff --git a/Penny/Lincoln/Balance.hs b/Penny/Lincoln/Balance.hs deleted file mode 100644 --- a/Penny/Lincoln/Balance.hs +++ /dev/null @@ -1,109 +0,0 @@ -module Penny.Lincoln.Balance ( - Balance, - unBalance, - Balanced(Balanced, Inferable, NotInferable), - isBalanced, - entryToBalance, - addBalances, - removeZeroCommodities, - BottomLine(Zero, NonZero), - Column(Column, drCr, qty) - ) where - -import Data.Map ( Map ) -import qualified Data.Map as M -import Data.Monoid ( Monoid, mempty, mappend ) -import qualified Data.Semigroup as Semi - -import Penny.Lincoln.Bits ( - add, difference, Difference(LeftBiggerBy, RightBiggerBy, Equal)) -import qualified Penny.Lincoln.Bits as B - --- | A balance summarizes several entries. You do not create a Balance --- directly. Instead, use 'entryToBalance'. -newtype Balance = Balance (Map B.Commodity BottomLine) - deriving (Show, Eq) - --- | Returns a map where the keys are the commodities in the balance --- and the values are the balance for each commodity. If there is no --- balance at all, this map can be empty. -unBalance :: Balance -> Map B.Commodity BottomLine -unBalance (Balance m) = m - --- | Returned by 'isBalanced'. -data Balanced = Balanced - | Inferable B.Entry - | NotInferable - deriving (Show, Eq) - --- | Is this balance balanced? -isBalanced :: Balance -> Balanced -isBalanced (Balance m) = M.foldrWithKey f Balanced m where - f c n b = case n of - Zero -> b - (NonZero col) -> case b of - Balanced -> let - e = B.Entry dc a - dc = case drCr col of - B.Debit -> B.Credit - B.Credit -> B.Debit - q = qty col - a = B.Amount q c Nothing Nothing - in Inferable e - _ -> NotInferable - --- | Converts an Entry to a Balance. -entryToBalance :: B.Entry -> Balance -entryToBalance (B.Entry dc am) = Balance $ M.singleton c no where - c = B.commodity am - no = NonZero (Column dc (B.qty am)) - -data BottomLine = Zero - | NonZero Column - deriving (Show, Eq) - -instance Monoid BottomLine where - mempty = Zero - mappend n1 n2 = case (n1, n2) of - (Zero, Zero) -> Zero - (Zero, (NonZero c)) -> NonZero c - ((NonZero c), Zero) -> NonZero c - ((NonZero c1), (NonZero c2)) -> - let (Column dc1 q1) = c1 - (Column dc2 q2) = c2 - in if dc1 == dc2 - then NonZero $ Column dc1 (q1 `add` q2) - else case difference q1 q2 of - LeftBiggerBy diff -> - NonZero $ Column dc1 diff - RightBiggerBy diff -> - NonZero $ Column dc2 diff - Equal -> Zero - -data Column = Column { drCr :: B.DrCr - , qty :: B.Qty } - deriving (Show, Eq) - --- | Add two Balances together. Commodities are never removed from the --- balance, even if their balance is zero. Instead, they are left in --- the balance. Sometimes you want to know that a commodity was in the --- account but its balance is now zero. -addBalances :: Balance -> Balance -> Balance -addBalances (Balance t1) (Balance t2) = - Balance $ M.unionWith mappend t1 t2 - -instance Semi.Semigroup Balance where - (<>) = addBalances - -instance Monoid Balance where - mempty = Balance M.empty - mappend = addBalances - --- | Removes zero balances from a Balance. -removeZeroCommodities :: Balance -> Balance -removeZeroCommodities (Balance m) = - let p b = case b of - Zero -> False - _ -> True - m' = M.filter p m - in Balance m' diff --git a/Penny/Lincoln/Bits.hs b/Penny/Lincoln/Bits.hs deleted file mode 100644 --- a/Penny/Lincoln/Bits.hs +++ /dev/null @@ -1,97 +0,0 @@ --- | Essential data types used to make Transactions and Postings. -module Penny.Lincoln.Bits ( - -- * Accounts - O.SubAccount(SubAccount, unSubAccount), - O.Account(Account, unAccount), - - -- * Amounts - O.Amount(Amount, qty, commodity, side, spaceBetween), - - -- * Commodities - O.Commodity(Commodity, unCommodity), - - -- * DateTime - DT.TimeZoneOffset ( offsetToMins ), - DT.minsToOffset, - DT.noOffset, - DT.Hours ( unHours ), - DT.intToHours, - DT.zeroHours, - DT.Minutes ( unMinutes ), - DT.intToMinutes, - DT.zeroMinutes, - DT.midnight, - DT.Seconds ( unSeconds ), - DT.intToSeconds, - DT.zeroSeconds, - DT.DateTime ( .. ), - DT.dateTimeMidnightUTC, - DT.toUTC, - DT.toZonedTime, - DT.fromZonedTime, - DT.sameInstant, - DT.showDateTime, - - -- * Debits and Credits - O.DrCr(Debit, Credit), - O.opposite, - - -- * Entries - O.Entry(Entry, drCr, amount), - - -- * Flag - O.Flag(Flag, unFlag), - - -- * Memos - O.Memo(Memo, unMemo), - - -- * Number - O.Number(Number, unNumber), - - -- * Payee - O.Payee(Payee, unPayee), - - -- * Prices and price points - Pr.From(From, unFrom), Pr.To(To, unTo), - Pr.CountPerUnit(CountPerUnit, unCountPerUnit), - Pr.Price(from, to, countPerUnit), - Pr.convert, Pr.newPrice, - PricePoint ( .. ), - - -- * Quantities - Q.Qty, Q.NumberStr(..), Q.toQty, Q.mantissa, Q.places, - Q.add, Q.mult, Q.difference, Q.equivalent, Q.newQty, - Q.Mantissa, Q.Places, - Q.Difference(Q.LeftBiggerBy, Q.RightBiggerBy, Q.Equal), - Q.allocate, - - -- * Tags - O.Tag(Tag, unTag), - O.Tags(Tags, unTags), - - -- * Metadata - O.TopLineLine(..), - O.TopMemoLine(..), - O.Side(..), - O.SpaceBetween(..), - O.Filename(..), - O.PriceLine(..), - O.PostingLine(..), - O.GlobalPosting(..), - O.FilePosting(..), - O.GlobalTransaction(..), - O.FileTransaction(..) - ) where - - -import qualified Penny.Lincoln.Bits.Open as O -import qualified Penny.Lincoln.Bits.DateTime as DT -import qualified Penny.Lincoln.Bits.Price as Pr -import qualified Penny.Lincoln.Bits.Qty as Q - -data PricePoint = PricePoint { dateTime :: DT.DateTime - , price :: Pr.Price - , ppSide :: Maybe O.Side - , ppSpaceBetween :: Maybe O.SpaceBetween - , priceLine :: Maybe O.PriceLine } - deriving (Eq, Show) diff --git a/Penny/Lincoln/Bits/DateTime.hs b/Penny/Lincoln/Bits/DateTime.hs deleted file mode 100644 --- a/Penny/Lincoln/Bits/DateTime.hs +++ /dev/null @@ -1,152 +0,0 @@ -module Penny.Lincoln.Bits.DateTime - ( TimeZoneOffset ( offsetToMins ) - , minsToOffset - , noOffset - , Hours ( unHours ) - , intToHours - , zeroHours - , Minutes ( unMinutes ) - , intToMinutes - , zeroMinutes - , Seconds ( unSeconds ) - , intToSeconds - , zeroSeconds - , midnight - , DateTime ( .. ) - , dateTimeMidnightUTC - , toUTC - , toZonedTime - , fromZonedTime - , sameInstant - , showDateTime - ) where - -import qualified Data.Time as T - --- | The number of minutes that this timezone is offset from UTC. Can --- be positive, negative, or zero. -newtype TimeZoneOffset = TimeZoneOffset { offsetToMins :: Int } - deriving (Eq, Ord, Show) - --- | Convert minutes to a time zone offset. I'm having a hard time --- deciding whether to be liberal or strict in what to accept --- here. Currently it is somewhat strict in that it will fail if --- absolute value is greater than 840 minutes; currently the article --- at http://en.wikipedia.org/wiki/List_of_time_zones_by_UTC_offset --- says there is no offset greater than 14 hours, or 840 minutes. -minsToOffset :: Int -> Maybe TimeZoneOffset -minsToOffset m = if abs m > 840 - then Nothing - else Just $ TimeZoneOffset m - -noOffset :: TimeZoneOffset -noOffset = TimeZoneOffset 0 - -newtype Hours = Hours { unHours :: Int } - deriving (Eq, Ord, Show) - -newtype Minutes = Minutes { unMinutes :: Int } - deriving (Eq, Ord, Show) - -newtype Seconds = Seconds { unSeconds :: Int } - deriving (Eq, Ord, Show) - --- | succeeds if 0 <= x < 24 -intToHours :: Int -> Maybe Hours -intToHours h = - if h >= 0 && h < 24 then Just . Hours $ h else Nothing - -zeroHours :: Hours -zeroHours = Hours 0 - --- | succeeds if 0 <= x < 60 -intToMinutes :: Int -> Maybe Minutes -intToMinutes m = - if m >= 0 && m < 60 then Just . Minutes $ m else Nothing - -zeroMinutes :: Minutes -zeroMinutes = Minutes 0 - --- | succeeds if 0 <= x < 61 (to allow for leap seconds) -intToSeconds :: Int -> Maybe Seconds -intToSeconds s = - if s >= 0 && s < 61 - then Just . Seconds $ s - else Nothing - -zeroSeconds :: Seconds -zeroSeconds = Seconds 0 - -midnight :: (Hours, Minutes, Seconds) -midnight = (zeroHours, zeroMinutes, zeroSeconds) - --- | A DateTime is a a local date and time, along with a time zone --- offset. The Eq and Ord instances are derived; therefore, two --- DateTime instances will not be equivalent if the time zone offsets --- are different, even if they are the same instant. To compare one --- DateTime to another, you probably want to use 'toUTC' and compare --- those. To see if two DateTime are the same instant, use --- 'sameInstant'. -data DateTime = DateTime - { day :: T.Day - , hours :: Hours - , minutes :: Minutes - , seconds :: Seconds - , timeZone :: TimeZoneOffset - } deriving (Eq, Ord, Show) - -dateTimeMidnightUTC :: T.Day -> DateTime -dateTimeMidnightUTC d = DateTime d h m s z - where - (h, m, s) = midnight - z = noOffset - -toZonedTime :: DateTime -> T.ZonedTime -toZonedTime dt = T.ZonedTime lt tz - where - d = day dt - lt = T.LocalTime d tod - tod = T.TimeOfDay (unHours . hours $ dt) (unMinutes . minutes $ dt) - (fromIntegral . unSeconds . seconds $ dt) - tz = T.TimeZone (offsetToMins . timeZone $ dt) False "" - -fromZonedTime :: T.ZonedTime -> Maybe DateTime -fromZonedTime (T.ZonedTime (T.LocalTime d tod) tz) = do - h <- intToHours . T.todHour $ tod - m <- intToMinutes . T.todMin $ tod - let (sWhole, _) = properFraction . T.todSec $ tod - s <- intToSeconds sWhole - tzo <- minsToOffset . T.timeZoneMinutes $ tz - return $ DateTime d h m s tzo - -toUTC :: DateTime -> T.UTCTime -toUTC dt = T.localTimeToUTC tz lt - where - tz = T.minutesToTimeZone . offsetToMins . timeZone $ dt - tod = T.TimeOfDay (unHours h) (unMinutes m) - (fromIntegral . unSeconds $ s) - DateTime d h m s _ = dt - lt = T.LocalTime d tod - --- | Are these DateTimes the same instant in time, after adjusting for --- local timezones? - -sameInstant :: DateTime -> DateTime -> Bool -sameInstant t1 t2 = toUTC t1 == toUTC t2 - --- | Shows a DateTime in a pretty way. -showDateTime :: DateTime -> String -showDateTime (DateTime d h m s tz) = - ds ++ " " ++ hmss ++ " " ++ showOffset - where - ds = show d - hmss = hs ++ ":" ++ ms ++ ":" ++ ss - hs = pad0 . show . unHours $ h - ms = pad0 . show . unMinutes $ m - ss = pad0 . show . unSeconds $ s - pad0 str = if length str < 2 then '0':str else str - showOffset = - let (zoneHr, zoneMin) = abs (offsetToMins tz) `divMod` 60 - sign = if offsetToMins tz < 0 then "-" else "+" - in sign ++ pad0 (show zoneHr) ++ pad0 (show zoneMin) - diff --git a/Penny/Lincoln/Bits/Open.hs b/Penny/Lincoln/Bits/Open.hs deleted file mode 100644 --- a/Penny/Lincoln/Bits/Open.hs +++ /dev/null @@ -1,124 +0,0 @@ --- | These are the bits that are "open"; that is, their constructors --- are exported. This includes most bits. Some bits that have open --- constructors are not in this module because they include other bits --- that do not have exported constructors. - -module Penny.Lincoln.Bits.Open where - -import Data.Text (Text) -import qualified Data.Text as X -import qualified Penny.Lincoln.Serial as S -import qualified Penny.Lincoln.Bits.Qty as Q - -newtype SubAccount = - SubAccount { unSubAccount :: Text } - deriving (Eq, Ord, Show) - -newtype Account = Account { unAccount :: [SubAccount] } - deriving (Eq, Show, Ord) - -data Amount = Amount { qty :: Q.Qty - , commodity :: Commodity - , side :: Maybe Side - , spaceBetween :: Maybe SpaceBetween } - deriving (Eq, Show, Ord) - -newtype Commodity = - Commodity { unCommodity :: Text } - deriving (Eq, Ord, Show) - -data DrCr = Debit | Credit deriving (Eq, Show, Ord) - --- | Debit returns Credit; Credit returns Debit -opposite :: DrCr -> DrCr -opposite d = case d of - Debit -> Credit - Credit -> Debit - -data Entry = Entry { drCr :: DrCr - , amount :: Amount } - deriving (Eq, Show, Ord) - -newtype Flag = Flag { unFlag :: Text } - deriving (Eq, Show, Ord) - --- | There is one item in the list for each line of the memo. Do not --- include newlines in the texts themselves. However there is nothing --- to enforce this convention. -newtype Memo = Memo { unMemo :: [Text] } - deriving (Eq, Show, Ord) - -newtype Number = Number { unNumber :: Text } - deriving (Eq, Show, Ord) - -newtype Payee = Payee { unPayee :: Text } - deriving (Eq, Show, Ord) - -newtype Tag = Tag { unTag :: Text } - deriving (Eq, Show, Ord) - -newtype Tags = Tags { unTags :: [Tag] } - deriving (Eq, Show, Ord) - --- Metadata - --- | The line number that the TopLine starts on (excluding the memo --- accompanying the TopLine). -newtype TopLineLine = TopLineLine { unTopLineLine :: Int } - deriving (Eq, Show) - --- | The line number that the memo accompanying the TopLine starts on. -newtype TopMemoLine = TopMemoLine { unTopMemoLine :: Int } - deriving (Eq, Show) - --- | The commodity and and the quantity may appear with the commodity --- on the left (e.g. USD 2.14) or with the commodity on the right --- (e.g. 2.14 USD). -data Side - = CommodityOnLeft - | CommodityOnRight - deriving (Eq, Show, Ord) - --- | There may or may not be a space in between the commodity and the --- quantity. -data SpaceBetween - = SpaceBetween - | NoSpaceBetween - deriving (Eq, Show, Ord) - --- | The name of the file in which a transaction appears. -newtype Filename = Filename { unFilename :: X.Text } - deriving (Eq, Show) - --- | The line number on which a price appears. -newtype PriceLine = PriceLine { unPriceLine :: Int } - deriving (Eq, Show) - --- | The line number on which a posting appears. -newtype PostingLine = PostingLine { unPostingLine :: Int } - deriving (Eq, Show) - --- | All postings are numbered in order, beginning with the first --- posting in the first file and ending with the last posting --- in the last file. -newtype GlobalPosting = - GlobalPosting { unGlobalPosting :: S.Serial } - deriving (Eq, Show) - --- | The postings in each file are numbered in order. -newtype FilePosting = - FilePosting { unFilePosting :: S.Serial } - deriving (Eq, Show) - --- | All transactions are numbered in order, beginning with the first --- transaction in the first file and ending with the last transaction --- in the last file. -newtype GlobalTransaction = - GlobalTransaction { unGlobalTransaction :: S.Serial } - deriving (Eq, Show) - --- | The transactions in each file are numbered in order. -newtype FileTransaction = - FileTransaction { unFileTransaction :: S.Serial } - deriving (Eq, Show) - diff --git a/Penny/Lincoln/Bits/Price.hs b/Penny/Lincoln/Bits/Price.hs deleted file mode 100644 --- a/Penny/Lincoln/Bits/Price.hs +++ /dev/null @@ -1,42 +0,0 @@ -module Penny.Lincoln.Bits.Price ( - From ( From, unFrom ), - To ( To, unTo ), - CountPerUnit ( CountPerUnit, unCountPerUnit ), - Price ( from, to, countPerUnit ), - convert, - newPrice) where - -import qualified Penny.Lincoln.Bits.Open as O -import Penny.Lincoln.Bits.Qty (Qty, mult) - -newtype From = From { unFrom :: O.Commodity } - deriving (Eq, Ord, Show) - -newtype To = To { unTo :: O.Commodity } - deriving (Eq, Ord, Show) - -newtype CountPerUnit = CountPerUnit { unCountPerUnit :: Qty } - deriving (Eq, Ord, Show) - -data Price = Price { from :: From - , to :: To - , countPerUnit :: CountPerUnit } - deriving (Eq, Ord, Show) - --- | Convert an amount from the From price to the To price. Fails if --- the From commodity in the Price is not the same as the commodity in --- the Amount. -convert :: Price -> O.Amount -> Maybe O.Amount -convert p (O.Amount q c sd sb) = - if (unFrom . from $ p) /= c - then Nothing - else let q' = q `mult` (unCountPerUnit . countPerUnit $ p) - in Just (O.Amount q' (unTo . to $ p) sd sb) - --- | Succeeds only if From and To are different commodities. -newPrice :: From -> To -> CountPerUnit -> Maybe Price -newPrice f t cpu = - if unFrom f == unTo t - then Nothing - else Just $ Price f t cpu - diff --git a/Penny/Lincoln/Bits/Qty.hs b/Penny/Lincoln/Bits/Qty.hs deleted file mode 100644 --- a/Penny/Lincoln/Bits/Qty.hs +++ /dev/null @@ -1,300 +0,0 @@ --- | Penny quantities. A quantity is simply a count (possibly --- fractional) of something. It does not have a commodity or a --- Debit/Credit. -module Penny.Lincoln.Bits.Qty ( - Qty, NumberStr(..), toQty, mantissa, places, newQty, - Mantissa, Places, - add, mult, Difference(LeftBiggerBy, RightBiggerBy, Equal), - equivalent, difference, allocate, - TotSeats, PartyVotes, SeatsWon, largestRemainderMethod) where - -import qualified Control.Monad.Exception.Synchronous as Ex -import qualified Data.Foldable as F -import Data.List (genericLength, genericReplicate, genericSplitAt, sortBy) -import Data.List.NonEmpty (NonEmpty((:|))) -import Data.Ord (comparing) - -data NumberStr = - Whole String - -- ^ A whole number only. No radix point. - | WholeRad String - -- ^ A whole number and a radix point, but nothing after the radix - -- point. - | WholeRadFrac String String - -- ^ A whole number and something after the radix point. - | RadFrac String - -- ^ A radix point and a fractional value after it, but nothing - -- before the radix point. - deriving Show - - --- | Converts strings to Qty. Fails if any of the strings have --- non-digits, or if any are negative, or if the result is not greater --- than zero, or if the strings are empty. -toQty :: NumberStr -> Maybe Qty -toQty ns = case ns of - Whole s -> fmap (\m -> Qty m 0) (readInteger s) - WholeRad s -> fmap (\m -> Qty m 0) (readInteger s) - WholeRadFrac w f -> fromWholeRadFrac w f - RadFrac f -> fromWholeRadFrac "0" f - where - fromWholeRadFrac w f = - fmap (\m -> Qty m (genericLength f)) (readInteger (w ++ f)) - --- | Reads non-negative integers only. -readInteger :: String -> Maybe Integer -readInteger s = case reads s of - (i, ""):[] -> if i < 0 then Nothing else Just i - _ -> Nothing - --- | A quantity is always greater than zero. Various odd questions --- happen if quantities can be zero. For instance, what if you have a --- debit whose quantity is zero? Does it require a balancing credit --- that is also zero? And how can you have a debit of zero anyway? --- --- I can imagine situations where a quantity of zero might be useful; --- for instance maybe you want to specifically indicate that a --- particular posting in a transaction did not happen (for instance, --- that a paycheck deduction did not take place). I think the better --- way to handle that though would be through an addition to --- Debit/Credit - maybe Debit/Credit/Zero. Barring the addition of --- that, though, the best way to indicate a situation such as this --- would be through transaction memos. --- --- The Eq instance is derived. Therefore q1 == q2 only if q1 and q2 --- have both the same mantissa and the same exponent. You may instead --- want 'equivalent'. -data Qty = Qty { mantissa :: Integer - , places :: Integer - } deriving Eq - -type Mantissa = Integer -type Places = Integer - -newQty :: Mantissa -> Places -> Maybe Qty -newQty m p - | m > 0 && p >= 0 = Just $ Qty m p - | otherwise = Nothing - --- | Shows a quantity, nicely formatted after accounting for both the --- mantissa and decimal places, e.g. @0.232@ or @232.12@ or whatever. -instance Show Qty where - show (Qty m e) = - let man = show m - len = genericLength man - small = "0." ++ ((genericReplicate (e - len) '0') ++ man) - in case compare e len of - GT -> small - EQ -> small - LT -> - let (b, end) = genericSplitAt (len - e) man - in if e == 0 - then man - else b ++ ['.'] ++ end - - --- | Compares Qty after equalizing their exponents. --- --- > compare (newQty 15 1) (newQty 1500 3) == EQ -instance Ord Qty where - compare q1 q2 = compare (mantissa q1') (mantissa q2') - where - (q1', q2') = equalizeExponents q1 q2 - --- | Adjust the exponents on two Qty so they are equivalent --- before, but now have the same exponent. -equalizeExponents :: Qty -> Qty -> (Qty, Qty) -equalizeExponents x y = (x', y') - where - (ex, ey) = (places x, places y) - (x', y') = case compare ex ey of - GT -> (x, increaseExponent (ex - ey) y) - LT -> (increaseExponent (ey - ex) x, y) - EQ -> (x, y) - - --- | Increase the exponent by the amount given, so that the new Qty is --- equivalent to the old one. Takes the absolute value of the --- adjustment argument. -increaseExponent :: Integer -> Qty -> Qty -increaseExponent i (Qty m e) = Qty m' e' - where - amt = abs i - m' = m * 10 ^ amt - e' = e + amt - --- | Increases the exponent to the given amount. Does nothing if the --- exponent is already at or higher than this amount. -increaseExponentTo :: Integer -> Qty -> Qty -increaseExponentTo i q@(Qty _ e) = - let diff = i - e - in if diff >= 0 then increaseExponent diff q else q - --- | Compares Qty after equalizing their exponents. -equivalent :: Qty -> Qty -> Bool -equivalent x y = x' == y' - where - (x', y') = equalizeExponents x y - -data Difference = - LeftBiggerBy Qty - | RightBiggerBy Qty - | Equal - deriving (Eq, Show) - --- | Subtract the second Qty from the first, after equalizing their --- exponents. -difference :: Qty -> Qty -> Difference -difference x y = - let (x', y') = equalizeExponents x y - (mx, my) = (mantissa x', mantissa y') - in case compare mx my of - GT -> LeftBiggerBy (Qty (mx - my) (places x')) - LT -> RightBiggerBy (Qty (my - mx) (places x')) - EQ -> Equal - -add :: Qty -> Qty -> Qty -add x y = - let ((Qty xm e), (Qty ym _)) = equalizeExponents x y - in Qty (xm + ym) e - -mult :: Qty -> Qty -> Qty -mult (Qty xm xe) (Qty ym ye) = Qty (xm * ym) (xe + ye) - - --- | Allocate a Qty proportionally so that the sum of the results adds --- up to a given Qty. Fails if the allocation cannot be made (e.g. if --- it is impossible to allocate without overflowing Decimal.) The --- result will always add up to the given sum. -allocate - :: Qty - -- ^ The result will add up to this Qty. - - -> NonEmpty Qty - -- ^ Allocate using this list of Qty. - - -> NonEmpty Qty - -- ^ The length of this list will be equal to the length of the list - -- of allocations. Each item will correspond to the original - -- allocation. - -allocate tot ls = - let (tot', ls', e') = sameExponent tot ls - (tI, lsI) = (mantissa tot', fmap mantissa ls') - (seats, (p1 :| ps), moreE) = growTarget tI lsI - adjSeats = seats - (genericLength ps + 1) - del = largestRemainderMethod adjSeats (p1 : ps) - totE = e' + moreE - r1:rs = fmap (\m -> Qty (m + 1) totE) del - in r1 :| rs - - --- | Given a list of Decimals, and a single Decimal, return Decimals --- that are equivalent to the original Decimals, but where all --- Decimals have the same exponent. Also returns new exponent. -sameExponent - :: Qty - -> NonEmpty Qty - -> (Qty, NonEmpty Qty, Integer) -sameExponent dec ls = - let newExp = max (F.maximum . fmap places $ ls) - (places dec) - dec' = increaseExponentTo newExp dec - ls' = fmap (increaseExponentTo newExp) ls - in (dec', ls', newExp) - - --- | Given an Integer and a list of Integers, multiply all integers by --- ten raised to an exponent, so that the first Integer is larger than --- the count of the number of Integers in the list. Returns --- the new Integer, new list of Integers, and the exponent used. --- --- Previously this only grew the first Integer so that it was at least --- as large as the count of Integers in the list, but this causes --- problems, as there must be at least one seat for the allocation process. -growTarget - :: Integer - -> NonEmpty Integer - -> (Integer, NonEmpty Integer, Integer) -growTarget target is = go target is 0 - where - len = genericLength . F.toList $ is - go t xs c = - let t' = t * 10 ^ c - xs' = fmap (\x -> x * 10 ^ c) xs - in if t' > len - then (t', xs', c) - else go t' xs' (c + 1) - --- Largest remainder method: votes for one party is divided by --- (total votes / number of seats). Result is an integer and a --- remainder. Each party gets the number of seats indicated by its --- integer. Parties are then ranked on the basis of the remainders, and --- those with the largest remainders get an additional seat until all --- seats have been distributed. -type AutoSeats = Integer -type PartyVotes = Integer -type TotVotes = Integer -type TotSeats = Integer -type Remainder = Rational -type SeatsWon = Integer - --- | Allocates integers using the largest remainder method. This is --- the method used to allocate parliamentary seats in many countries, --- so the types are named accordingly. -largestRemainderMethod - :: TotSeats - -- ^ Total number of seats in the legislature. This is the integer - -- that will be allocated. This number must be positive or this - -- function will fail at runtime. - - -> [PartyVotes] - -- ^ The total seats will be allocated proportionally depending on - -- how many votes each party received. The sum of this list must be - -- positive, and each member of the list must be at least zero; - -- otherwise a runtime error will occur. - - -> [SeatsWon] - -- ^ The sum of this list will always be equal to the total number - -- of seats, and its length will always be equal to length of the - -- PartyVotes list. - -largestRemainderMethod ts pvs = - let err s = error $ "largestRemainderMethod: error: " ++ s - in Ex.resolve err $ do - Ex.assert "TotalSeats not positive" (ts > 0) - Ex.assert "sum of [PartyVotes] not positive" (sum pvs > 0) - Ex.assert "negative member of [PartyVotes]" (minimum pvs >= 0) - return (allocRemainder ts . allocAuto ts $ pvs) - -autoAndRemainder - :: TotSeats -> TotVotes -> PartyVotes -> (AutoSeats, Remainder) -autoAndRemainder ts tv pv = - let fI = fromIntegral - quota = if ts == 0 - then error "autoAndRemainder: zero total seats" - else if tv == 0 - then error "autoAndRemainder: zero total votes" - else fI tv / fI ts - in properFraction (fI pv / quota) - - -allocAuto :: TotSeats -> [PartyVotes] -> [(AutoSeats, Remainder)] -allocAuto ts pvs = map (autoAndRemainder ts (sum pvs)) pvs - -allocRemainder - :: TotSeats - -> [(AutoSeats, Remainder)] - -> [SeatsWon] -allocRemainder ts ls = - let totLeft = ts - (sum . map fst $ ls) - (leftForEach, stillLeft) = totLeft `divMod` genericLength ls - wIndex = zip ([0..] :: [Integer]) ls - sorted = sortBy (comparing (snd . snd)) wIndex - wOrder = zip [0..] sorted - awarder (ord, (ix, (as, _))) = - if ord < stillLeft - then (ix, as + leftForEach + 1) - else (ix, as + leftForEach) - awarded = map awarder wOrder - in map snd . sortBy (comparing fst) $ awarded diff --git a/Penny/Lincoln/Builders.hs b/Penny/Lincoln/Builders.hs deleted file mode 100644 --- a/Penny/Lincoln/Builders.hs +++ /dev/null @@ -1,28 +0,0 @@ --- | Partial functions that make common types in Lincoln. Some data --- types in Lincoln are deeply nested, with TextNonEmpty nested inside --- of a newtype, nested inside of a NonEmptyList, nested inside --- of... :) All the nesting ensures to the maximum extent possible --- that the type system reflects the restrictions that exist on --- Penny's data. For example, it would make no sense to have an empty --- account (that is, an account with no sub-accounts) or a sub-account --- whose name is an empty Text. --- --- The disadvantage of the nesting is that building these data types --- can be tedious if, for example, you want to build some data within --- a short custom Haskell program. Thus, this module. - -module Penny.Lincoln.Builders - ( account - ) where - -import qualified Penny.Lincoln.Bits as B -import qualified Data.Text as X - --- | Create an Account. You supply a single Text, with colons to --- separate the different sub-accounts. -account :: X.Text -> B.Account -account s = - if X.null s - then B.Account [] - else B.Account . map B.SubAccount . X.splitOn (X.singleton ':') $ s - diff --git a/Penny/Lincoln/Family.hs b/Penny/Lincoln/Family.hs deleted file mode 100644 --- a/Penny/Lincoln/Family.hs +++ /dev/null @@ -1,104 +0,0 @@ --- | A Transaction consists of a TopLine (information common to all --- postings, such as the DateTime) and of at least two Postings. This --- data relationship is so important and useful that it is expressed --- in these modules. This module has its own functions and re-exports --- functions and types from other modules in this hierarchy. There are --- handy accessor functions for the records within each of the family --- types, but these are not exported due to name conflicts; if you --- want these simply import the necessary module (maybe qualified). -module Penny.Lincoln.Family ( - -- * Family types - F.Family(Family), - C.Child(Child), - S.Siblings(Siblings), - - -- * Mapping families - F.mapChildrenA, - F.mapChildren, - F.mapParentA, - F.mapParent, - - -- * Functions to manipulate families - children, - orphans, - adopt, - marryWith, - marry, - divorceWith, - divorce, - F.filterChildren, - F.find, - S.collapse ) where - -import qualified Penny.Lincoln.Family.Family as F -import qualified Penny.Lincoln.Family.Child as C -import qualified Penny.Lincoln.Family.Siblings as S - --- | Gets a family's children. The Child type contains information on --- the parent, and each Child contains information on the other --- Siblings. -children :: F.Family p c -> S.Siblings (C.Child p c) -children (F.Family p c1 c2 cRest) = S.Siblings fc sc rc where - fc = C.Child c1 c2 cRest p - sc = C.Child c2 c1 cRest p - rc = map toChild rest - rest = others cRest - toChild (c, cs) = C.Child c c1 (c2:cs) p - --- | Separates the children from their parent. -orphans :: F.Family p c -> S.Siblings c -orphans (F.Family _ c1 c2 cs) = S.Siblings c1 c2 cs - --- | Unites a parent and some siblings into one family; the dual of --- orphans. -adopt :: p -> S.Siblings c -> F.Family p c -adopt p (S.Siblings c1 c2 cs) = F.Family p c1 c2 cs - --- | Marries two families into one. This function is rather cruel: if --- one family has more children than the other family, then the extra --- children are discarded. That is, all children must pair one-by-one. -marryWith :: (p1 -> p2 -> p3) - -> (c1 -> c2 -> c3) - -> F.Family p1 c1 - -> F.Family p2 c2 - -> F.Family p3 c3 -marryWith fp fc (F.Family lp lc1 lc2 lcs) (F.Family rp rc1 rc2 rcs) = - F.Family (fp lp rp) (fc lc1 rc1) (fc lc2 rc2) - (zipWith fc lcs rcs) - --- | marryWith a tupling function. -marry :: F.Family p1 c1 - -> F.Family p2 c2 - -> F.Family (p1, p2) (c1, c2) -marry = marryWith (,) (,) - --- | Splits up a family. -divorceWith :: (p1 -> (p2, p3)) - -> (c1 -> (c2, c3)) - -> F.Family p1 c1 - -> (F.Family p2 c2, F.Family p3 c3) -divorceWith fp fc (F.Family p c1 c2 cs) = (f2, f3) where - f2 = F.Family p2 c21 c22 c2s - f3 = F.Family p3 c31 c32 c3s - (p2, p3) = fp p - (c21, c31) = fc c1 - (c22, c32) = fc c2 - cps = map fc cs - (c2s, c3s) = (map fst cps, map snd cps) - --- | divorceWith an untupling function. -divorce :: F.Family (p1, p2) (c1, c2) - -> (F.Family p1 c1, F.Family p2 c2) -divorce = divorceWith id id - -others :: [a] -> [(a, [a])] -others = map yank . allIndexes - -allIndexes :: [a] -> [(Int, [a])] -allIndexes as = zip [0..] (replicate (length as) as) - -yank :: (Int, [a]) -> (a, [a]) -yank (i, as) = let - (ys, zs) = splitAt i as - in (head zs, ys ++ (tail zs)) - diff --git a/Penny/Lincoln/Family/Child.hs b/Penny/Lincoln/Family/Child.hs deleted file mode 100644 --- a/Penny/Lincoln/Family/Child.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Penny.Lincoln.Family.Child where - --- | A Child has at least one sibling and a parent. -data Child p c = - Child { child :: c - , sibling1 :: c - , siblings :: [c] - , parent :: p } - deriving Show diff --git a/Penny/Lincoln/Family/Family.hs b/Penny/Lincoln/Family/Family.hs deleted file mode 100644 --- a/Penny/Lincoln/Family/Family.hs +++ /dev/null @@ -1,76 +0,0 @@ -module Penny.Lincoln.Family.Family where - -import Control.Applicative ((<$>), (<*>), pure, Applicative) -import qualified Data.List as L -import Data.Traversable (traverse) - --- | A Family has one parent (ah, the anomie, sorry) and at least two --- children. -data Family p c = - Family { parent :: p - , child1 :: c - , child2 :: c - , children :: [c] } - deriving (Eq, Show) - --- | Maps over all children, in order starting with child --- 1, then child 2, then the children in the list from left to right. -mapChildrenA :: - Applicative m - => (a -> m b) - -> Family p a - -> m (Family p b) -mapChildrenA f (Family p c1 c2 cs) = - Family p <$> f c1 <*> f c2 <*> traverse f cs - - --- | Maps over all children. -mapChildren :: - (a -> b) - -> Family p a - -> Family p b -mapChildren f (Family p c1 c2 cs) = - Family p (f c1) (f c2) (map f cs) - - --- | Maps over the parent in an Applicative. -mapParentA :: - Applicative m - => (a -> m b) - -> Family a c - -> m (Family b c) -mapParentA f (Family p c1 c2 cs) = - Family <$> f p <*> pure c1 <*> pure c2 <*> pure cs - - --- | Maps over the parent. -mapParent :: (a -> b) -> Family a c -> Family b c -mapParent f (Family p c1 c2 cs) = Family (f p) c1 c2 cs - - --- | Finds the first child matching a predicate. -find :: (p -> c -> Bool) -> Family p c -> Maybe c -find f (Family p c1 c2 cs) - | f p c1 = Just c1 - | f p c2 = Just c2 - | otherwise = L.find (f p) cs - --- | Filters the children. Fails if there are not at least two --- children after filtering. Retains the original order of the --- children (after removing the children you don't want.) -filterChildren :: (a -> Bool) -> Family p a -> Maybe (Family p a) -filterChildren f (Family p c1 c2 cs) = - case (f c1, f c2) of - (True, True) -> Just (Family p c1 c2 (filter f cs)) - (True, False) -> - case filter f cs of - [] -> Nothing - x:xs -> Just (Family p c1 x xs) - (False, True) -> - case filter f cs of - [] -> Nothing - x:xs -> Just (Family p c2 x xs) - (False, False) -> - case filter f cs of - x1:x2:xs -> Just (Family p x1 x2 xs) - _ -> Nothing diff --git a/Penny/Lincoln/Family/Siblings.hs b/Penny/Lincoln/Family/Siblings.hs deleted file mode 100644 --- a/Penny/Lincoln/Family/Siblings.hs +++ /dev/null @@ -1,54 +0,0 @@ -module Penny.Lincoln.Family.Siblings ( - Siblings(Siblings, first, second, rest), - collapse - ) where - -import qualified Prelude as P -import Prelude hiding (concat) -import qualified Data.Semigroup as S -import qualified Data.List.NonEmpty as NE -import Data.List.NonEmpty (NonEmpty((:|))) -import qualified Data.Foldable as Foldable -import qualified Data.Traversable as T -import Control.Applicative ((<*>), (<$>)) - --- | Describes the siblings of a family, but tells you nothing about --- the parent. There are always at least two Siblings. -data Siblings a = Siblings { first :: a - , second :: a - , rest :: [a] } - deriving (Eq, Show) - -instance S.Semigroup (Siblings a) where - (Siblings a1 a2 ar) <> (Siblings b1 b2 br) = - Siblings a1 a2 (ar ++ (b1:b2:br)) - -instance Functor Siblings where - fmap g (Siblings f s rs) = Siblings (g f) (g s) (map g rs) - -instance Foldable.Foldable Siblings where - foldr g b (Siblings f s rs) = g f (g s (foldr g b rs)) - -instance T.Traversable Siblings where - -- traverse :: Applicative f => (a -> f b) -> t a -> f (t b) - traverse g (Siblings f s rs) = - Siblings - <$> g f - <*> g s - <*> T.traverse g rs - --- | Change a Siblings of NonEmpty lists to a Siblings. The original --- order of the elements contained in the Siblings and within the --- NonEmpty lists is preserved. -collapse :: Siblings (NE.NonEmpty a) - -> Siblings a -collapse (Siblings (s1_1:|s1_r) s2@(s2_1:|s2_r) sr) = - Siblings r1 r2 rr where - r1 = s1_1 - (r2, rr) = case s1_r of - [] -> (s2_1, (s2_r ++ concatNE sr)) - x:xs -> (x, xs ++ concatNE (s2 : sr)) - -concatNE :: [NE.NonEmpty a] -> [a] -concatNE = foldr f [] where - f (a :| as) soFar = (a:as) ++ soFar diff --git a/Penny/Lincoln/HasText.hs b/Penny/Lincoln/HasText.hs deleted file mode 100644 --- a/Penny/Lincoln/HasText.hs +++ /dev/null @@ -1,44 +0,0 @@ -module Penny.Lincoln.HasText where - -import Data.Text (Text) - -import qualified Penny.Lincoln.Bits as B - -class HasText a where - text :: a -> Text - -instance HasText Text where - text = id - -instance HasText B.SubAccount where - text = B.unSubAccount - -instance HasText B.Flag where - text = B.unFlag - -instance HasText B.Commodity where - text = B.unCommodity - -instance HasText B.Number where - text = B.unNumber - -instance HasText B.Payee where - text = B.unPayee - -instance HasText B.Tag where - text = B.unTag - -instance HasText B.Filename where - text = B.unFilename - -class HasTextList a where - textList :: a -> [Text] - -instance HasTextList B.Account where - textList = map text . B.unAccount - -instance HasTextList B.Tags where - textList = map text . B.unTags - -instance HasTextList B.Memo where - textList = B.unMemo diff --git a/Penny/Lincoln/Matchers.hs b/Penny/Lincoln/Matchers.hs deleted file mode 100644 --- a/Penny/Lincoln/Matchers.hs +++ /dev/null @@ -1,21 +0,0 @@ --- | Type synonyms for functions dealing with text matching. - -module Penny.Lincoln.Matchers where - -import qualified Data.Text as X -import qualified Control.Monad.Exception.Synchronous as Ex -import qualified Text.Matchers as MT - --- | A function that makes Matchers. -type Factory - = MT.CaseSensitive - -- ^ Will this matcher be case sensitive? - - -> X.Text - -- ^ The pattern to use when testing for a match. For example, this - -- might be a regular expression, or simply the text to be matched. - - -> Ex.Exceptional X.Text MT.Matcher - -- ^ Sometimes producing a matcher might fail; for example, the user - -- might have supplied a bad pattern. If so, an exception is - -- returned. On success, a Matcher is returned. diff --git a/Penny/Lincoln/Predicates.hs b/Penny/Lincoln/Predicates.hs deleted file mode 100644 --- a/Penny/Lincoln/Predicates.hs +++ /dev/null @@ -1,254 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | Functions that return a boolean based upon some criterion that --- matches something, often a PostFam. Useful when filtering --- Postings. -module Penny.Lincoln.Predicates - ( LPdct - , MakePdct - , payee - , number - , flag - , postingMemo - , transactionMemo - , date - , qty - , drCr - , debit - , credit - , commodity - , account - , accountLevel - , accountAny - , tag - , filename - , reconciled - , clonedTransactions - , clonedTopLines - , clonedPostings - ) where - - -import Data.List (intersperse) -import Data.Monoid ((<>)) -import Data.Text (Text) -import qualified Data.Text as X -import qualified Data.Time as Time -import qualified Penny.Lincoln.Bits as B -import Penny.Lincoln.HasText (HasText, text, HasTextList, textList) -import qualified Penny.Lincoln.Family.Family as F -import qualified Penny.Lincoln.Queries as Q -import Penny.Lincoln.Transaction (PostFam) -import qualified Penny.Lincoln.Transaction as T -import qualified Text.Matchers as M -import qualified Data.Prednote.Pdct as P - -type LPdct = P.Pdct PostFam - -type MakePdct = M.Matcher -> LPdct - --- * Matching helpers -match - :: HasText a - => Text - -- ^ Description of this field - -> (PostFam -> a) - -- ^ Function that returns the field being matched - -> M.Matcher - -> LPdct -match t f m = P.operand desc pd - where - desc = makeDesc t m - pd = M.match m . text . f - -matchMaybe - :: HasText a - => Text - -- ^ Description of this field - -> (PostFam -> Maybe a) - -> M.Matcher - -> LPdct -matchMaybe t f m = P.operand desc pd - where - desc = makeDesc t m - pd = maybe False (M.match m . text) . f - -makeDesc :: Text -> M.Matcher -> Text -makeDesc t m - = "subject: " <> t - <> " matcher: " <> M.matchDesc m - --- | Does the given matcher match any of the elements of the Texts in --- a HasTextList? -matchAny - :: HasTextList a - => Text - -> (PostFam -> a) - -> M.Matcher - -> LPdct -matchAny t f m = P.operand desc pd - where - desc = makeDesc t m - pd = any (M.match m) . textList . f - --- | Does the given matcher match the text that is at the given --- element of a HasTextList? If the HasTextList does not have a --- sufficent number of elements to perform this test, returns False. -matchLevel - :: HasTextList a - => Int - -> Text - -> (PostFam -> a) - -> M.Matcher - -> LPdct -matchLevel l d f m = P.operand desc pd - where - desc = makeDesc ("level " <> X.pack (show l) <> " of " <> d) m - pd pf = let ts = textList (f pf) - in if l < 0 || l >= length ts - then False - else M.match m (ts !! l) - --- | Does the matcher match the text of the memo? Joins each line of --- the memo with a space. -matchMemo - :: Text - -> (PostFam -> Maybe B.Memo) - -> M.Matcher - -> LPdct -matchMemo t f m = P.operand desc pd - where - desc = makeDesc t m - pd = maybe False doMatch . f - doMatch = M.match m - . X.intercalate (X.singleton ' ') - . B.unMemo - -matchDelimited - :: HasTextList a - => Text - -- ^ Separator - -> Text - -- ^ Label - -> (PostFam -> a) - -> M.Matcher - -> LPdct -matchDelimited sep lbl f m = match lbl f' m - where - f' = X.concat . intersperse sep . textList . f - --- * Pattern matching fields - -payee :: MakePdct -payee = matchMaybe "payee" Q.payee - -number :: MakePdct -number = matchMaybe "number" Q.number - -flag :: MakePdct -flag = matchMaybe "flag" Q.flag - -filename :: MakePdct -filename = matchMaybe "filename" Q.filename - -postingMemo :: MakePdct -postingMemo = matchMemo "posting memo" Q.postingMemo - -transactionMemo :: MakePdct -transactionMemo = matchMemo "transaction memo" Q.transactionMemo - --- * Date - -date - :: Ordering - -> Time.UTCTime - -> LPdct -date ord u = P.compareBy (X.pack . show $ u) - "UTC date and time" - (\l -> compare (B.toUTC . Q.dateTime $ l) u) ord - - -qty :: Ordering -> B.Qty -> LPdct -qty o q = P.compareBy (X.pack . show $ q) "quantity" - (\l -> compare (Q.qty l) q) o - - -drCr :: B.DrCr -> LPdct -drCr dc = P.operand desc pd - where - desc = "entry is a " <> s - s = case dc of { B.Debit -> "debit"; B.Credit -> "credit" } - pd pf = Q.drCr pf == dc - -debit :: LPdct -debit = drCr B.Debit - -credit :: LPdct -credit = drCr B.Credit - -commodity :: M.Matcher -> LPdct -commodity = match "commodity" Q.commodity - -account :: M.Matcher -> LPdct -account = matchDelimited ":" "account" Q.account - -accountLevel :: Int -> M.Matcher -> LPdct -accountLevel i = matchLevel i "account" Q.account - -accountAny :: M.Matcher -> LPdct -accountAny = matchAny "any sub-account" Q.account - -tag :: M.Matcher -> LPdct -tag = matchAny "any tag" Q.tags - --- | True if a posting is reconciled; that is, its flag is exactly --- @R@. -reconciled :: LPdct -reconciled = P.operand d p - where - d = "posting flag is exactly \"R\" (is reconciled)" - p = maybe False ((== X.singleton 'R') . B.unFlag) . Q.flag - --- | Returns True if these two transactions are clones; that is, if --- they are identical in all respects except some aspects of their --- metadata. The metadata that is disregarded when testing for clones --- pertains to the location of the transaction. (Resembles cloned --- sheep, which are identical but cannot be in exactly the same --- place.) -clonedTransactions :: T.Transaction -> T.Transaction -> Bool -clonedTransactions a b = - let (F.Family ta p1a p2a psa) = T.unTransaction a - (F.Family tb p1b p2b psb) = T.unTransaction b - in clonedTopLines ta tb - && clonedPostings p1a p1b - && clonedPostings p2a p2b - && (length psa == length psb) - && (and (zipWith clonedPostings psa psb)) - --- | Returns True if two TopLines are clones. Considers only the --- non-metadata aspects of the TopLine; the metadata all pertains only --- to the location of the TopLine. The DateTimes are compared based on --- both the local time and the time zone; that is, two times that --- refer to the same instant will not compare as identical if they --- have different time zones. -clonedTopLines :: T.TopLine -> T.TopLine -> Bool -clonedTopLines t1 t2 = - (T.tDateTime t1 == T.tDateTime t2) - && (T.tFlag t1 == T.tFlag t2) - && (T.tNumber t1 == T.tNumber t2) - && (T.tPayee t2 == T.tPayee t2) - && (T.tMemo t1 == T.tMemo t2) - --- | Returns True if two Postings are clones. Considers only the --- non-location-related aspects of the posting metadata. -clonedPostings :: T.Posting -> T.Posting -> Bool -clonedPostings p1 p2 = - (T.pPayee p1 == T.pPayee p2) - && (T.pNumber p1 == T.pNumber p2) - && (T.pFlag p1 == T.pFlag p2) - && (T.pAccount p1 == T.pAccount p2) - && (T.pTags p1 == T.pTags p2) - && (T.pEntry p1 == T.pEntry p2) - && (T.pMemo p1 == T.pMemo p2) - && (T.pInferred p1 == T.pInferred p2) - diff --git a/Penny/Lincoln/Predicates/Siblings.hs b/Penny/Lincoln/Predicates/Siblings.hs deleted file mode 100644 --- a/Penny/Lincoln/Predicates/Siblings.hs +++ /dev/null @@ -1,210 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | Functions that return a boolean based upon some criterion that --- matches something, often a PostFam. Useful when filtering --- Postings. -module Penny.Lincoln.Predicates.Siblings - ( LPdct - , MakePdct - , payee - , number - , flag - , postingMemo - , qty - , parseQty - , drCr - , debit - , credit - , commodity - , account - , accountLevel - , accountAny - , tag - , reconciled - ) where - - -import Data.List (intersperse) -import Data.Monoid ((<>)) -import Data.Text (Text) -import qualified Data.Text as X -import qualified Penny.Lincoln.Bits as B -import Penny.Lincoln.HasText (HasText, text, HasTextList, textList) -import qualified Penny.Lincoln.Queries.Siblings as Q -import Penny.Lincoln.Transaction (PostFam) -import qualified Text.Matchers as M -import qualified Data.Prednote.Pdct as P - -type LPdct = P.Pdct PostFam - -type MakePdct = M.Matcher -> LPdct - --- * Matching helpers -match - :: HasText a - => Text - -- ^ Description of this field - -> (PostFam -> [a]) - -- ^ Function that returns the field being matched - -> M.Matcher - -> LPdct -match t f m = P.operand desc pd - where - desc = makeDesc t m - pd = any (M.match m) . map text . f - -matchMaybe - :: HasText a - => Text - -- ^ Description of this field - -> (PostFam -> [Maybe a]) - -> M.Matcher - -> LPdct -matchMaybe t f m = P.operand desc pd - where - desc = makeDesc t m - pd = any (== (Just True)) - . map (fmap (M.match m . text)) - . f - -makeDesc :: Text -> M.Matcher -> Text -makeDesc t m - = "subject: " <> t <> " (any sibling posting) matcher: " - <> M.matchDesc m - --- | Does the given matcher match any of the elements of the Texts in --- a HasTextList? -matchAny - :: HasTextList a - => Text - -> (PostFam -> [a]) - -> M.Matcher - -> LPdct -matchAny t f m = P.operand desc pd - where - desc = makeDesc t m - pd = any (any (M.match m)) . map textList . f - --- | Does the given matcher match the text that is at the given --- element of a HasTextList? If the HasTextList does not have a --- sufficent number of elements to perform this test, returns False. -matchLevel - :: HasTextList a - => Int - -> Text - -> (PostFam -> [a]) - -> M.Matcher - -> LPdct -matchLevel l d f m = P.operand desc pd - where - desc = makeDesc ("level " <> X.pack (show l) <> " of " <> d) m - pd pf = let doMatch list = if l < 0 || l >= length list - then False - else M.match m (list !! l) - in any doMatch . map textList . f $ pf - --- | Does the matcher match the text of the memo? Joins each line of --- the memo with a space. -matchMemo - :: Text - -> (PostFam -> [Maybe B.Memo]) - -> M.Matcher - -> LPdct -matchMemo t f m = P.operand desc pd - where - desc = makeDesc t m - pd = any (maybe False doMatch) . f - doMatch = M.match m - . X.intercalate (X.singleton ' ') - . B.unMemo - -matchDelimited - :: HasTextList a - => Text - -- ^ Separator - -> Text - -- ^ Label - -> (PostFam -> [a]) - -> M.Matcher - -> LPdct -matchDelimited sep lbl f m = match lbl f' m - where - f' = map (X.concat . intersperse sep . textList) . f - --- * Pattern matching fields - -payee :: MakePdct -payee = matchMaybe "payee" Q.payee - -number :: MakePdct -number = matchMaybe "number" Q.number - -flag :: MakePdct -flag = matchMaybe "flag" Q.flag - -postingMemo :: MakePdct -postingMemo = matchMemo "posting memo" Q.postingMemo - --- | A Pdct that returns True if @compare subject qty@ returns the --- given Ordering. -qty :: Ordering -> B.Qty -> LPdct -qty o q = P.operand desc pd - where - desc = "quantity of any sibling is " <> dd <> " " <> X.pack (show q) - dd = case o of - LT -> "less than" - GT -> "greater than" - EQ -> "equal to" - pd = any ((== o) . (`compare` q)) . Q.qty - -parseQty - :: X.Text - -> Maybe (B.Qty -> LPdct) -parseQty x - | x == "==" = Just (qty EQ) - | x == "=" = Just (qty EQ) - | x == ">" = Just (qty GT) - | x == "<" = Just (qty LT) - | x == "/=" = Just (\q -> P.not (qty EQ q)) - | x == "!=" = Just (\q -> P.not (qty EQ q)) - | x == ">=" = Just (\q -> P.or [qty GT q, qty EQ q]) - | x == "<=" = Just (\q -> P.or [qty LT q, qty EQ q]) - | otherwise = Nothing - -drCr :: B.DrCr -> LPdct -drCr dc = P.operand desc pd - where - desc = "entry of any sibling is a " <> s - s = case dc of { B.Debit -> "debit"; B.Credit -> "credit" } - pd = any (== dc) . Q.drCr - -debit :: LPdct -debit = drCr B.Debit - -credit :: LPdct -credit = drCr B.Credit - -commodity :: M.Matcher -> LPdct -commodity = match "commodity" Q.commodity - -account :: M.Matcher -> LPdct -account = matchDelimited ":" "account" Q.account - -accountLevel :: Int -> M.Matcher -> LPdct -accountLevel i = matchLevel i "account" Q.account - -accountAny :: M.Matcher -> LPdct -accountAny = matchAny "any sub-account" Q.account - -tag :: M.Matcher -> LPdct -tag = matchAny "any tag" Q.tags - --- | True if a posting is reconciled; that is, its flag is exactly --- @R@. -reconciled :: LPdct -reconciled = P.operand d p - where - d = "posting flag is exactly \"R\" (is reconciled)" - p = any (maybe False ((== X.singleton 'R') . B.unFlag)) - . Q.flag - diff --git a/Penny/Lincoln/PriceDb.hs b/Penny/Lincoln/PriceDb.hs deleted file mode 100644 --- a/Penny/Lincoln/PriceDb.hs +++ /dev/null @@ -1,98 +0,0 @@ --- | A database of price information. A PricePoint has a DateTime, a --- From commodity, a To commodity, and a QtyPerUnit. The PriceDb holds --- this information for several prices. You can query the database by --- supplying a from commodity, a to commodity, and a DateTime, and the --- database will give you the QtyPerUnit, if there is one. -module Penny.Lincoln.PriceDb ( - PriceDb, - emptyDb, - addPrice, - getPrice, - PriceDbError(FromNotFound, ToNotFound, CpuNotFound), - convert - ) where - -import qualified Control.Monad.Exception.Synchronous as Ex -import qualified Data.Map as M -import qualified Data.Time as T -import qualified Penny.Lincoln.Bits as B - -type CpuMap = M.Map T.UTCTime B.CountPerUnit -type ToMap = M.Map B.To CpuMap - --- | The PriceDb holds information about prices. Create an empty one --- using 'emptyDb' then fill it with values using foldl or similar. -newtype PriceDb = PriceDb (M.Map B.From ToMap) - --- | An empty PriceDb -emptyDb :: PriceDb -emptyDb = PriceDb M.empty - --- | Add a single price to the PriceDb. -addPrice :: PriceDb -> B.PricePoint -> PriceDb -addPrice (PriceDb db) (B.PricePoint dt pr _ _ _) = PriceDb m' - where - m' = M.alter f (B.from pr) db - utc = B.toUTC dt - cpu = B.countPerUnit pr - f k = case k of - Nothing -> Just $ M.singleton (B.to pr) cpuMap - where - cpuMap = M.singleton utc cpu - Just tm -> Just tm' - where - tm' = M.alter g (B.to pr) tm - g maybeTo = case maybeTo of - Nothing -> Just $ M.singleton utc cpu - Just cpuMap -> Just $ M.insert utc cpu cpuMap - - - --- | Getting prices can fail; if it fails, an Error is returned. -data PriceDbError = FromNotFound | ToNotFound | CpuNotFound - --- | Looks up values from the PriceDb. Throws "Error" if something --- fails. --- --- The DateTime is the time at which to find a price. If a price --- exists for that exact DateTime, that price is returned. If no price --- exists for that exact DateTime, but there is a price for an earlier --- DateTime, the latest possible price is returned. If there are no --- earlier prices, CpuNotFound is thrown. - -getPrice :: - PriceDb - -> B.From - -> B.To - -> B.DateTime - -> Ex.Exceptional PriceDbError B.CountPerUnit -getPrice (PriceDb db) fr to dt = do - let utc = B.toUTC dt - toMap <- Ex.fromMaybe FromNotFound $ M.lookup fr db - cpuMap <- Ex.fromMaybe ToNotFound $ M.lookup to toMap - let (lower, exact, _) = M.splitLookup utc cpuMap - case exact of - Just c -> return c - Nothing -> - if M.null lower - then Ex.throw CpuNotFound - else return . snd . M.findMax $ lower - - --- | Given an Amount and a Commodity to convert the amount to, --- converts the Amount to the given commodity. If the Amount given is --- already in the To commodity, simply returns what was passed in. Can --- fail and throw PriceDbError. Internally uses 'getPrice', so read its --- documentation for details on how price lookup works. -convert :: - PriceDb - -> B.DateTime - -> B.To - -> B.Amount - -> Ex.Exceptional PriceDbError B.Qty -convert db dt to (B.Amount qt fr _ _) - | fr == B.unTo to = return qt - | otherwise = do - cpu <- fmap B.unCountPerUnit (getPrice db (B.From fr) to dt) - let qt' = B.mult cpu qt - return qt' diff --git a/Penny/Lincoln/Queries.hs b/Penny/Lincoln/Queries.hs deleted file mode 100644 --- a/Penny/Lincoln/Queries.hs +++ /dev/null @@ -1,100 +0,0 @@ --- | Examining a PostFam for a particular component of the main --- posting (as opposed to the sibling postings) in the PostFam. For --- some components, such as the payee, the posting might have one --- piece of data while the TopLine has something else. These functions --- will examine the Posting first and, if it has no information, use --- the data from the TopLine if it is there. -module Penny.Lincoln.Queries where - -import qualified Penny.Lincoln.Bits as B -import Penny.Lincoln.Family.Child (child, parent) -import qualified Penny.Lincoln.Transaction as T -import Penny.Lincoln.Balance (Balance, entryToBalance) -import qualified Data.Time as Time - --- | Uses the data from the Posting if it is set; otherwise, use the --- data from the TopLine. -best :: - (T.Posting -> Maybe a) - -> (T.TopLine -> Maybe a) - -> T.PostFam - -> Maybe a -best fp ft c = case fp . child . T.unPostFam $ c of - Just r -> Just r - Nothing -> ft . parent . T.unPostFam $ c - - -payee :: T.PostFam -> Maybe B.Payee -payee = best T.pPayee T.tPayee - -number :: T.PostFam -> Maybe B.Number -number = best T.pNumber T.tNumber - -flag :: T.PostFam -> Maybe B.Flag -flag = best T.pFlag T.tFlag - -postingMemo :: T.PostFam -> Maybe B.Memo -postingMemo = T.pMemo . child . T.unPostFam - -transactionMemo :: T.PostFam -> Maybe B.Memo -transactionMemo = T.tMemo . parent . T.unPostFam - -dateTime :: T.PostFam -> B.DateTime -dateTime = T.tDateTime . parent . T.unPostFam - -localDay :: T.PostFam -> Time.Day -localDay = B.day . dateTime - -account :: T.PostFam -> B.Account -account = T.pAccount . child . T.unPostFam - -tags :: T.PostFam -> B.Tags -tags = T.pTags . child . T.unPostFam - -entry :: T.PostFam -> B.Entry -entry = T.pEntry . child . T.unPostFam - -balance :: T.PostFam -> Balance -balance = entryToBalance . entry - -drCr :: T.PostFam -> B.DrCr -drCr = B.drCr . entry - -amount :: T.PostFam -> B.Amount -amount = B.amount . entry - -qty :: T.PostFam -> B.Qty -qty = B.qty . amount - -commodity :: T.PostFam -> B.Commodity -commodity = B.commodity . amount - -topMemoLine :: T.PostFam -> Maybe B.TopMemoLine -topMemoLine = T.tTopMemoLine . parent . T.unPostFam - -topLineLine :: T.PostFam -> Maybe B.TopLineLine -topLineLine = T.tTopLineLine . parent . T.unPostFam - -filename :: T.PostFam -> Maybe B.Filename -filename = T.tFilename . parent . T.unPostFam - -globalTransaction :: T.PostFam -> Maybe B.GlobalTransaction -globalTransaction = T.tGlobalTransaction . parent . T.unPostFam - -fileTransaction :: T.PostFam -> Maybe B.FileTransaction -fileTransaction = T.tFileTransaction . parent . T.unPostFam - -postingLine :: T.PostFam -> Maybe B.PostingLine -postingLine = T.pPostingLine . child . T.unPostFam - -side :: T.PostFam -> Maybe B.Side -side = B.side . amount - -spaceBetween :: T.PostFam -> Maybe B.SpaceBetween -spaceBetween = B.spaceBetween . amount - -globalPosting :: T.PostFam -> Maybe B.GlobalPosting -globalPosting = T.pGlobalPosting . child . T.unPostFam - -filePosting :: T.PostFam -> Maybe B.FilePosting -filePosting = T.pFilePosting . child . T.unPostFam diff --git a/Penny/Lincoln/Queries/Siblings.hs b/Penny/Lincoln/Queries/Siblings.hs deleted file mode 100644 --- a/Penny/Lincoln/Queries/Siblings.hs +++ /dev/null @@ -1,87 +0,0 @@ --- | Like 'Penny.Lincoln.Queries' but instead of querying the main --- posting of the PostFam, queries the siblings. Therefore, these --- functions return a list, with each entry in the list containing the --- best answer for each sibling. There is one item in the list for --- each sibling, even if all these items contain the same data (for --- instance, a posting might have five siblings, but all five siblings --- might have the same payee. Nonetheless the 'payee' function will --- return a list of five items.) -module Penny.Lincoln.Queries.Siblings where - -import qualified Penny.Lincoln.Bits as B -import Penny.Lincoln.Family.Child (Child(Child)) -import qualified Penny.Lincoln.Transaction as T -import Penny.Lincoln.Balance (Balance, entryToBalance) - --- | For all siblings, uses information from the Posting if it is set; --- otherwise, uses data from the TopLine. -bestSibs - :: (T.Posting -> Maybe a) - -> (T.TopLine -> Maybe a) - -> T.PostFam - -> [Maybe a] -bestSibs fp ft pf = - let (Child _ s1 ss p) = T.unPostFam pf - get = maybe (ft p) Just . fp - in get s1 : map get ss - --- | For all siblings, get the information from the Posting if it --- exists; otherwise Nothing. -sibs - :: (T.Posting -> a) - -> T.PostFam - -> [a] -sibs fp pf = - let (Child _ s1 ss _) = T.unPostFam pf - in fp s1 : map fp ss - -payee :: T.PostFam -> [Maybe B.Payee] -payee = bestSibs T.pPayee T.tPayee - -number :: T.PostFam -> [Maybe B.Number] -number = bestSibs T.pNumber T.tNumber - -flag :: T.PostFam -> [Maybe B.Flag] -flag = bestSibs T.pFlag T.tFlag - -postingMemo :: T.PostFam -> [Maybe B.Memo] -postingMemo = sibs T.pMemo - -account :: T.PostFam -> [B.Account] -account = sibs T.pAccount - -tags :: T.PostFam -> [B.Tags] -tags = sibs T.pTags - -entry :: T.PostFam -> [B.Entry] -entry = sibs T.pEntry - -balance :: T.PostFam -> [Balance] -balance = map entryToBalance . entry - -drCr :: T.PostFam -> [B.DrCr] -drCr = map B.drCr . entry - -amount :: T.PostFam -> [B.Amount] -amount = map B.amount . entry - -qty :: T.PostFam -> [B.Qty] -qty = map B.qty . amount - -commodity :: T.PostFam -> [B.Commodity] -commodity = map B.commodity . amount - -postingLine :: T.PostFam -> [Maybe B.PostingLine] -postingLine = sibs T.pPostingLine - -side :: T.PostFam -> [Maybe B.Side] -side = map B.side . amount - -spaceBetween :: T.PostFam -> [Maybe B.SpaceBetween] -spaceBetween = map B.spaceBetween . amount - -globalPosting :: T.PostFam -> [Maybe B.GlobalPosting] -globalPosting = sibs T.pGlobalPosting - -filePosting :: T.PostFam -> [Maybe B.FilePosting] -filePosting = sibs T.pFilePosting diff --git a/Penny/Lincoln/Serial.hs b/Penny/Lincoln/Serial.hs deleted file mode 100644 --- a/Penny/Lincoln/Serial.hs +++ /dev/null @@ -1,58 +0,0 @@ -module Penny.Lincoln.Serial ( - Serial, forward, backward, GenSerial, - incrementBack, getSerial, makeSerials, serialItems, - nSerials ) where - -import Control.Applicative (Applicative, (<*>), pure, (*>)) -import Control.Monad (ap) - -data SerialSt = SerialSt - { nextFwd :: Int - , nextBack :: Int - } deriving Show - -data Serial = Serial - { forward :: Int - , backward :: Int - } deriving (Eq, Show, Ord) - -newtype GenSerial a = GenSerial (SerialSt -> (a, SerialSt)) - -instance Functor GenSerial where - fmap f (GenSerial k) = GenSerial $ \s -> - let (a', st') = k s - in (f a', st') - -instance Applicative GenSerial where - pure = return - (<*>) = ap - -instance Monad GenSerial where - return a = GenSerial $ \s -> (a, s) - (GenSerial k) >>= f = GenSerial $ \s -> - let (a, s') = k s - GenSerial g = f a - in g s' - -incrementBack :: GenSerial () -incrementBack = GenSerial $ \s -> - let s' = SerialSt (nextFwd s) (nextBack s + 1) - in ((), s') - -getSerial :: GenSerial Serial -getSerial = GenSerial $ \s -> - let s' = SerialSt (nextFwd s + 1) (nextBack s - 1) - in (Serial (nextFwd s) (nextBack s), s') - -makeSerials :: GenSerial a -> a -makeSerials (GenSerial k) = - let (r, _) = k (SerialSt 0 0) in r - -serialItems :: (Serial -> a -> b) -> [a] -> [b] -serialItems f as = zipWith f (nSerials (length as)) as - -nSerials :: Int -> [Serial] -nSerials n = - makeSerials $ - (sequence . replicate n $ incrementBack) - *> (sequence . replicate n $ getSerial) diff --git a/Penny/Lincoln/Transaction.hs b/Penny/Lincoln/Transaction.hs deleted file mode 100644 --- a/Penny/Lincoln/Transaction.hs +++ /dev/null @@ -1,499 +0,0 @@ --- | Transactions, the heart of Penny. The Transaction data type is --- abstract, so that only this module can create Transactions. This --- provides assurance that if a Transaction exists, it is a valid, --- balanced Transaction. In addition, the Posting data type is --- abstract as well, so you know that if you have a Posting, it was --- created as part of a balanced Transaction. --- --- Functions prefixed with a @p@ query a particular posting for its --- properties. Functions prefixed with a @t@ query transactions. Every --- transaction has a single DateTime, and all the postings have this --- same DateTime, so there is no function to query a posting's --- DateTime. Just query the parent transaction. For other things such --- as Number and Flag, the transaction might have data and the posting --- might have data as well, so functions are provided to query both. --- --- Often you will want to query a single posting and have a function --- that gives you, for example, the posting's flag if it has one, or --- the transaction's flag if it has one, or Nothing if neither the --- posting nor the transaction has a flag. The functions in --- "Penny.Lincoln.Queries" do that. -module Penny.Lincoln.Transaction ( - - -- * Postings and transactions - Posting, - Transaction, - PostFam, - unPostFam, - - -- * Making and deconstructing transactions - transaction, - RTransaction(..), - rTransaction, - Error ( UnbalancedError, CouldNotInferError), - toUnverified, - - -- * Querying postings - Inferred(Inferred, NotInferred), - pPayee, pNumber, pFlag, pAccount, pTags, - pEntry, pMemo, pInferred, pPostingLine, - pGlobalPosting, pFilePosting, - - -- * Querying transactions - TopLine, - tDateTime, tFlag, tNumber, tPayee, tMemo, tTopLineLine, - tTopMemoLine, tFilename, tGlobalTransaction, tFileTransaction, - unTransaction, postFam, - - -- * Box - Box ( Box, boxMeta, boxPostFam ), - - -- * Changers - - -- | Functions allowing you to change aspects of an existing - -- transaction, without having to destroy and completely rebuild the - -- transaction. You cannot change the Entry or any of its - -- components, as changing any of these would unbalance the - -- Transaction. - TopLineChangeData(..), - emptyTopLineChangeData, - PostingChangeData(..), - emptyPostingChangeData, - changeTransaction - ) where - -import qualified Penny.Lincoln.Bits as B -import Penny.Lincoln.Family ( children, orphans, adopt ) -import qualified Penny.Lincoln.Family.Family as F -import qualified Penny.Lincoln.Family.Child as C -import qualified Penny.Lincoln.Family.Siblings as S -import qualified Penny.Lincoln.Transaction.Unverified as U -import qualified Penny.Lincoln.Balance as Bal - -import Control.Monad.Exception.Synchronous ( - Exceptional (Exception, Success) , throw ) -import qualified Control.Monad.Exception.Synchronous as Ex -import qualified Data.Foldable as Fdbl -import Data.Maybe ( catMaybes, fromMaybe ) -import qualified Data.Traversable as Tr -import qualified Control.Monad.Trans.State.Lazy as St -import Control.Monad.Trans.Class ( lift ) - --- | Indicates whether the entry for this posting was inferred. That --- is, if the user did not supply an entry for this posting, then it --- was inferred. -data Inferred = Inferred | NotInferred deriving (Eq, Show) - --- | Each Transaction consists of at least two Postings. -data Posting = - Posting { pPayee :: Maybe B.Payee - , pNumber :: Maybe B.Number - , pFlag :: Maybe B.Flag - , pAccount :: B.Account - , pTags :: B.Tags - , pEntry :: B.Entry - , pMemo :: Maybe B.Memo - , pInferred :: Inferred - , pPostingLine :: Maybe B.PostingLine - , pGlobalPosting :: Maybe B.GlobalPosting - , pFilePosting :: Maybe B.FilePosting - } - deriving (Eq, Show) - --- | The TopLine holds information that applies to all the postings in --- a transaction (so named because in a ledger file, this information --- appears on the top line.) -data TopLine = - TopLine { tDateTime :: B.DateTime - , tFlag :: Maybe B.Flag - , tNumber :: Maybe B.Number - , tPayee :: Maybe B.Payee - , tMemo :: Maybe B.Memo - , tTopLineLine :: Maybe B.TopLineLine - , tTopMemoLine :: Maybe B.TopMemoLine - , tFilename :: Maybe B.Filename - , tGlobalTransaction :: Maybe B.GlobalTransaction - , tFileTransaction :: Maybe B.FileTransaction } - deriving (Eq, Show) - --- | All the Postings in a Transaction must produce a Total whose --- debits and credits are equal. That is, the Transaction must be --- balanced. No Transactions are created that are not balanced. -newtype Transaction = - Transaction { unTransaction :: F.Family TopLine Posting } - deriving (Eq, Show) - --- | Errors that can arise when making a Transaction. -data Error = UnbalancedError - | CouldNotInferError - deriving (Eq, Show) - -newtype PostFam = PostFam { unPostFam :: C.Child TopLine Posting } - deriving Show - --- | Get the Postings from a Transaction, with information on the --- sibling Postings. -postFam :: Transaction -> [PostFam] -postFam (Transaction ps) = map PostFam . Fdbl.toList . children $ ps - -{- BNF-like grammar for the various sorts of allowed postings. - -postingGroup ::= (inferGroup balancedGroup*) | balancedGroup+ -inferGroup ::= "at least 1 posting. All postings have same account and - commodity. The balance is inferable." -balancedGroup ::= "at least 2 postings. All postings have the same - account and commodity. The balance is balanced." - --} - --- | Deconstruct a Transaction to a family of unverified data. -toUnverified :: Transaction -> F.Family U.TopLine U.Posting -toUnverified = F.mapParent fp . F.mapChildren fc . unTransaction - where - fp tl = toUTopLine tl - fc p = toUPosting p - --- | Makes transactions. -transaction :: - F.Family U.TopLine U.Posting - -> Exceptional Error Transaction -transaction f@(F.Family p _ _ _) = do - let os = orphans f - t = totalAll os - p' = toTopLine p - a2 <- inferAll os t - return $ Transaction (adopt p' a2) - -totalAll :: S.Siblings U.Posting - -> Bal.Balance -totalAll = - Fdbl.foldr1 Bal.addBalances - . catMaybes - . Fdbl.toList - . fmap (fmap Bal.entryToBalance . U.pEntry) - -infer :: - U.Posting - -> Ex.ExceptionalT Error - (St.State (Maybe B.Entry)) Posting -infer po = - case U.pEntry po of - Nothing -> do - st <- lift St.get - case st of - Nothing -> Ex.throwT CouldNotInferError - (Just e) -> do - lift $ St.put Nothing - return $ toPosting po e Inferred - (Just e) -> return $ toPosting po e NotInferred - -runInfer :: - Maybe B.Entry - -> S.Siblings U.Posting - -> Exceptional Error (S.Siblings Posting) -runInfer me pos = do - let (res, finalSt) = St.runState ext me - ext = Ex.runExceptionalT (Tr.mapM infer pos) - case finalSt of - (Just _) -> throw UnbalancedError - Nothing -> case res of - (Exception e) -> throw e - (Success g) -> return g - -inferAll :: - S.Siblings U.Posting - -> Bal.Balance - -> Exceptional Error (S.Siblings Posting) -inferAll pos t = do - en <- case Bal.isBalanced t of - Bal.Balanced -> return Nothing - (Bal.Inferable e) -> return $ Just e - Bal.NotInferable -> throw UnbalancedError - runInfer en pos - -toUPosting :: Posting -> U.Posting -toUPosting p = U.Posting - { U.pPayee = pPayee p - , U.pNumber = pNumber p - , U.pFlag = pFlag p - , U.pAccount = pAccount p - , U.pTags = pTags p - , U.pEntry = case pInferred p of - Inferred -> Nothing - NotInferred -> Just (pEntry p) - , U.pMemo = pMemo p - , U.pPostingLine = pPostingLine p - , U.pGlobalPosting = pGlobalPosting p - , U.pFilePosting = pFilePosting p - } - - -toPosting :: U.Posting - -> B.Entry - -> Inferred - -> Posting -toPosting u e i = - Posting - { pPayee = U.pPayee u - , pNumber = U.pNumber u - , pFlag = U.pFlag u - , pAccount = U.pAccount u - , pTags = U.pTags u - , pEntry = e - , pMemo = U.pMemo u - , pInferred = i - , pPostingLine = U.pPostingLine u - , pGlobalPosting = U.pGlobalPosting u - , pFilePosting = U.pFilePosting u - } - - -toUTopLine :: TopLine -> U.TopLine -toUTopLine t = U.TopLine - { U.tDateTime = tDateTime t - , U.tFlag = tFlag t - , U.tNumber = tNumber t - , U.tPayee = tPayee t - , U.tMemo = tMemo t - , U.tTopLineLine = tTopLineLine t - , U.tTopMemoLine = tTopMemoLine t - , U.tFilename = tFilename t - , U.tGlobalTransaction = tGlobalTransaction t - , U.tFileTransaction = tFileTransaction t - } - -toTopLine :: U.TopLine -> TopLine -toTopLine t = TopLine - { tDateTime = U.tDateTime t - , tFlag = U.tFlag t - , tNumber = U.tNumber t - , tPayee = U.tPayee t - , tMemo = U.tMemo t - , tTopLineLine = U.tTopLineLine t - , tTopMemoLine = U.tTopMemoLine t - , tFilename = U.tFilename t - , tGlobalTransaction = U.tGlobalTransaction t - , tFileTransaction = U.tFileTransaction t - } - -fromRPosting :: U.RPosting -> B.Entry -> Inferred -> Posting -fromRPosting u e i = Posting - { pPayee = U.rPayee u - , pNumber = U.rNumber u - , pFlag = U.rFlag u - , pAccount = U.rAccount u - , pTags = U.rTags u - , pEntry = e - , pMemo = U.rMemo u - , pInferred = i - , pPostingLine = U.rPostingLine u - , pGlobalPosting = U.rGlobalPosting u - , pFilePosting = U.rFilePosting u - } - -fromIPosting :: U.IPosting -> B.Entry -> Inferred -> Posting -fromIPosting u e i = Posting - { pPayee = U.iPayee u - , pNumber = U.iNumber u - , pFlag = U.iFlag u - , pAccount = U.iAccount u - , pTags = U.iTags u - , pEntry = e - , pMemo = U.iMemo u - , pInferred = i - , pPostingLine = U.iPostingLine u - , pGlobalPosting = U.iGlobalPosting u - , pFilePosting = U.iFilePosting u - } - -data RTransaction = RTransaction - { rtCommodity :: B.Commodity - -- ^ All postings will have this same commodity - - , rtSide :: Maybe B.Side - -- ^ All commodities will be on this side of the amount - - , rtSpaceBetween :: Maybe B.SpaceBetween - -- ^ All amounts will have this SpaceBetween - - , rtDrCr :: B.DrCr - -- ^ All postings except the inferred one will have this DrCr - - , rtTopLine :: U.TopLine - - , rtPosting :: U.RPosting - -- ^ You must have at least one posting whose quantity you specify - - , rtMorePostings :: [U.RPosting] - -- ^ Optionally you can have additional restricted postings. - - , rtIPosting :: U.IPosting - -- ^ And at least one posting whose quantity and DrCr will be inferred - - } deriving Show - --- | Creates a @restricted transaction@; that is, one in which all the --- entries will have the same commodity, and in which all but one of --- the postings will all be debits or credits. The last posting will --- have no quantity specified at all and will be inferred. Creating --- these transactions never fails, in contrast to the transactions --- created by 'transaction', which can fail at runtime. -rTransaction :: RTransaction -> Transaction -rTransaction rt = Transaction (F.Family tl p1 p2 ps) - where - tl = toTopLine (rtTopLine rt) - tot = foldl1 B.add $ (U.rQty . rtPosting $ rt) - : map U.rQty (rtMorePostings rt) - sd = rtSide rt - sb = rtSpaceBetween rt - inf = fromIPosting (rtIPosting rt) - ( B.Entry (B.opposite (rtDrCr rt)) - (B.Amount tot (rtCommodity rt) sd sb)) - Inferred - toPstg p = fromRPosting p - (B.Entry (rtDrCr rt) - (B.Amount (U.rQty p) (rtCommodity rt) sd sb)) NotInferred - p1 = toPstg . rtPosting $ rt - (p2, ps) = case rtMorePostings rt of - [] -> (inf, []) - x:xs -> (toPstg x, (map toPstg xs) ++ [inf]) - --- | A box stores a family of transaction data along with --- metadata. The transaction is stored in child form, indicating a --- particular posting of interest. The metadata is in addition to the --- metadata associated with the TopLine and with each posting. -data Box m = - Box { boxMeta :: m - , boxPostFam :: PostFam } - deriving Show - -instance Functor Box where - fmap f (Box m pf) = Box (f m) pf - -------------------------------------------------------------- --- Changers -------------------------------------------------------------- - --- | Each field in the record is a Maybe. If Nothing, make no change --- to this part of the TopLine. -data TopLineChangeData = TopLineChangeData - { tcDateTime :: Maybe B.DateTime - , tcFlag :: Maybe (Maybe B.Flag) - , tcNumber :: Maybe (Maybe B.Number) - , tcPayee :: Maybe (Maybe B.Payee) - , tcMemo :: Maybe (Maybe B.Memo) - , tcTopLineLine :: Maybe (Maybe B.TopLineLine) - , tcTopMemoLine :: Maybe (Maybe B.TopMemoLine) - , tcFilename :: Maybe (Maybe B.Filename) - , tcGlobalTransaction :: Maybe (Maybe B.GlobalTransaction) - , tcFileTransaction :: Maybe (Maybe B.FileTransaction) - } deriving Show - -emptyTopLineChangeData :: TopLineChangeData -emptyTopLineChangeData = TopLineChangeData - { tcDateTime = Nothing - , tcFlag = Nothing - , tcNumber = Nothing - , tcPayee = Nothing - , tcMemo = Nothing - , tcTopLineLine = Nothing - , tcTopMemoLine = Nothing - , tcFilename = Nothing - , tcGlobalTransaction = Nothing - , tcFileTransaction = Nothing - } - - -applyTopLineChange :: TopLineChangeData -> TopLine -> TopLine -applyTopLineChange c t = TopLine - { tDateTime = fromMaybe (tDateTime t) (tcDateTime c) - , tFlag = fromMaybe (tFlag t) (tcFlag c) - , tNumber = fromMaybe (tNumber t) (tcNumber c) - , tPayee = fromMaybe (tPayee t) (tcPayee c) - , tMemo = fromMaybe (tMemo t) (tcMemo c) - , tTopLineLine = fromMaybe (tTopLineLine t) (tcTopLineLine c) - , tTopMemoLine = fromMaybe (tTopMemoLine t) (tcTopMemoLine c) - , tFilename = fromMaybe (tFilename t) (tcFilename c) - , tGlobalTransaction = fromMaybe (tGlobalTransaction t) - (tcGlobalTransaction c) - , tFileTransaction = fromMaybe (tFileTransaction t) - (tcFileTransaction c) - } - -data PostingChangeData = PostingChangeData - { pcPayee :: Maybe (Maybe B.Payee) - , pcNumber :: Maybe (Maybe B.Number) - , pcFlag :: Maybe (Maybe B.Flag) - , pcAccount :: Maybe B.Account - , pcTags :: Maybe B.Tags - , pcMemo :: Maybe (Maybe B.Memo) - , pcSide :: Maybe (Maybe B.Side) - , pcSpaceBetween :: Maybe (Maybe B.SpaceBetween) - , pcPostingLine :: Maybe (Maybe B.PostingLine) - , pcGlobalPosting :: Maybe (Maybe B.GlobalPosting) - , pcFilePosting :: Maybe (Maybe B.FilePosting) - } deriving Show - -emptyPostingChangeData :: PostingChangeData -emptyPostingChangeData = PostingChangeData - { pcPayee = Nothing - , pcNumber = Nothing - , pcFlag = Nothing - , pcAccount = Nothing - , pcTags = Nothing - , pcMemo = Nothing - , pcSide = Nothing - , pcSpaceBetween = Nothing - , pcPostingLine = Nothing - , pcGlobalPosting = Nothing - , pcFilePosting = Nothing - } - - -applyPostingChange :: PostingChangeData -> Posting -> Posting -applyPostingChange c p = Posting - { pPayee = fromMaybe (pPayee p) (pcPayee c) - , pNumber = fromMaybe (pNumber p) (pcNumber c) - , pFlag = fromMaybe (pFlag p) (pcFlag c) - , pAccount = fromMaybe (pAccount p) (pcAccount c) - , pTags = fromMaybe (pTags p) (pcTags c) - , pEntry = en - , pMemo = fromMaybe (pMemo p) (pcMemo c) - , pInferred = pInferred p - , pPostingLine = fromMaybe (pPostingLine p) (pcPostingLine c) - , pGlobalPosting = fromMaybe (pGlobalPosting p) (pcGlobalPosting c) - , pFilePosting = fromMaybe (pFilePosting p) (pcFilePosting c) - } - where - enOld = pEntry p - amOld = B.amount enOld - en = B.Entry (B.drCr enOld) am - am = B.Amount (B.qty amOld) (B.commodity amOld) sd sb - sd = fromMaybe (B.side amOld) (pcSide c) - sb = fromMaybe (B.spaceBetween amOld) (pcSpaceBetween c) - --- | Allows you to change the parts of a transaction that can be --- chanaged without unbalancing the transaction. You cannot change the --- DrCr, Qty, or Commodity, as changing these might unbalance the --- transaction. If there are elements you do not want to change at --- all, use an 'emptyTopLineChangeData' or an 'emptyPostingChangeData' --- in the appropriate part of the Family that you pass in. If the --- Family of change data has more children than the transaction, these --- extra children are ignored. If the Family in the Transaction has --- more children than the Family of change data, the extra postings --- are unchanged. That is, 'changeTransaction' will never delete --- postings. -changeTransaction - :: F.Family TopLineChangeData PostingChangeData - -> Transaction - -> Transaction -changeTransaction c (Transaction t) = - let F.Family ctl cp1 cp2 cps = c - F.Family tl p1 p2 ps = t - tl' = applyTopLineChange ctl tl - p1' = applyPostingChange cp1 p1 - p2' = applyPostingChange cp2 p2 - ps' = zipWith applyPostingChange - (cps ++ repeat emptyPostingChangeData) ps - in Transaction (F.Family tl' p1' p2' ps') - diff --git a/Penny/Lincoln/Transaction/Unverified.hs b/Penny/Lincoln/Transaction/Unverified.hs deleted file mode 100644 --- a/Penny/Lincoln/Transaction/Unverified.hs +++ /dev/null @@ -1,131 +0,0 @@ --- | Provides record types to hold the data that are in an unverified --- transaction. Use these records along with the functions in --- 'Penny.Lincoln.Transaction' to create Transactions. You can create --- a Transaction only if the postings are balanced. --- --- The functions that create transactions will fail at runtime if the --- postings are not balanced (this is impossible to enforce at compile --- time.) However, if you are creating a transaction in which both of --- the amounts have the same commodity, for which all but one of the --- entries will have the same DrCr, and in which one of the postings --- has no entry at all (that is, its entry will be inferred), then it --- is possible to create a transaction that is guaranteed to be --- balanced. Use the RPosting and IPosting types for this purpose. (It --- is necessary for all the postings except for the inferred one to --- have the same DrCr because otherwise it would be possible to create --- a transaction in which the inferred posting would have to have an --- entry with a quantity of zero, which is impossible. -module Penny.Lincoln.Transaction.Unverified where - -import qualified Penny.Lincoln.Bits as B - -data TopLine = TopLine - { tDateTime :: B.DateTime - , tFlag :: Maybe B.Flag - , tNumber :: Maybe B.Number - , tPayee :: Maybe B.Payee - , tMemo :: Maybe B.Memo - , tTopLineLine :: Maybe B.TopLineLine - , tTopMemoLine :: Maybe B.TopMemoLine - , tFilename :: Maybe B.Filename - , tGlobalTransaction :: Maybe B.GlobalTransaction - , tFileTransaction :: Maybe B.FileTransaction - } deriving (Eq, Show) - -emptyTopLine :: B.DateTime -> TopLine -emptyTopLine d = TopLine - { tDateTime = d - , tFlag = Nothing - , tNumber = Nothing - , tPayee = Nothing - , tMemo = Nothing - , tTopLineLine = Nothing - , tTopMemoLine = Nothing - , tFilename = Nothing - , tGlobalTransaction = Nothing - , tFileTransaction = Nothing - } - -data Posting = Posting - { pPayee :: Maybe B.Payee - , pNumber :: Maybe B.Number - , pFlag :: Maybe B.Flag - , pAccount :: B.Account - , pTags :: B.Tags - , pEntry :: Maybe B.Entry - , pMemo :: Maybe B.Memo - , pPostingLine :: Maybe B.PostingLine - , pGlobalPosting :: Maybe B.GlobalPosting - , pFilePosting :: Maybe B.FilePosting - } deriving (Eq, Show) - -emptyPosting :: B.Account -> Posting -emptyPosting a = Posting - { pPayee = Nothing - , pNumber = Nothing - , pFlag = Nothing - , pAccount = a - , pTags = B.Tags [] - , pEntry = Nothing - , pMemo = Nothing - , pPostingLine = Nothing - , pGlobalPosting = Nothing - , pFilePosting = Nothing - } - --- | A @restricted posting@ in which only the quantity is specified; --- the commodity and DrCr are specified when the transaction is --- created. -data RPosting = RPosting - { rPayee :: Maybe B.Payee - , rNumber :: Maybe B.Number - , rFlag :: Maybe B.Flag - , rAccount :: B.Account - , rTags :: B.Tags - , rQty :: B.Qty - , rMemo :: Maybe B.Memo - , rPostingLine :: Maybe B.PostingLine - , rGlobalPosting :: Maybe B.GlobalPosting - , rFilePosting :: Maybe B.FilePosting - } deriving (Eq, Show) - -emptyRPosting :: B.Account -> B.Qty -> RPosting -emptyRPosting a q = RPosting - { rPayee = Nothing - , rNumber = Nothing - , rFlag = Nothing - , rAccount = a - , rTags = B.Tags [] - , rQty = q - , rMemo = Nothing - , rPostingLine = Nothing - , rGlobalPosting = Nothing - , rFilePosting = Nothing - } - --- | An @inferred posting@ in which no quantity is specified. -data IPosting = IPosting - { iPayee :: Maybe B.Payee - , iNumber :: Maybe B.Number - , iFlag :: Maybe B.Flag - , iAccount :: B.Account - , iTags :: B.Tags - , iMemo :: Maybe B.Memo - , iPostingLine :: Maybe B.PostingLine - , iGlobalPosting :: Maybe B.GlobalPosting - , iFilePosting :: Maybe B.FilePosting - } deriving (Eq, Show) - -emptyIPosting :: B.Account -> IPosting -emptyIPosting a = IPosting - { iPayee = Nothing - , iNumber = Nothing - , iFlag = Nothing - , iAccount = a - , iTags = B.Tags [] - , iMemo = Nothing - , iPostingLine = Nothing - , iGlobalPosting = Nothing - , iFilePosting = Nothing - } - diff --git a/Penny/Shield.hs b/Penny/Shield.hs deleted file mode 100644 --- a/Penny/Shield.hs +++ /dev/null @@ -1,105 +0,0 @@ --- | Shield - the Penny runtime environment --- --- Both Cabin and Copper can benefit from knowing information about --- the Penny runtime environment, such as environment variables and --- whether standard output is a terminal. That information is provided --- by the Runtime type. In the future this module may also provide --- information about the POSIX locale configuration. For now, that --- information would require reaching into the FFI and so it is not --- implemented. - -module Penny.Shield ( - ScreenLines, - unScreenLines, - ScreenWidth, - unScreenWidth, - Output(IsTTY, NotTTY), - Runtime, - environment, - currentTime, - output, - screenLines, - screenWidth, - term, - runtime, - termFromEnv, - autoTerm) - where - -import Control.Applicative ((<$>), (<*>)) -import qualified Data.Time as T -import System.Environment (getEnvironment) -import System.IO (hIsTerminalDevice, stdout) -import qualified System.Console.Rainbow as C - -import qualified Penny.Lincoln.Bits as B - -data ScreenLines = ScreenLines { unScreenLines :: Int } - deriving Show - -newtype ScreenWidth = ScreenWidth { unScreenWidth :: Int } - deriving Show - -data Output = IsTTY | NotTTY deriving (Eq, Ord, Show) - -newtype Term = Term { unTerm :: String } deriving Show - --- | Information about the runtime environment. -data Runtime = Runtime { environment :: [(String, String)] - , currentTime :: B.DateTime - , output :: Output } - -runtime :: IO Runtime -runtime = Runtime - <$> getEnvironment - <*> (toDT <$> T.getZonedTime) - <*> findOutput - where - toDT t = case B.fromZonedTime t of - Nothing -> error "time conversion error" - Just ti -> ti - -findOutput :: IO Output -findOutput = do - isTerm <- hIsTerminalDevice stdout - return $ if isTerm then IsTTY else NotTTY - -screenLines :: Runtime -> Maybe ScreenLines -screenLines r = - (lookup "LINES" . environment $ r) - >>= safeRead - >>= return . ScreenLines - -screenWidth :: Runtime -> Maybe ScreenWidth -screenWidth r = - (lookup "COLUMNS" . environment $ r) - >>= safeRead - >>= return . ScreenWidth - -term :: Runtime -> Maybe Term -term r = - (lookup "TERM" . environment $ r) - >>= return . Term - --- | Read, but without crashes. -safeRead :: (Read a) => String -> Maybe a -safeRead s = case reads s of - (a, []):[] -> Just a - _ -> Nothing - --- | Determines which Chunk Term to use based on the TERM environment --- variable, regardless of whether standard output is a terminal. Uses --- Dumb if TERM is not set. -termFromEnv :: Runtime -> C.Term -termFromEnv rt = case term rt of - Just t -> C.TermName . unTerm $ t - Nothing -> C.Dumb - --- | Determines which Chunk Term to use based on whether standard --- output is a terminal. Uses Dumb if standard output is not a --- terminal; otherwise, uses the TERM environment variable. -autoTerm :: Runtime -> C.Term -autoTerm rt = case output rt of - IsTTY -> termFromEnv rt - NotTTY -> C.Dumb - diff --git a/Penny/Steel.hs b/Penny/Steel.hs deleted file mode 100644 --- a/Penny/Steel.hs +++ /dev/null @@ -1,3 +0,0 @@ --- | Steel - independent Penny utilities - -module Penny.Steel where diff --git a/Penny/Steel/NestedMap.hs b/Penny/Steel/NestedMap.hs deleted file mode 100644 --- a/Penny/Steel/NestedMap.hs +++ /dev/null @@ -1,275 +0,0 @@ --- | A nested map. The values in each NestedMap are tuples, with the --- first element of the tuple being a label that you select and the --- second value being another NestedMap. Functions are provided so you --- may query the map at any level or insert new labels (and, --- therefore, new keys) at any level. -module Penny.Steel.NestedMap ( - NestedMap ( NestedMap, unNestedMap ), - empty, - relabel, - descend, - insert, - cumulativeTotal, - traverse, - traverseWithTrail, - toForest ) where - -import Control.Applicative ((<*>), (<$>)) -import Data.Map ( Map ) -import qualified Data.Foldable as F -import qualified Data.Traversable as T -import qualified Data.Tree as E -import qualified Data.Map as M -import Data.Monoid ( Monoid, mconcat, mappend, mempty ) - -newtype NestedMap k l = - NestedMap { unNestedMap :: Map k (l, NestedMap k l) } - deriving (Eq, Show, Ord) - -instance Functor (NestedMap k) where - fmap f (NestedMap m) = let - g (l, s) = (f l, fmap f s) - in NestedMap $ M.map g m - -instance (Ord k) => F.Foldable (NestedMap k) where - foldMap = T.foldMapDefault - -instance (Ord k) => T.Traversable (NestedMap k) where - -- traverse :: Applicative f - -- => (a -> f b) - -- -> NestedMap k a - -- -> f (NestedMap k b) - traverse f (NestedMap m) = let - f' (l, m') = (,) <$> f l <*> T.traverse f m' - in NestedMap <$> T.traverse f' m - --- | An empty NestedMap. -empty :: NestedMap k l -empty = NestedMap (M.empty) - --- | Helper function for relabel. For a given key and function --- that modifies the label, return the new submap to insert into the --- given map. Does not actually insert the submap though. That way, --- relabel can then modify the returned submap before --- inserting it into the mother map with the given label. -newSubmap :: - (Ord k) - => NestedMap k l - -> k - -> (Maybe l -> l) - -> (l, NestedMap k l) -newSubmap (NestedMap m) k g = (newL, NestedMap newM) where - (newL, newM) = case M.lookup k m of - Nothing -> (g Nothing, M.empty) - (Just (oldL, (NestedMap oldM))) -> (g (Just oldL), oldM) - --- | Descends through a NestedMap with successive keys in the list, --- proceeding from left to right. At any given level, if the key --- given does not already exist, then inserts an empty submap and --- applies the given label modification function to Nothing to --- determine the new label. If the given key already does exist, then --- preserves the existing submap and applies the given label --- modification function to (Just oldlabel) to determine the new --- label. -relabel :: - (Ord k) - => NestedMap k l - -> [(k, (Maybe l -> l))] - -> NestedMap k l -relabel m [] = m -relabel (NestedMap m) ((k, f):vs) = let - (newL, newM) = newSubmap (NestedMap m) k f - newM' = relabel newM vs - in NestedMap $ M.insert k (newL, newM') m - --- | Given a list of keys, find the key that is furthest down in the --- map that matches the requested list of keys. Returns [(k, l)], --- where the first item in the list is the topmost key found and its --- matching label, and the last item in the list is the deepest key --- found and its matching label. (Often you will be most interested --- in the deepest key.) -descend :: - Ord k - => [k] - -> NestedMap k l - -> [(k, l)] -descend keys (NestedMap mi) = descend' keys mi where - descend' [] _ = [] - descend' (k:ks) m = case M.lookup k m of - Nothing -> [] - Just (l, (NestedMap im)) -> (k, l) : descend' ks im - - --- | Descends through the NestedMap one level at a time, proceeding --- key by key from left to right through the list of keys given. At --- the last key, appends the given label to the labels already --- present; if no label is present, uses mempty and mappend to create --- a new label. If the list of keys is empty, does nothing. -insert :: - (Ord k, Monoid l) - => NestedMap k l - -> [k] - -> l - -> NestedMap k l -insert m [] _ = m -insert m ks l = relabel m ts where - ts = firsts ++ [end] - firsts = map (\k -> (k, keepOld)) (init ks) where - keepOld mk = case mk of - (Just old) -> old - Nothing -> mempty - end = (key, newL) where - key = last ks - newL mk = case mk of - (Just old) -> old `mappend` l - Nothing -> mempty `mappend` l - -totalMap :: - (Monoid l) - => NestedMap k l - -> l -totalMap (NestedMap m) = - if M.null m - then mempty - else mconcat . map totalTuple . M.elems $ m - -totalTuple :: - (Monoid l) - => (l, NestedMap k l) - -> l -totalTuple (l, (NestedMap top)) = - if M.null top - then l - else mappend l (totalMap (NestedMap top)) - -remapWithTotals :: - (Monoid l) - => NestedMap k l - -> NestedMap k l -remapWithTotals (NestedMap top) = - if M.null top - then NestedMap M.empty - else NestedMap $ M.map f top where - f a@(_, m) = (totalTuple a, remapWithTotals m) - --- | Leaves all keys of the map and submaps the same. Changes each --- label to reflect the total of that label and of all the labels of --- the maps within the NestedMap accompanying the label. Returns the --- total of the entire NestedMap. -cumulativeTotal :: - (Monoid l) - => NestedMap k l - -> (l, NestedMap k l) -cumulativeTotal m = (totalMap m, remapWithTotals m) - --- | Supply a function that takes a key, a label, and a --- NestedMap. traverse will traverse the NestedMap. For each (label, --- NestedMap) pair, traverse will first apply the given function to --- the label before descending through the NestedMap. The function is --- applied to the present key and label and the accompanying --- NestedMap. The function you supply must return a Maybe. If the --- result is Nothing, then the pair is deleted as a value from its --- parent NestedMap. If the result is (Just s), then the label of this --- level of the NestedMap is changed to s before descending to the --- next level of the NestedMap. --- --- All this is done in a monad, so you can carry out arbitrary side --- effects such as inspecting or changing a state or doing IO. If you --- don't need a monad, just use Identity. --- --- Thus this function can be used to inspect, modify, and prune a --- NestedMap. --- --- For a simpler traverse that does not provide you with so much --- information, NestedMap is also an instance of Data.Traversable. -traverse :: - (Monad m, Ord k) - => (k -> l -> NestedMap k l -> m (Maybe a)) - -> NestedMap k l - -> m (NestedMap k a) -traverse f m = traverseWithTrail (\_ -> f) m - --- | Like traverse, but the supplied function is also applied to a --- list that tells it about the levels of NestedMap that are parents --- to this NestedMap. -traverseWithTrail :: - (Monad m, Ord k) - => ( [(k, l)] -> k -> l -> NestedMap k l -> m (Maybe a) ) - -> NestedMap k l - -> m (NestedMap k a) -traverseWithTrail f = traverseWithTrail' f [] - -traverseWithTrail' :: - (Monad m, Ord k) - => ([(k, l)] -> k -> l -> NestedMap k l -> m (Maybe a)) - -> [(k, l)] - -> NestedMap k l - -> m (NestedMap k a) -traverseWithTrail' f ts (NestedMap m) = - if M.null m - then return $ NestedMap M.empty - else do - let ps = M.assocs m - mlsMaybes <- mapM (traversePairWithTrail f ts) ps - let ps' = zip (M.keys m) mlsMaybes - folder (k, ma) rs = case ma of - (Just r) -> (k, r):rs - Nothing -> rs - ps'' = foldr folder [] ps' - return (NestedMap (M.fromList ps'')) - -traversePairWithTrail :: - (Monad m, Ord k) - => ( [(k, l)] -> k -> l -> NestedMap k l -> m (Maybe a) ) - -> [(k, l)] - -> (k, (l, NestedMap k l)) - -> m (Maybe (a, NestedMap k a)) -traversePairWithTrail f ls (k, (l, m)) = do - ma <- f ls k l m - case ma of - Nothing -> return Nothing - (Just a) -> do - m' <- traverseWithTrail' f ((k, l):ls) m - return (Just (a, m')) - --- | Convert a NestedMap to a Forest. -toForest :: Ord k => NestedMap k l -> E.Forest (k, l) -toForest = map toNode . M.assocs . unNestedMap - where - toNode (k, (l, m)) = E.Node (k, l) (toForest m) - --- For testing -_new :: (k, l) -> (k, (Maybe l -> l)) -_new (k, l) = (k, const l) - -_map1, _map2, _map3, _map4 :: NestedMap Int String -_map1 = NestedMap M.empty -_map2 = relabel _map1 [_new (5, "hello"), _new (66, "goodbye"), _new (777, "yeah")] -_map3 = relabel _map2 [_new (6, "what"), _new (77, "zeke"), _new (888, "foo")] -_map4 = relabel _map3 - [ (6, (\m -> case m of Nothing -> "_new"; (Just s) -> s ++ "_new")) - , (77, (\m -> case m of Nothing -> "_new"; (Just s) -> s ++ "more _new")) ] - -_printer :: Int -> String -> a -> IO (Maybe ()) -_printer i s _ = do - putStrLn (show i) - putStrLn s - return $ Just () - -_printerWithTrail :: [(Int, String)] -> Int -> String -> a -> IO (Maybe ()) -_printerWithTrail ps n str _ = do - let ptr (i, s) = putStr ("(" ++ show i ++ ", " ++ s ++ ") ") - mapM_ ptr . reverse $ ps - ptr (n, str) - putStrLn "" - return $ Just () - -_showMap4 :: IO () -_showMap4 = do - _ <- traverse _printer _map4 - return () - -_showMapWithTrail :: IO () -_showMapWithTrail = do - _ <- traverseWithTrail _printerWithTrail _map4 - return () diff --git a/Penny/Wheat.hs b/Penny/Wheat.hs deleted file mode 100644 --- a/Penny/Wheat.hs +++ /dev/null @@ -1,365 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | Wheat - Penny ledger tests --- --- Wheat helps you build tests to check all the postings in your --- ledger. Perhaps you want to make sure all the account names are --- valid, or that your checking account has no unreconciled --- transactions. With Wheat you can easily build a command line --- program that will check all the postings in a ledger for you --- against criteria that you specify. - -module Penny.Wheat - ( -- * Configuration - WheatConf(..) - - -- * Tests - , eachPostingMustBeTrue - , atLeastNPostings - - -- * Convenience functions - , futureFirstsOfTheMonth - - -- * Running tests - , main - ) where - -import Control.Monad (when) -import qualified Control.Monad.Exception.Synchronous as Ex -import Data.Either (partitionEithers) -import Data.Maybe (mapMaybe) -import qualified Penny.Copper as Cop -import qualified Penny.Copper.Parsec as CP -import qualified Penny.Lincoln as L -import qualified Penny.Liberty as Ly -import qualified Data.Text as X -import qualified Data.Time as Time -import qualified Text.Matchers as M -import qualified Text.Parsec as Parsec -import qualified System.Exit as Exit -import qualified System.IO as IO -import qualified Penny.Shield as S - -import qualified Data.Version as V -import qualified Data.Prednote.TestTree as TT -import qualified Data.Prednote.Pdct as Pe -import qualified System.Console.Rainbow as Rb -import qualified System.Console.MultiArg as MA -import System.Locale (defaultTimeLocale) - ------------------------------------------------------------- --- Other conveniences ------------------------------------------------------------- - - --- | A non-terminating list of starting with the first day of the --- first month following the given day, followed by successive first --- days of the month. -futureFirstsOfTheMonth :: Time.Day -> [Time.Day] -futureFirstsOfTheMonth d = iterate (Time.addGregorianMonthsClip 1) d1 - where - d1 = Time.fromGregorian yr mo 1 - (yr, mo, _) = Time.toGregorian $ Time.addGregorianMonthsClip 1 d - ------------------------------------------------------------- --- CLI ------------------------------------------------------------- - --- | Record holding all data to configure Wheat. -data WheatConf = WheatConf - { briefDescription :: String - -- ^ This is displayed at the beginning of the online help. It - -- should be a one-line description of what this program does--for - -- example, what it checks for. - - , moreHelp :: [String] - -- ^ Displayed at the end of the online help. It should be a list - -- of lines, wich each line not terminated by a newline - -- character. It is displayed at the end of the online help. - - , tests :: [Time.UTCTime -> TT.TestTree L.PostFam] - -- ^ The actual tests to run. The UTCTime is the @base time@. Each - -- test may decide what to do with the base time--for example, the - -- test might say that all postings have to have a date on or - -- before that date. Or the test might just ignore the base time. - - , indentAmt :: Pe.IndentAmt - -- ^ How many spaces to indent each level in a tree of tests. - - , passVerbosity :: TT.Verbosity - -- ^ Verbosity for tests that pass - - , failVerbosity :: TT.Verbosity - -- ^ Verbosity for tests that fail - - , groupPred :: TT.Name -> Bool - -- ^ Group names are filtered with this function; a group is only - -- run if this function returns True. - - , testPred :: TT.Name -> Bool - -- ^ Test names are filtered with this function; a test is only - -- run if this function returns True. - - , showSkippedTests :: Bool - -- ^ Some tests might be skipped; see 'testPred'. This controls - -- whether you want to see a notification of tests that were - -- skipped. (Does not affect skipped groups; see 'groupVerbosity' - -- for that.) - - , groupVerbosity :: TT.GroupVerbosity - -- ^ Show group names? Even if you do not show the names of - -- groups, tests within the group will still be indented. - - , stopOnFail :: Bool - -- ^ If True, then tests will stop running immediately after a - -- single test fails. If False, all tests are always run. - - , colorToFile :: Bool - -- ^ Use colors even if stdout is not a file? - - , baseTime :: Time.UTCTime - -- ^ Tests may use this date and time as they wish; see - -- 'tests'. Typically you will set this to the current instant. - - , ledgers :: [String] - -- ^ Ledger files to read in from disk. - } - -data Parsed = Parsed - { p_indentAmt :: Pe.IndentAmt - , p_passVerbosity :: TT.Verbosity - , p_failVerbosity :: TT.Verbosity - , p_groupPred :: TT.Name -> Bool - , p_testPred :: TT.Name -> Bool - , p_showSkippedTests :: Bool - , p_groupVerbosity :: TT.GroupVerbosity - , p_stopOnFail :: Bool - , p_colorToFile :: Bool - , p_baseTime :: Time.UTCTime - , p_help :: Bool - , p_ledgers :: [String] - } - -parseBaseTime :: String -> Ex.Exceptional MA.OptArgError Time.UTCTime -parseBaseTime s = case Parsec.parse CP.dateTime "" (X.pack s) of - Left e -> Ex.throw (MA.ErrorMsg $ "could not parse date: " ++ show e) - Right g -> return . L.toUTC $ g - -parseRegexp :: String -> Ex.Exceptional MA.OptArgError (TT.Name -> Bool) -parseRegexp s = case M.pcre M.Sensitive (X.pack s) of - Ex.Exception e -> Ex.throw . MA.ErrorMsg $ - "could not parse regular expression: " ++ X.unpack e - Ex.Success m -> return . M.match $ m - -parseArg :: String -> Parsed -> Parsed -parseArg s p = p { p_ledgers = p_ledgers p ++ [s] } - -allOpts :: [MA.OptSpec (Parsed -> Parsed)] -allOpts = - let allChoices = - [ ("silent", \p -> p { p_failVerbosity = TT.Silent }) - , ("minimal", \p -> p { p_failVerbosity = TT.PassFail }) - , ("false", \p -> p { p_failVerbosity = TT.FalseSubjects }) - , ("true", \p -> p { p_failVerbosity = TT.TrueSubjects }) - , ("all", \p -> p { p_failVerbosity = TT.Discards }) - ] in - [ MA.OptSpec ["indentation"] "i" - (fmap (\i p -> p { p_indentAmt = i }) (MA.OneArgE MA.reader)) - - , MA.OptSpec ["pass-verbosity"] "p" $ MA.ChoiceArg allChoices - - , MA.OptSpec ["fail-verbosity"] "f" $ MA.ChoiceArg allChoices - - , MA.OptSpec ["group-regexp"] "g" - (fmap (\f p -> p { p_groupPred = f }) (MA.OneArgE parseRegexp)) - - , MA.OptSpec ["test-regexp"] "t" - (fmap (\f p -> p { p_testPred = f }) (MA.OneArgE parseRegexp)) - - , MA.OptSpec ["show-skipped-tests"] "" - ( MA.NoArg (\p -> p { p_showSkippedTests - = not (p_showSkippedTests p) })) - - , MA.OptSpec ["group-verbosity"] "G" $ MA.ChoiceArg - [ ("silent", \p -> p { p_groupVerbosity = TT.NoGroups }) - , ("active", \p -> p { p_groupVerbosity = TT.ActiveGroups }) - , ("all", \p -> p { p_groupVerbosity = TT.AllGroups }) - ] - - , MA.OptSpec ["stop-on-failure"] "" - ( MA.NoArg (\p -> p { p_stopOnFail - = not (p_stopOnFail p) })) - - , MA.OptSpec ["color-to-file"] "" - ( MA.NoArg (\p -> p { p_colorToFile - = not (p_colorToFile p) })) - - , MA.OptSpec ["base-date"] "" - (fmap (\d p -> p { p_baseTime = d }) (MA.OneArgE parseBaseTime)) - ] - -getTTOpts :: [a] -> Parsed -> TT.TestOpts a -getTTOpts as o = TT.TestOpts - { TT.tIndentAmt = p_indentAmt o - , TT.tPassVerbosity = p_passVerbosity o - , TT.tFailVerbosity = p_failVerbosity o - , TT.tGroupPred = p_groupPred o - , TT.tTestPred = p_testPred o - , TT.tShowSkippedTests = p_showSkippedTests o - , TT.tGroupVerbosity = p_groupVerbosity o - , TT.tSubjects = as - , TT.tStopOnFail = p_stopOnFail o - } - --- | Runs Wheat tests. Prints the result to standard output. Exits --- unsuccessfully if the user gave bad command line options or if at --- least a single test failed; exits successfully if all tests --- succeeded. Shows the version number and exits successfully if that --- was requested. -main - :: V.Version - -- ^ Version of the binary - -> (S.Runtime -> WheatConf) -> IO () -main ver getWc = do - rt <- S.runtime - let wc = getWc rt - parsed <- MA.simpleWithHelp (help wc) MA.Intersperse - (fmap Left (Ly.version ver) : (map (fmap Right) allOpts)) - (fmap Right parseArg) - let (showVers, fns) = partitionEithers parsed - case showVers of - [] -> return () - x:_ -> x - let fn = foldl (flip (.)) id fns - psd = fn (getParsedFromWheatConf wc) - term <- Rb.smartTermFromEnv (p_colorToFile psd) IO.stdout - pfs <- getItems (p_ledgers psd) - let ttOpts = getTTOpts pfs psd - tts = zipWith ($) (tests wc) (repeat (p_baseTime psd)) - (cks, _, nFail) = TT.runTests ttOpts 0 tts - Rb.printChunks term cks - when (nFail > 0) Exit.exitFailure - -getParsedFromWheatConf :: WheatConf -> Parsed -getParsedFromWheatConf w = Parsed - { p_indentAmt = indentAmt w - , p_passVerbosity = passVerbosity w - , p_failVerbosity = failVerbosity w - , p_groupPred = groupPred w - , p_testPred = testPred w - , p_showSkippedTests = showSkippedTests w - , p_groupVerbosity = groupVerbosity w - , p_stopOnFail = stopOnFail w - , p_colorToFile = colorToFile w - , p_baseTime = baseTime w - , p_help = False - , p_ledgers = ledgers w - } - -getItems :: [String] -> IO [L.PostFam] -getItems ss = fmap f $ Cop.open ss - where - f = concatMap L.postFam . mapMaybe toTxn . Cop.unLedger - toTxn i = case i of { Cop.Transaction x -> Just x; _ -> Nothing } - --- --- Tests --- - --- | Passes only if each posting is True. -eachPostingMustBeTrue - :: TT.Name - -> Pe.Pdct L.PostFam - -> TT.TestTree L.PostFam -eachPostingMustBeTrue n = TT.eachSubjectMustBeTrue n L.display - --- | Passes if at least a particular number of postings is True. -atLeastNPostings - :: Int - -- ^ The number of postings that must be true for the test to pass - -> TT.Name - -> Pe.Pdct L.PostFam - -> TT.TestTree L.PostFam -atLeastNPostings i n = TT.nSubjectsMustBeTrue n L.display i - --- --- Help --- - -help - :: WheatConf - -> String - -- ^ Program name - -> String -help wc pn = unlines - [ "usage: " ++ pn ++ " [options] [FILE...]" - , "" - , briefDescription wc - , "" - , "Options:" - , " -i, --indentation AMT" - , " Indent each level by this many spaces" - , " " ++ dflt (show . indentAmt $ wc) - , " -p, --pass-verbosity VERBOSITY" - , " Verbosity for tests that pass. Argument may be:" - , " silent - show nothing at all" - , " minimal - show whether the test passed or failed" - , " false - show subjects that are false" - , " true - show subjects that are true or false" - , " all - show all subjects" - , " " ++ dflt (showVerbosity . passVerbosity $ wc) - , " -f, --fail-verbosity VERBOSITY" - , " Verbosity for tests that fail." - , " (uses same VERBOSITY options as --pass-verbosity)" - , " " ++ dflt (showVerbosity . failVerbosity $ wc) - , " -g, --group-regexp REGEXP" - , " Run only groups whose name matches the given" - , " Perl-compatible regular expression" - , " (overrides the compiled-in default)" - , " -t, --test-regexp REGEXP" - , " Run only tests whose name matches the given" - , " Perl-compatible regular expression" - , " (overrides the compiled-in default)" - , " --show-skipped-tests" - , " Toggle whether to show tests that are skipped" - , " using the --test-regexp option" - , " (does not affect groups that are skipped; see next option)" - , " " ++ dflt (show . showSkippedTests $ wc) - , " --G, group-verbosity ARG" - , " Control which group names are shown. Argument may be:" - , " silent - do not show any group names" - , " active - show group names that were not skipped" - , " all - show all group names, including skipped ones" - , " " ++ dflt (showGroupVerbosity . groupVerbosity $ wc) - , " --stop-on-failure" - , " Stop running tests after a single test fails" - , " " ++ dflt (show . stopOnFail $ wc) - , " --color-to-file" - , " Use color even when standard output is not a terminal" - , " " ++ dflt (show . colorToFile $ wc) - , " --base-date DATE" - , " Use this date as a basis for checks" - , " " ++ dflt ( Time.formatTime defaultTimeLocale "%c" - . baseTime $ wc) - , "" - ] - ++ unlines (moreHelp wc) - -dflt :: String -> String -dflt s = "(default: " ++ s ++ ")" - -showVerbosity :: TT.Verbosity -> String -showVerbosity v = case v of - TT.Silent -> "silent" - TT.PassFail -> "minimal" - TT.FalseSubjects -> "false" - TT.TrueSubjects -> "true" - TT.Discards -> "all" - -showGroupVerbosity :: TT.GroupVerbosity -> String -showGroupVerbosity v = case v of - TT.NoGroups -> "silent" - TT.ActiveGroups -> "active" - TT.AllGroups -> "all" - - diff --git a/Penny/Zinc.hs b/Penny/Zinc.hs deleted file mode 100644 --- a/Penny/Zinc.hs +++ /dev/null @@ -1,747 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | Zinc - the Penny command-line interface -module Penny.Zinc - ( Defaults(..) - , ColorToFile(..) - , Matcher(..) - , SortField(..) - , runZinc - ) where - -import qualified Penny.Cabin.Interface as I -import qualified Penny.Cabin.Parsers as P -import qualified Penny.Cabin.Scheme as E -import qualified Penny.Cabin.Scheme.Schemes as Schemes -import qualified Penny.Copper as C -import qualified Penny.Liberty as Ly -import qualified Data.Prednote.Expressions as X -import qualified Data.Prednote.Pdct as Pe -import qualified Penny.Lincoln as L -import qualified Penny.Lincoln.Queries as Q -import qualified Penny.Shield as S - -import Control.Applicative ((<*>), pure, (<$)) -import Control.Monad (join) -import qualified Control.Monad.Trans.State as St -import qualified Control.Monad.Exception.Synchronous as Ex -import Data.Char (toUpper, toLower) -import Data.Either (partitionEithers) -import Data.List (isPrefixOf) -import Data.Maybe (mapMaybe, catMaybes, fromMaybe) -import Data.Monoid (mappend, mconcat, (<>)) -import Data.Ord (comparing) -import Data.Text (Text, pack) -import Data.Version (Version) -import qualified Data.Text.IO as TIO -import qualified System.Console.MultiArg as MA -import qualified System.Exit as Exit -import qualified System.IO as IO -import qualified Text.Matchers as M -import qualified System.Console.Rainbow as R - -runZinc - :: Version - -- ^ Version of the executable - -> Defaults - -> S.Runtime - -> [I.Report] - -> IO () -runZinc ver df rt rs = do - let ord = sortPairsToFn . sorter $ df - hlp = helpText df rt rs - join $ MA.modesWithHelp hlp (allOpts ver (S.currentTime rt) df) - (processGlobal rt ord df rs) - - --- | Whether to use color when standard output is not a terminal. -newtype ColorToFile = ColorToFile { unColorToFile :: Bool } - deriving (Eq, Show) - -data Matcher - = Within - | Exact - | TDFA - | PCRE - deriving (Eq, Show) - -data SortField - = Payee - | Date - | Flag - | Number - | Account - | DrCr - | Qty - | Commodity - | PostingMemo - | TransactionMemo - deriving (Eq, Show, Ord) - -data Defaults = Defaults - { sensitive :: M.CaseSensitive - , matcher :: Matcher - , colorToFile :: ColorToFile - , defaultScheme :: Maybe E.Scheme - -- ^ If Nothing, no default scheme. If the user does not pick a - -- scheme, no colors are used. - , moreSchemes :: [E.Scheme] - , sorter :: [(SortField, P.SortOrder)] - -- ^ For example, to sort by date and then by payee if the dates - -- are equal, use - -- - -- > [(Date, Ascending), (Payee, Ascending)] - - , exprDesc :: X.ExprDesc - } - -sortPairToFn :: (SortField, P.SortOrder) -> Orderer -sortPairToFn (s, d) = if d == P.Descending then flipOrder r else r - where - r = case s of - Payee -> comparing Q.payee - Date -> comparing Q.dateTime - Flag -> comparing Q.flag - Number -> comparing Q.number - Account -> comparing Q.account - DrCr -> comparing Q.drCr - Qty -> comparing Q.qty - Commodity -> comparing Q.commodity - PostingMemo -> comparing Q.postingMemo - TransactionMemo -> comparing Q.transactionMemo - -descPair :: (SortField, P.SortOrder) -> String -descPair (i, d) = desc ++ ", " ++ dir - where - dir = case d of - P.Ascending -> "ascending" - P.Descending -> "descending" - desc = case show i of - [] -> [] - x:xs -> toLower x : xs - -descSortList :: [(SortField, P.SortOrder)] -> [String] -descSortList ls = case ls of - [] -> [" No sorting performed by default"] - x:xs -> descFirst x : map descRest xs - -descFirst :: (SortField, P.SortOrder) -> String -descFirst p = " Default sort order: " ++ descPair p - -descRest :: (SortField, P.SortOrder) -> String -descRest p = " then: " ++ descPair p - -sortPairsToFn :: [(SortField, P.SortOrder)] -> Orderer -sortPairsToFn = mconcat . map sortPairToFn - --- --- ## Option parsing --- - --- --- ## OptResult, and functions dealing with it --- -newtype ShowExpression = ShowExpression Bool - deriving (Show, Eq) - -newtype VerboseFilter = VerboseFilter Bool - deriving (Show, Eq) - -type Error = Text - -data OptResult - = ROperand (M.CaseSensitive - -> Ly.MatcherFactory - -> Ex.Exceptional Ly.Error Ly.Operand) - | RPostFilter (Ex.Exceptional Ly.Error Ly.PostFilterFn) - | RMatcherSelect Ly.MatcherFactory - | RCaseSelect M.CaseSensitive - | ROperator (X.Token L.PostFam) - | RSortSpec (Ex.Exceptional Error Orderer) - | RColorToFile ColorToFile - | RScheme E.Changers - | RExprDesc X.ExprDesc - | RShowExpression - | RVerboseFilter - | RShowVersion (IO ()) - -getPostFilters - :: [OptResult] - -> Ex.Exceptional Ly.Error [Ly.PostFilterFn] -getPostFilters = - sequence - . mapMaybe f - where - f o = case o of - RPostFilter pf -> Just pf - _ -> Nothing - -getExprDesc - :: Defaults - -> [OptResult] - -> X.ExprDesc -getExprDesc df os = case mapMaybe f os of - [] -> exprDesc df - xs -> last xs - where - f (RExprDesc d) = Just d - f _ = Nothing - -getSortSpec - :: Orderer - -> [OptResult] - -> Ex.Exceptional Error Orderer -getSortSpec i ls = - let getSpec o = case o of - RSortSpec x -> Just x - _ -> Nothing - exSpecs = mapMaybe getSpec ls - in if null exSpecs - then return i - else fmap mconcat . sequence $ exSpecs - -getShowVersion :: [OptResult] -> Maybe (IO ()) -getShowVersion ls = case mapMaybe f ls of - [] -> Nothing - xs -> Just $ last xs - where - f o = case o of { RShowVersion i -> Just i; _ -> Nothing } - -type Factory = M.CaseSensitive - -> Text -> Ex.Exceptional Text M.Matcher - -makeToken - :: OptResult - -> St.State (M.CaseSensitive, Factory) - (Maybe (Ex.Exceptional Ly.Error (X.Token L.PostFam))) -makeToken o = case o of - ROperand f -> do - (s, fty) <- St.get - let g = fmap X.operand (f s fty) - return (Just g) - RMatcherSelect f -> do - (c, _) <- St.get - St.put (c, f) - return Nothing - RCaseSelect c -> do - (_, f) <- St.get - St.put (c, f) - return Nothing - ROperator t -> return . Just . return $ t - _ -> return Nothing - - -makeTokens - :: Defaults - -> [OptResult] - -> Ex.Exceptional Ly.Error ( [X.Token L.PostFam] - , (M.CaseSensitive, Factory) ) -makeTokens df os = - let initSt = (sensitive df, fty) - fty = case matcher df of - Within -> \c t -> return (M.within c t) - Exact -> \c t -> return (M.exact c t) - TDFA -> M.tdfa - PCRE -> M.pcre - lsSt = mapM makeToken os - (ls, st') = St.runState lsSt initSt - in fmap (\xs -> (xs, st')) . sequence . catMaybes $ ls - - -allOpts :: Version -> L.DateTime -> Defaults -> [MA.OptSpec OptResult] -allOpts ver dt df = - map (fmap ROperand) (Ly.operandSpecs dt) - ++ [fmap RPostFilter . fst $ Ly.postFilterSpecs] - ++ [fmap RPostFilter . snd $ Ly.postFilterSpecs] - ++ map (fmap RMatcherSelect) Ly.matcherSelectSpecs - ++ map (fmap RCaseSelect) Ly.caseSelectSpecs - ++ map (fmap ROperator) Ly.operatorSpecs - ++ [fmap RSortSpec sortSpecs] - ++ [ optColorToFile ] - ++ let ss = moreSchemes df - in (if not . null $ ss then [optScheme ss] else []) - ++ map (fmap RExprDesc) Ly.exprDesc - ++ [ RShowExpression <$ Ly.showExpression - , RVerboseFilter <$ Ly.verboseFilter - , fmap RShowVersion (Ly.version ver) - ] - -optColorToFile :: MA.OptSpec OptResult -optColorToFile = MA.OptSpec ["color-to-file"] "" (MA.ChoiceArg ls) - where - ls = [ ("yes", RColorToFile $ ColorToFile True) - , ("no", RColorToFile $ ColorToFile False) ] - -getColorToFile :: Defaults -> [OptResult] -> ColorToFile -getColorToFile d ls = - case mapMaybe getOpt ls of - [] -> colorToFile d - xs -> last xs - where - getOpt o = case o of - RColorToFile c -> Just c - _ -> Nothing - -optScheme :: [E.Scheme] -> MA.OptSpec OptResult -optScheme ss = MA.OptSpec ["scheme"] "" (MA.ChoiceArg ls) - where - ls = map f ss - f (E.Scheme n _ s) = (n, RScheme s) - -getScheme :: Defaults -> [OptResult] -> Maybe E.Changers -getScheme d ls = - case mapMaybe getOpt ls of - [] -> fmap E.changers $ defaultScheme d - xs -> Just $ last xs - where - getOpt o = case o of - RScheme s -> Just s - _ -> Nothing - -getShowExpression :: [OptResult] -> ShowExpression -getShowExpression ls = case mapMaybe f ls of - [] -> ShowExpression False - _ -> ShowExpression True - where - f o = case o of { RShowExpression -> Just (); _ -> Nothing } - -getVerboseFilter :: [OptResult] -> VerboseFilter -getVerboseFilter ls = case mapMaybe f ls of - [] -> VerboseFilter False - _ -> VerboseFilter True - where - f o = case o of { RVerboseFilter -> Just (); _ -> Nothing } - --- | Indicates the result of a successful parse of filtering options. -data FilterOpts = FilterOpts - { foResultFactory :: Factory - -- ^ The factory indicated, so that it can be used in - -- subsequent parses of the same command line. - - , foResultSensitive :: M.CaseSensitive - -- ^ Indicated case sensitivity, so that it can be used in - -- subsequent parses of the command line. - - , foSorterFilterer :: [L.Transaction] - -> ([R.Chunk], [L.Box Ly.LibertyMeta]) - -- ^ Applied to a list of Transaction, will sort and filter - -- the transactions and assign them LibertyMeta. - - , foTextSpecs :: Maybe E.Changers - - , foColorToFile :: ColorToFile - , foExprDesc :: X.ExprDesc - , foPredicate :: Pe.Pdct L.PostFam - , foShowExpression :: ShowExpression - , foVerboseFilter :: VerboseFilter - } - -processGlobal - :: S.Runtime - -> Orderer - -> Defaults - -> [I.Report] - -> [OptResult] - -> Either (a -> IO ()) [MA.Mode (IO ())] -processGlobal rt srt df rpts os - = case processFiltOpts srt df os of - Ex.Exception s -> Left $ (const $ handleTextError s) - Ex.Success mayFo -> case mayFo of - Left i -> Left . const $ i - Right fo -> Right $ map (makeMode rt fo) rpts - -processFiltOpts - :: Orderer - -> Defaults - -> [OptResult] - -> Ex.Exceptional Error (Either (IO ()) FilterOpts) - -- ^ Left if the user asked to see the version; Right with the - -- FilterOpts otherwise. -processFiltOpts ord df os = case getShowVersion os of - Just i -> return $ Left i - Nothing -> do - postFilts <- getPostFilters os - sortSpec <- getSortSpec ord os - (toks, (rs, rf)) <- makeTokens df os - let ctf = getColorToFile df os - sch = getScheme df os - expDsc = getExprDesc df os - showExpr = getShowExpression os - verbFilt = getVerboseFilter os - pdct <- Ly.parsePredicate expDsc toks - let sf = Ly.xactionsToFiltered pdct postFilts sortSpec - return . Right $ FilterOpts rf rs sf sch - ctf expDsc pdct showExpr verbFilt - -makeMode - :: S.Runtime - -> FilterOpts - -> I.Report - -> MA.Mode (IO ()) -makeMode rt fo r = fmap makeIO mode - where - mode = snd (r rt) (foResultSensitive fo) (foResultFactory fo) - (fromMaybe Schemes.plainLabels . foTextSpecs $ fo) - (foExprDesc fo) (fmap snd (foSorterFilterer fo)) - makeIO parseResult = do - (posArgs, printRpt) <- - Ex.switch handleTextError return parseResult - (txns, pps) <- fmap splitLedger $ C.open posArgs - let term = if unColorToFile (foColorToFile fo) - then S.termFromEnv rt - else S.autoTerm rt - printer = R.printChunks term - verbFiltChunks = fst . foSorterFilterer fo $ txns - showFilterExpression printer (foShowExpression fo) (foPredicate fo) - showVerboseFilter printer (foVerboseFilter fo) verbFiltChunks - Ex.switch handleTextError (R.printChunks term) - $ printRpt txns pps - - -handleTextError :: Text -> IO a -handleTextError x = do - pn <- MA.getProgName - TIO.hPutStr IO.stderr $ (pack pn) <> ": error: " <> x - Exit.exitFailure - -indentAmt :: Pe.IndentAmt -indentAmt = 4 - -blankLine :: R.Chunk -blankLine = R.plain "\n" - -showFilterExpression - :: ([R.Chunk] -> IO ()) - -> ShowExpression - -> Pe.Pdct L.PostFam - -> IO () -showFilterExpression ptr (ShowExpression se) pdct = - if not se - then return () - else ptr $ info : blankLine : - (Pe.showPdct indentAmt 0 pdct ++ [blankLine]) - where - info = R.plain "Posting filter expression:\n" - -showVerboseFilter - :: ([R.Chunk] -> IO ()) - -> VerboseFilter - -> [R.Chunk] - -> IO () -showVerboseFilter ptr (VerboseFilter vb) cks = - if not vb - then return () - else ptr $ info : blankLine : (cks ++ [blankLine]) - where - info = R.plain "Filtering information:\n" - --- | Splits a Ledger into its Transactions and PricePoints. -splitLedger :: C.Ledger -> ([L.Transaction], [L.PricePoint]) -splitLedger = partitionEithers . mapMaybe toEither . C.unLedger - where - toEither i = case i of - C.Transaction t -> Just $ Left t - C.PricePoint p -> Just $ Right p - _ -> Nothing - -helpText - :: Defaults - -> S.Runtime - -> [I.Report] - -> String - -> String -helpText df rt pairMakers pn = - mappend (help df pn) . mconcat . map addHdr . fmap fst $ pairs - where - pairs = pairMakers <*> pure rt - addHdr s = hdr ++ s - hdr = unlines [ "", replicate 50 '=' ] - - ------------------------------------------------------------- --- ## Sorting ------------------------------------------------------------- - --- The monoid instance of Ordering takes the first non-EQ item. For --- example: --- --- mconcat [EQ, LT, GT] == LT. --- --- If b is a monoid, then (a -> b) is also a monoid. Therefore (a -> a --- -> Ordering) is also a monoid. So for example to compare the first --- element of a pair and then by the second element only if the first --- element is equal: --- --- mconcat [comparing fst, comparing snd] - -type Orderer = L.PostFam -> L.PostFam -> Ordering - -flipOrder :: (a -> a -> Ordering) -> (a -> a -> Ordering) -flipOrder f = f' where - f' p1 p2 = case f p1 p2 of - LT -> GT - GT -> LT - EQ -> EQ - -capitalizeFirstLetter :: String -> String -capitalizeFirstLetter s = case s of - [] -> [] - (x:xs) -> toUpper x : xs - -ordPairs :: [(String, Orderer)] -ordPairs = - [ ("payee", comparing Q.payee) - , ("date", comparing Q.dateTime) - , ("flag", comparing Q.flag) - , ("number", comparing Q.number) - , ("account", comparing Q.account) - , ("drCr", comparing Q.drCr) - , ("qty", comparing Q.qty) - , ("commodity", comparing Q.commodity) - , ("postingMemo", comparing Q.postingMemo) - , ("transactionMemo", comparing Q.transactionMemo) ] - -ords :: [(String, Orderer)] -ords = ordPairs ++ uppers ++ [none] where - uppers = map toReversed ordPairs - toReversed (s, f) = - (capitalizeFirstLetter s, flipOrder f) - none = ("none", const . const $ EQ) - - --- | True if the first argument matches the second argument. The match --- on the first letter is case sensitive; the match on the other --- letters is not case sensitive. True if both strings are empty. -argMatch :: String -> String -> Bool -argMatch s1 s2 = case (s1, s2) of - (x:xs, y:ys) -> - (x == y) && ((map toUpper xs) `isPrefixOf` (map toUpper ys)) - _ -> True - -sortSpecs :: MA.OptSpec (Ex.Exceptional Error Orderer) -sortSpecs = MA.OptSpec ["sort"] ['s'] (MA.OneArg f) - where - f a = - let matches = filter (\p -> a `argMatch` (fst p)) ords - in case matches of - x:[] -> return $ snd x - _ -> Ex.throw $ "bad sort specification: " <> pack a <> "\n" - - - ------------------------------------------------------------- --- ## Help ------------------------------------------------------------- - -help :: Defaults -> String -> String -help d pn = unlines $ - [ "usage: " ++ pn ++ " [posting filters] report [report options] file . . ." - , "" - , "Posting filters" - , "------------------------------------------" - , "" - , "Dates" - , "-----" - , "" - , "-d, --date cmp timespec" - , " Date must be within the time frame given. timespec" - , " is a day or a day and a time. Valid values for cmp:" - , " <, >, <=, >=, ==, /=, !=" - , "--current" - , " Same as \"--date <= (right now) \"" - , "" - , "Serials" - , "----------------" - , "These options take the form --option cmp num; the given" - , "sequence number must fall within the given range. \"rev\"" - , "in the option name indicates numbering is from end to beginning." - , "" - , "--globalTransaction, --revGlobalTransaction" - , " All transactions, after reading the ledger files" - , "--globalPosting, --revGlobalPosting" - , " All postings, after reading the leder files" - , "--fileTransaction, --revFileTransaction" - , " Transactions in each ledger file, after reading the files" - , " (numbering restarts with each file)" - , "--filePosting, --revFilePosting" - , " Postings in each ledger file, after reading the files" - , " (numbering restarts with each file)" - , "" - , "Pattern matching" - , "----------------" - , "" - , "-a pattern, --account pattern" - , " Pattern must match colon-separated account name" - , "--account-level num pat" - , " Pattern must match sub account at given level" - , "--account-any pat" - , " Pattern must match sub account at any level" - , "-p pattern, --payee pattern" - , " Payee must match pattern" - , "-t pattern, --tag pattern" - , " Tag must match pattern" - , "-n, --number pattern" - , " Number must match pattern" - , "-f, --flag pattern" - , " Flag must match pattern" - , "-y, --commodity pattern" - , " Pattern must match commodity name" - , "--posting-memo pattern" - , " Posting memo must match pattern" - , "--transaction-memo pattern" - , " Transaction memo must match pattern" - , "" - , "Other posting characteristics" - , "-----------------------------" - , "--debit" - , " Entry must be a debit" - , "--credit" - , " Entry must be a credit" - , "-q, --qty cmp number" - , " Entry quantity must fall within given range" - , "--filename pattern" - , " Filename of posting must match pattern" - , "" - , "Filtering based upon sibling postings" - , "-------------------------------------" - , "--s-globalPosting" - , "--s-revGlobalPosting" - , "--s-filePosting" - , "--s-revFilePosting" - , "--s-account" - , "--s-account-level" - , "--s-account-any" - , "--s-payee" - , "--s-tag" - , "--s-number" - , "--s-flag" - , "--s-commodity" - , "--s-posting-memo" - , "--s-debit" - , "--s-credit" - , "--s-qty" - , "" - , "Options affecting patterns" - , "--------------------------" - , "" - - , "-i, --case-insensitive" - , " Be case insensitive" - ++ ifDefault (sensitive d == M.Insensitive) - - , "-I, --case-sensitive" - , " Be case sensitive" - ++ ifDefault (sensitive d == M.Sensitive) - - , "" - - , "-w, --within" - , " Use \"within\" matcher" - ++ ifDefault (matcher d == Within) - - , "-r, --pcre" - , " Use \"pcre\" matcher" - ++ ifDefault (matcher d == PCRE) - - , "--posix" - , " Use \"posix\" matcher" - ++ ifDefault (matcher d == TDFA) - - , "-x, --exact" - , " Use \"exact\" matcher" - ++ ifDefault (matcher d == Exact) - , "" - , "Infix or RPN selection" - , "----------------------" - , "--infix - use infix notation" - ++ ifDefault (exprDesc d == X.Infix) - , "--rpn - use reverse polish notation" - ++ ifDefault (exprDesc d == X.RPN) - , "" - , "Infix Operators - from highest to lowest precedence" - , "(all are left associative)" - , "--------------------------" - , "--open expr --close" - , "-( expr -)" - , " Force precedence (as in \"open\" and \"close\" parentheses)" - , "--not, -N expr" - , " True if expr is false" - , "expr1 --and expr2" - , "expr -A expr2" - , " True if expr and expr2 are both true" - , "expr1 --or expr2" - , "expr1 -O expr2" - , " True if either expr1 or expr2 is true" - , "" - , "RPN Operators" - , "-------------" - , "--not, -N" - , "--and, -A" - , "--or, -O" - , " RPN counterparts to the infix operators" - , " are postfix and manipulate the RPN stack accordingly" - , "" - , "Showing expressions" - , "-------------------" - , "--show-expression" - , " Show the parsed filter expression" - , "--verbose-filter" - , " Verbosely show filtering results" - , "" - , "Removing postings after sorting and filtering" - , "---------------------------------------------" - , "--head n" - , " Keep only the first n postings" - , "--tail n" - , " Keep only the last n postings" - , "" - , "Sorting" - , "-------" - , "" - , "-s key, --sort key" - , " Sort postings according to key" - , "" - , "Keys:" - , " payee, date, flag, number, account, drCr," - , " qty, commodity, postingMemo, transactionMemo" - , "" - , " Ascending order by default; for descending order," - , " capitalize the name of the key." - , " (use \"none\" to leave postings in ledger file order)" - , "" - ] ++ descSortList (sorter d) ++ - [ "" - , "Colors" - , "------" - , "default scheme:" - , maybe " (none)" descScheme (defaultScheme d) - , "" - ] - ++ let schs = moreSchemes d - in (if not . null $ schs - then - [ "--scheme SCHEME_NAME" - , " use color scheme for report. Available schemes:" - ] ++ map descScheme schs - else []) - ++ - [ "" - , "--color-to-file no|yes" - , " Whether to use color when standard output is not a" - , " terminal (default: " ++ - if unColorToFile . colorToFile $ d then "yes)" else "no)" - , "" - , "Meta" - , "----" - , "--help, -h - show this help and exit" - , "--version - show version and exit" - ] - - -descScheme :: E.Scheme -> String -descScheme (E.Scheme n d _) = " " ++ n ++ " - " ++ d - --- | The string @ (default)@ if the condition is True; otherwise, --- nothing. -ifDefault :: Bool -> String -ifDefault b = if b then " (default)" else "" diff --git a/lib/Penny.hs b/lib/Penny.hs new file mode 100644 --- /dev/null +++ b/lib/Penny.hs @@ -0,0 +1,455 @@ +-- | Penny - extensible double-entry accounting system + +module Penny + ( -- * Building a custom Penny binary + + -- | Everything you need to create a custom Penny program is + -- available by importing only this module. + Version(..) + , Defaults(..) + , Z.Matcher(..) + + -- ** Color schemes + , E.Scheme(..) + , E.Changers + , E.Labels(..) + , E.EvenAndOdd(..) + , module System.Console.Rainbow + + -- ** Sorting + , Z.SortField(..) + , CabP.SortOrder(..) + + -- ** Expression type + , Exp.ExprDesc(..) + + -- ** Formatting quantities + , defaultQtyFormat + + -- ** Convert report options + , Target(..) + , CP.SortBy(..) + + -- ** Postings report options + , Fields(..) + , Spacers(..) + , widthFromRuntime + , Ps.yearMonthDay + , Ps.qtyAsIs + , Ps.balanceAsIs + + -- ** Runtime + , S.Runtime + , S.environment + + -- ** Text + , X.Text + , X.pack + + -- ** Main function + , runPenny + + -- * Developer overview + + -- | Penny is organized into a tree of modules, each with a + -- name. Check out the links for details on each component of + -- Penny. + -- + -- "Penny.Brenner" - Penny financial institution transaction + -- handling. Depends on Lincoln and Copper. + -- + -- "Penny.Cabin" - Penny reports. Depends on Lincoln and Liberty. + -- + -- "Penny.Copper" - the Penny parser. Depends on Lincoln. + -- + -- "Penny.Liberty" - Penny command line parser helpers. Depends on + -- Lincoln and Copper. + -- + -- "Penny.Lincoln" - the Penny core. Depends on no other Penny + -- components. + -- + -- "Penny.Shield" - the Penny runtime environment. Depends on + -- Lincoln. + -- + -- "Penny.Steel" - independent utilities. Depends on no other + -- Penny components. + -- + -- "Penny.Wheat" - tools to use with + -- "Penny.Steel.Prednote". Depends on Steel, Lincoln, and Copper. + -- + -- "Penny.Zinc" - the Penny command-line interface. Depends on + -- Cabin, Copper, Liberty, and Lincoln. + -- + -- The dependencies are represented as a dot file in + -- bin/doc/dependencies.dot in the Penny git repository. + ) where + +import qualified Data.Text as X +import Data.Version (Version(..)) +import qualified Penny.Cabin.Balance.Convert as Conv +import qualified Penny.Cabin.Balance.Convert.Parser as CP +import qualified Penny.Cabin.Balance.Convert.Options as ConvOpts +import qualified Penny.Cabin.Balance.MultiCommodity as MC +import qualified Penny.Cabin.Balance.MultiCommodity.Parser as MP +import System.Console.Rainbow +import qualified Penny.Cabin.Interface as I +import qualified Penny.Cabin.Options as CO +import qualified Penny.Cabin.Parsers as CabP +import qualified Penny.Cabin.Posts as Ps +import qualified Penny.Cabin.Posts.Fields as PF +import qualified Penny.Cabin.Posts.Spacers as PS +import qualified Penny.Cabin.Posts.Meta as M +import qualified Penny.Cabin.Scheme as E +import qualified Penny.Lincoln as L +import qualified Data.Prednote.Expressions as Exp +import qualified Penny.Zinc as Z +import qualified Penny.Shield as S +import qualified Text.Matchers as Mr + +-- | This type contains settings for all the reports, as well as +-- default settings for the global options. Some of these can be +-- overridden on the command line. +data Defaults = Defaults + { caseSensitive :: Bool + -- ^ Whether the matcher is case sensitive by default + + , matcher :: Z.Matcher + -- ^ Which matcher to use + + , colorToFile :: Bool + -- ^ Use colors when standard output is not a terminal? + + , expressionType :: Exp.ExprDesc + -- ^ Use RPN or infix expressions? This affects both the posting + -- filter and the filter for the Postings report. + + , defaultScheme :: Maybe E.Scheme + -- ^ Default color scheme. If Nothing, there is no default color + -- scheme. If there is no default color scheme and the user does + -- not pick one on the command line, no colors will be used. + + , additionalSchemes :: [E.Scheme] + -- ^ Additional color schemes the user can pick from on the + -- command line. + + , sorter :: [(Z.SortField, CabP.SortOrder)] + -- ^ Postings are sorted in this order by default. For example, if + -- the first pair is (Date, Ascending), then postings are first + -- sorted by date in ascending order. If the second pair is + -- (Payee, Ascending), then postings with the same date are then + -- sorted by payee. + -- + -- If this list is empty, then by default postings are left in the + -- same order as they appear in the ledger files. + + , balanceFormat :: L.Commodity -> L.Qty -> X.Text + -- ^ How to format balances in the balance report. Change this + -- function if, for example, you want to allow for digit grouping. + + , balanceShowZeroBalances :: Bool + -- ^ Show zero balances in the balance report? If True, show them; + -- if False, hide them. + + , balanceOrder :: CabP.SortOrder + -- ^ Whether to sort the accounts in ascending or descending order + -- by account name in the balance report. + + , convertShowZeroBalances :: Bool + -- ^ Show zero balances in the convert report? If True, show them; + -- if False, hide them. + + , convertTarget :: Target + -- ^ The commodity to which to convert the commodities in the + -- convert report. + + , convertOrder :: CabP.SortOrder + -- ^ Sort the convert report in ascending or descending order. + + , convertSortBy :: CP.SortBy + -- ^ Sort by account or by quantity in the convert report. + + , convertFormat :: L.Commodity -> L.Qty -> X.Text + -- ^ How to format balances in the convert report. For instance, + -- this function might perform digit grouping. + + , postingsFields :: Fields Bool + -- ^ Fields to show by default in the postings report. + + , postingsWidth :: Int + -- ^ The postings report is roughly this wide by + -- default. Typically this will be as wide as your terminal. + + , postingsShowZeroBalances :: Bool + -- ^ Show zero balances in the postings report? If True, show + -- them; if False, hide them. + + , postingsDateFormat :: (M.PostMeta, L.Posting) -> X.Text + -- ^ How to format dates in the postings report. + + , postingsQtyFormat :: (M.PostMeta, L.Posting) -> X.Text + -- ^ How to format quantities in the balance report. This function + -- is used when showing the quantity for the posting itself, and + -- not the quantity for the totals columns (for that, see + -- postingsBalanceFormat.) For example this function might perform + -- digit grouping. + + , postingsBalanceFormat :: L.Commodity -> L.Qty -> X.Text + -- ^ How to format balance totals in the postings report. + + , postingsSubAccountLength :: Int + -- ^ Account names in the postings report are shortened if + -- necessary in order to help the report fit within the allotted + -- width (see postingsWidth). Account names are only shortened as + -- much as is necessary for them to fit; however, each sub-account + -- name will not be shortened any more than the amount given here. + + , postingsPayeeAllocation :: Int + -- ^ postingsPayeeAllocation and postingsAccountAllocation + -- determine how much space is allotted to the payee and account + -- fields in the postings report. These fields are variable + -- width. After space for most other fields is allotted, space is + -- allotted for these two fields. The two fields divide the space + -- proportionally depending on postingsPayeeAllocation and + -- postingsAccountAllocation. For example, if + -- postingsPayeeAllocation is 60 and postingsAccountAllocation is + -- 40, then the payee field gets 60 percent of the leftover space + -- and the account field gets 40 percent of the leftover space. + -- + -- Both postingsPayeeAllocation and postingsAccountAllocation + -- must be positive integers; if either one is less than 1, your + -- program will crash at runtime. + + , postingsAccountAllocation :: Int + -- ^ See postingsPayeeAllocation above for an explanation + + , postingsSpacers :: Spacers Int + -- ^ Determines the number of spaces that appears to the right of + -- each named field; for example, sPayee indicates how many spaces + -- will appear to the right of the payee field. Each field of the + -- Spacers should be a non-negative integer (although currently + -- the absolute value of the field is taken.) + } + +-- | Creates an IO action that you can use for the main function. +runPenny + :: Version + -- ^ Version of the executable + -> (S.Runtime -> Defaults) + -- ^ runPenny will apply this function to the Runtime. This way + -- the defaults you use can vary depending on environment + -- variables, the terminal type, the date, etc. + -> IO () +runPenny ver getDefaults = do + rt <- S.runtime + let df = getDefaults rt + rs = allReports df + Z.runZinc ver (toZincDefaults df) rt rs + +-- | The commodity to which to convert the commodities in the convert +-- report. +data Target + = AutoTarget + -- ^ Selects a target commodity automatically, based on which + -- commodity is the most common target commodity in the prices in + -- your ledger files. If there is a tie for most common target + -- commodity, the target that appears later in your ledger files + -- is used. + | ManualTarget String + -- ^ Always uses the commodity named by the string given. + deriving Show + +-- | Gets the current screen width from the runtime. If the COLUMNS +-- environment variable is not set, uses 80. +widthFromRuntime :: S.Runtime -> Int +widthFromRuntime rt = case S.screenWidth rt of + Nothing -> 80 + Just sw -> S.unScreenWidth sw + +convTarget :: Target -> CP.Target +convTarget t = case t of + AutoTarget -> CP.AutoTarget + ManualTarget s -> CP.ManualTarget . L.To . L.Commodity . X.pack $ s + +allReports + :: Defaults + -> [I.Report] +allReports df = + let bd = toBalanceDefaults df + cd = toConvertDefaults df + pd = toPostingsDefaults df + in [ Ps.zincReport pd + , MC.parseReport (balanceFormat df) bd + , Conv.cmdLineReport cd + ] + +toZincDefaults :: Defaults -> Z.Defaults +toZincDefaults d = Z.Defaults + { Z.sensitive = + if caseSensitive d then Mr.Sensitive else Mr.Insensitive + , Z.matcher = matcher d + , Z.colorToFile = Z.ColorToFile . colorToFile $ d + , Z.defaultScheme = defaultScheme d + , Z.moreSchemes = additionalSchemes d + , Z.sorter = sorter d + , Z.exprDesc = expressionType d + } + +toBalanceDefaults :: Defaults -> MP.ParseOpts +toBalanceDefaults d = MP.ParseOpts + { MP.showZeroBalances = + CO.ShowZeroBalances . balanceShowZeroBalances $ d + , MP.order = balanceOrder d + } + +toConvertDefaults :: Defaults -> ConvOpts.DefaultOpts +toConvertDefaults d = ConvOpts.DefaultOpts + { ConvOpts.showZeroBalances = + CO.ShowZeroBalances . convertShowZeroBalances $ d + , ConvOpts.target = convTarget . convertTarget $ d + , ConvOpts.sortOrder = convertOrder d + , ConvOpts.sortBy = convertSortBy d + , ConvOpts.format = convertFormat d + } + +toPostingsDefaults :: Defaults -> Ps.ZincOpts +toPostingsDefaults d = Ps.ZincOpts + { Ps.fields = convFields . postingsFields $ d + , Ps.width = Ps.ReportWidth . postingsWidth $ d + , Ps.showZeroBalances = + CO.ShowZeroBalances . postingsShowZeroBalances $ d + , Ps.dateFormat = postingsDateFormat d + , Ps.qtyFormat = postingsQtyFormat d + , Ps.balanceFormat = postingsBalanceFormat d + , Ps.subAccountLength = + Ps.SubAccountLength . postingsSubAccountLength $ d + , Ps.payeeAllocation = + Ps.alloc . postingsPayeeAllocation $ d + , Ps.accountAllocation = + Ps.alloc . postingsAccountAllocation $ d + , Ps.spacers = convSpacers . postingsSpacers $ d + } + +defaultQtyFormat :: L.Qty -> X.Text +defaultQtyFormat = X.pack . L.prettyShowQty + +data Spacers a = Spacers + { sGlobalTransaction :: a + , sRevGlobalTransaction :: a + , sGlobalPosting :: a + , sRevGlobalPosting :: a + , sFileTransaction :: a + , sRevFileTransaction :: a + , sFilePosting :: a + , sRevFilePosting :: a + , sFiltered :: a + , sRevFiltered :: a + , sSorted :: a + , sRevSorted :: a + , sVisible :: a + , sRevVisible :: a + , sLineNum :: a + , sDate :: a + , sFlag :: a + , sNumber :: a + , sPayee :: a + , sAccount :: a + , sPostingDrCr :: a + , sPostingCmdty :: a + , sPostingQty :: a + , sTotalDrCr :: a + , sTotalCmdty :: a + } deriving (Show, Eq) + +data Fields a = Fields + { fGlobalTransaction :: a + , fRevGlobalTransaction :: a + , fGlobalPosting :: a + , fRevGlobalPosting :: a + , fFileTransaction :: a + , fRevFileTransaction :: a + , fFilePosting :: a + , fRevFilePosting :: a + , fFiltered :: a + , fRevFiltered :: a + , fSorted :: a + , fRevSorted :: a + , fVisible :: a + , fRevVisible :: a + , fLineNum :: a + , fDate :: a + , fFlag :: a + , fNumber :: a + , fPayee :: a + , fAccount :: a + , fPostingDrCr :: a + , fPostingCmdty :: a + , fPostingQty :: a + , fTotalDrCr :: a + , fTotalCmdty :: a + , fTotalQty :: a + , fTags :: a + , fMemo :: a + , fFilename :: a + } deriving (Show, Eq) + +convSpacers :: Spacers a -> PS.Spacers a +convSpacers s = PS.Spacers + { PS.globalTransaction = sGlobalTransaction s + , PS.revGlobalTransaction = sRevGlobalTransaction s + , PS.globalPosting = sGlobalPosting s + , PS.revGlobalPosting = sRevGlobalPosting s + , PS.fileTransaction = sFileTransaction s + , PS.revFileTransaction = sRevFileTransaction s + , PS.filePosting = sFilePosting s + , PS.revFilePosting = sRevFilePosting s + , PS.filtered = sFiltered s + , PS.revFiltered = sRevFiltered s + , PS.sorted = sSorted s + , PS.revSorted = sRevSorted s + , PS.visible = sVisible s + , PS.revVisible = sRevVisible s + , PS.lineNum = sLineNum s + , PS.date = sDate s + , PS.flag = sFlag s + , PS.number = sNumber s + , PS.payee = sPayee s + , PS.account = sAccount s + , PS.postingDrCr = sPostingDrCr s + , PS.postingCmdty = sPostingCmdty s + , PS.postingQty = sPostingQty s + , PS.totalDrCr = sTotalDrCr s + , PS.totalCmdty = sTotalCmdty s + } + +convFields :: Fields a -> PF.Fields a +convFields f = PF.Fields + { PF.globalTransaction = fGlobalTransaction f + , PF.revGlobalTransaction = fRevGlobalTransaction f + , PF.globalPosting = fGlobalPosting f + , PF.revGlobalPosting = fRevGlobalPosting f + , PF.fileTransaction = fFileTransaction f + , PF.revFileTransaction = fRevFileTransaction f + , PF.filePosting = fFilePosting f + , PF.revFilePosting = fRevFilePosting f + , PF.filtered = fFiltered f + , PF.revFiltered = fRevFiltered f + , PF.sorted = fSorted f + , PF.revSorted = fRevSorted f + , PF.visible = fVisible f + , PF.revVisible = fRevVisible f + , PF.lineNum = fLineNum f + , PF.date = fDate f + , PF.flag = fFlag f + , PF.number = fNumber f + , PF.payee = fPayee f + , PF.account = fAccount f + , PF.postingDrCr = fPostingDrCr f + , PF.postingCmdty = fPostingCmdty f + , PF.postingQty = fPostingQty f + , PF.totalDrCr = fTotalDrCr f + , PF.totalCmdty = fTotalCmdty f + , PF.totalQty = fTotalQty f + , PF.tags = fTags f + , PF.memo = fMemo f + , PF.filename = fFilename f + } diff --git a/lib/Penny/Brenner.hs b/lib/Penny/Brenner.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Brenner.hs @@ -0,0 +1,263 @@ +-- | Brenner - Penny financial institution interfaces +-- +-- Brenner provides a uniform way to interact with downloaded data +-- from financial Given a parser, Brenner will import the transactions +-- and store them in a database. From there it is easy to merge the +-- transactions (without duplicates) into a ledger file, and then to +-- clear transactions from statements in an automated fashion. +module Penny.Brenner + ( FitAcct(..) + , Config(..) + , R.GroupSpecs(..) + , R.GroupSpec(..) + , Y.Translator(..) + , L.Side(..) + , L.SpaceBetween(..) + , usePayeeOrDesc + , brennerMain + , ofxParser + ) where + +import qualified Penny.Brenner.Types as Y +import Control.Monad (join) +import Data.Either (partitionEithers) +import qualified Data.Text as X +import qualified Data.Version as V +import qualified Penny.Liberty as Ly +import qualified Penny.Lincoln as L +import qualified Penny.Lincoln.Builders as Bd +import qualified Penny.Copper.Render as R +import qualified Penny.Brenner.Clear as C +import qualified Penny.Brenner.Database as D +import qualified Penny.Brenner.Import as I +import qualified Penny.Brenner.Info as Info +import qualified Penny.Brenner.Merge as M +import qualified Penny.Brenner.OFX as O +import qualified Penny.Brenner.Print as P +import qualified Penny.Brenner.Util as U +import qualified System.Console.MultiArg as MA +import qualified Control.Monad.Exception.Synchronous as Ex + +-- | Brenner, with a pre-compiled configuration. +brennerMain + :: V.Version + -- ^ Binary version + -> Config + -> IO () +brennerMain v cf = do + let cf' = convertConfig cf + join $ MA.modesWithHelp (help False) (globalOpts v) + (preProcessor cf') + +-- | Parses global options for a pre-compiled configuration. +globalOpts + :: V.Version + -- ^ Binary version + -> [MA.OptSpec (Either (IO ()) Y.FitAcctName)] +globalOpts v = + [ MA.OptSpec ["fit-account"] "f" + (MA.OneArg (Right . Y.FitAcctName . X.pack)) + , fmap Left (Ly.version v) + ] + +-- | Pre-processes global options for a pre-compiled configuration. +preProcessor + :: Y.Config + -> [Either (IO ()) Y.FitAcctName] + -> Either (a -> IO ()) [MA.Mode (IO ())] +preProcessor cf args = + let (vers, as) = partitionEithers args + in case vers of + [] -> makeModes Nothing cf as + x:_ -> Left (const x) + +-- | Makes modes for a pre-compiled configuration. +makeModes + :: Maybe Y.ConfigLocation + -> Y.Config + -> [Y.FitAcctName] + -- ^ Names of financial institutions given on command line + -> Either (a -> IO ()) [MA.Mode (IO ())] +makeModes cl cf as = Ex.toEither . Ex.mapException (const . U.errExit) $ do + mayFi <- case as of + [] -> return $ Y.defaultFitAcct cf + _ -> + let pdct a = Y.fitAcctName a == s + s = last as + toFilter = case Y.defaultFitAcct cf of + Nothing -> Y.moreFitAccts cf + Just d -> d : Y.moreFitAccts cf + in case filter pdct toFilter of + [] -> Ex.throw $ + "financial institution account " + ++ (X.unpack . Y.unFitAcctName $ s) ++ " not configured." + c:[] -> return $ Just c + _ -> Ex.throw $ + "more than one financial institution account " + ++ "named " ++ (X.unpack . Y.unFitAcctName $ s) + ++ " configured." + return . map (fmap (\f -> f cl cf mayFi)) $ allModes + +-- | Each mode takes a Maybe FitAcct. Even if every mode needs a +-- FitAcct to function, they take a Maybe FitAcct because otherwise +-- the user will not even get online help if a FitAcct is not +-- supplied. Each mode must fail on its own if it actually needs a +-- FitAcct. +type ModeFunc + = Maybe Y.ConfigLocation + -> Y.Config + -> Maybe Y.FitAcct + -> IO () + +allModes :: [MA.Mode ModeFunc] +allModes = + fmap (\f cl cf _ -> f cl cf) Info.mode + : map (fmap (const . const)) + [C.mode, I.mode, M.mode, P.mode, D.mode] + +-- | Help for a pre-compiled configuration. +help + :: Bool + -- ^ True if running under a dynamic configuration + -> String + -- ^ Program name + + -> String +help dyn n = unlines ls + where + ls = [ "usage: " ++ n ++ " [global-options]" + ++ " COMMAND [local-options]" + ++ " ARGS..." + , "" + , "where COMMAND is one of:" + , "import, merge, clear, database, print, info" + , "" + , "For help on an individual command and its" + ++ " local options, use " + , n ++ " COMMAND --help" + , "" + , "Global Options:" + , "-f, --fit-account ACCOUNT" + , " use the given financial institution account" + , " (use the \"info\" command to see which are available)." + , " If this option does not appear," + , " the default account is used if there is one." + ] ++ if not dyn then [] else + [ "" + , "-c, --config-file FILENAME" + , " Specify configuration file location" + ] + +-- | Information to configure a single financial institution account. +data FitAcct = FitAcct + { fitAcctName :: String + -- ^ Name for this financial institution account, e.g. @House + -- Checking@ or @Megabank@. + + , fitAcctDesc :: String + -- ^ Additional information about this financial institution + -- account. Here I put information on where to find the statments + -- for download on the website. + + , dbLocation :: String + -- ^ Path and filename to where the database is kept. You can use + -- an absolute or relative path (if it is relative, it will be + -- resolved relative to the current directory at runtime.) + + , pennyAcct :: String + -- ^ The account that you use in your Penny file to hold + -- transactions for this card. Separate each sub-account with + -- colons (as you do in the Penny file.) + + , defaultAcct :: String + -- ^ When new transactions are created, one of the postings will + -- be in the amexAcct given above. The other posting will be in + -- this account. + + , currency :: String + -- ^ The commodity for the currency of your card (e.g. @$@). + + , groupSpecs :: R.GroupSpecs + -- ^ How to group digits when printing the resulting ledger. All + -- quantities (not just those affected by this program) will be + -- formatted using this specification. + + , translator :: Y.Translator + -- ^ See the documentation under the 'Translator' type for + -- details. + + , side :: L.Side + -- ^ When creating new transactions, the commodity will be on this + -- side + + , spaceBetween :: L.SpaceBetween + -- ^ When creating new transactions, is there a space between the + -- commodity and the quantity + + , parser :: ( Y.ParserDesc + , Y.FitFileLocation -> IO (Ex.Exceptional String [Y.Posting])) + -- ^ Parses a file of transactions from the financial + -- institution. The function must open the file and parse it. This + -- is in the IO monad not only because the function must open the + -- file itself, but also so the function can perform arbitrary IO + -- (run pdftotext, maybe?) If there is failure, the function can + -- return an Exceptional String, which is the error + -- message. Alternatively the function can raise an exception in the + -- IO monad (currently Brenner makes no attempt to catch these) so + -- if any of the IO functions throw you can simply not handle the + -- exceptions. + -- + -- The first element of the pair is a help string which should + -- indicate how to download the data, as a helpful reminder. + + , toLincolnPayee :: Y.Desc -> Y.Payee -> L.Payee + -- ^ Sometimes the financial institution provides Payee information, + -- sometimes it does not. Sometimes the Desc might have additional + -- information that you might want to remove. This function can be + -- used to do that. The resulting Lincoln Payee is used for any + -- transactions that are created by the merge command. The resulting + -- payee is also used when comparing new financial institution + -- postings to already existing ledger transactions in order to + -- guess at which payee and accounts to create in the transactions + -- created by the merge command. + + + } deriving Show + +convertFitAcct :: FitAcct -> Y.FitAcct +convertFitAcct (FitAcct fn fd db ax df cy gs tl sd sb ps tlp) = Y.FitAcct + { Y.fitAcctName = Y.FitAcctName . X.pack $ fn + , Y.fitAcctDesc = Y.FitAcctDesc . X.pack $ fd + , Y.dbLocation = Y.DbLocation . X.pack $ db + , Y.pennyAcct = Y.PennyAcct . Bd.account . X.pack $ ax + , Y.defaultAcct = Y.DefaultAcct . Bd.account . X.pack $ df + , Y.currency = Y.Currency . L.Commodity . X.pack $ cy + , Y.groupSpecs = gs + , Y.translator = tl + , Y.side = sd + , Y.spaceBetween = sb + , Y.parser = ps + , Y.toLincolnPayee = tlp + } + +data Config = Config + { defaultFitAcct :: Maybe FitAcct + , moreFitAccts :: [FitAcct] + } deriving Show + +convertConfig :: Config -> Y.Config +convertConfig (Config d m) = Y.Config + { Y.defaultFitAcct = fmap convertFitAcct d + , Y.moreFitAccts = map convertFitAcct m + } + +-- | A simple function to use for 'toLincolnPayee'. Uses the financial +-- institution payee if it is available; otherwise, uses the financial +-- institution description. +usePayeeOrDesc :: Y.Desc -> Y.Payee -> L.Payee +usePayeeOrDesc (Y.Desc d) (Y.Payee p) = L.Payee $ + if X.null p then d else p + +-- | Parser for OFX data. +ofxParser :: (Y.ParserDesc, Y.ParserFn) +ofxParser = O.parser diff --git a/lib/Penny/Brenner/Clear.hs b/lib/Penny/Brenner/Clear.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Brenner/Clear.hs @@ -0,0 +1,185 @@ +module Penny.Brenner.Clear (mode) where + +import Control.Applicative +import qualified Control.Monad.Exception.Synchronous as Ex +import Control.Monad (guard, mzero, when) +import Data.Maybe (mapMaybe, fromMaybe) +import Data.Monoid (mconcat, First(..)) +import qualified Data.Set as Set +import qualified Data.Map as M +import qualified Data.Text as X +import qualified Data.Traversable as Tr +import qualified System.Console.MultiArg as MA +import qualified Penny.Lincoln as L +import qualified Penny.Liberty as Ly +import qualified Penny.Steel.Sums as S +import qualified Control.Monad.Trans.State as St +import qualified Control.Monad.Trans.Maybe as MT +import Control.Monad.Trans.Class (lift) +import qualified Penny.Copper as C +import qualified Penny.Copper.Render as R +import Text.Show.Pretty (ppShow) +import qualified Penny.Brenner.Types as Y +import qualified Penny.Brenner.Util as U + + +help :: String -> String +help pn = unlines + [ "usage: " ++ pn ++ " clear [options] FIT_FILE LEDGER_FILE..." + , "Parses all postings that are in FIT_FILE. Then marks all" + , "postings that are in the FILEs given that correspond to one" + , "of the postings in the FIT_FILE as being cleared." + , "Quits if one of the postings found in FIT_FILE is not found" + , "in the database, if one of the postings in the database" + , "is not found in one of the FILEs, or if any of the postings found" + , "in one of the FILEs already has a flag." + , "" + , "Results are printed to standard output. If no FILE, or FILE is \"-\"," + , "read standard input." + , "" + , "Options:" + , " -o, --output FILENAME - send output to FILENAME" + , " (default: send to standard output)" + , " -h, --help - show help and exit" + ] + +data Arg + = APosArg String + | AOutput (X.Text -> IO ()) + +toPosArg :: Arg -> Maybe String +toPosArg a = case a of { APosArg s -> Just s; _ -> Nothing } + +toOutput :: Arg -> Maybe (X.Text -> IO ()) +toOutput a = case a of { AOutput x -> Just x; _ -> Nothing } + +data Opts = Opts + { csvLocation :: Y.FitFileLocation + , ledgerLocations :: [String] + , printer :: X.Text -> IO () + } deriving Show + + +mode :: MA.Mode (Maybe Y.FitAcct -> IO ()) +mode = MA.Mode + { MA.mName = "clear" + , MA.mIntersperse = MA.Intersperse + , MA.mOpts = [fmap AOutput Ly.output] + , MA.mPosArgs = return . APosArg + , MA.mProcess = process + , MA.mHelp = help + } + +process :: [Arg] -> Maybe Y.FitAcct -> IO () +process as mayFa = do + fa <- U.getFitAcct mayFa + (csv, ls) <- case mapMaybe toPosArg as of + [] -> fail "clear: you must provide a postings file." + x:xs -> return (Y.FitFileLocation x, xs) + let os = Opts csv ls (Ly.processOutput . mapMaybe toOutput $ as) + runClear fa os + +runClear :: Y.FitAcct -> Opts -> IO () +runClear c os = do + dbList <- U.loadDb (Y.AllowNew False) (Y.dbLocation c) + let db = M.fromList dbList + (_, prsr) = Y.parser c + txns <- fmap (Ex.switch fail return) $ prsr (csvLocation os) + leds <- C.open (ledgerLocations os) + toClear <- case mapM (findUNumber db) (concat txns) of + Nothing -> fail $ "at least one posting was not found in the" + ++ " database. Ensure all postings have " + ++ "been imported and merged." + Just ls -> return $ Set.fromList ls + let (led', left) = changeLedger (Y.pennyAcct c) toClear leds + led'' = map C.stripMeta led' + when (not (Set.null left)) + (fail $ "some postings were not cleared. " + ++ "Those not cleared:\n" ++ ppShow left) + case mapM (R.item (Y.groupSpecs c)) led'' of + Nothing -> + fail "could not render resulting ledger." + Just txts -> + let glued = X.concat txts + in glued `seq` printer os glued + + +-- | Examines an financial institution transaction and the DbMap to +-- find a matching UNumber. Fails if the financial institution +-- transaction is not in the Db. +findUNumber :: Y.DbMap -> Y.Posting -> Maybe Y.UNumber +findUNumber m pstg = + let atn = Y.fitId pstg + p ap = Y.fitId ap == atn + filteredMap = M.filter p m + ls = M.toList filteredMap + in case ls of + (n, _):[] -> Just n + _ -> Nothing + + +clearedFlag :: L.Flag +clearedFlag = L.Flag . X.singleton $ 'C' + +-- | Changes a ledger to clear postings. Returns postings still not +-- cleared. +changeLedger + :: Y.PennyAcct + -> Set.Set Y.UNumber + -> [C.LedgerItem] + -> ([C.LedgerItem], Set.Set Y.UNumber) +changeLedger ax s l = St.runState k s + where + k = mapM f l + f x = case x of + S.S4a t -> fmap S.S4a $ changeTxn ax t + S.S4b z -> fmap S.S4b $ return z + S.S4c z -> fmap S.S4c $ return z + S.S4d z -> fmap S.S4d $ return z + +changeTxn + :: Y.PennyAcct + -> L.Transaction + -> St.State (Set.Set Y.UNumber) L.Transaction +changeTxn ax (L.Transaction (tld, d)) = + (\tl es -> L.Transaction (tl, es)) + <$> pure tld + <*> Tr.mapM (changePstg ax) d + + +-- | Sees if this posting is a posting in the right account and has a +-- UNumber that needs to be cleared. If so, clears it. If this posting +-- already has a flag, skips it. +changePstg + :: Y.PennyAcct + -> L.PostingData + -> St.State (Set.Set Y.UNumber) L.PostingData +changePstg ax p = + fmap (fromMaybe p) . MT.runMaybeT $ do + let c = L.pdCore p + guard (L.pAccount c == (Y.unPennyAcct ax)) + let tags = L.pTags c + un <- maybe mzero return $ parseUNumberFromTags tags + guard (L.pFlag c == Nothing) + set <- lift St.get + guard (Set.member un set) + lift $ St.put (Set.delete un set) + let c' = c { L.pFlag = Just clearedFlag } + return $ p { L.pdCore = c' } + +parseUNumberFromTags :: L.Tags -> Maybe Y.UNumber +parseUNumberFromTags = + getFirst + . mconcat + . map First + . map parseUNumberFromTag + . L.unTags + +parseUNumberFromTag :: L.Tag -> Maybe Y.UNumber +parseUNumberFromTag (L.Tag x) = do + (f, xs) <- X.uncons x + guard (f == 'U') + case reads . X.unpack $ xs of + (u, ""):[] -> Just (Y.UNumber u) + _ -> Nothing + diff --git a/lib/Penny/Brenner/Database.hs b/lib/Penny/Brenner/Database.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Brenner/Database.hs @@ -0,0 +1,41 @@ +module Penny.Brenner.Database (mode) where + +import qualified Penny.Brenner.Types as Y +import qualified Penny.Brenner.Util as U +import qualified System.Console.MultiArg as MA + +help :: String -> String +help pn = unlines + [ "usage: " ++ pn ++ " [global-options] database [local-options]" + , "Shows the database of financial institution transactions." + , "Does not accept any non-option arguments." + , "" + , "Local options:" + , " --help, -h Show this help and exit." + ] + +data Arg = ArgPos String + +mode :: MA.Mode (Maybe Y.FitAcct -> IO ()) +mode = MA.Mode + { MA.mName = "database" + , MA.mIntersperse = MA.Intersperse + , MA.mOpts = [] + , MA.mPosArgs = return . ArgPos + , MA.mProcess = processor + , MA.mHelp = help + } + +processor + :: [Arg] + -> Maybe Y.FitAcct + -> IO () +processor ls mayFa + | not . null $ ls = fail $ + "penny-fit database: error: this command does" + ++ " not accept non-option arguments." + | otherwise = do + fa <- U.getFitAcct mayFa + let dbLoc = Y.dbLocation fa + db <- U.loadDb (Y.AllowNew False) dbLoc + mapM_ putStr . map U.showDbPair $ db diff --git a/lib/Penny/Brenner/Import.hs b/lib/Penny/Brenner/Import.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Brenner/Import.hs @@ -0,0 +1,140 @@ +module Penny.Brenner.Import (mode) where + +import Control.Applicative ((<|>)) +import qualified Control.Monad.Exception.Synchronous as Ex +import Data.Maybe (mapMaybe) +import qualified System.Console.MultiArg as MA +import qualified Penny.Brenner.Types as Y +import qualified Penny.Brenner.Util as U + +data Arg + = AFitFile String + | AAllowNew + | AUNumber Integer + +toFitFile :: Arg -> Maybe String +toFitFile a = case a of + AFitFile s -> Just s + _ -> Nothing + +toNewUNumber :: [Arg] -> Maybe Integer +toNewUNumber as = + let f i = case i of { AUNumber x -> Just x; _ -> Nothing } + in case mapMaybe f as of + [] -> Nothing + xs -> Just $ last xs + +data ImportOpts = ImportOpts + { fitFile :: Y.FitFileLocation + , allowNew :: Y.AllowNew + , parser :: Y.FitFileLocation + -> IO (Ex.Exceptional String [Y.Posting]) + , newUNumber :: Maybe Integer + } + +mode + :: MA.Mode (Maybe Y.FitAcct -> IO ()) +mode = MA.Mode + { MA.mName = "import" + , MA.mIntersperse = MA.Intersperse + , MA.mOpts = + [ MA.OptSpec ["new"] "n" (MA.NoArg AAllowNew) + , MA.OptSpec ["unumber"] "u" . MA.OneArgE $ \s -> do + i <- MA.reader s + return $ AUNumber i + ] + , MA.mPosArgs = return . AFitFile + , MA.mProcess = processor + , MA.mHelp = help + } + +processor + :: [Arg] + -> Maybe Y.FitAcct + -> IO () +processor as mayFa = do + fa <- U.getFitAcct mayFa + let (dbLoc, prsr) = (Y.dbLocation fa, snd . Y.parser $ fa) + loc <- case mapMaybe toFitFile as of + [] -> fail "you must provide a postings file to read" + x:[] -> return (Y.FitFileLocation x) + _ -> fail "you cannot provide more than one postings file to read" + let aNew = Y.AllowNew + $ any (\a -> case a of { AAllowNew -> True; _ -> False }) as + maybeNewU = toNewUNumber as + doImport dbLoc (ImportOpts loc aNew prsr maybeNewU) + + +-- | Appends new Amex transactions to the existing list. +appendNew + :: Maybe Integer + -- ^ If Just, this is the new U-number for the first + -- transaction. Otherwise, the next U number will be the one that is + -- one larger than the current maximum in the database. + + -> [(Y.UNumber, Y.Posting)] + -- ^ Existing transactions + + -> [Y.Posting] + -- ^ New transactions + + -> Maybe ([(Y.UNumber, Y.Posting)], Int) + -- ^ New list, and number of transactions added. Fails if the new U + -- number was passed in the first argument and this number is not + -- valid. + +appendNew mu db new = + let currFitIds = map (Y.fitId . snd) db + isNew p = not (any (== Y.fitId p) currFitIds) + newPstgs = filter isNew new + mkPair i p = (Y.UNumber i, p) + maybeU = nextUNum mu db + in fmap (\u -> let newWithU = (zipWith mkPair [u..] newPstgs) + in (db ++ newWithU, length newWithU)) maybeU + +nextUNum + :: Maybe Integer + -> [(Y.UNumber, Y.Posting)] + -> Maybe Integer +nextUNum mu db = + let defaultU = if null db then Nothing + else Just $ ( Y.unUNumber . maximum + . map fst $ db) + 1 + in case mu of + Nothing -> defaultU <|> Just 0 + Just u -> case defaultU of + Nothing -> if u >= 0 then Just u else Nothing + Just du -> if u >= du then Just u else Nothing + +doImport :: Y.DbLocation -> ImportOpts -> IO () +doImport dbLoc os = do + txnsOld <- U.loadDb (allowNew os) dbLoc + parseResult <- parser os (fitFile os) + ins <- case parseResult of + Ex.Exception e -> fail e + Ex.Success g -> return g + (new, len) <- case appendNew (newUNumber os) txnsOld ins of + Just r -> return r + Nothing -> fail "invalid new U number given." + U.saveDb dbLoc new + putStrLn $ "imported " ++ show len ++ " new transactions." + +help :: String -> String +help pn = unlines + [ "usage: " ++ pn ++ " [global-options] import [local-options] FIT_FILE" + , "where FIT_FILE is the file downloaded from the financial" + , "institution." + , "" + , "Local Options:" + , "" + , "-n, --new - Allows creation of new database. Without this option," + , "if the database file is not found, quits with an error." + , "" + , "-u, --unumber - The first U number assigned will be this number." + , "Fails if the number you give is not greater than the largest" + , "U number already in the database." + , "" + , "-h, --help - Show this help." + , "" + ] + diff --git a/lib/Penny/Brenner/Info.hs b/lib/Penny/Brenner/Info.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Brenner/Info.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE OverloadedStrings #-} +module Penny.Brenner.Info (mode) where + +import qualified Control.Monad.Exception.Synchronous as Ex +import qualified Penny.Brenner.Types as Y +import qualified Data.Text as X +import qualified Data.Text.IO as TIO +import Data.Monoid ((<>)) +import qualified Penny.Lincoln as L +import qualified Penny.Copper.Render as R +import qualified System.Console.MultiArg as MA + +help :: String -> String +help pn = unlines + [ "usage: " ++ pn ++ " info [options]" + , "Shows further information about the configuration of your" + , "financial institution accounts." + , "" + , "Options:" + , " -h, --help - show help and exit" + ] + +mode :: MA.Mode (Maybe Y.ConfigLocation -> Y.Config -> IO ()) +mode = MA.Mode + { MA.mName = "info" + , MA.mIntersperse = MA.Intersperse + , MA.mOpts = [] + , MA.mPosArgs = const . Ex.throw . MA.ErrorMsg + $ "this mode does not accept positional arguments" + , MA.mProcess = const process + , MA.mHelp = help + } + +process :: Maybe Y.ConfigLocation -> Y.Config -> IO () +process cf cn = TIO.putStr $ showInfo cf cn + +showInfo :: Maybe Y.ConfigLocation -> Y.Config -> X.Text +showInfo cf cn = + maybe "These settings are compiled into your program.\n\n" + (\l -> label "From configuration file at" (L.text l) <> "\n\n") + cf + <> showConfig cn + +showConfig :: Y.Config -> X.Text +showConfig (Y.Config dflt more) = + "Default financial institution account:" + <> case dflt of + Nothing -> " (no default)\n\n" + Just d -> "\n\n" <> showFitAcct d <> "\n" + <> "Additional financial institution accounts:" + <> case more of + [] -> " no additional accounts\n" + ls -> "\n\n" <> showFitAccts ls + +sepBar :: X.Text +sepBar = X.replicate 40 "=" <> "\n" + +sepWithSpace :: X.Text +sepWithSpace = "\n" <> sepBar <> "\n" + +showFitAccts :: [Y.FitAcct] -> X.Text +showFitAccts = X.intercalate sepWithSpace . map showFitAcct + +label :: X.Text -> X.Text -> X.Text +label l t = l <> ": " <> t + +showFitAcct :: Y.FitAcct -> X.Text +showFitAcct c = + (L.text . Y.fitAcctName $ c) <> "\n\n" + <> (L.text . Y.fitAcctDesc $ c) <> "\n" + <> X.unlines + [ label "Database location" (L.text . Y.dbLocation $ c) + , label "Penny account" (L.text . L.Delimited ":" . Y.pennyAcct $ c) + , label "Default account" (L.text . L.Delimited ":" . Y.defaultAcct $ c) + , label "Currency" (L.text . Y.currency $ c) + , label "Group amounts to left of decimal point" + (showGroupLeft . R.left . Y.groupSpecs $ c) + + , label "Group amounts to right of decimal point" + (showGroupRight . R.right . Y.groupSpecs $ c) + + , label "Financial institution increases are" + (showTranslator . Y.translator $ c) + + , label "In new postings, commodity is on the" + (showSide . Y.side $ c) + + , label "Space between commodity and quantity in new postings" + (showSpaceBetween . Y.spaceBetween $ c) + ] + <> "Parser description:\n" + <> (L.text . fst . Y.parser $ c) + +showGroupLeft :: R.GroupSpec -> X.Text +showGroupLeft s = case s of + R.NoGrouping -> "never" + R.GroupLarge -> "when greater than 9,999" + R.GroupAll -> "always" + +showGroupRight :: R.GroupSpec -> X.Text +showGroupRight s = case s of + R.NoGrouping -> "never" + R.GroupLarge -> "when mor than four decimal places" + R.GroupAll -> "always" + +showTranslator :: Y.Translator -> X.Text +showTranslator y = case y of + Y.IncreaseIsDebit -> "debits" + Y.IncreaseIsCredit -> "credits" + +showSide :: L.Side -> X.Text +showSide L.CommodityOnLeft = "left" +showSide L.CommodityOnRight = "right" + +showSpaceBetween :: L.SpaceBetween -> X.Text +showSpaceBetween L.SpaceBetween = "yes" +showSpaceBetween L.NoSpaceBetween = "no" + +{- + label "Database location" + (X.unpack . Y.unDbLocation . Y.dbLocation $ c) + + ++ label "Penny account" + (showAccount . Y.unPennyAcct . Y.pennyAcct $ c) + + ++ label "Account for new offsetting postings" + (showAccount . Y.unDefaultAcct . Y.defaultAcct $ c) + + ++ label "Currency" + (X.unpack . L.unCommodity . Y.unCurrency . Y.currency $ c) + + ++ "\n" + + ++ "More information about the parser:\n" + ++ (Y.unParserDesc . fst . Y.parser $ c) + ++ "\n\n" + + +-} diff --git a/lib/Penny/Brenner/Merge.hs b/lib/Penny/Brenner/Merge.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Brenner/Merge.hs @@ -0,0 +1,360 @@ +module Penny.Brenner.Merge (mode) where + +import Control.Applicative +import Control.Monad (guard) +import qualified Control.Monad.Trans.State as St +import Data.List (find, sortBy, foldl') +import qualified Data.Map as M +import Data.Maybe (mapMaybe, isNothing, fromMaybe) +import Data.Monoid (First(..), mconcat) +import qualified Data.Text as X +import qualified System.Console.MultiArg as MA +import qualified Penny.Copper as C +import qualified Penny.Copper.Render as R +import qualified Penny.Lincoln as L +import qualified Penny.Liberty as Ly +import qualified Penny.Lincoln.Queries as Q +import qualified Penny.Brenner.Types as Y +import qualified Penny.Brenner.Util as U +import qualified Penny.Steel.Sums as S + +type NoAuto = Bool + +data Arg + = APos String + | ANoAuto + | AOutput (X.Text -> IO ()) + +instance Eq Arg where + APos l == APos r = l == r + ANoAuto == ANoAuto = True + _ == _ = False + +toPosArg :: Arg -> Maybe String +toPosArg a = case a of { APos s -> Just s; _ -> Nothing } + +toOutput :: Arg -> Maybe (X.Text -> IO ()) +toOutput a = case a of { AOutput x -> Just x; _ -> Nothing } + +mode :: MA.Mode (Maybe Y.FitAcct -> IO ()) +mode = MA.Mode + { MA.mName = "merge" + , MA.mIntersperse = MA.Intersperse + , MA.mOpts = [ MA.OptSpec ["no-auto"] "n" (MA.NoArg ANoAuto) + , fmap AOutput Ly.output + ] + , MA.mPosArgs = return . APos + , MA.mProcess = processor + , MA.mHelp = help + } + +processor :: [Arg] -> Maybe Y.FitAcct -> IO () +processor as mayFa = do + fa <- U.getFitAcct mayFa + doMerge fa + (ANoAuto `elem` as) + (Ly.processOutput . mapMaybe toOutput $ as) + (mapMaybe toPosArg as) + +doMerge + :: Y.FitAcct + -> NoAuto + -> (X.Text -> IO ()) + -- ^ Function to handle the output + -> [String] + -- ^ Ledger filenames to open + -> IO () +doMerge acct noAuto printer ss = do + dbLs <- U.loadDb (Y.AllowNew False) (Y.dbLocation acct) + l <- C.open ss + let dbWithEntry = fmap (pairWithEntry acct) . M.fromList $ dbLs + (l', db') = changeItems acct + l (filterDb (Y.pennyAcct acct) dbWithEntry l) + newTxns = createTransactions noAuto acct l dbLs db' + final = l' ++ newTxns + case mapM (R.item (Y.groupSpecs acct)) (map C.stripMeta final) of + Nothing -> fail "Could not render final ledger." + Just txts -> + let txt = X.concat txts + in txt `seq` printer txt + + +help :: String -> String +help pn = unlines + [ "usage: " ++ pn ++ " merge: merges new transactions from database" + , "to ledger file." + , "usage: penny-fit merge [options] FILE..." + , "Results are printed to standard output. If no FILE, or if FILE is -," + , "read standard input." + , "" + , "Options:" + , " -n, --no-auto - do not automatically assign payees and accounts" + , " -o, --output FILENAME - send output to FILENAME" + , " (default: send to standard output)" + , " -h, --help - show help and exit" + ] + +-- | Removes all Brenner postings that already have a Penny posting +-- with the correct uNumber. +filterDb :: Y.PennyAcct -> DbWithEntry -> [C.LedgerItem] -> DbWithEntry +filterDb ax m l = M.difference m ml + where + ml = M.fromList + . flip zip (repeat ()) + . mapMaybe toUNum + . filter inPennyAcct + . concatMap L.transactionToPostings + . ( let cn = const Nothing + in mapMaybe (S.caseS4 Just cn cn cn)) + $ l + inPennyAcct p = Q.account p == (Y.unPennyAcct ax) + toUNum p = getUNumberFromTags . Q.tags $ p + +-- | Gets the first UNumber from a list of Tags. +getUNumberFromTags :: L.Tags -> Maybe Y.UNumber +getUNumberFromTags = + getFirst + . mconcat + . map First + . map getUNumberFromTag + . L.unTags + +-- | Examines a tag to see if it is a uNumber. If so, returns the +-- UNumber. Otherwise, returns Nothing. +getUNumberFromTag :: L.Tag -> Maybe Y.UNumber +getUNumberFromTag (L.Tag x) = do + (f, r) <- X.uncons x + guard (f == 'U') + case reads . X.unpack $ r of + (y, ""):[] -> return $ Y.UNumber y + _ -> Nothing + + +-- | Changes a single Item. +changeItem + :: Y.FitAcct + -> C.LedgerItem + -> St.State DbWithEntry C.LedgerItem +changeItem acct = + S.caseS4 (fmap S.S4a . changeTransaction acct) + (return . S.S4b) (return . S.S4c) (return . S.S4d) + + +-- | Changes all postings that match an AmexTxn to assign them the +-- proper UNumber. Returns a list of changed items, and the DbMap of +-- still-unassigned AmexTxns. +changeItems + :: Y.FitAcct + -> [C.LedgerItem] + -> DbWithEntry + -> ([C.LedgerItem], DbWithEntry) +changeItems acct l = St.runState (mapM (changeItem acct) l) + + +changeTransaction + :: Y.FitAcct + -> L.Transaction + -> St.State DbWithEntry L.Transaction +changeTransaction acct txn = + (\tl es -> L.Transaction (tl, es)) + <$> pure (fst . L.unTransaction $ txn) + <*> L.traverseEnts (inspectAndChange acct + (fst . L.unTransaction $ txn)) + (snd . L.unTransaction $ txn) + +-- | Inspects a posting to see if it is an Amex posting and, if so, +-- whether it matches one of the remaining AmexTxns. If so, then +-- changes the transaction's UNumber, and remove that UNumber from the +-- DbMap. If the posting alreay has a Number (UNumber or otherwise) +-- skips it. +inspectAndChange + :: Y.FitAcct + -> L.TopLineData + -> L.Ent L.PostingData + -> St.State DbWithEntry L.PostingData +inspectAndChange acct tld p = do + m <- St.get + case findMatch acct tld p m of + Nothing -> return (L.meta p) + Just (n, m') -> + let c = L.pdCore . L.meta $ p + L.Tags oldTags = L.pTags c + tags' = L.Tags (oldTags ++ [newLincolnUNumber n]) + c' = c { L.pTags = tags' } + p' = (L.meta p) { L.pdCore = c' } + in St.put m' >> return p' + +newLincolnUNumber :: Y.UNumber -> L.Tag +newLincolnUNumber a = + L.Tag ('U' `X.cons` (X.pack . show . Y.unUNumber $ a)) + + +-- | Searches a DbMap for an AmexTxn that matches a given posting. If +-- a match is found, returns the matching UNumber and a new DbMap that +-- has the match removed. +findMatch + :: Y.FitAcct + -> L.TopLineData + -> L.Ent L.PostingData + -> DbWithEntry + -> Maybe (Y.UNumber, DbWithEntry) +findMatch acct tl p m = fmap toResult findResult + where + findResult = find (pennyTxnMatches acct tl p) + . M.toList $ m + toResult (u, (_, _)) = (u, M.delete u m) + +-- | Pairs each association in a DbMap with an Entry representing the +-- transaction's entry in the ledger. +pairWithEntry :: Y.FitAcct -> Y.Posting -> (Y.Posting, L.Entry) +pairWithEntry acct p = (p, en) + where + en = L.Entry dc (L.Amount qty cty) + dc = Y.translate (Y.incDec p) (Y.translator acct) + qty = U.parseQty (Y.amount p) + cty = Y.unCurrency . Y.currency $ acct + +type DbWithEntry = M.Map Y.UNumber (Y.Posting, L.Entry) + +-- | Does the given Penny transaction match this posting? Makes sure +-- that the account, quantity, date, commodity, and DrCr match, and +-- that the posting does not have a number (it's OK if the transaction +-- has a number.) +pennyTxnMatches + :: Y.FitAcct + -> L.TopLineData + -> L.Ent L.PostingData + -> (a, (Y.Posting, L.Entry)) + -> Bool +pennyTxnMatches acct tl pstg (_, (a, e)) = + mA && noFlag && mQ && mDC && mDate && mCmdty + where + p = L.pdCore . L.meta $ pstg + mA = L.pAccount p == (Y.unPennyAcct . Y.pennyAcct $ acct) + mQ = L.equivalent (L.qty . L.amount . L.entry $ pstg) + (L.qty . L.amount $ e) + mDC = (L.drCr e) == (L.drCr . L.entry $ pstg) + mDate = (L.day . L.tDateTime . L.tlCore $ tl) == (Y.unDate . Y.date $ a) + noFlag = isNothing . L.pNumber $ p + mCmdty = (L.commodity . L.amount . L.entry $ pstg) + == (Y.unCurrency . Y.currency $ acct) + + +-- | Creates a new transaction corresponding to a given AmexTxn. Uses +-- the Amex payee if that string is non empty; otherwise, uses the +-- Amex description for the payee. +newTransaction + :: NoAuto + -> Y.FitAcct + -> UNumberLookupMap + -> PyeLookupMap + -> (Y.UNumber, (Y.Posting, L.Entry)) + -> L.Transaction +newTransaction noAuto acct mu mp (u, (a, e)) = L.Transaction (tld, ents) where + tld = L.TopLineData tlc Nothing Nothing + tlc = (L.emptyTopLineCore (L.dateTimeMidnightUTC . Y.unDate . Y.date $ a)) + { L.tPayee = Just pa } + (pa, ac) = if noAuto then (dfltPye, dfltAcct) + else ( fromMaybe dfltPye guessedPye, + fromMaybe dfltAcct guessedAcct) + (guessedPye, guessedAcct) = guessInfo (Y.toLincolnPayee acct) mu mp a + dfltPye = getPye (Y.desc a) (Y.payee a) + dfltAcct = Y.unDefaultAcct . Y.defaultAcct $ acct + getPye = Y.toLincolnPayee acct + pennyAcct = Y.unPennyAcct . Y.pennyAcct $ acct + p1data = L.PostingData p1core Nothing Nothing + p2data = L.PostingData p2core Nothing Nothing + p1core = (L.emptyPostingCore pennyAcct) + { L.pTags = L.Tags [newLincolnUNumber u] + , L.pSide = Just $ Y.side acct + , L.pSpaceBetween = Just $ Y.spaceBetween acct + } + p2core = L.emptyPostingCore ac + ents = L.rEnts (Y.unCurrency . Y.currency $ acct) (L.drCr e) + (L.qty . L.amount $ e, p1data) + [] p2data + +-- | Creates new transactions for all the items remaining in the +-- DbMap. Appends a blank line after each one. +createTransactions + :: NoAuto + -> Y.FitAcct + -> [C.LedgerItem] + -> Y.DbList + -> DbWithEntry + -> [C.LedgerItem] +createTransactions noAuto acct led dbLs db = + concatMap (\i -> [i, S.S4d C.BlankLine]) + . map S.S4a + . map (newTransaction noAuto acct mu mp) + . M.assocs + $ db + where + mu = makeUNumberLookup (Y.toLincolnPayee acct) dbLs + mp = makePyeLookupMap (Y.pennyAcct acct) led + +-- | Maps financial institution postings to UNumbers. The key is the +-- Lincoln Payee of the financial institution posting, which is +-- computed using the toLincolnPayee function in the FitAcct. The +-- UNumbers are in a list, with UNumbers from most recent financial +-- institution postings first. +type UNumberLookupMap = M.Map L.Payee [Y.UNumber] + +-- | Create a UNumberLookupMap from a DbWithEntry. Financial +-- institution postings with higher U-numbers will come first. +makeUNumberLookup + :: (Y.Desc -> Y.Payee -> L.Payee) + -> Y.DbList + -> UNumberLookupMap +makeUNumberLookup toPye = foldl' ins M.empty . map f . sortBy g + where + ins m (k, v) = M.alter alterer k m + where alterer Nothing = Just [v] + alterer (Just ls) = Just $ v:ls + f (u, p) = (toPye (Y.desc p) (Y.payee p), u) + g (_, p1) (_, p2) = compare (Y.date p1) (Y.date p2) + +-- | Given a list of keys, find the first key that is in the +-- map. Returns Nothing if no key is in the map. +findFirstKey :: Ord k => M.Map k v -> [k] -> Maybe v +findFirstKey _ [] = Nothing +findFirstKey m (k:ks) = case M.lookup k m of + Nothing -> findFirstKey m ks + Just v -> Just v + +-- | Maps UNumbers to payees and accounts from the ledger. +type PyeLookupMap = M.Map Y.UNumber (Maybe L.Payee, Maybe L.Account) + +-- | Makes a payee lookup map. Puts those postings which match the +-- PennyAcct and have a UNumber into the map. (If two postings match +-- the PennyAcct and have the same UNumber, the one that appears later +-- in the ledger file will be in the map.) +makePyeLookupMap :: Y.PennyAcct -> [C.LedgerItem] -> PyeLookupMap +makePyeLookupMap a l + = M.fromList . mapMaybe f . concatMap L.transactionToPostings + . mapMaybe toPstg + $ l + where + f pstg = do + guard $ (Q.account pstg) == Y.unPennyAcct a + u <- getUNumberFromTags . Q.tags $ pstg + let tailents = L.tailEnts . snd . L.unPosting $ pstg + ac = case tailents of + (x, []) -> Just (L.pAccount . L.pdCore . L.meta $ x) + _ -> Nothing + return (u, (Q.payee pstg, ac)) + toPstg = let cn = const Nothing in S.caseS4 Just cn cn cn + +-- | Given a UNumber and the maps, looks up the payee and account +-- information from previous transactions if this information is +-- available. +guessInfo + :: (Y.Desc -> Y.Payee -> L.Payee) + -> UNumberLookupMap + -> PyeLookupMap + -> Y.Posting + -> (Maybe L.Payee, Maybe L.Account) +guessInfo getPye mu mp p = fromMaybe (Nothing, Nothing) $ do + let pstgPayee = getPye (Y.desc p) (Y.payee p) + unums <- M.lookup pstgPayee mu + findFirstKey mp unums diff --git a/lib/Penny/Brenner/OFX.hs b/lib/Penny/Brenner/OFX.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Brenner/OFX.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Parses any OFX 1.0-series file. Uses the parser from the ofx +-- package. + +module Penny.Brenner.OFX (parser) where + +import Control.Applicative +import qualified Control.Monad.Exception.Synchronous as Ex +import Data.List (isPrefixOf) +import qualified Data.OFX as O +import qualified Data.Text as X +import qualified Data.Time as T +import qualified Penny.Brenner.Types as Y +import qualified Text.Parsec as P + +-- | Parser for OFX files. +parser :: ( Y.ParserDesc, Y.ParserFn ) +parser = (Y.ParserDesc d, loadIncoming) + where + d = X.unlines + [ "Parses OFX 1.0-series files." + , "Open Financial Exchange (OFX) is a standard format" + , "for providing financial information. It is documented" + , "at http://www.ofx.net" + , "This parser also handles QFX files, which are OFX" + , "files with minor additions by the makers of Quicken." + , "Many banks make this format available with the label" + , "\"Download to Quicken\" or similar." + ] + +loadIncoming + :: Y.FitFileLocation + -> IO (Ex.Exceptional String [Y.Posting]) +loadIncoming (Y.FitFileLocation fn) = do + contents <- readFile fn + return $ + ( Ex.mapException show + . Ex.fromEither + $ P.parse O.ofxFile fn contents ) + >>= O.transactions + >>= mapM txnToPosting + + +txnToPosting + :: O.Transaction + -> Ex.Exceptional String Y.Posting +txnToPosting t = Y.Posting + <$> pure (Y.Date ( T.utctDay . T.zonedTimeToUTC + . O.txDTPOSTED $ t)) + <*> pure (Y.Desc X.empty) + <*> pure incDec + <*> amt + <*> pure ( Y.Payee $ case O.txPayeeInfo t of + Nothing -> X.empty + Just ei -> case ei of + Left x -> X.pack x + Right p -> X.pack . O.peNAME $ p ) + <*> pure (Y.FitId . X.pack . O.txFITID $ t) + where + amtStr = O.txTRNAMT t + incDec = + if "-" `isPrefixOf` amtStr then Y.Decrease else Y.Increase + amt = case amtStr of + [] -> Ex.throw "empty amount" + x:xs -> let str = if x == '-' || x == '+' then xs else amtStr + in Ex.fromMaybe ("could not parse amount: " ++ amtStr) + $ Y.mkAmount str + diff --git a/lib/Penny/Brenner/Print.hs b/lib/Penny/Brenner/Print.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Brenner/Print.hs @@ -0,0 +1,59 @@ +-- | Prints parsed transactions. +-- +-- TODO add support to this and other Brenner components for reading +-- from stdin. +module Penny.Brenner.Print (mode) where + +import qualified Penny.Brenner.Types as Y +import qualified Penny.Brenner.Util as U +import qualified System.Console.MultiArg as MA +import qualified Control.Monad.Exception.Synchronous as Ex +import Data.Maybe (mapMaybe) + +help :: String -> String +help pn = unlines + [ "usage: " ++ pn ++ " [global-options] print [local-options] FILE..." + , "Parses the transactions in each FILE using the appropriate parser" + , "and prints the parse result to standard output." + , "" + , "Local options:" + , " --help, -h Show this help and exit." + ] + +data Arg + = ArgFile String + +mode + :: MA.Mode (Maybe Y.FitAcct -> IO ()) +mode = MA.Mode + { MA.mName = "print" + , MA.mIntersperse = MA.Intersperse + , MA.mOpts = [] + , MA.mPosArgs = return . ArgFile + , MA.mProcess = processor + , MA.mHelp = help + } + +processor + :: [Arg] + -> Maybe Y.FitAcct + -> IO () +processor ls mayFa = do + fa <- U.getFitAcct mayFa + doPrint (snd . Y.parser $ fa) ls + +doPrint + :: (Y.FitFileLocation -> IO (Ex.Exceptional String [Y.Posting])) + -> [Arg] + -> IO () +doPrint prsr ls = mapM_ f . mapMaybe toFile $ ls + where + f file = do + r <- prsr file + case r of + Ex.Exception s -> do + fail $ "penny-fit print: error: " ++ s + Ex.Success ps -> mapM putStr . map U.showPosting $ ps + toFile a = case a of + ArgFile s -> Just (Y.FitFileLocation s) + diff --git a/lib/Penny/Brenner/Types.hs b/lib/Penny/Brenner/Types.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Brenner/Types.hs @@ -0,0 +1,340 @@ +module Penny.Brenner.Types + ( Date(..) + , IncDec(..) + , UNumber(..) + , FitId(..) + , Payee(..) + , Desc(..) + , Amount(unAmount) + , mkAmount + , translate + , DbMap + , DbList + , Posting(..) + , ConfigLocation(..) + , DbLocation(..) + , FitAcctName(..) + , FitAcctDesc(..) + , ParserDesc(..) + , PennyAcct(..) + , Translator(..) + , DefaultAcct(..) + , Currency(..) + , FitAcct(..) + , Config(..) + , FitFileLocation(..) + , AllowNew(..) + , ParserFn + ) where + +import Control.Applicative ((<$>), (<*>)) +import qualified Control.Monad.Exception.Synchronous as Ex +import qualified Data.Map as M +import qualified Data.Time as Time +import qualified Penny.Copper.Render as R +import qualified Penny.Lincoln as L +import Data.Text (Text, pack, unpack) +import qualified Data.Text.Encoding as E +import qualified Data.Serialize as S + +-- | The date reported by the financial institution. +newtype Date = Date { unDate :: Time.Day } + deriving (Eq, Show, Ord, Read) + +instance S.Serialize Date where + put = S.put . show . unDate + get = Date <$> (read <$> S.get) + +-- | Reports changes in account balances. Avoids using /debit/ and +-- /credit/ as these terms are used differently by the bank than in +-- your ledger (that is, the bank reports it from their perspective, +-- not yours) so instead the terms /increase/ and /decrease/ are +-- used. IncDec is used to record the bank's transactions so +-- /increase/ and /decrease/ are used in the same way you would see +-- them on a bank statement, whether it's a credit card, loan, +-- checking account, etc. +data IncDec + = Increase + -- ^ Increases the account balance. For a checking or savings + -- account, this is a deposit. For a credit card, this is a purchase. + + | Decrease + -- ^ Decreases the account balance. On a credit card, this is a + -- payment. On a checking account, this is a withdrawal. + deriving (Eq, Show, Read) + +instance S.Serialize IncDec where + put x = case x of + Increase -> S.putWord8 0 + Decrease -> S.putWord8 1 + get = S.getWord8 >>= f + where + f x = case x of + 0 -> return Increase + 1 -> return Decrease + _ -> fail "read IncDec error" + +-- | A unique number assigned by Brenner to identify each +-- posting. This is unique within a particular financial institution +-- account only. +newtype UNumber = UNumber { unUNumber :: Integer } + deriving (Eq, Show, Ord, Read) + +instance S.Serialize UNumber where + put = S.put . unUNumber + get = UNumber <$> S.get + +putText :: Text -> S.Put +putText = S.put . E.encodeUtf8 + +getText :: S.Get Text +getText = S.get >>= f + where + f bs = case E.decodeUtf8' bs of + Left _ -> fail "text reading failed" + Right x -> return x + + +-- | For Brenner to work, the bank has to assign unique identifiers to +-- each transaction that it gives you for download. This is the +-- easiest reliable way to ensure duplicates are not processed +-- multiple times. (There are other ways to accomplish this, but they +-- are much harder and less reliable.) If the bank does not do this, +-- you can't use Brenner. +newtype FitId = FitId { unFitId :: Text } + deriving (Eq, Show, Ord, Read) + +instance S.Serialize FitId where + put = putText . unFitId + get = FitId <$> getText + +-- | Some financial institutions assign a separate Payee in addition +-- to a description. Others just have a single Description field. If +-- this institution uses both, put something here. Brenner will prefer +-- the Payee if it is not zero length; then it will use the Desc. +newtype Payee = Payee { unPayee :: Text } + deriving (Eq, Show, Ord, Read) + +instance S.Serialize Payee where + put = putText . unPayee + get = Payee <$> getText + +-- | The transaction description. Some institutions assign only a +-- description (sometimes muddling a payee with long codes, some +-- dates, etc). Brenner prefers the Payee if there is one, and uses a +-- Desc otherwise. +newtype Desc = + Desc { unDesc :: Text } + deriving (Eq, Show, Ord, Read) + +instance S.Serialize Desc where + put = putText . unDesc + get = Desc <$> getText + +-- | The amount of the transaction. Do not include any leading plus or +-- minus signs; this should be only digits and a decimal point. +newtype Amount = Amount { unAmount :: Text } + deriving (Eq, Show, Ord, Read) + +instance S.Serialize Amount where + put = putText . unAmount + get = getText >>= f + where + f x = case mkAmount . unpack $ x of + Nothing -> fail $ "failed to load amount: " ++ unpack x + Just a -> return a + +-- | Ensures that incoming Amounts have only digits and (up to) one +-- decimal point. +mkAmount :: String -> Maybe Amount +mkAmount s = + let isDigit c = c >= '0' && c <= '9' + (_, rs) = span isDigit s + in case rs of + "" -> if not . null $ s + then return . Amount . pack $ s + else Nothing + '.':rest -> if all isDigit rest + then return . Amount . pack $ s + else Nothing + _ -> Nothing + +translate + :: IncDec + -> Translator + -> L.DrCr +translate Increase IncreaseIsDebit = L.Debit +translate Increase IncreaseIsCredit = L.Credit +translate Decrease IncreaseIsDebit = L.Credit +translate Decrease IncreaseIsCredit = L.Debit + +type DbMap = M.Map UNumber Posting +type DbList = [(UNumber, Posting)] + +data Posting = Posting + { date :: Date + , desc :: Desc + , incDec :: IncDec + , amount :: Amount + , payee :: Payee + , fitId :: FitId + } deriving (Read, Show) + + +instance S.Serialize Posting where + put x = S.put (date x) + >> S.put (desc x) + >> S.put (incDec x) + >> S.put (amount x) + >> S.put (payee x) + >> S.put (fitId x) + get = Posting + <$> S.get + <*> S.get + <*> S.get + <*> S.get + <*> S.get + <*> S.get + +-- | Where is a configuration file +newtype ConfigLocation = ConfigLocation + { unConfigLocation :: Text } + deriving (Eq, Show) + +instance L.HasText ConfigLocation where text = unConfigLocation + +-- | Where is the database of postings? +newtype DbLocation = DbLocation { unDbLocation :: Text } + deriving (Eq, Show) + +instance L.HasText DbLocation where text = unDbLocation + +-- | Text description of the financial institution account. +newtype FitAcctDesc = FitAcctDesc { unFitAcctDesc :: Text } + deriving (Eq, Show) + +instance L.HasText FitAcctDesc where text = unFitAcctDesc + +-- | Text description of the parser itself. +newtype ParserDesc = ParserDesc { unParserDesc :: Text } + deriving (Eq, Show) + +instance L.HasText ParserDesc where text = unParserDesc + +-- | A name used to refer to a batch of settings. +newtype FitAcctName = FitAcctName { unFitAcctName :: Text } + deriving (Eq, Show) + +instance L.HasText FitAcctName where text = unFitAcctName + +-- | The Penny account holding postings for this financial +-- institution. For instance it might be @Assets:Checking@ if this is +-- your checking account, @Liabilities:Credit Card@, or whatever. +newtype PennyAcct = PennyAcct { unPennyAcct :: L.Account } + deriving (Eq, Show) + +instance L.HasTextList PennyAcct where + textList = L.textList . unPennyAcct + +-- | What the financial institution shows as an increase or decrease +-- has to be recorded as a debit or credit in the PennyAcct. +data Translator + = IncreaseIsDebit + -- ^ That is, when the financial institution shows a posting that + -- increases your account balance, you record a debit. You will + -- probably use this for deposit accounts, like checking and + -- savings. These are asset accounts so if the balance goes up you + -- record a debit in your ledger. + + | IncreaseIsCredit + -- ^ That is, when the financial institution shows a posting that + -- increases your account balance, you record a credit. You will + -- probably use this for liabilities, such as credit cards and other + -- loans. + + deriving (Eq, Show) + +-- | The default account to place unclassified postings in. For +-- instance @Expenses:Unclassified@. +newtype DefaultAcct = DefaultAcct { unDefaultAcct :: L.Account } + deriving (Eq, Show) + +instance L.HasTextList DefaultAcct where + textList = L.textList . unDefaultAcct + +-- | The currency for all transactions, e.g. @$@. +newtype Currency = Currency { unCurrency :: L.Commodity } + deriving (Eq, Show) + +instance L.HasText Currency where text = L.text . unCurrency + +-- | A batch of settings representing a single financial institution +-- account. +data FitAcct = FitAcct + { fitAcctName :: FitAcctName + , fitAcctDesc :: FitAcctDesc + , dbLocation :: DbLocation + , pennyAcct :: PennyAcct + , defaultAcct :: DefaultAcct + , currency :: Currency + , groupSpecs :: R.GroupSpecs + , translator :: Translator + + , side :: L.Side + -- ^ When creating new transactions, the commodity will be on this + -- side + + , spaceBetween :: L.SpaceBetween + -- ^ When creating new transactions, is there a space between the + -- commodity and the quantity + + , parser :: ( ParserDesc + , FitFileLocation -> IO (Ex.Exceptional String [Posting])) + -- ^ Parses a file of transactions from the financial + -- institution. The function must open the file and parse it. This + -- is in the IO monad not only because the function must open the + -- file itself, but also so the function can perform arbitrary IO + -- (run pdftotext, maybe?) If there is failure, the function can + -- return an Exceptional String, which is the error + -- message. Alternatively the function can raise an exception in the + -- IO monad (currently Brenner makes no attempt to catch these) so + -- if any of the IO functions throw you can simply not handle the + -- exceptions. + -- + -- The first element of the pair gives information about the parser. + + , toLincolnPayee :: Desc -> Payee -> L.Payee + -- ^ Sometimes the financial institution provides Payee information, + -- sometimes it does not. Sometimes the Desc might have additional + -- information that you might want to remove. This function can be + -- used to do that. The resulting Lincoln Payee is used for any + -- transactions that are created by the merge command. The resulting + -- payee is also used when comparing new financial institution + -- postings to already existing ledger transactions in order to + -- guess at which payee and accounts to create in the transactions + -- created by the merge command. + + } + +-- | Configuration for the Brenner program. You can optionally have +-- a default FitAcct, which is used if you do not specify any FitAcct on the +-- command line. You can also name any number of additional FitAccts. If +-- you do not specify a default FitAcct, you must specify a FitAcct on the +-- command line. + +data Config = Config + { defaultFitAcct :: Maybe FitAcct + , moreFitAccts :: [FitAcct] + } + +newtype FitFileLocation = FitFileLocation { unFitFileLocation :: String } + deriving (Show, Eq) + +newtype AllowNew = AllowNew { unAllowNew :: Bool } + deriving (Show, Eq) + +-- | All parsers must be of this type. +type ParserFn + = FitFileLocation + -> IO (Ex.Exceptional String [Posting]) + diff --git a/lib/Penny/Brenner/Util.hs b/lib/Penny/Brenner/Util.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Brenner/Util.hs @@ -0,0 +1,106 @@ +module Penny.Brenner.Util where + +import Control.Monad.Exception.Synchronous as Ex +import qualified Penny.Brenner.Types as Y +import qualified Data.ByteString as BS +import qualified System.IO.Error as IOE +import qualified Data.Serialize as S +import qualified Data.Text as X +import qualified Penny.Copper.Parsec as CP +import qualified Text.Parsec as P +import qualified Penny.Lincoln as L +import qualified System.Exit as Exit +import qualified System.Console.MultiArg as MA +import qualified System.IO as IO + +-- | Print an error message and exit. +errExit :: String -> IO a +errExit s = do + pn <- MA.getProgName + IO.hPutStrLn IO.stderr $ pn ++ ": error: " ++ s + Exit.exitFailure + +-- | Gets the FitAcct, if it was provided. If it was not provided, +-- exit with an error message. +getFitAcct :: Maybe Y.FitAcct -> IO Y.FitAcct +getFitAcct ma = case ma of + Nothing -> errExit $ "no default financial institution account, " + ++ "and no financial institution account provided" + ++ " on command line." + Just a -> return a + +-- | Loads the database from disk. If allowNew is True, then does not +-- fail if the file was not found. +loadDb + :: Y.AllowNew + -- ^ Is a new file allowed? + + -> Y.DbLocation + -- ^ DB location + + -> IO Y.DbList +loadDb (Y.AllowNew allowNew) (Y.DbLocation dbLoc) = do + eiStr <- IOE.tryIOError (BS.readFile . X.unpack $ dbLoc) + case eiStr of + Left e -> + if allowNew && IOE.isDoesNotExistError e + then return [] + else IOE.ioError e + Right g -> case readDbTuple g of + Ex.Exception e -> fail e + Ex.Success good -> return good + +-- | File version. Increment this when anything in the file format +-- changes. +version :: Int +version = 0 + +brenner :: String +brenner = "penny.brenner" + +readDbTuple + :: BS.ByteString + -> Ex.Exceptional String Y.DbList +readDbTuple bs = do + (s, v, ls) <- Ex.fromEither $ S.decode bs + Ex.assert "database file format not recognized." $ s == brenner + Ex.assert "wrong database version." $ v == version + return ls + +saveDbTuple :: Y.DbList -> BS.ByteString +saveDbTuple ls = S.encode (brenner, version, ls) + +-- | Writes a new database to disk. +saveDb :: Y.DbLocation -> Y.DbList -> IO () +saveDb (Y.DbLocation p) = BS.writeFile (X.unpack p) . saveDbTuple + +-- | Parses quantities from amounts. All amounts should be verified as +-- having only digits, optionally followed by a point and then more +-- digits. All these values should parse. So if there is a problem it +-- is a programmer error. Apply error. +parseQty :: Y.Amount -> L.Qty +parseQty a = case P.parse CP.quantity "" (Y.unAmount a) of + Left e -> error $ "could not parse quantity from string: " + ++ (X.unpack . Y.unAmount $ a) ++ ": " ++ show e + Right g -> g + +label :: String -> X.Text -> String +label s x = s ++ ": " ++ X.unpack x ++ "\n" + +-- | Shows a Posting in human readable format. +showPosting :: Y.Posting -> String +showPosting (Y.Posting dt dc nc am py fd) = + label "Date" (X.pack . show . Y.unDate $ dt) + ++ label "Description" (Y.unDesc dc) + ++ label "Type" (X.pack $ case nc of + Y.Increase -> "increase" + Y.Decrease -> "decrease") + ++ label "Amount" (Y.unAmount am) + ++ label "Payee" (Y.unPayee py) + ++ label "Financial institution ID" (Y.unFitId fd) + ++ "\n" + +showDbPair :: (Y.UNumber, Y.Posting) -> String +showDbPair (Y.UNumber u, p) = + label "U number" (X.pack . show $ u) + ++ showPosting p diff --git a/lib/Penny/Cabin.hs b/lib/Penny/Cabin.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Cabin.hs @@ -0,0 +1,7 @@ +-- | Cabin - Penny reports +-- +-- Cabin contains reports, or functions that take a list of postings +-- and return a formatted Text to display data in a human-readable +-- format. +module Penny.Cabin where + diff --git a/lib/Penny/Cabin/Balance.hs b/lib/Penny/Cabin/Balance.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Cabin/Balance.hs @@ -0,0 +1,21 @@ +-- | Penny balance reports. Currently there are two balance reports: +-- the MultiCommodity report, which cannot convert commodities and +-- which therefore might show more than one commodity in a single +-- report, and the Convert report, which uses price data in the Penny +-- file to convert all commodities to a single commodity. The Convert +-- report always displays only one commodity per account and this one +-- commodity for the whole report. +module Penny.Cabin.Balance where + +import qualified Penny.Cabin.Balance.MultiCommodity as MC +import qualified Penny.Cabin.Interface as I +import qualified Penny.Cabin.Balance.Convert as C +import qualified Penny.Cabin.Balance.Convert.Options as ConvOpts + +-- | The default multi-commodity balance report. +multiCommodity :: I.Report +multiCommodity = MC.defaultReport + +-- | The default converting balance report. +convert :: I.Report +convert = C.cmdLineReport ConvOpts.defaultOptions diff --git a/lib/Penny/Cabin/Balance/Convert.hs b/lib/Penny/Cabin/Balance/Convert.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Cabin/Balance/Convert.hs @@ -0,0 +1,334 @@ +-- | The Convert report. This report converts all account balances to +-- a single commodity, which must be specified. + +module Penny.Cabin.Balance.Convert ( + Opts(..) + , Sorter + , report + , cmdLineReport + , getSorter + ) where + +import Control.Applicative ((<$>), (<*>)) +import qualified Control.Monad.Exception.Synchronous as Ex +import qualified Data.Tree as E +import qualified Data.Traversable as Tvbl +import qualified Penny.Cabin.Options as CO +import qualified Penny.Cabin.Parsers as CP +import qualified Penny.Cabin.Scheme as Scheme +import qualified Penny.Cabin.Balance.Util as U +import qualified Penny.Cabin.Balance.Convert.Chunker as K +import qualified Penny.Cabin.Balance.Convert.Options as O +import qualified Penny.Cabin.Balance.Convert.Parser as P +import qualified Penny.Cabin.Interface as I +import qualified Penny.Lincoln as L +import qualified Penny.Lincoln.Balance as Bal +import qualified Penny.Liberty as Ly +import qualified Penny.Shield as S +import qualified Data.Either as Ei +import qualified Data.Map as M +import qualified Data.Text as X +import Data.Monoid (mempty, mappend, mconcat) +import qualified System.Console.MultiArg as MA +import qualified System.Console.Rainbow as Rb + +-- | Options for the Convert report. These are the only options you +-- need to use if you are supplying options programatically (as +-- opposed to parsing them in from the command line.) +data Opts = Opts + { balanceFormat :: L.Commodity -> L.Qty -> X.Text + , showZeroBalances :: CO.ShowZeroBalances + , sorter :: Sorter + , target :: L.To + , dateTime :: L.DateTime + , textFormats :: Scheme.Changers + } + +-- | How to sort each line of the report. Each subaccount has only one +-- BottomLine (unlike in the MultiCommodity report, where each +-- subaccount may have more than one BottomLine, one for each +-- commodity.) +type Sorter = + (L.SubAccount, L.BottomLine) + -> (L.SubAccount, L.BottomLine) + -> Ordering + +-- | Converts all commodities in a Balance to a single commodity and +-- combines all the BottomLines into one. Fails with an error message +-- if no conversion data is available. +convertBalance :: + L.PriceDb + -> L.DateTime + -> L.To + -> L.Balance + -> Ex.Exceptional X.Text L.BottomLine +convertBalance db dt to bal = fmap mconcat r + where + r = mapM (convertOne db dt to) . M.assocs . L.unBalance $ bal + +-- | Converts a single BottomLine to a new commodity. Fails with an +-- error message if no conversion data is available. +convertOne :: + L.PriceDb + -> L.DateTime + -> L.To + -> (L.Commodity, L.BottomLine) + -> Ex.Exceptional X.Text L.BottomLine +convertOne db dt to (cty, bl) = + case bl of + L.Zero -> return L.Zero + L.NonZero (L.Column dc qt) -> Ex.mapExceptional e g ex + where + ex = L.convertAsOf db dt to am + am = L.Amount qt cty + e = convertError to (L.From cty) + g r = L.NonZero (L.Column dc r) + +-- | Creates an error message for conversion errors. +convertError :: + L.To + -> L.From + -> L.PriceDbError + -> X.Text +convertError (L.To to) (L.From fr) e = + let fromErr = L.unCommodity fr + toErr = L.unCommodity to + in case e of + L.FromNotFound -> + X.pack "no data to convert from commodity " + `X.append` fromErr + L.ToNotFound -> + X.pack "no data to convert to commodity " + `X.append` toErr + L.CpuNotFound -> + X.pack "no data to convert from commodity " + `X.append` fromErr + `X.append` (X.pack " to commodity ") + `X.append` toErr + `X.append` (X.pack " at given date and time") + + +-- | Create a price database. +buildDb :: [L.PricePoint] -> L.PriceDb +buildDb = foldl f L.emptyDb where + f db pb = L.addPrice db pb + +-- | All data for the report after all balances have been converted to +-- a single commodity and all the sums of the child accounts have been +-- added to the parent accounts. +data ForestAndBL = ForestAndBL { + _tbForest :: E.Forest (L.SubAccount, L.BottomLine) + , _tbTotal :: L.BottomLine + , _tbTo :: L.To + } + +-- | Converts the balance data in preparation for screen rendering. +rows :: ForestAndBL -> ([K.Row], L.To) +rows (ForestAndBL f tot to) = (first:second:rest, to) + where + first = K.ROneCol $ K.OneColRow 0 desc + desc = X.pack "All amounts reported in commodity: " + `X.append` (L.unCommodity + . L.unTo + $ to) + second = K.RMain $ K.MainRow 0 (X.pack "Total") tot + rest = map mainRow + . concatMap E.flatten + . map U.labelLevels + $ f + + +mainRow :: (Int, (L.SubAccount, L.BottomLine)) -> K.Row +mainRow (l, (a, b)) = K.RMain $ K.MainRow l x b + where + x = L.text a + +-- | The function for the Convert report. Use this function if you are +-- setting the options from a program (as opposed to parsing them in +-- from the command line.) Will fail if the balance conversions fail. +report + :: Opts + -> [L.PricePoint] + -> [(a, L.Posting)] + -> Ex.Exceptional X.Text [Rb.Chunk] +report os@(Opts getFmt _ _ _ _ txtFormats) ps bs = do + fstBl <- sumConvertSort os ps bs + let (rs, L.To cy) = rows fstBl + fmt = getFmt cy + return $ K.rowsToChunks txtFormats fmt rs + + +-- | Creates a report respecting the standard interface for reports +-- whose options are parsed in from the command line. +cmdLineReport + :: O.DefaultOpts + -> I.Report +cmdLineReport o rt = (help o, mkMode) + where + mkMode _ _ chgrs _ fsf = MA.Mode + { MA.mName = "convert" + , MA.mIntersperse = MA.Intersperse + , MA.mOpts = map (fmap Right) P.allOptSpecs + , MA.mPosArgs = return . Left + , MA.mProcess = process rt chgrs o fsf + , MA.mHelp = const (help o) + } + +process + :: S.Runtime + -> Scheme.Changers + -> O.DefaultOpts + -> ([L.Transaction] -> [(Ly.LibertyMeta, L.Posting)]) + -> [Either String (P.Opts -> Ex.Exceptional String P.Opts)] + -> Ex.Exceptional X.Text I.ArgsAndReport +process rt chgrs defaultOpts fsf ls = do + let (posArgs, parsed) = Ei.partitionEithers ls + op' = foldl (>>=) (return (O.toParserOpts defaultOpts rt)) parsed + case op' of + Ex.Exception s -> Ex.throw . X.pack $ s + Ex.Success g -> return $ + let noDefault = X.pack "no default price found" + f = fromParsedOpts chgrs g + pr ts pps = do + rptOpts <- Ex.fromMaybe noDefault $ + f pps (O.format defaultOpts) + let boxes = fsf ts + report rptOpts pps boxes + in (posArgs, pr) + + +-- | Sums the balances from the bottom to the top of the tree (so that +-- parent accounts have the sum of the balances of all their +-- children.) Then converts the commodities to a single commodity, and +-- sorts the accounts as requested. Fails if the conversion fails. +sumConvertSort + :: Opts + -> [L.PricePoint] + -> [(a, L.Posting)] + -> Ex.Exceptional X.Text ForestAndBL +sumConvertSort os ps bs = mkResult <$> convertedFrst <*> convertedTot + where + (Opts _ szb str tgt dt _) = os + bals = U.balances szb bs + (frst, tot) = U.sumForest mempty mappend bals + convertBal (a, bal) = + (\bl -> (a, bl)) <$> convertBalance db dt tgt bal + db = buildDb ps + convertedFrst = mapM (Tvbl.mapM convertBal) frst + convertedTot = convertBalance db dt tgt tot + mkResult f t = ForestAndBL (U.sortForest str f) t tgt + +-- | Determine the most frequent To commodity. +mostFrequent :: [L.PricePoint] -> Maybe L.To +mostFrequent = U.lastMode . map (L.to . L.price) + + +type DoReport = [L.PricePoint] + -> (L.Commodity -> L.Qty -> X.Text) + -> (Maybe Opts) + +-- | Get options for the report, depending on what options were parsed +-- from the command line. Fails if the user did not specify a +-- commodity and mostFrequent fails. +fromParsedOpts + :: Scheme.Changers + -> P.Opts + -> DoReport +fromParsedOpts chgrs (P.Opts szb tgt dt so sb) = + \pps fmt -> case tgt of + P.ManualTarget to -> + Just $ Opts fmt szb (getSorter so sb) to dt chgrs + P.AutoTarget -> + case mostFrequent pps of + Nothing -> Nothing + Just to -> + Just $ Opts fmt szb (getSorter so sb) to dt chgrs + +-- | Returns a function usable to sort pairs of SubAccount and +-- BottomLine depending on how you want them sorted. +getSorter :: CP.SortOrder -> P.SortBy -> Sorter +getSorter o b = flipper f + where + flipper = case o of + CP.Ascending -> id + CP.Descending -> + \g p1 p2 -> case g p1 p2 of + LT -> GT + GT -> LT + EQ -> EQ + f p1@(a1, _) p2@(a2, _) = case b of + P.SortByName -> compare a1 a2 + P.SortByQty -> cmpBottomLine p1 p2 + +cmpBottomLine :: Sorter +cmpBottomLine (n1, bl1) (n2, bl2) = + case (bl1, bl2) of + (L.Zero, L.Zero) -> EQ + (L.NonZero _, L.Zero) -> LT + (L.Zero, L.NonZero _) -> GT + (L.NonZero c1, L.NonZero c2) -> + mconcat [dc, qt, na] + where + dc = case (Bal.colDrCr c1, Bal.colDrCr c2) of + (L.Debit, L.Debit) -> EQ + (L.Debit, L.Credit) -> LT + (L.Credit, L.Debit) -> GT + (L.Credit, L.Credit) -> EQ + qt = compare (Bal.colQty c1) (Bal.colQty c2) + na = compare n1 n2 + +------------------------------------------------------------ +-- ## Help +------------------------------------------------------------ +ifDefault :: Bool -> String +ifDefault b = if b then " (default)" else "" + +help :: O.DefaultOpts -> String +help o = unlines $ + [ "convert" + , " Show account balances, after converting all amounts" + , " to a single commodity. Accepts ONLY the following options:" + , "" + , "--show-zero-balances" + , " Show balances that are zero" + ++ ifDefault (CO.unShowZeroBalances . O.showZeroBalances $ o) + , "--hide-zero-balances" + , " Hide balances that are zero" + ++ ifDefault (not . CO.unShowZeroBalances . O.showZeroBalances $ o) + , "" + , "--commodity TARGET-COMMMODITY, -c TARGET-COMMODITY" + , " Convert all commodities to TARGET-COMMODITY." + ] ++ case O.target o of + P.ManualTarget (L.To cy) -> + [ " default: " ++ (X.unpack . L.unCommodity $ cy) ] + _ -> [] + ++ + [ "--auto-commodity" + , " convert all commodities to the commodity that appears most" + , " often as the target commodity in your price data. If" + , " there is a tie, the price closest to the end of your list" + , " of prices is used." + ++ case O.target o of + P.AutoTarget -> " (default)" + _ -> "" + , "" + , "--date DATE-TIME, -d DATE-TIME" + , " Convert prices as of the date and time given" + , " (by default, the current date and time is used.)" + , "" + , "--sort qty|name, -s qty|name" + , " Sort balances by sub-account name" + ++ ifDefault (O.sortBy o == P.SortByName) + ++ " or by quantity" + ++ ifDefault (O.sortBy o == P.SortByQty) + , "--ascending" + , " Sort in ascending order" + ++ ifDefault (O.sortOrder o == CP.Ascending) + , "--descending" + , " Sort in descending order" + ++ ifDefault (O.sortOrder o == CP.Descending) + , "" + , "--help, -h" + , " Show this help and exit" + ] + diff --git a/lib/Penny/Cabin/Balance/Convert/Chunker.hs b/lib/Penny/Cabin/Balance/Convert/Chunker.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Cabin/Balance/Convert/Chunker.hs @@ -0,0 +1,239 @@ +-- | Creates the output Chunks for the Balance report for +-- multi-commodity reports only. + +module Penny.Cabin.Balance.Convert.Chunker ( + MainRow(..), + OneColRow(..), + Row(..), + rowsToChunks + ) where + + +import Control.Applicative + (Applicative (pure), (<$>), (<*>)) +import qualified Penny.Cabin.Scheme as E +import qualified Penny.Cabin.Meta as Meta +import qualified Penny.Cabin.Row as R +import qualified Penny.Lincoln as L +import qualified Data.Foldable as Fdbl +import qualified Data.Text as X +import qualified System.Console.Rainbow as Rb + +type IsEven = Bool + +data Columns a = Columns { + acct :: a + , drCr :: a + , quantity :: a + } deriving Show + +instance Functor Columns where + fmap f c = Columns { + acct = f (acct c) + , drCr = f (drCr c) + , quantity = f (quantity c) + } + +instance Applicative Columns where + pure a = Columns a a a + fn <*> fa = Columns { + acct = (acct fn) (acct fa) + , drCr = (drCr fn) (drCr fa) + , quantity = (quantity fn) (quantity fa) + } + +data PreSpec = PreSpec { + _justification :: R.Justification + , _padSpec :: (E.Label, E.EvenOdd) + , bits :: Rb.Chunk } + +-- | When given a list of columns, determine the widest row in each +-- column. +maxWidths :: [Columns PreSpec] -> Columns R.Width +maxWidths = Fdbl.foldl' maxWidthPerColumn (pure (R.Width 0)) + +-- | Applied to a Columns of PreSpec and a Colums of widths, return a +-- Columns that has the wider of the two values. +maxWidthPerColumn :: + Columns R.Width + -> Columns PreSpec + -> Columns R.Width +maxWidthPerColumn w p = f <$> w <*> p where + f old new = max old (R.Width . X.length . Rb.chunkText . bits $ new) + +-- | Changes a single set of Columns to a set of ColumnSpec of the +-- given width. +preSpecToSpec :: + Columns R.Width + -> Columns PreSpec + -> Columns R.ColumnSpec +preSpecToSpec ws p = f <$> ws <*> p where + f width (PreSpec j ps bs) = R.ColumnSpec j width ps [bs] + +resizeColumnsInList :: [Columns PreSpec] -> [Columns R.ColumnSpec] +resizeColumnsInList cs = map (preSpecToSpec w) cs where + w = maxWidths cs + + +widthSpacerAcct :: Int +widthSpacerAcct = 4 + +widthSpacerDrCr :: Int +widthSpacerDrCr = 1 + +colsToBits + :: E.Changers + -> IsEven + -> Columns R.ColumnSpec + -> [Rb.Chunk] +colsToBits chgrs isEven (Columns a dc q) = let + fillSpec = if isEven + then (E.Other, E.Even) + else (E.Other, E.Odd) + spacer w = R.ColumnSpec j (R.Width w) fillSpec [] + j = R.LeftJustify + cs = a + : spacer widthSpacerAcct + : dc + : spacer widthSpacerDrCr + : q + : [] + in R.row chgrs cs + +colsListToBits + :: E.Changers + -> [Columns R.ColumnSpec] + -> [[Rb.Chunk]] +colsListToBits chgrs = zipWith f bools where + f b c = colsToBits chgrs b c + bools = iterate not True + +preSpecsToBits + :: E.Changers + -> [Columns PreSpec] + -> [Rb.Chunk] +preSpecsToBits chgrs = + concat + . colsListToBits chgrs + . resizeColumnsInList + +data Row = RMain MainRow | ROneCol OneColRow + +-- | Displays a one-column row. +data OneColRow = OneColRow { + ocIndentation :: Int + -- ^ Indent the text by this many levels (not by this many + -- spaces; this number is multiplied by another number in the + -- Chunker source to arrive at the final indentation amount) + + , ocText :: X.Text + -- ^ Text for the left column + } + +-- | Displays a single account in a Balance report. In a +-- single-commodity report, this account will only be one screen line +-- long. In a multi-commodity report, it might be multiple lines long, +-- with one screen line for each commodity. +data MainRow = MainRow { + mrIndentation :: Int + -- ^ Indent the account name by this many levels (not by this many + -- spaces; this number is multiplied by another number in the + -- Chunker source to arrive at the final indentation amount) + + , mrText :: X.Text + -- ^ Text for the name of the account + + , mrBottomLine :: L.BottomLine + -- ^ Commodity balances. If this list is empty, dashes are + -- displayed for the DrCr and Qty. + } + + +rowsToChunks + :: E.Changers + -> (L.Qty -> X.Text) + -- ^ How to format a balance to allow for digit grouping + -> [Row] + -> [Rb.Chunk] +rowsToChunks chgrs fmt = + preSpecsToBits chgrs + . rowsToColumns chgrs fmt + +rowsToColumns + :: E.Changers + -> (L.Qty -> X.Text) + -- ^ How to format a balance to allow for digit grouping + + -> [Row] + -> [Columns PreSpec] +rowsToColumns chgrs fmt + = map (mkRow chgrs fmt) + . L.serialItems (\ser r -> (Meta.VisibleNum ser, r)) + + +mkRow + :: E.Changers + -> (L.Qty -> X.Text) + -> (Meta.VisibleNum, Row) + -> Columns PreSpec +mkRow chgrs fmt (vn, r) = case r of + RMain m -> mkMainRow chgrs fmt (vn, m) + ROneCol c -> mkOneColRow chgrs (vn, c) + +mkOneColRow + :: E.Changers + -> (Meta.VisibleNum, OneColRow) + -> Columns PreSpec +mkOneColRow chgrs (vn, (OneColRow i t)) = Columns ca cd cq + where + txt = X.append indents t + indents = X.replicate (indentAmount * max 0 i) + (X.singleton ' ') + eo = E.fromVisibleNum vn + lbl = E.Other + ca = PreSpec R.LeftJustify (lbl, eo) + (E.getEvenOddLabelValue lbl eo chgrs $ Rb.plain txt) + cd = PreSpec R.LeftJustify (lbl, eo) + (E.getEvenOddLabelValue lbl eo chgrs $ Rb.plain X.empty) + cq = cd + +mkMainRow + :: E.Changers + -> (L.Qty -> X.Text) + -> (Meta.VisibleNum, MainRow) + -> Columns PreSpec +mkMainRow chgrs fmt (vn, (MainRow i acctTxt b)) = Columns ca cd cq + where + applyFmt = E.getEvenOddLabelValue lbl eo chgrs + eo = E.fromVisibleNum vn + lbl = E.Other + ca = PreSpec R.LeftJustify (lbl, eo) (applyFmt (Rb.plain txt)) + where + txt = X.append indents acctTxt + indents = X.replicate (indentAmount * max 0 i) + (X.singleton ' ') + cd = PreSpec R.LeftJustify (lbl, eo) (applyFmt cksDrCr) + cq = PreSpec R.LeftJustify (lbl, eo) (applyFmt cksQty) + (cksDrCr, cksQty) = balanceChunks chgrs fmt vn b + + +balanceChunks + :: E.Changers + -> (L.Qty -> X.Text) + -> Meta.VisibleNum + -> L.BottomLine + -> (Rb.Chunk, Rb.Chunk) +balanceChunks chgrs fmt vn bl = (chkDc, chkQt) + where + eo = E.fromVisibleNum vn + chkDc = E.bottomLineToDrCr bl eo chgrs + qtFmt = E.getEvenOddLabelValue lbl eo chgrs + chkQt = qtFmt $ Rb.plain t + (lbl, t) = case bl of + L.Zero -> (E.Zero, X.pack "--") + L.NonZero (L.Column dc qt) -> (E.dcToLbl dc, fmt qt) + + +indentAmount :: Int +indentAmount = 2 + diff --git a/lib/Penny/Cabin/Balance/Convert/Options.hs b/lib/Penny/Cabin/Balance/Convert/Options.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Cabin/Balance/Convert/Options.hs @@ -0,0 +1,43 @@ +-- | Default options for the Convert report when used from the command +-- line. +module Penny.Cabin.Balance.Convert.Options where + +import qualified Penny.Cabin.Balance.Convert.Parser as P +import qualified Penny.Cabin.Parsers as CP +import qualified Penny.Cabin.Options as CO +import qualified Penny.Lincoln as L +import qualified Penny.Shield as S +import qualified Data.Text as X + +-- | Default options for the Convert report. This record is used as +-- the starting point when parsing in options from the command +-- line. You don't need to use it if you are setting the options for +-- the Convert report directly from your own code. + +data DefaultOpts = DefaultOpts + { showZeroBalances :: CO.ShowZeroBalances + , target :: P.Target + , sortOrder :: CP.SortOrder + , sortBy :: P.SortBy + , format :: L.Commodity -> L.Qty -> X.Text + } + +toParserOpts :: DefaultOpts -> S.Runtime -> P.Opts +toParserOpts d rt = P.Opts + { P.showZeroBalances = showZeroBalances d + , P.target = target d + , P.dateTime = S.currentTime rt + , P.sortOrder = sortOrder d + , P.sortBy = sortBy d + } + +defaultOptions :: DefaultOpts +defaultOptions = DefaultOpts + { showZeroBalances = CO.ShowZeroBalances False + , target = P.AutoTarget + , sortOrder = CP.Ascending + , sortBy = P.SortByName + , format = \_ q -> X.pack . L.prettyShowQty $ q + } + + diff --git a/lib/Penny/Cabin/Balance/Convert/Parser.hs b/lib/Penny/Cabin/Balance/Convert/Parser.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Cabin/Balance/Convert/Parser.hs @@ -0,0 +1,87 @@ +-- | Parsing options for the Convert report from the command line. +module Penny.Cabin.Balance.Convert.Parser ( + Opts(..) + , Target(..) + , SortBy(..) + , allOptSpecs + ) where + + +import qualified Control.Monad.Exception.Synchronous as Ex +import qualified Data.Text as X +import qualified Penny.Cabin.Options as CO +import qualified Penny.Cabin.Parsers as P +import qualified Penny.Lincoln as L +import qualified Penny.Copper.Parsec as Pc +import qualified System.Console.MultiArg.Combinator as C +import qualified Text.Parsec as Parsec + + +-- | Is the target commodity determined by the user or automatically? +data Target = AutoTarget | ManualTarget L.To + +data SortBy = SortByQty | SortByName deriving (Eq, Show, Ord) + +-- | Default starting options for the Convert report. After +-- considering what is parsed in from the command line and price data, +-- a Convert.Opts will be generated. +data Opts = Opts + { showZeroBalances :: CO.ShowZeroBalances + , target :: Target + , dateTime :: L.DateTime + , sortOrder :: P.SortOrder + , sortBy :: SortBy + } + +-- | Do not be tempted to change the setup in this module so that the +-- individual functions such as parseColor and parseBackground return +-- parsers rather than OptSpec. Such an arrangement breaks the correct +-- parsing of abbreviated long options. +allOptSpecs :: [C.OptSpec (Opts -> Ex.Exceptional String Opts)] +allOptSpecs = + [ fmap toExc parseZeroBalances + , parseCommodity + , fmap toExc parseAuto + , parseDate + , fmap toExc parseSort + , fmap toExc parseOrder ] + where + toExc f = return . f + +parseZeroBalances :: C.OptSpec (Opts -> Opts) +parseZeroBalances = fmap f P.zeroBalances + where + f x o = o { showZeroBalances = x } + + +parseCommodity :: C.OptSpec (Opts -> Ex.Exceptional String Opts) +parseCommodity = C.OptSpec ["commodity"] "c" (C.OneArg f) + where + f a1 os = + case Parsec.parse Pc.lvl1Cmdty "" (X.pack a1) of + Left _ -> Ex.throw $ "invalid commodity: " ++ a1 + Right g -> return $ os { target = ManualTarget . L.To $ g } + +parseAuto :: C.OptSpec (Opts -> Opts) +parseAuto = C.OptSpec ["auto-commodity"] "" (C.NoArg f) + where + f os = os { target = AutoTarget } + +parseDate :: C.OptSpec (Opts -> Ex.Exceptional String Opts) +parseDate = C.OptSpec ["date"] "d" (C.OneArg f) + where + f a1 os = + case Parsec.parse Pc.dateTime "" (X.pack a1) of + Left _ -> Ex.throw $ "invalid date: " ++ a1 + Right g -> return $ os { dateTime = g } + +parseSort :: C.OptSpec (Opts -> Opts) +parseSort = C.OptSpec ["sort"] "s" (C.ChoiceArg ls) + where + ls = [ ("qty", (\os -> os { sortBy = SortByQty })) + , ("name", (\os -> os { sortBy = SortByName })) ] + +parseOrder :: C.OptSpec (Opts -> Opts) +parseOrder = fmap f P.order + where + f x o = o { sortOrder = x } diff --git a/lib/Penny/Cabin/Balance/MultiCommodity.hs b/lib/Penny/Cabin/Balance/MultiCommodity.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Cabin/Balance/MultiCommodity.hs @@ -0,0 +1,177 @@ +-- | The multi-commodity Balance report. This is the simpler balance +-- report because it does not allow for commodities to be converted. + +module Penny.Cabin.Balance.MultiCommodity ( + Opts(..), + defaultOpts, + defaultParseOpts, + defaultFormat, + parseReport, + defaultReport, + report + ) where + +import Control.Applicative (Applicative, pure) +import qualified Penny.Cabin.Balance.Util as U +import qualified Penny.Cabin.Scheme as E +import qualified Penny.Cabin.Scheme.Schemes as Schemes +import qualified Penny.Lincoln as L +import qualified Penny.Liberty as Ly +import qualified Data.Either as Ei +import qualified Data.Map as M +import qualified Penny.Cabin.Options as CO +import Data.Monoid (mappend, mempty) +import qualified Data.Text as X +import qualified Data.Tree as E +import qualified Penny.Cabin.Balance.MultiCommodity.Chunker as K +import qualified Penny.Cabin.Balance.MultiCommodity.Parser as P +import qualified Penny.Cabin.Interface as I +import qualified Penny.Cabin.Parsers as CP +import qualified System.Console.MultiArg as MA +import qualified System.Console.Rainbow as R + +-- | Options for making the balance report. These are the only options +-- needed to make the report if the options are not being parsed in +-- from the command line. +data Opts = Opts + { balanceFormat :: L.Commodity -> L.Qty -> X.Text + , showZeroBalances :: CO.ShowZeroBalances + , order :: L.SubAccount -> L.SubAccount -> Ordering + , textFormats :: E.Changers + } + +defaultOpts :: Opts +defaultOpts = Opts + { balanceFormat = defaultFormat + , showZeroBalances = CO.ShowZeroBalances True + , order = compare + , textFormats = Schemes.darkLabels + } + +defaultParseOpts :: P.ParseOpts +defaultParseOpts = P.ParseOpts + { P.showZeroBalances = CO.ShowZeroBalances False + , P.order = CP.Ascending + } + +fromParseOpts + :: E.Changers + -> (L.Commodity -> L.Qty -> X.Text) + -> P.ParseOpts + -> Opts +fromParseOpts chgrs fmt (P.ParseOpts szb o) = Opts fmt szb o' chgrs + where + o' = case o of + CP.Ascending -> compare + CP.Descending -> CO.descending compare + +defaultFormat :: a -> L.Qty -> X.Text +defaultFormat _ = X.pack . L.prettyShowQty + +summedSortedBalTree :: + CO.ShowZeroBalances + -> (L.SubAccount -> L.SubAccount -> Ordering) + -> [(a, L.Posting)] + -> (E.Forest (L.SubAccount, L.Balance), L.Balance) +summedSortedBalTree szb o = + U.sumForest mempty mappend + . U.sortForest o' + . U.balances szb + where + o' x y = o (fst x) (fst y) + +rows :: + (E.Forest (L.SubAccount, L.Balance), L.Balance) + -> [K.Row] +rows (o, b) = first:rest + where + first = K.Row 0 (X.pack "Total") (M.assocs . L.unBalance $ b) + rest = map row . concatMap E.flatten . map U.labelLevels $ o + row (l, (s, ib)) = + K.Row l (L.text s) (M.assocs . L.unBalance $ ib) + +-- | This report is what to use if you already have your options (that +-- is, you are not parsing them in from the command line.) +report :: Opts -> [(a, L.Posting)] -> [R.Chunk] +report (Opts bf szb o chgrs) = + K.rowsToChunks chgrs bf + . rows + . summedSortedBalTree szb o + +-- | The MultiCommodity report with configurable options that have +-- been parsed from the command line. +parseReport :: + (L.Commodity -> L.Qty -> X.Text) + -- ^ How to format balances. For instance you can use this to + -- perform commodity-sensitive digit grouping. + + -> P.ParseOpts + -- ^ Default options for the report. These can be overriden on the + -- command line. + + -> I.Report +parseReport fmt o rt = (help o, makeMode) + where + makeMode _ _ chgrs _ fsf = MA.Mode + { MA.mName = "balance" + , MA.mIntersperse = MA.Intersperse + , MA.mOpts = map (fmap Right) P.allSpecs + , MA.mPosArgs = return . Left + , MA.mProcess = process chgrs fmt o rt fsf + , MA.mHelp = const (help o) + } + +process + :: Applicative f + => E.Changers + -> (L.Commodity -> L.Qty -> X.Text) + -> P.ParseOpts + -> a + -> ([L.Transaction] -> [(Ly.LibertyMeta, L.Posting)]) + -> [Either String (P.ParseOpts -> P.ParseOpts)] + -> f I.ArgsAndReport +process chgrs fmt o _ fsf ls = + let (posArgs, fns) = Ei.partitionEithers ls + mkParsedOpts = foldl (flip (.)) id fns + os' = mkParsedOpts o + mcOpts = fromParseOpts chgrs fmt os' + pr txns _ = return $ report mcOpts (fsf txns) + in pure (posArgs, pr) + + +-- | The MultiCommodity report, with default options. +defaultReport :: I.Report +defaultReport = parseReport defaultFormat defaultParseOpts + +------------------------------------------------------------ +-- ## Help +------------------------------------------------------------ +ifDefault :: Bool -> String +ifDefault b = if b then " (default)" else "" + +help :: P.ParseOpts -> String +help o = unlines + [ "balance" + , " Show account balances. Accepts ONLY the following options:" + , "" + , "--show-zero-balances" + , " Show balances that are zero" + ++ ifDefault (CO.unShowZeroBalances . P.showZeroBalances $ o) + , "--hide-zero-balances" + , " Hide balances that are zero" + ++ ifDefault ( not . CO.unShowZeroBalances + . P.showZeroBalances $ o) + , "" + , "--ascending" + , " Sort in ascending order by account name" + ++ ifDefault (P.order o == CP.Ascending) + + , "--descending" + , " Sort in descending order by account name" + ++ ifDefault (P.order o == CP.Descending) + + , "" + , "--help, -h" + , " Show this help and exit" + ] + diff --git a/lib/Penny/Cabin/Balance/MultiCommodity/Chunker.hs b/lib/Penny/Cabin/Balance/MultiCommodity/Chunker.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Cabin/Balance/MultiCommodity/Chunker.hs @@ -0,0 +1,222 @@ +-- | Creates the output Chunks for the Balance report for both +-- multi-commodity reports. + +module Penny.Cabin.Balance.MultiCommodity.Chunker ( + Row(..), + rowsToChunks + ) where + + +import Control.Applicative + (Applicative (pure), (<$>), (<*>)) +import qualified Penny.Cabin.Meta as Meta +import qualified Penny.Cabin.Row as R +import qualified Penny.Cabin.Scheme as E +import qualified Penny.Lincoln as L +import qualified Data.Foldable as Fdbl +import qualified Data.Text as X +import qualified System.Console.Rainbow as Rb + +type IsEven = Bool + +data Columns a = Columns { + acct :: a + , drCr :: a + , commodity :: a + , quantity :: a + } deriving Show + +instance Functor Columns where + fmap f c = Columns { + acct = f (acct c) + , drCr = f (drCr c) + , commodity = f (commodity c) + , quantity = f (quantity c) + } + +instance Applicative Columns where + pure a = Columns a a a a + fn <*> fa = Columns { + acct = (acct fn) (acct fa) + , drCr = (drCr fn) (drCr fa) + , commodity = (commodity fn) (commodity fa) + , quantity = (quantity fn) (quantity fa) + } + +data PreSpec = PreSpec { + _justification :: R.Justification + , _padSpec :: (E.Label, E.EvenOdd) + , bits :: [Rb.Chunk] } + +-- | When given a list of columns, determine the widest row in each +-- column. +maxWidths :: [Columns PreSpec] -> Columns R.Width +maxWidths = Fdbl.foldl' maxWidthPerColumn (pure (R.Width 0)) + +-- | Applied to a Columns of PreSpec and a Colums of widths, return a +-- Columns that has the wider of the two values. +maxWidthPerColumn :: + Columns R.Width + -> Columns PreSpec + -> Columns R.Width +maxWidthPerColumn w p = f <$> w <*> p where + f old new = max old ( safeMaximum (R.Width 0) + . map (R.Width . X.length . Rb.chunkText) + . bits $ new) + safeMaximum d ls = if null ls then d else maximum ls + +-- | Changes a single set of Columns to a set of ColumnSpec of the +-- given width. +preSpecToSpec :: + Columns R.Width + -> Columns PreSpec + -> Columns R.ColumnSpec +preSpecToSpec ws p = f <$> ws <*> p where + f width (PreSpec j ps bs) = R.ColumnSpec j width ps bs + +resizeColumnsInList :: [Columns PreSpec] -> [Columns R.ColumnSpec] +resizeColumnsInList cs = map (preSpecToSpec w) cs where + w = maxWidths cs + + +-- Step 9 +widthSpacerAcct :: Int +widthSpacerAcct = 4 + +widthSpacerDrCr :: Int +widthSpacerDrCr = 1 + +widthSpacerCommodity :: Int +widthSpacerCommodity = 1 + +colsToBits + :: E.Changers + -> IsEven + -> Columns R.ColumnSpec + -> [Rb.Chunk] +colsToBits chgrs isEven (Columns a dc c q) = let + fillSpec = if isEven + then (E.Other, E.Even) + else (E.Other, E.Odd) + spacer w = R.ColumnSpec j (R.Width w) fillSpec [] + j = R.LeftJustify + cs = a + : spacer widthSpacerAcct + : dc + : spacer widthSpacerDrCr + : c + : spacer widthSpacerCommodity + : q + : [] + in R.row chgrs cs + +colsListToBits + :: E.Changers + -> [Columns R.ColumnSpec] + -> [[Rb.Chunk]] +colsListToBits chgrs = zipWith f bools where + f b c = colsToBits chgrs b c + bools = iterate not True + +preSpecsToBits + :: E.Changers + -> [Columns PreSpec] + -> [Rb.Chunk] +preSpecsToBits chgrs = + concat + . colsListToBits chgrs + . resizeColumnsInList + +-- | Displays a single account in a Balance report. In a +-- single-commodity report, this account will only be one screen line +-- long. In a multi-commodity report, it might be multiple lines long, +-- with one screen line for each commodity. +data Row = Row + { indentation :: Int + -- ^ Indent the account name by this many levels (not by this many + -- spaces; this number is multiplied by another number in the + -- Chunker source to arrive at the final indentation amount) + + , accountTxt :: X.Text + -- ^ Text for the name of the account + + , balances :: [(L.Commodity, L.BottomLine)] + -- ^ Commodity balances. If this list is empty, dashes are + -- displayed for the DrCr, Commodity, and Qty. + } + +rowsToChunks + :: E.Changers + -> (L.Commodity -> L.Qty -> X.Text) + -- ^ How to format a balance to allow for digit grouping + -> [Row] + -> [Rb.Chunk] +rowsToChunks chgrs fmt = + preSpecsToBits chgrs + . rowsToColumns chgrs fmt + +rowsToColumns + :: E.Changers + -> (L.Commodity -> L.Qty -> X.Text) + -- ^ How to format a balance to allow for digit grouping + + -> [Row] + -> [Columns PreSpec] +rowsToColumns chgrs fmt + = map (mkColumn chgrs fmt) + . L.serialItems (\ser a -> (Meta.VisibleNum ser, a)) + + +mkColumn + :: E.Changers + -> (L.Commodity -> L.Qty -> X.Text) + -> (Meta.VisibleNum, Row) + -> Columns PreSpec +mkColumn chgrs fmt (vn, (Row i acctTxt bs)) = Columns ca cd cc cq + where + lbl = E.Other + eo = E.fromVisibleNum vn + applyFmt = E.getEvenOddLabelValue lbl eo chgrs + ca = PreSpec R.LeftJustify (lbl, eo) [applyFmt $ Rb.plain txt] + where + txt = X.append indents acctTxt + indents = X.replicate (indentAmount * max 0 i) + (X.singleton ' ') + cd = PreSpec R.LeftJustify (lbl, eo) cksDrCr + cc = PreSpec R.RightJustify (lbl, eo) cksCmdty + cq = PreSpec R.LeftJustify (lbl, eo) cksQty + (cksDrCr, cksCmdty, cksQty) = + if null bs + then balanceChunksEmpty chgrs eo + else + let balChks = map (balanceChunks chgrs fmt eo) bs + cDrCr = map (\(a, _, _) -> a) balChks + cCmdty = map (\(_, a, _) -> a) balChks + cQty = map (\(_, _, a) -> a) balChks + in (cDrCr, cCmdty, cQty) + + +balanceChunksEmpty + :: E.Changers + -> E.EvenOdd + -> ([Rb.Chunk], [Rb.Chunk], [Rb.Chunk]) +balanceChunksEmpty chgrs eo = (dash, dash, dash) + where + dash = [E.getEvenOddLabelValue E.Other eo chgrs $ Rb.plain (X.pack "--")] + +balanceChunks + :: E.Changers + -> (L.Commodity -> L.Qty -> X.Text) + -> E.EvenOdd + -> (L.Commodity, L.BottomLine) + -> (Rb.Chunk, Rb.Chunk, Rb.Chunk) +balanceChunks chgrs fmt eo (cty, bl) = (chkDc, chkCt, chkQt) + where + chkDc = E.bottomLineToDrCr bl eo chgrs + chkCt = E.bottomLineToCmdty chgrs eo (cty, bl) + chkQt = E.bottomLineToQty chgrs fmt eo (cty, bl) + + +indentAmount :: Int +indentAmount = 2 + diff --git a/lib/Penny/Cabin/Balance/MultiCommodity/Parser.hs b/lib/Penny/Cabin/Balance/MultiCommodity/Parser.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Cabin/Balance/MultiCommodity/Parser.hs @@ -0,0 +1,29 @@ +module Penny.Cabin.Balance.MultiCommodity.Parser ( + ParseOpts(..) + , allSpecs + ) where + +import qualified Penny.Cabin.Options as CO +import qualified Penny.Cabin.Parsers as P +import qualified System.Console.MultiArg as MA + +-- | Options for the Balance report that have been parsed from the +-- command line. +data ParseOpts = ParseOpts + { showZeroBalances :: CO.ShowZeroBalances + , order :: P.SortOrder + } + + +zeroBalances :: MA.OptSpec (ParseOpts -> ParseOpts) +zeroBalances = fmap toResult P.zeroBalances + where + toResult szb o = o { showZeroBalances = szb } + +parseOrder :: MA.OptSpec (ParseOpts -> ParseOpts) +parseOrder = fmap toResult P.order + where + toResult x o = o { order = x } + +allSpecs :: [MA.OptSpec (ParseOpts -> ParseOpts)] +allSpecs = [zeroBalances, parseOrder] diff --git a/lib/Penny/Cabin/Balance/Util.hs b/lib/Penny/Cabin/Balance/Util.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Cabin/Balance/Util.hs @@ -0,0 +1,230 @@ +-- | Grab bag of utility functions. + +module Penny.Cabin.Balance.Util + ( tieredForest + , tieredPostings + , filterForest + , balances + , flatten + , treeWithParents + , forestWithParents + , sumForest + , sumTree + , boxesBalance + , labelLevels + , sortForest + , sortTree + , lastMode + ) where + +import qualified Penny.Cabin.Options as CO +import qualified Penny.Lincoln as L +import qualified Penny.Steel.NestedMap as NM +import qualified Data.Foldable as Fdbl +import qualified Data.Map as M +import Data.Ord (comparing) +import Data.List (sortBy, maximumBy, groupBy) +import Data.Monoid (mconcat, Monoid) +import Data.Maybe (mapMaybe) +import qualified Data.Tree as T +import qualified Penny.Lincoln.Queries as Q + +-- | Constructs a forest sorted into tiers based on lists of keys that +-- are extracted from the elements. +tieredForest :: + Ord k + => (a -> [k]) + -- ^ Extracts a key from the elements we are putting in the tree. If + -- this function returns an empty list for any element, the element + -- will not appear in the tiered forest. + -> [a] + -> T.Forest (k, [a]) +tieredForest getKeys ls = fmap (fmap revSnd) . NM.toForest $ nm + where + revSnd (a, xs) = (a, reverse xs) + nm = foldr f NM.empty ls + f a m = NM.relabel m ps + where + ps = case getKeys a of + [] -> [] + ks -> + let mkInitPair k = (k, maybe [] id) + mkLastPair k = (k, maybe [a] (a:)) + in (map mkInitPair . init $ ks) + ++ [(mkLastPair (last ks))] + +-- | Takes a list of postings and puts them into a Forest. Each level +-- of each of the trees corresponds to a sub account. The label of the +-- node tells you the sub account name and gives you a list of the +-- postings at that level. +tieredPostings + :: [(a, L.Posting)] + -> T.Forest (L.SubAccount, [(a, L.Posting)]) +tieredPostings = tieredForest e + where + e = Fdbl.toList . L.unAccount . Q.account . snd + +-- | Keeps only Trees that match a given condition. First examines +-- child trees to determine whether they should be retained. If a +-- child tree is retained, does not delete the parent tree. +filterForest :: (a -> Bool) -> T.Forest a -> T.Forest a +filterForest f = mapMaybe pruneTree + where + pruneTree (T.Node a fs) = + case filterForest f fs of + [] -> if not (f a) then Nothing else Just (T.Node a []) + cs -> Just (T.Node a cs) + + +-- | Puts all Boxes into a Tree and sums the balances. Removes +-- accounts that have empty balances if requested. Does NOT sum +-- balances from the bottom up. +balances :: + CO.ShowZeroBalances + -> [(a, L.Posting)] + -> T.Forest (L.SubAccount, L.Balance) +balances (CO.ShowZeroBalances szb) = + remover + . map (fmap (mapSnd boxesBalance)) + . tieredPostings + where + remover = + if szb + then id + else filterForest (not . M.null . L.unBalance . snd) + . map (fmap (mapSnd L.removeZeroCommodities)) + + +-- | Takes a tree of Balances (like what is produced by the 'balances' +-- function) and produces a flat list of accounts with the balance of +-- each account. +flatten + :: T.Forest (L.SubAccount, L.Balance) + -> [(L.Account, L.Balance)] +flatten = + concatMap T.flatten + . map (fmap toPair) . forestWithParents + where + toPair ((s, b), ls) = + case reverse . map fst $ ls of + [] -> (L.Account [s], b) + s1:sr -> (L.Account (s1 : (sr ++ [s])), b) + +-- | Takes a Tree and returns a Tree where each node has information +-- about its parent Nodes. The list of parent nodes has the most +-- immediate parent first and the most distant parent last. +treeWithParents :: T.Tree a -> T.Tree (a, [a]) +treeWithParents = treeWithParentsR [] + +-- | Given a list of the parents seen so far, return a Tree where each +-- node contains information about its parents. +treeWithParentsR :: [a] -> T.Tree a -> T.Tree (a, [a]) +treeWithParentsR ls (T.Node n cs) = T.Node (n, ls) cs' + where + cs' = map (treeWithParentsR (n:ls)) cs + +-- | Takes a Forest and returns a Forest where each node has +-- information about its parent Nodes. +forestWithParents :: T.Forest a -> T.Forest (a, [a]) +forestWithParents = map (treeWithParentsR []) + +-- | Sums a forest from the bottom up. Returns a pair, where the first +-- element is the forest, but with the second element of each node +-- replaced with the sum of that node and all its children. The second +-- element is the sum of all the second elements in the forest. +sumForest :: + s + -- ^ Zero + + -> (s -> s -> s) + -- ^ Combiner + + -> T.Forest (a, s) + -> (T.Forest (a, s), s) +sumForest z f ts = (ts', s) + where + ts' = map (sumTree z f) ts + s = foldr f z . map (snd . T.rootLabel) $ ts' + +-- | Sums a tree from the bottom up. +sumTree :: + s + -- ^ Zero + + -> (s -> s -> s) + -- ^ Combiner + + -> T.Tree (a, s) + -> T.Tree (a, s) +sumTree z f (T.Node (a, s) cs) = T.Node (a, f s cSum) cs' + where + (cs', cSum) = sumForest z f cs + + +boxesBalance :: [(a, L.Posting)] -> L.Balance +boxesBalance = mconcat . map L.entryToBalance . map Q.entry + . map snd + +mapSnd :: (a -> b) -> (f, a) -> (f, b) +mapSnd f (x, a) = (x, f a) + +-- | Label each level of a Tree with an integer indicating how deep it +-- is. The top node of the tree is level 0. +labelLevels :: T.Tree a -> T.Tree (Int, a) +labelLevels = go 0 + where + go l (T.Node x xs) = T.Node (l, x) (map (go (l + 1)) xs) + +-- | Sorts each level of a Forest. +sortForest :: + (a -> a -> Ordering) + -> T.Forest a + -> T.Forest a +sortForest o f = sortBy o' (map (sortTree o) f) + where + o' x y = o (T.rootLabel x) (T.rootLabel y) + +-- | Sorts each level of a Tree. +sortTree :: + (a -> a -> Ordering) + -> T.Tree a + -> T.Tree a +sortTree o (T.Node l f) = T.Node l (sortForest o f) + +-- | Like lastModeBy but using Ord. +lastMode :: Ord a => [a] -> Maybe a +lastMode = lastModeBy compare + +-- | Finds the mode of a list. Takes the mode that is located last in +-- the list. Returns Nothing if there is no mode (that is, if the list +-- is empty). +lastModeBy :: + (a -> a -> Ordering) + -> [a] + -> Maybe a +lastModeBy o ls = + case modesBy o' ls' of + [] -> Nothing + ms -> Just . fst . maximumBy fx $ ms + where + fx = comparing snd + ls' = zip ls ([0..] :: [Int]) + o' x y = o (fst x) (fst y) + +-- | Finds the modes of a list. +modesBy :: (a -> a -> Ordering) -> [a] -> [a] +modesBy o = + concat + . longestLists + . groupBy (\x y -> o x y == EQ) + . sortBy o + + +-- | Returns the longest lists. This function is partial. It is bottom +-- if the argument list is empty. Therefore, do not export this +-- function. +longestLists :: [[a]] -> [[a]] +longestLists as = + let lengths = map (\ls -> (ls, length ls)) as + maxLen = maximum . map snd $ lengths + in map fst . filter (\(_, len) -> len == maxLen) $ lengths diff --git a/lib/Penny/Cabin/Interface.hs b/lib/Penny/Cabin/Interface.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Cabin/Interface.hs @@ -0,0 +1,77 @@ +-- | An interface for other Penny components to use. A report is +-- anything that is a 'Report'. +module Penny.Cabin.Interface where + +import qualified Data.Prednote.Expressions as Exp +import qualified Penny.Cabin.Scheme as S +import Control.Monad.Exception.Synchronous (Exceptional) +import qualified Data.Text as X +import Text.Matchers (CaseSensitive) +import qualified Text.Matchers as TM +import qualified System.Console.MultiArg as MA +import qualified System.Console.Rainbow as R + +import qualified Penny.Lincoln as L +import qualified Penny.Liberty as Ly +import Penny.Shield (Runtime) + +-- | The function that will print the report, and the positional +-- arguments. If there was a problem parsing the command line options, +-- return an Exception with an error message. + +-- | Parsing the filter options can have one of two results: a help +-- string, or a list of positional arguments and a function that +-- prints a report. Or, the parse might fail. + +type PosArg = String +type HelpStr = String +type ArgsAndReport = ([PosArg], PrintReport) + +-- | The result of parsing the arguments to a report. Failures are +-- indicated with a Text. The name of the executable and the word +-- @error@ will be prepended to this Text; otherwise, it is printed +-- as-is, so be sure to include any trailing newline if needed. +type ParseResult = Exceptional X.Text ArgsAndReport + +type PrintReport + = [L.Transaction] + -- ^ All transactions; the report must sort and filter them + + -> [L.PricePoint] + -- ^ PricePoints to be included in the report + + + -> Exceptional X.Text [R.Chunk] + -- ^ The exception type is a strict Text, containing the error +-- message. The success type is a list of either a Chunk or a PreChunk +-- containing the resulting report. This allows for errors after the +-- list of transactions has been seen. The name of the executable and +-- the word @error@ will be prepended to this Text; otherwise, it is +-- printed as-is, so be sure to include any trailing newline if +-- needed. + + +type Report = Runtime -> (HelpStr, MkReport) +type MkReport + = CaseSensitive + -- ^ Result from previous parses indicating whether the user desires + -- case sensitivity (this may have been changed in the filtering + -- options) + + -> (CaseSensitive -> X.Text -> Exceptional X.Text TM.Matcher) + -- ^ Result from previous parsers indicating the matcher factory the + -- user wishes to use + + -> S.Changers + -- ^ Result from previous parsers indicating which color scheme to + -- use. + + -> Exp.ExprDesc + -- ^ Result from previous parsers indicating whether the user wants + -- RPN or infix + + -> ([L.Transaction] -> [(Ly.LibertyMeta, L.Posting)]) + -- ^ Result from previous parsers that will sort and filter incoming + -- transactions + + -> MA.Mode ParseResult diff --git a/lib/Penny/Cabin/Meta.hs b/lib/Penny/Cabin/Meta.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Cabin/Meta.hs @@ -0,0 +1,13 @@ +-- | Metadata that is specific to Cabin. +module Penny.Cabin.Meta where + +import qualified Penny.Lincoln as L + +-- | Each row that is visible on screen is assigned a VisibleNum. This +-- is used to number the rows in the report for the user's benefit. It +-- is also used to determine whether the row is even or odd for the +-- purpose of assigning the background color (this way the background +-- colors can alternate, like a checkbook register.) +newtype VisibleNum = VisibleNum { unVisibleNum :: L.Serial } + deriving (Eq, Show) + diff --git a/lib/Penny/Cabin/Options.hs b/lib/Penny/Cabin/Options.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Cabin/Options.hs @@ -0,0 +1,16 @@ +-- | Options applicable to multiple Cabin reports. + +module Penny.Cabin.Options where + +-- | Whether to show zero balances in reports. +newtype ShowZeroBalances = + ShowZeroBalances { unShowZeroBalances :: Bool } + deriving (Show, Eq) + +-- | Converts an ordering to a descending order. +descending :: (a -> a -> Ordering) + -> a -> a -> Ordering +descending f x y = case f x y of + LT -> GT + GT -> LT + EQ -> EQ diff --git a/lib/Penny/Cabin/Parsers.hs b/lib/Penny/Cabin/Parsers.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Cabin/Parsers.hs @@ -0,0 +1,24 @@ +-- | Command line parsers that are common to various Cabin reports. + +module Penny.Cabin.Parsers where + +import qualified Penny.Cabin.Options as CO +import qualified System.Console.MultiArg.Combinator as C + + +zeroBalances :: C.OptSpec CO.ShowZeroBalances +zeroBalances = C.OptSpec ["zero-balances"] "" (C.ChoiceArg ls) + where + ls = [ ("show", CO.ShowZeroBalances True) + , ("hide", CO.ShowZeroBalances False) ] + +data SortOrder = Ascending | Descending deriving (Eq, Ord, Show) + +order :: C.OptSpec SortOrder +order = C.OptSpec ["order"] "" (C.ChoiceArg ls) + where + ls = [ ("ascending", Ascending) + , ("descending", Descending) ] + +help :: C.OptSpec () +help = C.OptSpec ["help"] "h" (C.NoArg ()) diff --git a/lib/Penny/Cabin/Posts.hs b/lib/Penny/Cabin/Posts.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Cabin/Posts.hs @@ -0,0 +1,621 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | The Penny Postings report +-- +-- The Postings report displays postings in a tabular format designed +-- to be read by humans. Some terminology used in the Postings report: +-- +-- [@row@] The smallest unit that spans from left to right. A row, +-- however, might consist of more than one screen line. For example, +-- the running balance is shown on the far right side of the Postings +-- report. The running balance might consist of more than one +-- commodity. Each commodity is displayed on its own screen +-- line. However, all these lines put together are displayed in a +-- single row. +-- +-- [@column@] The smallest unit that spans from top to bottom. +-- +-- [@tranche@] Each posting is displayed in several rows. The group of +-- rows that is displayed for a single posting is called a tranche. +-- +-- [@tranche row@] Each tranche has a particular number of rows +-- (currently four); each of these rows is known as a tranche row. +-- +-- [@field@] Corresponds to a particular element of the posting, such +-- as whether it is a debit or credit or its payee. The user can +-- select which fields to see. +-- +-- [@allocation@] The width of the Payee and Account fields is +-- variable. Generally their width will adjust to fill the entire +-- width of the screen. The allocations of the Payee and Account +-- fields determine how much of the remaining space each field will +-- receive. +-- +-- The Postings report is easily customized from the command line to +-- show various fields. However, the order of the fields is not +-- configurable without editing the source code (sorry). + +module Penny.Cabin.Posts + ( postsReport + , zincReport + , defaultOptions + , ZincOpts(..) + , A.Alloc + , A.SubAccountLength(..) + , A.alloc + , yearMonthDay + , qtyAsIs + , balanceAsIs + , defaultWidth + , columnsVarToWidth + , widthFromRuntime + , defaultFields + , defaultSpacerWidth + , T.ReportWidth(..) + ) where + +import Control.Applicative ((<$>), (<*>)) +import qualified Control.Monad.Exception.Synchronous as Ex +import Data.List.Split (chunksOf) +import qualified Data.Either as Ei +import Data.Monoid ((<>)) +import qualified Data.Text as X +import qualified Penny.Cabin.Interface as I +import qualified Penny.Cabin.Options as CO +import qualified Penny.Cabin.Posts.Allocated as A +import qualified Penny.Cabin.Posts.Chunk as C +import qualified Penny.Cabin.Posts.Fields as F +import qualified Penny.Cabin.Posts.Meta as M +import qualified Penny.Cabin.Posts.Parser as P +import qualified Penny.Cabin.Posts.Spacers as S +import qualified Penny.Cabin.Posts.Types as T +import qualified Penny.Cabin.Scheme as E + +import qualified Penny.Lincoln as L +import qualified Penny.Lincoln.Queries as Q +import qualified Penny.Liberty as Ly +import qualified Penny.Shield as Sh +import qualified Data.Prednote.Expressions as Exp +import qualified Data.Prednote.Pdct as Pe +import qualified System.Console.Rainbow as Rb + +import Data.List (intersperse) +import Data.Maybe (catMaybes) +import qualified Data.Foldable as Fdbl +import Data.Time as Time +import qualified System.Console.MultiArg as MA +import System.Locale (defaultTimeLocale) +import Text.Matchers (CaseSensitive) + +-- | All information needed to make a Posts report. This function +-- never fails. +postsReport + :: E.Changers + -> CO.ShowZeroBalances + -> (Pe.Pdct (Ly.LibertyMeta, L.Posting)) + -- ^ Removes posts from the report if applying this function to the + -- post returns False. Posts removed still affect the running + -- balance. + + -> [Ly.PostFilterFn] + -- ^ Applies these post-filters to the list of posts that results + -- from applying the predicate above. Might remove more + -- postings. Postings removed still affect the running balance. + + -> C.ChunkOpts + -> [(Ly.LibertyMeta, L.Posting)] + -> [Rb.Chunk] + +postsReport ch szb pdct pff co = + C.makeChunk ch co + . M.toBoxList szb pdct pff + + +zincReport :: ZincOpts -> I.Report +zincReport opts rt = (helpStr opts, md) + where + md cs fty ch expr fsf = MA.Mode + { MA.mName = "postings" + , MA.mIntersperse = MA.Intersperse + , MA.mOpts = specs rt + , MA.mPosArgs = return . Left + , MA.mProcess = process opts cs fty ch expr fsf + , MA.mHelp = const (helpStr opts) + } + +specs + :: Sh.Runtime + -> [MA.OptSpec (Either String (P.State -> Ex.Exceptional X.Text P.State))] +specs = map (fmap Right) . P.allSpecs + + +process + :: ZincOpts + -> CaseSensitive + -> L.Factory + -> E.Changers + -> Exp.ExprDesc + -> ([L.Transaction] -> [(Ly.LibertyMeta, L.Posting)]) + -> [Either String (P.State -> Ex.Exceptional X.Text P.State)] + -> Ex.Exceptional X.Text I.ArgsAndReport +process os cs fty ch expr fsf ls = + let (posArgs, clOpts) = Ei.partitionEithers ls + pState = newParseState cs fty expr os + exState' = foldl (>>=) (return pState) clOpts + in fmap (mkPrintReport posArgs os ch fsf) exState' + +mkPrintReport + :: [String] + -> ZincOpts + -> E.Changers + -> ([L.Transaction] -> [(Ly.LibertyMeta, L.Posting)]) + -> P.State + -> I.ArgsAndReport +mkPrintReport posArgs zo ch fsf st = (posArgs, f) + where + f txns _ = do + pdct <- getPredicate (P.exprDesc st) (P.tokens st) + let boxes = fsf txns + rptChks = postsReport ch (P.showZeroBalances st) pdct + (P.postFilter st) (chunkOpts st zo) boxes + expChks = showExpression (P.showExpression st) pdct + verbChks = showVerboseFilter (P.verboseFilter st) pdct boxes + chks = expChks + ++ verbChks + ++ rptChks + return chks + +indentAmt :: Pe.IndentAmt +indentAmt = 4 + +blankLine :: Rb.Chunk +blankLine = Rb.plain (X.singleton '\n') + +showExpression + :: P.ShowExpression + -> Pe.Pdct ((Ly.LibertyMeta, L.Posting)) + -> [Rb.Chunk] +showExpression (P.ShowExpression b) pdct = + if not b then [] else info : blankLine : (chks ++ [blankLine]) + where + info = Rb.plain (X.pack "Postings filter expression:\n") + chks = Pe.showPdct indentAmt 0 pdct + +showVerboseFilter + :: P.VerboseFilter + -> Pe.Pdct ((Ly.LibertyMeta, L.Posting)) + -> [(Ly.LibertyMeta, L.Posting)] + -> [Rb.Chunk] +showVerboseFilter (P.VerboseFilter b) pdct bs = + if not b then [] else info : blankLine : (chks ++ [blankLine]) + where + pdcts = map (makeLabeledPdct pdct) bs + chks = concat . map snd $ zipWith doEval bs pdcts + doEval subj pd = Pe.evaluate indentAmt False subj 0 pd + info = Rb.plain (X.pack "Postings report filter:\n") + +-- | Creates a Pdct and prepends a one-line description of the PostFam +-- to the Pdct's label so it can be easily identified in the output. +makeLabeledPdct + :: Pe.Pdct ((Ly.LibertyMeta, L.Posting)) + -> (Ly.LibertyMeta, L.Posting) + -> Pe.Pdct ((Ly.LibertyMeta, L.Posting)) +makeLabeledPdct pd box = Pe.rename f pd + where + f old = old <> " - " <> L.display pf + pf = snd box + +defaultOptions + :: Sh.Runtime + -> ZincOpts +defaultOptions rt = ZincOpts + { fields = defaultFields + , width = widthFromRuntime rt + , showZeroBalances = CO.ShowZeroBalances False + , dateFormat = yearMonthDay + , qtyFormat = qtyAsIs + , balanceFormat = balanceAsIs + , subAccountLength = A.SubAccountLength 2 + , payeeAllocation = A.alloc 60 + , accountAllocation = A.alloc 40 + , spacers = defaultSpacerWidth + } + + +type Error = X.Text + +getPredicate + :: Exp.ExprDesc + -> [Exp.Token ((Ly.LibertyMeta, L.Posting))] + -> Ex.Exceptional Error (Pe.Pdct ((Ly.LibertyMeta, L.Posting))) +getPredicate d ts = + case ts of + [] -> return $ Pe.always + _ -> Exp.parseExpression d ts + + +-- | All the information to configure the postings report if the +-- options will be parsed in from the command line. +data ZincOpts = ZincOpts + { fields :: F.Fields Bool + -- ^ Default fields to show in the report. + + , width :: T.ReportWidth + -- ^ Gives the default report width. This can be + -- overridden on the command line. You can use the + -- information from the Runtime to make this as wide as + -- the current terminal. + + , showZeroBalances :: CO.ShowZeroBalances + -- ^ Are commodities that have no balance shown in the Total fields + -- of the report? + + , dateFormat :: (M.PostMeta, L.Posting) -> X.Text + -- ^ How to display dates. This function is applied to the + -- a PostingInfo so it has lots of information, but it + -- should return a date for use in the Date field. + + , qtyFormat :: (M.PostMeta, L.Posting) -> X.Text + -- ^ How to display the quantity of the posting. This + -- function is applied to a Box so it has lots of + -- information, but it should return a formatted string of + -- the quantity. Allows you to format digit grouping, + -- radix points, perform rounding, etc. + + , balanceFormat :: L.Commodity -> L.Qty -> X.Text + -- ^ How to display balance totals. Similar to + -- balanceFormat. + + , subAccountLength :: A.SubAccountLength + -- ^ When shortening the names of sub accounts to make + -- them fit, they will be this long. + + , payeeAllocation :: A.Alloc + -- ^ This and accountAllocation determine how much space + -- payees and accounts receive. They divide up the + -- remaining space after everything else is displayed. For + -- instance if payeeAllocation is 60 and accountAllocation + -- is 40, the payee takes about 60 percent of the + -- remaining space and the account takes about 40 percent. + + , accountAllocation :: A.Alloc + -- ^ See payeeAllocation above + + , spacers :: S.Spacers Int + -- ^ Default width for spacer fields. If any of these Ints are + -- less than or equal to zero, there will be no spacer. There is + -- never a spacer for fields that do not appear in the report. + + } + +chunkOpts :: + P.State + -> ZincOpts + -> C.ChunkOpts +chunkOpts s z = C.ChunkOpts + { C.dateFormat = dateFormat z + , C.qtyFormat = qtyFormat z + , C.balanceFormat = balanceFormat z + , C.fields = P.fields s + , C.subAccountLength = subAccountLength z + , C.payeeAllocation = payeeAllocation z + , C.accountAllocation = accountAllocation z + , C.spacers = spacers z + , C.reportWidth = P.width s + } + + +newParseState :: + CaseSensitive + -> L.Factory + -> Exp.ExprDesc + -> ZincOpts + -> P.State +newParseState cs fty expr o = P.State + { P.sensitive = cs + , P.factory = fty + , P.tokens = [] + , P.postFilter = [] + , P.fields = fields o + , P.width = width o + , P.showZeroBalances = showZeroBalances o + , P.exprDesc = expr + , P.verboseFilter = P.VerboseFilter False + , P.showExpression = P.ShowExpression False + } + +-- | Shows the date of a posting in YYYY-MM-DD format. +yearMonthDay :: (M.PostMeta, L.Posting) -> X.Text +yearMonthDay p = X.pack (Time.formatTime defaultTimeLocale fmt d) + where + d = L.day + . Q.dateTime + . snd + $ p + fmt = "%Y-%m-%d" + +-- | Shows the quantity of a posting. Does no rounding or +-- prettification; simply uses show on the underlying Decimal. +qtyAsIs :: (M.PostMeta, L.Posting) -> X.Text +qtyAsIs p = X.pack . L.prettyShowQty . Q.qty . snd $ p + +-- | Shows the quantity of a balance. If there is no quantity, shows +-- two dashes. +balanceAsIs :: a -> L.Qty -> X.Text +balanceAsIs _ = X.pack . L.prettyShowQty + +-- | The default width for the report. +defaultWidth :: T.ReportWidth +defaultWidth = T.ReportWidth 80 + +-- | Applied to the value of the COLUMNS environment variable, returns +-- an appropriate ReportWidth. +columnsVarToWidth :: Maybe String -> T.ReportWidth +columnsVarToWidth ms = case ms of + Nothing -> defaultWidth + Just str -> case reads str of + [] -> defaultWidth + (i, []):[] -> if i > 0 then T.ReportWidth i else defaultWidth + _ -> defaultWidth + +-- | Given the Runtime, use the defaultWidth given above to calculate +-- the report's width if COLUMNS does not yield a value. Otherwise, +-- use what is in COLUMNS. +widthFromRuntime :: Sh.Runtime -> T.ReportWidth +widthFromRuntime rt = case Sh.screenWidth rt of + Nothing -> defaultWidth + Just w -> T.ReportWidth . Sh.unScreenWidth $ w + +-- | Default fields to show in the Postings report. +defaultFields :: F.Fields Bool +defaultFields = + F.Fields { F.globalTransaction = False + , F.revGlobalTransaction = False + , F.globalPosting = False + , F.revGlobalPosting = False + , F.fileTransaction = False + , F.revFileTransaction = False + , F.filePosting = False + , F.revFilePosting = False + , F.filtered = False + , F.revFiltered = False + , F.sorted = False + , F.revSorted = False + , F.visible = False + , F.revVisible = False + , F.lineNum = False + , F.date = True + , F.flag = False + , F.number = False + , F.payee = True + , F.account = True + , F.postingDrCr = True + , F.postingCmdty = True + , F.postingQty = True + , F.totalDrCr = True + , F.totalCmdty = True + , F.totalQty = True + , F.tags = False + , F.memo = False + , F.filename = False } + +-- | Default width of spacers; most are one character wide, but the +-- spacer after payee is 4 characters wide. +defaultSpacerWidth :: S.Spacers Int +defaultSpacerWidth = + S.Spacers { S.globalTransaction = 1 + , S.revGlobalTransaction = 1 + , S.globalPosting = 1 + , S.revGlobalPosting = 1 + , S.fileTransaction = 1 + , S.revFileTransaction = 1 + , S.filePosting = 1 + , S.revFilePosting = 1 + , S.filtered = 1 + , S.revFiltered = 1 + , S.sorted = 1 + , S.revSorted = 1 + , S.visible = 1 + , S.revVisible = 1 + , S.lineNum = 1 + , S.date = 1 + , S.flag = 1 + , S.number = 1 + , S.payee = 4 + , S.account = 1 + , S.postingDrCr = 1 + , S.postingCmdty = 1 + , S.postingQty = 1 + , S.totalDrCr = 1 + , S.totalCmdty = 1 } + +------------------------------------------------------------ +-- ## Help +------------------------------------------------------------ + +ifDefault :: Bool -> String +ifDefault b = if b then " (default)" else "" + +helpStr :: ZincOpts -> String +helpStr o = unlines $ + [ "postings" + , " Show postings in order with a running balance." + , " Accepts the following options:" + , "" + , "Posting filters" + , "===============" + , "These options affect which postings are shown in the report." + , "Postings not shown still affect the running balance." + , "" + , "Dates" + , "-----" + , "" + , "--date cmp timespec, -d cmp timespec" + , " Date must be within the time frame given. timespec" + , " is a day or a day and a time. Valid values for cmp:" + , " <, >, <=, >=, ==, /=, !=" + , "--current" + , " Same as \"--date <= (right now) \"" + , "" + , "Serials" + , "-------" + , "These options take the form --option cmp num; the given" + , "sequence number must fall within the given range. \"rev\"" + , "in the option name indicates numbering is from end to beginning." + , "" + , "--globalTransaction, --revGlobalTransaction" + , " All transactions, after reading the ledger files" + , "--globalPosting, --revGlobalPosting" + , " All postings, after reading the leder files" + , "--fileTransaction, --revFileTransaction" + , " Transactions in each ledger file, after reading the files" + , " (numbering restarts with each file)" + , "--filePosting, --revFilePosting" + , " Postings in each ledger file, after reading the files" + , " (numbering restarts with each file)" + , "--filtered, --revFiltered" + , " All postings, after filters given in the filter" + , " specification portion of the command line are" + , " applied" + , "--sorted, --revSorted" + , " All postings remaining after filtering and after" + , " postings have been sorted" + , "" + , "Pattern matching" + , "----------------" + , "" + , "-a pattern, --account pattern" + , " Pattern must match colon-separated account name" + , "--account-level num pat" + , " Pattern must match sub account at given level" + , "--account-any pat" + , " Pattern must match sub account at any level" + , "-p pattern, --payee pattern" + , " Payee must match pattern" + , "-t pattern, --tag pattern" + , " Tag must match pattern" + , "--number pattern" + , " Number must match pattern" + , "--flag pattern" + , " Flag must match pattern" + , "--commodity pattern" + , " Pattern must match colon-separated commodity name" + , "--posting-memo pattern" + , " Posting memo must match pattern" + , "--transaction-memo pattern" + , " Transaction memo must match pattern" + , "" + , "Other posting characteristics" + , "-----------------------------" + , "--debit" + , " Entry must be a debit" + , "--credit" + , " Entry must be a credit" + , "--qty cmp number" + , " Entry quantity must fall within given range" + , "" + , "Infix or RPN selection" + , "----------------------" + , "--infix - use infix notation" + , "--rpn - use reverse polish notation" + , " (default: use what was used in the filtering options)" + , "" + , "Infix Operators - from highest to lowest precedence" + , "(all are left associative)" + , "--------------------------" + , "--open expr --close" + , " Force precedence (as in \"open\" and \"close\" parentheses)" + , "--not expr" + , " True if expr is false" + , "expr1 --and expr2 " + , " True if expr and expr2 are both true" + , "expr1 --or expr2" + , " True if either expr1 or expr2 is true" + , "" + , "RPN Operators" + , "-------------" + , "expr --not" + , " True if expr is false" + , "expr1 expr2 --and" + , " True if expr and expr2 are both true" + , "expr1 expr2 --or" + , " True if either expr1 or expr2 is true" + , "" + , "Options affecting patterns" + , "==========================" + , "" + , "-i, --case-insensitive" + , " Be case insensitive" + , "-I, --case-sensitive" + , " Be case sensitive" + , "" + , "--within" + , " Use \"within\" matcher" + , "--pcre" + , " Use \"pcre\" matcher" + , "--posix" + , " Use \"posix\" matcher" + , "--exact" + , " Use \"exact\" matcher" + , "" + , "Removing postings after sorting and filtering" + , "=============================================" + , "--head n" + , " Keep only the first n postings" + , "--tail n" + , " Keep only the last n postings" + , "" + , "Other options" + , "=============" + , "--width num" + , " Hint for roughly how wide the report should be in columns" + , " (currently: " ++ (show . T.unReportWidth . width $ o) ++ ")" + , "--show field, --hide field" + , " show or hide this field, where field is one of:" + , " globalTransaction, revGlobalTransaction," + , " globalPosting, revGlobalPosting," + , " fileTransaction, revFileTransaction," + , " filePosting, revFilePosting," + , " filtered, revFiltered," + , " sorted, revSorted," + , " visible, revVisible," + , " lineNum," + , " date, flag, number, payee, account," + , " postingDrCr, postingCommodity, postingQty," + , " totalDrCr, totalCommodity, totalQty," + , " tags, memo, filename" + , "--show-all" + , " Show all fields" + , "--hide-all" + , " Hide all fields" + , "" + ] ++ showDefaultFields (fields o) ++ + [ "" + , "--show-zero-balances" + , " Show balances that are zero" + ++ ifDefault (CO.unShowZeroBalances . showZeroBalances $ o) + , "--hide-zero-balances" + , " Hide balances that are zero" + ++ ifDefault (not . CO.unShowZeroBalances . showZeroBalances $ o) + , "" + , "--help, -h" + , " Show this help and exit" + ] + +-- | Shows which fields are on by default. +showDefaultFields :: F.Fields Bool -> [String] +showDefaultFields i = hdr : rest + where + hdr = "Fields shown by default:" + ++ if null rest then " (none)" else "" + rest = + map (" " ++) + . map concat + . map (intersperse ", ") + . chunksOf 3 + . catMaybes + . Fdbl.toList + . toMaybes + $ i + toMaybes flds = f <$> flds <*> F.fieldNames + f b n = if b then Just n else Nothing diff --git a/lib/Penny/Cabin/Posts/Allocated.hs b/lib/Penny/Cabin/Posts/Allocated.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Cabin/Posts/Allocated.hs @@ -0,0 +1,401 @@ +-- | Calculates the allocated cells -- the Payee cell and the Account +-- cell. Here is the logic for this process: +-- +-- 1. If neither Payee nor Account appears, do nothing. +-- +-- 2. Obtain the width of the growing cells, including the +-- spacers. One of the spacers attached to a field might be omitted: +-- +-- a. If the rightmost growing field is TotalQty, include all spacers. +-- +-- b. If the rightmost growing field is to the left of Payee, include +-- all spacers. +-- +-- c. If the rightmost growing field is to the right of Account but is +-- not TotalQty, omit its spacer. +-- +-- 2. Obtain the width of the Payee and Account spacers. Include each +-- spacer if its corresponding field appears in the report. +-- +-- 3. Subtract from the total report width the width of the the +-- growing cells and the width of the Payee and Account spacers. This +-- gives the total width available for the Payee and Account +-- fields. If there are not at least two columns available, return +-- without including the Payee and Account fields. +-- +-- 4. Determine the total width that the Payee and Account fields +-- would obtain if they had all the space they could ever need. This +-- is the "requested width". +-- +-- 5. Split up the available width for the Payee and Account fields +-- depending on which fields appear: +-- +-- a. If only the one field appears, then it shall be as wide as the +-- total available width or the its requested width, whichever is +-- smaller. +-- +-- b. If both fields appear, then calculate the allocated width for +-- each field. If either field's requested width is less than its +-- allocated width, then that field is only as wide as its requested +-- width. The other field is then as wide as (the sum of its allocated +-- width and the leftover width from the other field) or its requested +-- width, whichever is smaller. If neither field's requested width is +-- less than its allocated width, then each field gets ts allocated +-- width. +-- +-- 6. Fill cell contents; return filled cells. + +module Penny.Cabin.Posts.Allocated ( + payeeAndAcct + , AllocatedOpts(..) + , Fields(..) + , SubAccountLength(..) + , Alloc + , alloc + , unAlloc + ) where + +import Control.Applicative(Applicative((<*>), pure), (<$>)) +import Control.Arrow (second) +import Data.Maybe (catMaybes, isJust) +import Data.List (intersperse) +import qualified Data.Foldable as Fdbl +import qualified Data.Sequence as Seq +import qualified Data.Traversable as T +import qualified Data.Text as X +import qualified System.Console.Rainbow as Rb +import qualified Penny.Cabin.Row as R +import qualified Penny.Cabin.Posts.Growers as G +import qualified Penny.Cabin.Posts.Meta as M +import qualified Penny.Cabin.Posts.Spacers as S +import qualified Penny.Cabin.Posts.Types as Ty +import qualified Penny.Cabin.Scheme as E +import qualified Penny.Cabin.TextFormat as TF +import qualified Penny.Lincoln as L +import qualified Penny.Lincoln.Bits.Qty as Qty +import qualified Penny.Lincoln.Queries as Q +import qualified Penny.Lincoln.HasText as HT + +data Fields a = Fields { + payee :: a + , account :: a + } deriving (Eq, Show) + +newtype SubAccountLength = + SubAccountLength { unSubAccountLength :: Int } + deriving Show + +newtype Alloc = Alloc { unAlloc :: Int } + deriving Show + +alloc :: Int -> Alloc +alloc i = + if i < 1 + then error $ "allocations must be greater than zero." + ++ " supplied allocation: " ++ show i + else Alloc i + + +-- | All the information needed for allocated cells. +data AllocatedOpts = AllocatedOpts + { fields :: Fields Bool + , subAccountLength :: SubAccountLength + , allocations :: Fields Alloc + , spacers :: S.Spacers Int + , growerWidths :: G.Fields (Maybe Int) + , reportWidth :: Ty.ReportWidth + } + +-- | Creates Payee and Account cells. The user must have requested the +-- cells. In addition, no cells are created if there is not enough +-- space for them in the report. Returns a Fields; each element of the +-- Fields is Nothing if no cells were created (either because the user +-- did not ask for them, or because there was no room) or Just cs i, +-- where cs is a list of all the cells, and i is the width of all the +-- cells. +payeeAndAcct + :: E.Changers + -> AllocatedOpts + -> [(M.PostMeta, L.Posting)] + -> Fields (Maybe ([R.ColumnSpec], Int)) +payeeAndAcct ch ao bs = + let allBuilders = + T.traverse (builders ch (subAccountLength ao)) bs + availWidth = availableWidthForAllocs (growerWidths ao) + (spacers ao) (fields ao) (reportWidth ao) + finals = divideAvailableWidth availWidth (fields ao) + (allocations ao) + ( fmap (safeMaximum (Request 0)) + . fmap (fmap fst) $ allBuilders) + in fmap (fmap (second unFinal)) + . buildSpecs finals + . fmap (fmap snd) + $ allBuilders + + +safeMaximum :: Ord a => a -> [a] -> a +safeMaximum d ls = case ls of + [] -> d + xs -> maximum xs + +payeeAndAccountSpacerWidth + :: Fields Bool + -> S.Spacers Int + -> Int +payeeAndAccountSpacerWidth flds ss = pye + act + where + pye = if payee flds then abs (S.payee ss) else 0 + act = if account flds then abs (S.account ss) else 0 + +newtype AvailableWidth = AvailableWidth Int + deriving (Eq, Ord, Show) + +availableWidthForAllocs + :: G.Fields (Maybe Int) + -> S.Spacers Int + -> Fields Bool + -> Ty.ReportWidth + -> AvailableWidth +availableWidthForAllocs growers ss flds (Ty.ReportWidth w) = + AvailableWidth $ max 0 diff + where + tot = sumGrowersAndSpacers growers ss + + payeeAndAccountSpacerWidth flds ss + diff = w - tot + +-- | Sums spacers for growing cells. This function is intended for use +-- only by the functions that allocate cells for the report, so it +-- assumes that either the Payee or the Account field is showing. Sums +-- all spacers, UNLESS the rightmost field is from PostingDrCr to +-- TotalCmdty, in which case the rightmost spacer is omitted. Apply to +-- the second element of the tuple returned by growCells (which +-- reflects which fields actually have width) and to the accompanying +-- Spacers. +sumSpacers :: + G.Fields (Maybe a) + -> S.Spacers Int + -> Int +sumSpacers fs = + sum + . map fst + . appearingSpacers + . catMaybes + . Fdbl.toList + . fmap toWidth + . pairedWithSpacers fs + + +-- | Takes a triple: +-- +-- * The first element is Just _ if the field appears in the report; +-- Nothing if not +-- +-- * The second element is Maybe Int for the width of the spacer +-- (TotalQty has no spacer, so it will be Nothing) +-- +-- * The third element is the EFields tag +-- +-- Returns Nothing if the field does not appear in the report. Returns +-- Just a pair if the field does appear in the report, where the first +-- element is the width of the spacer, and the second element is the +-- EFields tag. +toWidth :: (Maybe a, Maybe Int, t) -> Maybe (Int, t) +toWidth (maybeShowing, maybeWidth, tag) = + if isJust maybeShowing + then case maybeWidth of + Just w -> Just (w, tag) + Nothing -> Just (0, tag) + else Nothing + + +-- | Given a list of all spacers that are attached to the fields that +-- are present in a report, return a list of the spacers that will +-- actually appear in the report. The rightmost spacer does not appear +-- if it is to the right of Account (unless there is a TotalQty field, +-- in which case, all spacers appear because TotalQty has no spacer.) +appearingSpacers :: [(Int, G.EFields)] -> [(Int, G.EFields)] +appearingSpacers ss = case ss of + [] -> [] + l -> case snd $ last l of + G.ETotalQty -> l + t -> if t > G.ENumber + then init l + else l + +-- | Applied to two arguments: first, a Fields, and second, a +-- Spacers. Combines each Field with its corresponding Spacer and with +-- the GFields, which indicates each particular field. +pairedWithSpacers :: + G.Fields a + -> S.Spacers b + -> G.Fields (a, Maybe b, G.EFields) +pairedWithSpacers f s = + (\(a, b) c -> (a, b, c)) + <$> G.pairWithSpacer f s + <*> G.eFields + +-- | Sums the widths of growing cells and their accompanying +-- spacers; makes the adjustments described in sumSpacers. +sumGrowersAndSpacers :: + G.Fields (Maybe Int) + -> S.Spacers Int + -> Int +sumGrowersAndSpacers fs ss = spcrs + flds where + spcrs = sumSpacers fs ss + flds = Fdbl.foldr f 0 fs where + f maybeI acc = case maybeI of + Nothing -> acc + Just i -> acc + i + +newtype Request = Request { unRequest :: Int } + deriving (Eq, Ord, Show) + +newtype Final = Final { unFinal :: Int } + deriving (Eq, Ord, Show) + + +buildSpecs + :: Fields (Maybe Final) + -> Fields ([Final -> R.ColumnSpec]) + -> Fields (Maybe ([R.ColumnSpec], Final)) +buildSpecs finals bs = f <$> finals <*> bs + where + f mayFinal gs = case mayFinal of + Nothing -> Nothing + Just fin -> Just ((gs <*> pure fin), fin) + + +-- | Divide the total available width between the two fields. +divideAvailableWidth + :: AvailableWidth + -> Fields Bool + -> Fields Alloc + -> Fields Request + -> Fields (Maybe Final) +divideAvailableWidth (AvailableWidth aw) appear allocs rws = Fields pye act + where + minFinal i1 i2 = + let m = min i1 i2 + in if m > 0 then Just . Final $ m else Nothing + pairAtLeast i1 i2 = (atLeast i1, atLeast i2) + where atLeast i = if i > 0 then Just . Final $ i else Nothing + reqP = unRequest . payee $ rws + reqA = unRequest . account $ rws + (pye, act) = case (payee appear, account appear) of + (False, False) -> (Nothing, Nothing) + (True, False) -> (minFinal reqP aw, Nothing) + (False, True) -> (Nothing, minFinal reqA aw) + (True, True) -> + let votes = [unAlloc . payee $ allocs, unAlloc . account $ allocs] + allocRslt = Qty.largestRemainderMethod (fromIntegral aw) + (map fromIntegral votes) + (allocP, allocA) = case allocRslt of + x:y:[] -> (fromIntegral x, fromIntegral y) + _ -> error "divideAvailableWidth error" + in case (allocP > reqP, allocA > reqA) of + (True, True) -> pairAtLeast reqP reqA + (True, False) -> + pairAtLeast reqP $ (min (allocA + (allocP - reqP))) reqA + (False, True) -> + pairAtLeast (min reqP (allocP + (allocA - reqA))) reqA + (False, False) -> pairAtLeast allocP allocA + + +builders + :: E.Changers + -> SubAccountLength + -> (M.PostMeta, L.Posting) + -> Fields (Request, Final -> R.ColumnSpec) +builders ch sl b = Fields (buildPayee ch b) (buildAcct ch sl b) + +buildPayee + :: E.Changers + -> (M.PostMeta, L.Posting) + -> (Request, Final -> R.ColumnSpec) + -- ^ Returns a tuple. The first element is the maximum width that + -- this cell needs to display its value perfectly. The second + -- element is a function that, when applied to an actual width, + -- returns a ColumnSpec. + +buildPayee ch i = (maxW, mkSpec) + where + pb = snd i + eo = E.fromVisibleNum . M.visibleNum . fst $ i + j = R.LeftJustify + ps = (E.Other, eo) + md = E.getEvenOddLabelValue E.Other eo ch + mayPye = Q.payee pb + maxW = Request $ maybe 0 (X.length . HT.text) mayPye + mkSpec (Final w) = R.ColumnSpec j (R.Width w) ps sq + where + sq = case mayPye of + Nothing -> [] + Just pye -> + let wrapped = + Fdbl.toList + . TF.unLines + . TF.wordWrap w + . TF.txtWords + . HT.text + $ pye + toBit (TF.Words seqTxts) = + md + . Rb.plain + . X.unwords + . Fdbl.toList + $ seqTxts + in fmap toBit wrapped + + +buildAcct + :: E.Changers + -> SubAccountLength + -> (M.PostMeta, L.Posting) + -> (Request, Final -> R.ColumnSpec) + -- ^ Returns a tuple. The first element is the maximum width that + -- this cell needs to display its value perfectly. The second + -- element is a function that, when applied to an actual width, + -- returns a ColumnSpec. + +buildAcct ch sl i = (maxW, mkSpec) + where + pb = snd i + eo = E.fromVisibleNum . M.visibleNum . fst $ i + ps = (E.Other, eo) + aList = L.unAccount . Q.account $ pb + maxW = Request + $ (sum . map (X.length . L.unSubAccount) $ aList) + + max 0 (length aList - 1) + md = E.getEvenOddLabelValue E.Other eo ch + mkSpec (Final aw) = R.ColumnSpec R.LeftJustify (R.Width aw) ps sq + where + target = TF.Target aw + shortest = TF.Shortest . unSubAccountLength $ sl + ws = TF.Words . Seq.fromList . map L.unSubAccount $ aList + (TF.Words shortened) = TF.shorten shortest target ws + sq = [ md + . Rb.plain + . X.concat + . intersperse (X.singleton ':') + . Fdbl.toList + $ shortened ] + +instance Functor Fields where + fmap f i = Fields { + payee = f (payee i) + , account = f (account i) } + +instance Applicative Fields where + pure a = Fields a a + ff <*> fa = Fields { + payee = payee ff (payee fa) + , account = account ff (account fa) } + +instance Fdbl.Foldable Fields where + foldr f z flds = + f (payee flds) (f (account flds) z) + +instance T.Traversable Fields where + traverse f flds = + Fields <$> f (payee flds) <*> f (account flds) + diff --git a/lib/Penny/Cabin/Posts/BottomRows.hs b/lib/Penny/Cabin/Posts/BottomRows.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Cabin/Posts/BottomRows.hs @@ -0,0 +1,648 @@ +-- | Fills the bottom rows, which contain the tags, memo, and +-- filename. These rows are formatted as follows: +-- +-- * If the columns for TotalDrCr, TotalCmdty, and TotalQty are all +-- present, AND if there are at least TWO other columns present, then +-- there will be a hanging indent. The bottom rows will begin at the +-- SECOND column and end with the last column to the left of +-- TotalDrCr. In this case, each bottom row will have three cells: one +-- padding on the left, one main content, and one padding on the +-- right. +-- +-- * Otherwise, if there are NO columns in the top row, these rows +-- will take the entire width of the report. Each bottom row will have +-- one cell. +-- +-- * Otherwise, the bottom rows are as wide as all the top cells +-- combined. Each bottom row will have one cell. + +module Penny.Cabin.Posts.BottomRows ( + BottomOpts(..), + bottomRows, Fields(..), TopRowCells(..), mergeWithSpacers, + topRowCells) where + +import Control.Applicative((<$>), Applicative(pure, (<*>))) +import qualified Data.Foldable as Fdbl +import Control.Monad (guard) +import Data.List (intersperse, find) +import qualified Data.List.NonEmpty as NE +import Data.Maybe (catMaybes) +import Data.Monoid (mappend, mempty, First(First, getFirst)) +import qualified Data.Sequence as Seq +import qualified Data.Text as X +import qualified Data.Traversable as T +import qualified System.Console.Rainbow as Rb +import qualified Penny.Cabin.Scheme as E +import qualified Penny.Cabin.Row as R +import qualified Penny.Cabin.TextFormat as TF +import qualified Penny.Cabin.Posts.Allocated as A +import qualified Penny.Cabin.Posts.Fields as F +import qualified Penny.Cabin.Posts.Growers as G +import qualified Penny.Cabin.Posts.Meta as M +import qualified Penny.Cabin.Posts.Spacers as S +import qualified Penny.Cabin.Posts.Types as Ty +import qualified Penny.Lincoln as L +import qualified Penny.Lincoln.HasText as HT +import qualified Penny.Lincoln.Queries as Q + +data BottomOpts = BottomOpts + { growingWidths :: G.Fields (Maybe Int) + , allocatedWidths :: A.Fields (Maybe Int) + , fields :: F.Fields Bool + , reportWidth :: Ty.ReportWidth + , spacers :: S.Spacers Int + } + +bottomRows + :: E.Changers + -> BottomOpts + -> [(M.PostMeta, L.Posting)] + -> Fields (Maybe [[Rb.Chunk]]) +bottomRows ch os bs = makeRows bs pcs where + pcs = infoProcessors ch topSpecs (reportWidth os) wanted + wanted = requestedMakers ch (fields os) + topSpecs = topCellSpecs (growingWidths os) (allocatedWidths os) + (spacers os) + + +data Fields a = Fields { + tags :: a + , memo :: a + , filename :: a + } deriving (Show, Eq) + +instance Fdbl.Foldable Fields where + foldr f z d = + f (tags d) + (f (memo d) + (f (filename d) z)) + +instance Functor Fields where + fmap f (Fields t m fn) = + Fields (f t) (f m) (f fn) + +instance Applicative Fields where + pure a = Fields a a a + ff <*> fa = Fields { + tags = (tags ff) (tags fa) + , memo = (memo ff) (memo fa) + , filename = (filename ff) (filename fa) + } + +bottomRowsFields :: F.Fields a -> Fields a +bottomRowsFields f = Fields { + tags = F.tags f + , memo = F.memo f + , filename = F.filename f } + + +data Hanging a = Hanging { + leftPad :: a + , mainCell :: a + , rightPad :: a + } deriving (Show, Eq) + + +newtype SpacerWidth = SpacerWidth Int deriving (Show, Eq) +newtype ContentWidth = ContentWidth Int deriving (Show, Eq) + + +hanging + :: E.Changers + -> [TopCellSpec] + -> Maybe (((M.PostMeta, L.Posting) -> Int -> ((E.Label, E.EvenOdd), R.ColumnSpec)) + -> (M.PostMeta, L.Posting) -> [Rb.Chunk]) +hanging ch specs = hangingWidths specs + >>= return . hangingInfoProcessor ch + +hangingInfoProcessor + :: E.Changers + -> Hanging Int + -> ((M.PostMeta, L.Posting) -> Int -> ((E.Label, E.EvenOdd), R.ColumnSpec)) + -> (M.PostMeta, L.Posting) + -> [Rb.Chunk] +hangingInfoProcessor ch widths mkr info = row where + row = R.row ch [left, mid, right] + (ts, mid) = mkr info (mainCell widths) + mkPad w = R.ColumnSpec R.LeftJustify (R.Width w) ts [] + left = mkPad (leftPad widths) + right = mkPad (rightPad widths) + +widthOfTopColumns + :: E.Changers + -> [TopCellSpec] + -> Maybe (((M.PostMeta, L.Posting) -> Int -> ((E.Label, E.EvenOdd), R.ColumnSpec)) + -> (M.PostMeta, L.Posting) -> [Rb.Chunk]) +widthOfTopColumns ch ts = + if null ts + then Nothing + else Just $ makeSpecificWidth ch w where + w = Fdbl.foldl' f 0 ts + f acc (_, maySpcWidth, (ContentWidth cw)) = + acc + cw + maybe 0 (\(SpacerWidth sw) -> sw) maySpcWidth + + +widthOfReport + :: E.Changers + -> Ty.ReportWidth + -> ((M.PostMeta, L.Posting) -> Int -> ((E.Label, E.EvenOdd), R.ColumnSpec)) + -> (M.PostMeta, L.Posting) + -> [Rb.Chunk] +widthOfReport ch (Ty.ReportWidth rw) fn info = + makeSpecificWidth ch rw fn info + +chooseProcessor + :: E.Changers + -> [TopCellSpec] + -> Ty.ReportWidth + -> ((M.PostMeta, L.Posting) -> Int -> ((E.Label, E.EvenOdd), R.ColumnSpec)) + -> (M.PostMeta, L.Posting) + -> [Rb.Chunk] +chooseProcessor ch specs rw fn = let + firstTwo = First (hanging ch specs) + `mappend` First (widthOfTopColumns ch specs) + in case getFirst firstTwo of + Nothing -> widthOfReport ch rw fn + Just r -> r fn + +infoProcessors + :: E.Changers + -> [TopCellSpec] + -> Ty.ReportWidth + -> Fields (Maybe ((M.PostMeta, L.Posting) -> Int -> ((E.Label, E.EvenOdd), R.ColumnSpec))) + -> Fields (Maybe ((M.PostMeta, L.Posting) -> [Rb.Chunk])) +infoProcessors ch specs rw flds = let + chooser = chooseProcessor ch specs rw + mkProcessor mayFn = case mayFn of + Nothing -> Nothing + Just fn -> Just $ chooser fn + in mkProcessor <$> flds + + +makeRows :: + [(M.PostMeta, L.Posting)] + -> Fields (Maybe ((M.PostMeta, L.Posting) -> [Rb.Chunk])) + -> Fields (Maybe [[Rb.Chunk]]) +makeRows is flds = let + mkRow fn = map fn is + in fmap (fmap mkRow) flds + + +-- | Calculates column widths for a Hanging report. If it cannot +-- calculate the widths (because these cells do not support hanging), +-- returns Nothing. +hangingWidths :: [TopCellSpec] + -> Maybe (Hanging Int) +hangingWidths ls = do + let len = length ls + guard (len > 4) + let matchColumn x (c, _, _) = x == c + totDrCr <- find (matchColumn ETotalDrCr) ls + totCmdty <- find (matchColumn ETotalCmdty) ls + totQty <- find (matchColumn ETotalQty) ls + let (first:middle) = take (len - 3) ls + mid <- NE.nonEmpty middle + return $ calcHangingWidths first mid (totDrCr, totCmdty, totQty) + +type TopCellSpec = (ETopRowCells, Maybe SpacerWidth, ContentWidth) + +-- | Given the first column in the top row, at least one middle +-- column, and the last three columns, calculate the width of the +-- three columns in the hanging report. +calcHangingWidths :: + TopCellSpec + -> NE.NonEmpty TopCellSpec + -> (TopCellSpec, TopCellSpec, TopCellSpec) + -> Hanging Int +calcHangingWidths l m r = Hanging left middle right where + calcWidth (_, maybeSp, (ContentWidth c)) = + c + maybe 0 (\(SpacerWidth w) -> abs w) maybeSp + left = calcWidth l + middle = Fdbl.foldl' f 0 m where + f acc c = acc + calcWidth c + (totDrCr, totCmdty, totQty) = r + right = calcWidth totDrCr + calcWidth totCmdty + + calcWidth totQty + + +topCellSpecs :: G.Fields (Maybe Int) + -> A.Fields (Maybe Int) + -> S.Spacers Int + -> [TopCellSpec] +topCellSpecs gFlds aFlds spcs = let + allFlds = topRowCells gFlds aFlds + cws = fmap (fmap ContentWidth) allFlds + merged = mergeWithSpacers cws spcs + tripler e (cw, maybeSpc) = (e, (fmap SpacerWidth maybeSpc), cw) + list = Fdbl.toList $ tripler <$> eTopRowCells <*> merged + toMaybe (e, maybeS, maybeC) = case maybeC of + Nothing -> Nothing + Just c -> Just (e, maybeS, c) + in catMaybes (map toMaybe list) + + +-- | Merges a TopRowCells with a Spacers. Returns Maybes because +-- totalQty has no spacer. +mergeWithSpacers :: + TopRowCells a + -> S.Spacers b + -> TopRowCells (a, Maybe b) +mergeWithSpacers t s = TopRowCells { + globalTransaction = (globalTransaction t, Just (S.globalTransaction s)) + , revGlobalTransaction = (revGlobalTransaction t, Just (S.revGlobalTransaction s)) + , globalPosting = (globalPosting t, Just (S.globalPosting s)) + , revGlobalPosting = (revGlobalPosting t, Just (S.revGlobalPosting s)) + , fileTransaction = (fileTransaction t, Just (S.fileTransaction s)) + , revFileTransaction = (revFileTransaction t, Just (S.revFileTransaction s)) + , filePosting = (filePosting t, Just (S.filePosting s)) + , revFilePosting = (revFilePosting t, Just (S.revFilePosting s)) + , filtered = (filtered t, Just (S.filtered s)) + , revFiltered = (revFiltered t, Just (S.revFiltered s)) + , sorted = (sorted t, Just (S.sorted s)) + , revSorted = (revSorted t, Just (S.revSorted s)) + , visible = (visible t, Just (S.visible s)) + , revVisible = (revVisible t, Just (S.revVisible s)) + , lineNum = (lineNum t, Just (S.lineNum s)) + , date = (date t, Just (S.date s)) + , flag = (flag t, Just (S.flag s)) + , number = (number t, Just (S.number s)) + , payee = (payee t, Just (S.payee s)) + , account = (account t, Just (S.account s)) + , postingDrCr = (postingDrCr t, Just (S.postingDrCr s)) + , postingCmdty = (postingCmdty t, Just (S.postingCmdty s)) + , postingQty = (postingQty t, Just (S.postingQty s)) + , totalDrCr = (totalDrCr t, Just (S.totalDrCr s)) + , totalCmdty = (totalCmdty t, Just (S.totalCmdty s)) + , totalQty = (totalQty t, Nothing) } + + +-- | Applied to a function that, when applied to the width of a cell, +-- returns a cell filled with data, returns a Row with that cell. +makeSpecificWidth + :: E.Changers -> Int -> ((M.PostMeta, L.Posting) -> Int -> (a, R.ColumnSpec)) + -> (M.PostMeta, L.Posting) -> [Rb.Chunk] +makeSpecificWidth ch w f i = R.row ch [c] where + (_, c) = f i w + + +type Maker + = E.Changers + -> (M.PostMeta, L.Posting) + -> Int + -> ((E.Label, E.EvenOdd), R.ColumnSpec) + +makers :: Fields Maker +makers = Fields tagsCell memoCell filenameCell + +-- | Applied to an Options, indicating which reports the user wants, +-- returns a Fields (Maybe Maker) with a Maker in each respective +-- field that the user wants to see. +requestedMakers + :: E.Changers + -> F.Fields Bool + -> Fields (Maybe ((M.PostMeta, L.Posting) -> Int -> ((E.Label, E.EvenOdd), R.ColumnSpec))) +requestedMakers ch allFlds = + let flds = bottomRowsFields allFlds + filler b mkr = if b then Just $ mkr ch else Nothing + in filler <$> flds <*> makers + +tagsCell + :: E.Changers + -> (M.PostMeta, L.Posting) + -> Int + -> ((E.Label, E.EvenOdd), R.ColumnSpec) +tagsCell ch info w = (ts, cell) where + vn = M.visibleNum . fst $ info + cell = R.ColumnSpec R.LeftJustify (R.Width w) ts cs + eo = E.fromVisibleNum vn + ts = (E.Other, eo) + cs = + Fdbl.toList + . fmap toBit + . TF.unLines + . TF.wordWrap w + . TF.Words + . Seq.fromList + . map (X.cons '*') + . HT.textList + . Q.tags + . snd + $ info + md = E.getEvenOddLabelValue E.Other eo ch + toBit (TF.Words ws) = md . Rb.plain $ t where + t = X.concat . intersperse (X.singleton ' ') . Fdbl.toList $ ws + + +memoBits + :: E.Changers -> (E.Label, E.EvenOdd) -> L.Memo -> R.Width -> [Rb.Chunk] +memoBits ch (lbl, eo) m (R.Width w) = cs where + cs = Fdbl.toList + . fmap toBit + . TF.unLines + . TF.wordWrap w + . TF.Words + . Seq.fromList + . X.words + . X.intercalate (X.singleton ' ') + . L.unMemo + $ m + md = E.getEvenOddLabelValue lbl eo ch + toBit (TF.Words ws) = md . Rb.plain $ (X.unwords . Fdbl.toList $ ws) + + +memoCell + :: E.Changers -> (M.PostMeta, L.Posting) -> Int -> ((E.Label, E.EvenOdd), R.ColumnSpec) +memoCell ch info width = (ts, cell) where + w = R.Width width + vn = M.visibleNum . fst $ info + eo = E.fromVisibleNum vn + ts = (E.Other, eo) + cell = R.ColumnSpec R.LeftJustify w ts cs + mayPm = Q.postingMemo . snd $ info + mayTm = Q.transactionMemo . snd $ info + cs = case (mayPm, mayTm) of + (Nothing, Nothing) -> mempty + (Nothing, Just tm) -> memoBits ch ts tm w + (Just pm, Nothing) -> memoBits ch ts pm w + (Just pm, Just tm) -> memoBits ch ts pm w `mappend` memoBits ch ts tm w + + +filenameCell + :: E.Changers -> (M.PostMeta, L.Posting) -> Int -> ((E.Label, E.EvenOdd), R.ColumnSpec) +filenameCell ch info width = (ts, cell) where + w = R.Width width + vn = M.visibleNum . fst $ info + eo = E.fromVisibleNum vn + ts = (E.Other, eo) + cell = R.ColumnSpec R.LeftJustify w ts cs + md = E.getEvenOddLabelValue E.Other eo ch + toBit n = md . Rb.plain + . X.drop (max 0 (X.length n - width)) $ n + cs = case Q.filename . snd $ info of + Nothing -> [] + Just fn -> [toBit . L.unFilename $ fn] + + +data TopRowCells a = TopRowCells + { globalTransaction :: a + , revGlobalTransaction :: a + , globalPosting :: a + , revGlobalPosting :: a + , fileTransaction :: a + , revFileTransaction :: a + , filePosting :: a + , revFilePosting :: a + , filtered :: a + , revFiltered :: a + , sorted :: a + , revSorted :: a + , visible :: a + , revVisible :: a + , lineNum :: a + -- ^ The line number from the posting's metadata + , date :: a + , flag :: a + , number :: a + , payee :: a + , account :: a + , postingDrCr :: a + , postingCmdty :: a + , postingQty :: a + , totalDrCr :: a + , totalCmdty :: a + , totalQty :: a } + deriving (Show, Eq) + +topRowCells :: G.Fields a -> A.Fields a -> TopRowCells a +topRowCells g a = TopRowCells + { globalTransaction = G.globalTransaction g + , revGlobalTransaction = G.revGlobalTransaction g + , globalPosting = G.globalPosting g + , revGlobalPosting = G.revGlobalPosting g + , fileTransaction = G.fileTransaction g + , revFileTransaction = G.revFileTransaction g + , filePosting = G.filePosting g + , revFilePosting = G.revFilePosting g + , filtered = G.filtered g + , revFiltered = G.revFiltered g + , sorted = G.sorted g + , revSorted = G.revSorted g + , visible = G.visible g + , revVisible = G.revVisible g + , lineNum = G.lineNum g + , date = G.date g + , flag = G.flag g + , number = G.number g + , payee = A.payee a + , account = A.account a + , postingDrCr = G.postingDrCr g + , postingCmdty = G.postingCmdty g + , postingQty = G.postingQty g + , totalDrCr = G.totalDrCr g + , totalCmdty = G.totalCmdty g + , totalQty = G.totalQty g } + + +data ETopRowCells = + EGlobalTransaction + | ERevGlobalTransaction + | EGlobalPosting + | ERevGlobalPosting + | EFileTransaction + | ERevFileTransaction + | EFilePosting + | ERevFilePosting + | EFiltered + | ERevFiltered + | ESorted + | ERevSorted + | EVisible + | ERevVisible + | ELineNum + | EDate + | EFlag + | ENumber + | EPayee + | EAccount + | EPostingDrCr + | EPostingCmdty + | EPostingQty + | ETotalDrCr + | ETotalCmdty + | ETotalQty + deriving (Show, Eq, Enum) + +eTopRowCells :: TopRowCells ETopRowCells +eTopRowCells = TopRowCells + { globalTransaction = EGlobalTransaction + , revGlobalTransaction = ERevGlobalTransaction + , globalPosting = EGlobalPosting + , revGlobalPosting = ERevGlobalPosting + , fileTransaction = EFileTransaction + , revFileTransaction = ERevFileTransaction + , filePosting = EFilePosting + , revFilePosting = ERevFilePosting + , filtered = EFiltered + , revFiltered = ERevFiltered + , sorted = ESorted + , revSorted = ERevSorted + , visible = EVisible + , revVisible = ERevVisible + , lineNum = ELineNum + , date = EDate + , flag = EFlag + , number = ENumber + , payee = EPayee + , account = EAccount + , postingDrCr = EPostingDrCr + , postingCmdty = EPostingCmdty + , postingQty = EPostingQty + , totalDrCr = ETotalDrCr + , totalCmdty = ETotalCmdty + , totalQty = ETotalQty } + +instance Functor TopRowCells where + fmap f t = TopRowCells + { globalTransaction = f (globalTransaction t) + , revGlobalTransaction = f (revGlobalTransaction t) + , globalPosting = f (globalPosting t) + , revGlobalPosting = f (revGlobalPosting t) + , fileTransaction = f (fileTransaction t) + , revFileTransaction = f (revFileTransaction t) + , filePosting = f (filePosting t) + , revFilePosting = f (revFilePosting t) + , filtered = f (filtered t) + , revFiltered = f (revFiltered t) + , sorted = f (sorted t) + , revSorted = f (revSorted t) + , visible = f (visible t) + , revVisible = f (revVisible t) + , lineNum = f (lineNum t) + , date = f (date t) + , flag = f (flag t) + , number = f (number t) + , payee = f (payee t) + , account = f (account t) + , postingDrCr = f (postingDrCr t) + , postingCmdty = f (postingCmdty t) + , postingQty = f (postingQty t) + , totalDrCr = f (totalDrCr t) + , totalCmdty = f (totalCmdty t) + , totalQty = f (totalQty t) } + +instance Applicative TopRowCells where + pure a = TopRowCells + { globalTransaction = a + , revGlobalTransaction = a + , globalPosting = a + , revGlobalPosting = a + , fileTransaction = a + , revFileTransaction = a + , filePosting = a + , revFilePosting = a + , filtered = a + , revFiltered = a + , sorted = a + , revSorted = a + , visible = a + , revVisible = a + , lineNum = a + , date = a + , flag = a + , number = a + , payee = a + , account = a + , postingDrCr = a + , postingCmdty = a + , postingQty = a + , totalDrCr = a + , totalCmdty = a + , totalQty = a } + + ff <*> fa = TopRowCells + { globalTransaction = globalTransaction ff (globalTransaction fa) + , revGlobalTransaction = revGlobalTransaction ff (revGlobalTransaction fa) + , globalPosting = globalPosting ff (globalPosting fa) + , revGlobalPosting = revGlobalPosting ff (revGlobalPosting fa) + , fileTransaction = fileTransaction ff (fileTransaction fa) + , revFileTransaction = revFileTransaction ff (revFileTransaction fa) + , filePosting = filePosting ff (filePosting fa) + , revFilePosting = revFilePosting ff (revFilePosting fa) + , filtered = filtered ff (filtered fa) + , revFiltered = revFiltered ff (revFiltered fa) + , sorted = sorted ff (sorted fa) + , revSorted = revSorted ff (revSorted fa) + , visible = visible ff (visible fa) + , revVisible = revVisible ff (revVisible fa) + , lineNum = lineNum ff (lineNum fa) + , date = date ff (date fa) + , flag = flag ff (flag fa) + , number = number ff (number fa) + , payee = payee ff (payee fa) + , account = account ff (account fa) + , postingDrCr = postingDrCr ff (postingDrCr fa) + , postingCmdty = postingCmdty ff (postingCmdty fa) + , postingQty = postingQty ff (postingQty fa) + , totalDrCr = totalDrCr ff (totalDrCr fa) + , totalCmdty = totalCmdty ff (totalCmdty fa) + , totalQty = totalQty ff (totalQty fa) } + +instance Fdbl.Foldable TopRowCells where + foldr f z o = + f (globalTransaction o) + (f (revGlobalTransaction o) + (f (globalPosting o) + (f (revGlobalPosting o) + (f (fileTransaction o) + (f (revFileTransaction o) + (f (filePosting o) + (f (revFilePosting o) + (f (filtered o) + (f (revFiltered o) + (f (sorted o) + (f (revSorted o) + (f (visible o) + (f (revVisible o) + (f (lineNum o) + (f (date o) + (f (flag o) + (f (number o) + (f (payee o) + (f (account o) + (f (postingDrCr o) + (f (postingCmdty o) + (f (postingQty o) + (f (totalDrCr o) + (f (totalCmdty o) + (f (totalQty o) z))))))))))))))))))))))))) + +instance T.Traversable TopRowCells where + traverse f t = + TopRowCells + <$> f (globalTransaction t) + <*> f (revGlobalTransaction t) + <*> f (globalPosting t) + <*> f (revGlobalPosting t) + <*> f (fileTransaction t) + <*> f (revFileTransaction t) + <*> f (filePosting t) + <*> f (revFilePosting t) + <*> f (filtered t) + <*> f (revFiltered t) + <*> f (sorted t) + <*> f (revSorted t) + <*> f (visible t) + <*> f (revVisible t) + <*> f (lineNum t) + <*> f (date t) + <*> f (flag t) + <*> f (number t) + <*> f (payee t) + <*> f (account t) + <*> f (postingDrCr t) + <*> f (postingCmdty t) + <*> f (postingQty t) + <*> f (totalDrCr t) + <*> f (totalCmdty t) + <*> f (totalQty t) + diff --git a/lib/Penny/Cabin/Posts/Chunk.hs b/lib/Penny/Cabin/Posts/Chunk.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Cabin/Posts/Chunk.hs @@ -0,0 +1,152 @@ +module Penny.Cabin.Posts.Chunk (ChunkOpts(..), makeChunk) where + +import qualified Data.Foldable as Fdbl +import Data.List (transpose) +import Data.Maybe (isNothing, catMaybes) +import qualified Penny.Cabin.Posts.Fields as F +import qualified Penny.Cabin.Posts.Growers as G +import qualified Penny.Cabin.Posts.Allocated as A +import qualified Penny.Cabin.Posts.BottomRows as B +import qualified Penny.Cabin.Posts.Spacers as S +import qualified Penny.Cabin.Row as R +import qualified Penny.Cabin.Scheme as E +import qualified System.Console.Rainbow as Rb +import qualified Penny.Cabin.Posts.Meta as M +import qualified Penny.Lincoln as L +import qualified Data.Text as X +import qualified Penny.Cabin.Posts.Types as Ty + +data ChunkOpts = ChunkOpts + { dateFormat :: (M.PostMeta, L.Posting) -> X.Text + , qtyFormat :: (M.PostMeta, L.Posting) -> X.Text + , balanceFormat :: L.Commodity -> L.Qty -> X.Text + , fields :: F.Fields Bool + , subAccountLength :: A.SubAccountLength + , payeeAllocation :: A.Alloc + , accountAllocation :: A.Alloc + , spacers :: S.Spacers Int + , reportWidth :: Ty.ReportWidth + } + +growOpts :: ChunkOpts -> G.GrowOpts +growOpts c = G.GrowOpts + { G.dateFormat = dateFormat c + , G.qtyFormat = qtyFormat c + , G.balanceFormat = balanceFormat c + , G.fields = fields c + } + +allocatedOpts :: ChunkOpts -> G.Fields (Maybe Int) -> A.AllocatedOpts +allocatedOpts c g = A.AllocatedOpts + { A.fields = let f = fields c + in A.Fields { A.payee = F.payee f + , A.account = F.account f } + , A.subAccountLength = subAccountLength c + , A.allocations = A.Fields { A.payee = payeeAllocation c + , A.account = accountAllocation c } + , A.spacers = spacers c + , A.growerWidths = g + , A.reportWidth = reportWidth c + } + +bottomOpts :: + ChunkOpts + -> G.Fields (Maybe Int) + -> A.Fields (Maybe Int) + -> B.BottomOpts +bottomOpts c g a = B.BottomOpts { + B.growingWidths = g + , B.allocatedWidths = a + , B.fields = fields c + , B.reportWidth = reportWidth c + , B.spacers = spacers c + } + +makeChunk + :: E.Changers + -> ChunkOpts + -> [(M.PostMeta, L.Posting)] + -> [Rb.Chunk] +makeChunk ch c bs = + let fmapSnd = fmap (fmap snd) + fmapFst = fmap (fmap fst) + gFldW = fmap (fmap snd) gFlds + aFldW = fmapSnd aFlds + gFlds = G.growCells ch (growOpts c) bs + aFlds = A.payeeAndAcct ch (allocatedOpts c gFldW) bs + bFlds = B.bottomRows ch (bottomOpts c gFldW aFldW) bs + topCells = B.topRowCells (fmapFst gFlds) (fmap (fmap fst) aFlds) + withSpacers = B.mergeWithSpacers topCells (spacers c) + topRows = makeTopRows ch withSpacers + bottomRows = makeBottomRows bFlds + in makeAllRows topRows bottomRows + + +topRowsCells + :: B.TopRowCells (Maybe [R.ColumnSpec], Maybe Int) + -> [[(R.ColumnSpec, Maybe R.ColumnSpec)]] +topRowsCells t = let + toWithSpc (mayCs, maySp) = case mayCs of + Nothing -> Nothing + Just cs -> Just (makeSpacers cs maySp) + f mayPairList acc = case mayPairList of + Nothing -> acc + (Just pairList) -> pairList : acc + in transpose $ Fdbl.foldr f [] (fmap toWithSpc t) + +makeRow :: E.Changers -> [(R.ColumnSpec, Maybe R.ColumnSpec)] -> [Rb.Chunk] +makeRow ch = R.row ch . foldr f [] where + f (c, mayC) acc = case mayC of + Nothing -> c:acc + Just spcr -> c:spcr:acc + + +makeSpacers + :: [R.ColumnSpec] + -> Maybe Int + -> [(R.ColumnSpec, Maybe R.ColumnSpec)] +makeSpacers cs mayI = case mayI of + Nothing -> map (\c -> (c, Nothing)) cs + Just i -> makeEvenOddSpacers cs i + +makeEvenOddSpacers + :: [R.ColumnSpec] + -> Int + -> [(R.ColumnSpec, Maybe R.ColumnSpec)] +makeEvenOddSpacers cs i = let absI = abs i in + if absI == 0 + then map (\c -> (c, Nothing)) cs + else let + spcrs = cycle [Just $ mkSpcr evenTs, Just $ mkSpcr oddTs] + mkSpcr ts = R.ColumnSpec R.LeftJustify (R.Width absI) ts [] + evenTs = (E.Other, E.Even) + oddTs = (E.Other, E.Odd) + in zip cs spcrs + +makeTopRows + :: E.Changers + -> B.TopRowCells (Maybe [R.ColumnSpec], Maybe Int) + -> Maybe [[Rb.Chunk]] +makeTopRows ch trc = + if Fdbl.all (isNothing . fst) trc + then Nothing + else Just $ map (makeRow ch) . topRowsCells $ trc + + +makeBottomRows :: + B.Fields (Maybe [[Rb.Chunk]]) + -> Maybe [[[Rb.Chunk]]] +makeBottomRows flds = + if Fdbl.all isNothing flds + then Nothing + else Just . transpose . catMaybes . Fdbl.toList $ flds + +makeAllRows :: Maybe [[Rb.Chunk]] -> Maybe [[[Rb.Chunk]]] -> [Rb.Chunk] +makeAllRows mayrs mayrrs = case (mayrs, mayrrs) of + (Nothing, Nothing) -> [] + (Just rs, Nothing) -> concat rs + (Nothing, Just rrs) -> concat . concat $ rrs + (Just rs, Just rrs) -> concat $ zipWith f rs rrs where + f topRow botRows = concat [topRow, concat botRows] + + diff --git a/lib/Penny/Cabin/Posts/Fields.hs b/lib/Penny/Cabin/Posts/Fields.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Cabin/Posts/Fields.hs @@ -0,0 +1,199 @@ +-- | Fields that can appear in the Posts report. +module Penny.Cabin.Posts.Fields where + +import Control.Applicative(Applicative(pure, (<*>))) +import qualified Data.Foldable as F + +data Fields a = Fields + { globalTransaction :: a + , revGlobalTransaction :: a + , globalPosting :: a + , revGlobalPosting :: a + , fileTransaction :: a + , revFileTransaction :: a + , filePosting :: a + , revFilePosting :: a + , filtered :: a + , revFiltered :: a + , sorted :: a + , revSorted :: a + , visible :: a + , revVisible :: a + , lineNum :: a + , date :: a + , flag :: a + , number :: a + , payee :: a + , account :: a + , postingDrCr :: a + , postingCmdty :: a + , postingQty :: a + , totalDrCr :: a + , totalCmdty :: a + , totalQty :: a + , tags :: a + , memo :: a + , filename :: a + } deriving (Show, Eq) + +instance Functor Fields where + fmap f fa = Fields { + globalTransaction = f (globalTransaction fa) + , revGlobalTransaction = f (revGlobalTransaction fa) + , globalPosting = f (globalPosting fa) + , revGlobalPosting = f (revGlobalPosting fa) + , fileTransaction = f (fileTransaction fa) + , revFileTransaction = f (revFileTransaction fa) + , filePosting = f (filePosting fa) + , revFilePosting = f (revFilePosting fa) + , filtered = f (filtered fa) + , revFiltered = f (revFiltered fa) + , sorted = f (sorted fa) + , revSorted = f (revSorted fa) + , visible = f (visible fa) + , revVisible = f (revVisible fa) + , lineNum = f (lineNum fa) + , date = f (date fa) + , flag = f (flag fa) + , number = f (number fa) + , payee = f (payee fa) + , account = f (account fa) + , postingDrCr = f (postingDrCr fa) + , postingCmdty = f (postingCmdty fa) + , postingQty = f (postingQty fa) + , totalDrCr = f (totalDrCr fa) + , totalCmdty = f (totalCmdty fa) + , totalQty = f (totalQty fa) + , tags = f (tags fa) + , memo = f (memo fa) + , filename = f (filename fa) } + +instance Applicative Fields where + pure a = Fields { + globalTransaction = a + , revGlobalTransaction = a + , globalPosting = a + , revGlobalPosting = a + , fileTransaction = a + , revFileTransaction = a + , filePosting = a + , revFilePosting = a + , filtered = a + , revFiltered = a + , sorted = a + , revSorted = a + , visible = a + , revVisible = a + , lineNum = a + , date = a + , flag = a + , number = a + , payee = a + , account = a + , postingDrCr = a + , postingCmdty = a + , postingQty = a + , totalDrCr = a + , totalCmdty = a + , totalQty = a + , tags = a + , memo = a + , filename = a } + + ff <*> fa = Fields { + globalTransaction = globalTransaction ff (globalTransaction fa) + , revGlobalTransaction = revGlobalTransaction ff + (revGlobalTransaction fa) + , globalPosting = globalPosting ff (globalPosting fa) + , revGlobalPosting = revGlobalPosting ff (revGlobalPosting fa) + , fileTransaction = fileTransaction ff (fileTransaction fa) + , revFileTransaction = revFileTransaction ff (revFileTransaction fa) + , filePosting = filePosting ff (filePosting fa) + , revFilePosting = revFilePosting ff (revFilePosting fa) + , filtered = filtered ff (filtered fa) + , revFiltered = revFiltered ff (revFiltered fa) + , sorted = sorted ff (sorted fa) + , revSorted = revSorted ff (revSorted fa) + , visible = visible ff (visible fa) + , revVisible = revVisible ff (revVisible fa) + , lineNum = lineNum ff (lineNum fa) + , date = date ff (date fa) + , flag = flag ff (flag fa) + , number = number ff (number fa) + , payee = payee ff (payee fa) + , account = account ff (account fa) + , postingDrCr = postingDrCr ff (postingDrCr fa) + , postingCmdty = postingCmdty ff (postingCmdty fa) + , postingQty = postingQty ff (postingQty fa) + , totalDrCr = totalDrCr ff (totalDrCr fa) + , totalCmdty = totalCmdty ff (totalCmdty fa) + , totalQty = totalQty ff (totalQty fa) + , tags = tags ff (tags fa) + , memo = memo ff (memo fa) + , filename = filename ff (filename fa) } + +instance F.Foldable Fields where + foldr f z t = + f (globalTransaction t) + (f (revGlobalTransaction t) + (f (globalPosting t) + (f (revGlobalPosting t) + (f (fileTransaction t) + (f (revFileTransaction t) + (f (filePosting t) + (f (revFilePosting t) + (f (filtered t) + (f (revFiltered t) + (f (sorted t) + (f (revSorted t) + (f (visible t) + (f (revVisible t) + (f (lineNum t) + (f (date t) + (f (flag t) + (f (number t) + (f (payee t) + (f (account t) + (f (postingDrCr t) + (f (postingCmdty t) + (f (postingQty t) + (f (totalDrCr t) + (f (totalCmdty t) + (f (totalQty t) + (f (tags t) + (f (memo t) + (f (filename t) z)))))))))))))))))))))))))))) + + +fieldNames :: Fields String +fieldNames = Fields + { globalTransaction = "globalTransaction" + , revGlobalTransaction = "revGlobalTransaction" + , globalPosting = "globalPosting" + , revGlobalPosting = "revGlobalPosting" + , fileTransaction = "fileTransaction" + , revFileTransaction = "revFileTransaction" + , filePosting = "filePosting" + , revFilePosting = "revFilePosting" + , filtered = "filtered" + , revFiltered = "revFiltered" + , sorted = "sorted" + , revSorted = "revSorted" + , visible = "visible" + , revVisible = "revVisible" + , lineNum = "lineNum" + , date = "date" + , flag = "flag" + , number = "number" + , payee = "payee" + , account = "account" + , postingDrCr = "postingDrCr" + , postingCmdty = "postingCmdty" + , postingQty = "postingQty" + , totalDrCr = "totalDrCr" + , totalCmdty = "totalCmdty" + , totalQty = "totalQty" + , tags = "tags" + , memo = "memo" + , filename = "filename" + } diff --git a/lib/Penny/Cabin/Posts/Growers.hs b/lib/Penny/Cabin/Posts/Growers.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Cabin/Posts/Growers.hs @@ -0,0 +1,595 @@ +-- | Calculates cells that "grow to fit." These cells grow to fit the +-- widest cell in the column. No information is ever truncated from +-- these cells (what use is a truncated dollar amount?) +module Penny.Cabin.Posts.Growers ( + GrowOpts(..), + growCells, Fields(..), grownWidth, + eFields, EFields(..), pairWithSpacer) where + +import Control.Applicative((<$>), Applicative(pure, (<*>))) +import qualified Data.Foldable as Fdbl +import Data.Map (elems) +import qualified Data.Map as Map +import qualified Data.Semigroup as Semi +import Data.Semigroup ((<>)) +import Data.Text (Text, pack, empty) +import qualified Data.Text as X +import qualified Penny.Cabin.Posts.Fields as F +import qualified Penny.Cabin.Posts.Meta as M +import qualified Penny.Cabin.Posts.Spacers as S +import qualified Penny.Cabin.Row as R +import qualified Penny.Cabin.Scheme as E +import qualified Penny.Liberty as Ly +import qualified Penny.Lincoln as L +import qualified Penny.Lincoln.Queries as Q +import qualified System.Console.Rainbow as Rb + + +-- | All the options needed to grow the cells. +data GrowOpts = GrowOpts + { dateFormat :: (M.PostMeta, L.Posting) -> X.Text + , qtyFormat :: (M.PostMeta, L.Posting) -> X.Text + , balanceFormat :: L.Commodity -> L.Qty -> X.Text + , fields :: F.Fields Bool + } + +-- | Grows the cells that will be GrowToFit cells in the report. First +-- this function fills in all visible cells with text, but leaves the +-- width undetermined. Then it determines the widest line in each +-- column. Finally it adjusts each cell in the column so that it is +-- that maximum width. +-- +-- Returns a list of rows, and a Fields holding the width of each +-- cell. Each of these widths will be at least 1; fields that were in +-- the report but that ended up having no width are changed to +-- Nothing. +growCells + :: E.Changers + -> GrowOpts + -> [(M.PostMeta, L.Posting)] + -> Fields (Maybe ([R.ColumnSpec], Int)) +growCells ch o infos = toPair <$> wanted <*> growers where + toPair b gwr + | b = + let cs = map (gwr o ch) infos + w = Fdbl.foldl' f 0 cs where + f acc c = max acc (widestLine c) + cs' = map (sizer (R.Width w)) cs + in if w > 0 then Just (cs', w) else Nothing + | otherwise = Nothing + wanted = growingFields . fields $ o + +widestLine :: PreSpec -> Int +widestLine (PreSpec _ _ bs) = + case bs of + [] -> 0 + xs -> maximum . map (X.length . Rb.chunkText) $ xs + +data PreSpec = PreSpec { + _justification :: R.Justification + , _padSpec :: (E.Label, E.EvenOdd) + , _bits :: [Rb.Chunk] } + + +-- | Given a PreSpec and a width, create a ColumnSpec of the right +-- size. +sizer :: R.Width -> PreSpec -> R.ColumnSpec +sizer w (PreSpec j ts bs) = R.ColumnSpec j w ts bs + +-- | Makes a left justified cell that is only one line long. The width +-- is unset. +oneLine :: E.Changers -> Text -> E.Label -> (M.PostMeta, L.Posting) -> PreSpec +oneLine chgrs t lbl b = + let eo = E.fromVisibleNum . M.visibleNum . fst $ b + j = R.LeftJustify + md = E.getEvenOddLabelValue lbl eo chgrs + ck = [md $ Rb.plain t] + in PreSpec j (lbl, eo) ck + + +-- | Gets a Fields with each field filled with the function that fills +-- the cells for that field. +growers :: Fields (GrowOpts -> E.Changers -> (M.PostMeta, L.Posting) -> PreSpec) +growers = Fields + { globalTransaction = const getGlobalTransaction + , revGlobalTransaction = const getRevGlobalTransaction + , globalPosting = const getGlobalPosting + , revGlobalPosting = const getRevGlobalPosting + , fileTransaction = const getFileTransaction + , revFileTransaction = const getRevFileTransaction + , filePosting = const getFilePosting + , revFilePosting = const getRevFilePosting + , filtered = const getFiltered + , revFiltered = const getRevFiltered + , sorted = const getSorted + , revSorted = const getRevSorted + , visible = const getVisible + , revVisible = const getRevVisible + , lineNum = const getLineNum + , date = \o ch -> getDate ch (dateFormat o) + , flag = const getFlag + , number = const getNumber + , postingDrCr = const getPostingDrCr + , postingCmdty = const getPostingCmdty + , postingQty = \o ch -> getPostingQty ch (qtyFormat o) + , totalDrCr = const getTotalDrCr + , totalCmdty = const getTotalCmdty + , totalQty = \o ch -> getTotalQty ch (balanceFormat o) + } + +-- | Make a left justified cell one line long that shows a serial. +serialCellMaybe + :: E.Changers + -> (L.Posting -> Maybe Int) + -- ^ When applied to a Box, this function returns Just Int if the + -- box has a serial, or Nothing if not. + + -> (M.PostMeta, L.Posting) -> PreSpec +serialCellMaybe chgrs f b = oneLine chgrs t E.Other b + where + t = case f (snd b) of + Nothing -> X.empty + Just i -> X.pack . show $ i + +serialCell + :: E.Changers + -> (M.PostMeta -> Int) + -> (M.PostMeta, L.Posting) -> PreSpec +serialCell chgrs f b = oneLine chgrs t E.Other b + where + t = pack . show . f . fst $ b + +getGlobalTransaction :: E.Changers -> (M.PostMeta, L.Posting) -> PreSpec +getGlobalTransaction chgrs = + serialCellMaybe chgrs (fmap (L.forward . L.unGlobalTransaction) + . Q.globalTransaction) + +getRevGlobalTransaction :: E.Changers -> (M.PostMeta, L.Posting) -> PreSpec +getRevGlobalTransaction chgrs = + serialCellMaybe chgrs (fmap (L.backward . L.unGlobalTransaction) + . Q.globalTransaction) + +getGlobalPosting :: E.Changers -> (M.PostMeta, L.Posting) -> PreSpec +getGlobalPosting chgrs = + serialCellMaybe chgrs (fmap (L.forward . L.unGlobalPosting) + . Q.globalPosting) + +getRevGlobalPosting :: E.Changers -> (M.PostMeta, L.Posting) -> PreSpec +getRevGlobalPosting chgrs = + serialCellMaybe chgrs (fmap (L.backward . L.unGlobalPosting) + . Q.globalPosting) + +getFileTransaction :: E.Changers -> (M.PostMeta, L.Posting) -> PreSpec +getFileTransaction chgrs = + serialCellMaybe chgrs (fmap (L.forward . L.unFileTransaction) + . Q.fileTransaction) + +getRevFileTransaction :: E.Changers -> (M.PostMeta, L.Posting) -> PreSpec +getRevFileTransaction chgrs = + serialCellMaybe chgrs (fmap (L.backward . L.unFileTransaction) + . Q.fileTransaction) + +getFilePosting :: E.Changers -> (M.PostMeta, L.Posting) -> PreSpec +getFilePosting chgrs = + serialCellMaybe chgrs (fmap (L.forward . L.unFilePosting) + . Q.filePosting) + +getRevFilePosting :: E.Changers -> (M.PostMeta, L.Posting) -> PreSpec +getRevFilePosting chgrs = + serialCellMaybe chgrs (fmap (L.backward . L.unFilePosting) + . Q.filePosting) + +getSorted :: E.Changers -> (M.PostMeta, L.Posting) -> PreSpec +getSorted chgrs = + serialCell chgrs (L.forward . Ly.unSortedNum . M.sortedNum) + +getRevSorted :: E.Changers -> (M.PostMeta, L.Posting) -> PreSpec +getRevSorted chgrs = + serialCell chgrs (L.backward . Ly.unSortedNum . M.sortedNum) + +getFiltered :: E.Changers -> (M.PostMeta, L.Posting) -> PreSpec +getFiltered chgrs = + serialCell chgrs (L.forward . Ly.unFilteredNum . M.filteredNum) + +getRevFiltered :: E.Changers -> (M.PostMeta, L.Posting) -> PreSpec +getRevFiltered chgrs = + serialCell chgrs (L.backward . Ly.unFilteredNum . M.filteredNum) + +getVisible :: E.Changers -> (M.PostMeta, L.Posting) -> PreSpec +getVisible chgrs = + serialCell chgrs (L.forward . M.unVisibleNum . M.visibleNum) + +getRevVisible :: E.Changers -> (M.PostMeta, L.Posting) -> PreSpec +getRevVisible chgrs = + serialCell chgrs (L.backward . M.unVisibleNum . M.visibleNum) + + +getLineNum :: E.Changers -> (M.PostMeta, L.Posting) -> PreSpec +getLineNum chgrs b = oneLine chgrs t E.Other b where + lineTxt = pack . show . L.unPostingLine + t = maybe empty lineTxt (Q.postingLine . snd $ b) + +getDate :: E.Changers -> ((M.PostMeta, L.Posting) -> X.Text) -> (M.PostMeta, L.Posting) -> PreSpec +getDate chgrs gd b = oneLine chgrs (gd b) E.Other b + +getFlag :: E.Changers -> (M.PostMeta, L.Posting) -> PreSpec +getFlag chgrs i = oneLine chgrs t E.Other i where + t = maybe empty L.text (Q.flag . snd $ i) + +getNumber :: E.Changers -> (M.PostMeta, L.Posting) -> PreSpec +getNumber chgrs i = oneLine chgrs t E.Other i where + t = maybe empty L.text (Q.number . snd $ i) + +dcTxt :: L.DrCr -> Text +dcTxt L.Debit = X.singleton '<' +dcTxt L.Credit = X.singleton '>' + +-- | Gives a one-line cell that is colored according to whether the +-- posting is a debit or credit. +coloredPostingCell :: E.Changers -> Text -> (M.PostMeta, L.Posting) -> PreSpec +coloredPostingCell chgrs t i = PreSpec j (lbl, eo) [bit] where + j = R.LeftJustify + lbl = case Q.drCr . snd $ i of + L.Debit -> E.Debit + L.Credit -> E.Credit + eo = E.fromVisibleNum . M.visibleNum . fst $ i + md = E.getEvenOddLabelValue lbl eo chgrs + bit = md $ Rb.plain t + + +getPostingDrCr :: E.Changers -> (M.PostMeta, L.Posting) -> PreSpec +getPostingDrCr ch i = coloredPostingCell ch t i where + t = dcTxt . Q.drCr . snd $ i + +getPostingCmdty :: E.Changers -> (M.PostMeta, L.Posting) -> PreSpec +getPostingCmdty ch i = coloredPostingCell ch t i where + t = L.unCommodity . Q.commodity . snd $ i + +getPostingQty :: E.Changers -> ((M.PostMeta, L.Posting) -> X.Text) -> (M.PostMeta, L.Posting) -> PreSpec +getPostingQty ch qf i = coloredPostingCell ch (qf i) i + +getTotalDrCr :: E.Changers -> (M.PostMeta, L.Posting) -> PreSpec +getTotalDrCr ch i = + let vn = M.visibleNum . fst $ i + ps = (lbl, eo) + dc = Q.drCr . snd $ i + lbl = E.dcToLbl dc + eo = E.fromVisibleNum vn + bal = L.unBalance . M.balance . fst $ i + md = E.getEvenOddLabelValue lbl eo ch + bits = + if Map.null bal + then [md . Rb.plain $ pack "--"] + else let mkChk e = E.bottomLineToDrCr e eo ch + in fmap mkChk . elems $ bal + j = R.LeftJustify + in PreSpec j ps bits + +getTotalCmdty :: E.Changers -> (M.PostMeta, L.Posting) -> PreSpec +getTotalCmdty ch i = + let vn = M.visibleNum . fst $ i + j = R.RightJustify + ps = (lbl, eo) + dc = Q.drCr . snd $ i + eo = E.fromVisibleNum vn + lbl = E.dcToLbl dc + bal = Map.toList . L.unBalance . M.balance . fst $ i + preChunks = E.balancesToCmdtys ch eo bal + in PreSpec j ps preChunks + +getTotalQty + :: E.Changers + -> (L.Commodity -> L.Qty -> X.Text) + -> (M.PostMeta, L.Posting) + -> PreSpec +getTotalQty ch balFmt i = + let vn = M.visibleNum . fst $ i + j = R.LeftJustify + dc = Q.drCr . snd $ i + ps = (E.dcToLbl dc, eo) + eo = E.fromVisibleNum vn + bal = Map.toList . L.unBalance . M.balance . fst $ i + preChunks = E.balanceToQtys ch balFmt eo bal + in PreSpec j ps preChunks + +growingFields :: F.Fields Bool -> Fields Bool +growingFields f = Fields + { globalTransaction = F.globalTransaction f + , revGlobalTransaction = F.revGlobalTransaction f + , globalPosting = F.globalPosting f + , revGlobalPosting = F.revGlobalPosting f + , fileTransaction = F.fileTransaction f + , revFileTransaction = F.revFileTransaction f + , filePosting = F.filePosting f + , revFilePosting = F.revFilePosting f + , filtered = F.filtered f + , revFiltered = F.revFiltered f + , sorted = F.sorted f + , revSorted = F.revSorted f + , visible = F.visible f + , revVisible = F.revVisible f + , lineNum = F.lineNum f + , date = F.date f + , flag = F.flag f + , number = F.number f + , postingDrCr = F.postingDrCr f + , postingCmdty = F.postingCmdty f + , postingQty = F.postingQty f + , totalDrCr = F.totalDrCr f + , totalCmdty = F.totalCmdty f + , totalQty = F.totalQty f } + +-- | All growing fields, as an ADT. +data EFields = + EGlobalTransaction + | ERevGlobalTransaction + | EGlobalPosting + | ERevGlobalPosting + | EFileTransaction + | ERevFileTransaction + | EFilePosting + | ERevFilePosting + | EFiltered + | ERevFiltered + | ESorted + | ERevSorted + | EVisible + | ERevVisible + | ELineNum + | EDate + | EFlag + | ENumber + | EPostingDrCr + | EPostingCmdty + | EPostingQty + | ETotalDrCr + | ETotalCmdty + | ETotalQty + deriving (Show, Eq, Ord, Enum) + +-- | Returns a Fields where each record has its corresponding EField. +eFields :: Fields EFields +eFields = Fields + { globalTransaction = EGlobalTransaction + , revGlobalTransaction = ERevGlobalTransaction + , globalPosting = EGlobalPosting + , revGlobalPosting = ERevGlobalPosting + , fileTransaction = EFileTransaction + , revFileTransaction = ERevFileTransaction + , filePosting = EFilePosting + , revFilePosting = ERevFilePosting + , filtered = EFiltered + , revFiltered = ERevFiltered + , sorted = ESorted + , revSorted = ERevSorted + , visible = EVisible + , revVisible = ERevVisible + , lineNum = ELineNum + , date = EDate + , flag = EFlag + , number = ENumber + , postingDrCr = EPostingDrCr + , postingCmdty = EPostingCmdty + , postingQty = EPostingQty + , totalDrCr = ETotalDrCr + , totalCmdty = ETotalCmdty + , totalQty = ETotalQty } + +-- | All growing fields. +data Fields a = Fields + { globalTransaction :: a + , revGlobalTransaction :: a + , globalPosting :: a + , revGlobalPosting :: a + , fileTransaction :: a + , revFileTransaction :: a + , filePosting :: a + , revFilePosting :: a + , filtered :: a + , revFiltered :: a + , sorted :: a + , revSorted :: a + , visible :: a + , revVisible :: a + , lineNum :: a + -- ^ The line number from the posting's metadata + , date :: a + , flag :: a + , number :: a + , postingDrCr :: a + , postingCmdty :: a + , postingQty :: a + , totalDrCr :: a + , totalCmdty :: a + , totalQty :: a } + deriving (Show, Eq) + +instance Fdbl.Foldable Fields where + foldr f z i = + f (globalTransaction i) + (f (revGlobalTransaction i) + (f (globalPosting i) + (f (revGlobalPosting i) + (f (fileTransaction i) + (f (revFileTransaction i) + (f (filePosting i) + (f (revFilePosting i) + (f (filtered i) + (f (revFiltered i) + (f (sorted i) + (f (revSorted i) + (f (visible i) + (f (revVisible i) + (f (lineNum i) + (f (date i) + (f (flag i) + (f (number i) + (f (postingDrCr i) + (f (postingCmdty i) + (f (postingQty i) + (f (totalDrCr i) + (f (totalCmdty i) + (f (totalQty i) z))))))))))))))))))))))) + +instance Functor Fields where + fmap f i = Fields + { globalTransaction = f (globalTransaction i) + , revGlobalTransaction = f (revGlobalTransaction i) + , globalPosting = f (globalPosting i) + , revGlobalPosting = f (revGlobalPosting i) + , fileTransaction = f (fileTransaction i) + , revFileTransaction = f (revFileTransaction i) + , filePosting = f (filePosting i) + , revFilePosting = f (revFilePosting i) + , filtered = f (filtered i) + , revFiltered = f (revFiltered i) + , sorted = f (sorted i) + , revSorted = f (revSorted i) + , visible = f (visible i) + , revVisible = f (revVisible i) + , lineNum = f (lineNum i) + , date = f (date i) + , flag = f (flag i) + , number = f (number i) + , postingDrCr = f (postingDrCr i) + , postingCmdty = f (postingCmdty i) + , postingQty = f (postingQty i) + , totalDrCr = f (totalDrCr i) + , totalCmdty = f (totalCmdty i) + , totalQty = f (totalQty i) } + +instance Applicative Fields where + pure a = Fields + { globalTransaction = a + , revGlobalTransaction = a + , globalPosting = a + , revGlobalPosting = a + , fileTransaction = a + , revFileTransaction = a + , filePosting = a + , revFilePosting = a + , filtered = a + , revFiltered = a + , sorted = a + , revSorted = a + , visible = a + , revVisible = a + , lineNum = a + , date = a + , flag = a + , number = a + , postingDrCr = a + , postingCmdty = a + , postingQty = a + , totalDrCr = a + , totalCmdty = a + , totalQty = a } + + fl <*> fa = Fields + { globalTransaction = globalTransaction fl (globalTransaction fa) + , revGlobalTransaction = revGlobalTransaction fl (revGlobalTransaction fa) + , globalPosting = globalPosting fl (globalPosting fa) + , revGlobalPosting = revGlobalPosting fl (revGlobalPosting fa) + , fileTransaction = fileTransaction fl (fileTransaction fa) + , revFileTransaction = revFileTransaction fl (revFileTransaction fa) + , filePosting = filePosting fl (filePosting fa) + , revFilePosting = revFilePosting fl (revFilePosting fa) + , filtered = filtered fl (filtered fa) + , revFiltered = revFiltered fl (revFiltered fa) + , sorted = sorted fl (sorted fa) + , revSorted = revSorted fl (revSorted fa) + , visible = visible fl (visible fa) + , revVisible = revVisible fl (revVisible fa) + , lineNum = lineNum fl (lineNum fa) + , date = date fl (date fa) + , flag = flag fl (flag fa) + , number = number fl (number fa) + , postingDrCr = postingDrCr fl (postingDrCr fa) + , postingCmdty = postingCmdty fl (postingCmdty fa) + , postingQty = postingQty fl (postingQty fa) + , totalDrCr = totalDrCr fl (totalDrCr fa) + , totalCmdty = totalCmdty fl (totalCmdty fa) + , totalQty = totalQty fl (totalQty fa) } + +-- | Pairs data from a Fields with its matching spacer field. The +-- spacer field is returned in a Maybe because the TotalQty field does +-- not have a spacer. +pairWithSpacer :: Fields a -> S.Spacers b -> Fields (a, Maybe b) +pairWithSpacer f s = Fields { + globalTransaction = (globalTransaction f, Just (S.globalTransaction s)) + , revGlobalTransaction = (revGlobalTransaction f, Just (S.revGlobalTransaction s)) + , globalPosting = (globalPosting f, Just (S.globalPosting s)) + , revGlobalPosting = (revGlobalPosting f, Just (S.revGlobalPosting s)) + , fileTransaction = (fileTransaction f, Just (S.fileTransaction s)) + , revFileTransaction = (revFileTransaction f, Just (S.revFileTransaction s)) + , filePosting = (filePosting f, Just (S.filePosting s)) + , revFilePosting = (revFilePosting f, Just (S.revFilePosting s)) + , filtered = (filtered f, Just (S.filtered s)) + , revFiltered = (revFiltered f, Just (S.revFiltered s)) + , sorted = (sorted f, Just (S.sorted s)) + , revSorted = (revSorted f, Just (S.revSorted s)) + , visible = (visible f, Just (S.visible s)) + , revVisible = (revVisible f, Just (S.revVisible s)) + , lineNum = (lineNum f, Just (S.lineNum s)) + , date = (date f, Just (S.date s)) + , flag = (flag f, Just (S.flag s)) + , number = (number f, Just (S.number s)) + , postingDrCr = (postingDrCr f, Just (S.postingDrCr s)) + , postingCmdty = (postingCmdty f, Just (S.postingCmdty s)) + , postingQty = (postingQty f, Just (S.postingQty s)) + , totalDrCr = (totalDrCr f, Just (S.totalDrCr s)) + , totalCmdty = (totalCmdty f, Just (S.totalCmdty s)) + , totalQty = (totalQty f, Nothing ) } + +-- | Reduces a set of Fields to a single value. +reduce :: Semi.Semigroup s => Fields s -> s +reduce f = + globalTransaction f + <> revGlobalTransaction f + <> globalPosting f + <> revGlobalPosting f + <> fileTransaction f + <> revFileTransaction f + <> filePosting f + <> revFilePosting f + <> filtered f + <> revFiltered f + <> sorted f + <> revSorted f + <> visible f + <> revVisible f + <> lineNum f + <> date f + <> flag f + <> number f + <> postingDrCr f + <> postingCmdty f + <> postingQty f + <> totalDrCr f + <> totalCmdty f + <> totalQty f + +-- | Compute the width of all Grown cells, including any applicable +-- spacer cells. +grownWidth :: + Fields (Maybe Int) + -> S.Spacers Int + -> Int +grownWidth fs ss = + Semi.getSum + . reduce + . fmap Semi.Sum + . fmap fieldWidth + $ pairWithSpacer fs ss + +-- | Compute the field width of a single field and its spacer. The +-- first element of the tuple is the field width, if present; the +-- second element of the tuple is the width of the spacer. If there is +-- no field, returns 0. +fieldWidth :: (Maybe Int, Maybe Int) -> Int +fieldWidth (m1, m2) = case m1 of + Nothing -> 0 + Just i1 -> case m2 of + Just i2 -> if i2 > 0 then i1 + i2 else i1 + Nothing -> i1 + diff --git a/lib/Penny/Cabin/Posts/Meta.hs b/lib/Penny/Cabin/Posts/Meta.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Cabin/Posts/Meta.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE RankNTypes #-} +module Penny.Cabin.Posts.Meta + ( M.VisibleNum(M.unVisibleNum) + , PostMeta(filteredNum, sortedNum, visibleNum, balance) + , toBoxList + ) where + +import Data.List (mapAccumL) +import qualified Penny.Lincoln as L +import qualified Penny.Lincoln.Queries as Q +import qualified Penny.Liberty as Ly +import qualified Penny.Cabin.Meta as M +import qualified Penny.Cabin.Options as CO +import qualified Data.Prednote.Pdct as Pe +import Data.Monoid (mempty, mappend) + +data PostMeta = PostMeta + { filteredNum :: Ly.FilteredNum + , sortedNum :: Ly.SortedNum + , visibleNum :: M.VisibleNum + , balance :: L.Balance } + deriving Show + + +addMetadata + :: [(L.Balance, (Ly.LibertyMeta, L.Posting))] + -> [(PostMeta, L.Posting)] +addMetadata = L.serialItems f where + f ser (bal, (lm, p)) = (pm, p) + where + pm = PostMeta + { filteredNum = Ly.filteredNum lm + , sortedNum = Ly.sortedNum lm + , visibleNum = M.VisibleNum ser + , balance = bal + } + +-- | Adds appropriate metadata, including the running balance, to a +-- list of Box. Because all posts are incorporated into the running +-- balance, first calculates the running balance for all posts. Then, +-- removes posts we're not interested in by applying the predicate and +-- the post-filter. Finally, adds on the metadata, which will include +-- the VisibleNum. +toBoxList + :: CO.ShowZeroBalances + -> Pe.Pdct (Ly.LibertyMeta, L.Posting) + -- ^ Removes posts from the report if applying this function to the + -- post returns a value other than Just True. Posts removed still + -- affect the running balance. + + -> [Ly.PostFilterFn] + -- ^ Applies these post-filters to the list of posts that results + -- from applying the predicate above. Might remove more + -- postings. Postings removed still affect the running balance. + + -> [(Ly.LibertyMeta, L.Posting)] + -> [(PostMeta, L.Posting)] +toBoxList szb pdct pff + = addMetadata + . Ly.processPostFilters pff + . filter (maybe False id . Pe.eval pdct . snd) + . addBalances szb + +addBalances + :: CO.ShowZeroBalances + -> [(a, L.Posting)] + -> [(L.Balance, (a, L.Posting))] +addBalances szb = snd . mapAccumL (balanceAccum szb) mempty + +balanceAccum + :: CO.ShowZeroBalances + -> L.Balance + -> (a, L.Posting) + -> (L.Balance, (L.Balance, (a, L.Posting))) +balanceAccum (CO.ShowZeroBalances szb) balOld (x, po) = + let balThis = L.entryToBalance . Q.entry $ po + balNew = mappend balOld balThis + balNoZeroes = L.removeZeroCommodities balNew + bal' = if szb then balNew else balNoZeroes + po' = (bal', (x, po)) + in (bal', po') + diff --git a/lib/Penny/Cabin/Posts/Parser.hs b/lib/Penny/Cabin/Posts/Parser.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Cabin/Posts/Parser.hs @@ -0,0 +1,286 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Penny.Cabin.Posts.Parser + ( State(..) + , allSpecs + , Error + , VerboseFilter(..) + , ShowExpression(..) + ) where + +import Control.Applicative ((<$>), pure, (<*>), + Applicative) +import qualified Control.Monad.Exception.Synchronous as Ex +import Data.Char (toLower) +import qualified Data.Foldable as Fdbl +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as X +import qualified System.Console.MultiArg.Combinator as C +import qualified System.Console.MultiArg as MA + +import qualified Penny.Cabin.Parsers as P +import qualified Penny.Cabin.Posts.Fields as F +import qualified Penny.Cabin.Posts.Types as Ty +import qualified Penny.Cabin.Options as CO +import qualified Penny.Liberty as Ly +import qualified Data.Prednote.Expressions as Exp +import qualified Data.Prednote.Pdct as Pt +import qualified Penny.Lincoln as L +import qualified Penny.Shield as S +import qualified Text.Matchers as M + +newtype VerboseFilter = VerboseFilter { unVerboseFilter :: Bool } + deriving (Eq, Show) + +newtype ShowExpression = ShowExpression { unShowExpression :: Bool } + deriving (Eq, Show) + +data State = State + { sensitive :: M.CaseSensitive + , factory :: L.Factory + , tokens :: [Exp.Token (Ly.LibertyMeta, L.Posting)] + , postFilter :: [Ly.PostFilterFn] + , fields :: F.Fields Bool + , width :: Ty.ReportWidth + , showZeroBalances :: CO.ShowZeroBalances + , exprDesc :: Exp.ExprDesc + , verboseFilter :: VerboseFilter + , showExpression :: ShowExpression + } + +type Error = X.Text + +allSpecs + :: S.Runtime -> [MA.OptSpec (State -> Ex.Exceptional Error State)] +allSpecs rt = + operand rt + ++ boxFilters + ++ parsePostFilter + ++ (map (fmap (pure .)) matcherSelect) + ++ (map (fmap (pure .)) caseSelect) + ++ (map (fmap (pure .)) operator) + ++ map (fmap (pure .)) parseExprType + ++ [ parseWidth + , showField + , hideField + , fmap (pure .) showAllFields + , fmap (pure .) hideAllFields + , fmap (pure .) parseZeroBalances + , fmap (pure .) parseShowExpression + , fmap (pure .) parseVerboseFilter + ] + + +operand + :: S.Runtime + -> [MA.OptSpec (State -> Ex.Exceptional Error State)] +operand rt = map (fmap f) (Ly.operandSpecs (S.currentTime rt)) + where + f lyFn st = do + let cs = sensitive st + fty = factory st + g <- lyFn cs fty + let g' = Pt.boxPdct snd g + ts' = tokens st ++ [Exp.operand g'] + return $ st { tokens = ts' } + + +-- | Processes a option for box-level serials. +optBoxSerial + :: String + -- ^ Serial name + + -> (Ly.LibertyMeta -> Int) + -- ^ Pulls the serial from the PostMeta + + -> C.OptSpec (State -> Ex.Exceptional Error State) + +optBoxSerial nm f = C.OptSpec [nm] "" (C.TwoArg g) + where + g a1 a2 st = do + i <- Ly.parseInt a2 + let getPd = Pt.compareBy (X.pack . show $ i) + ("serial " <> X.pack nm) cmp + cmp l = compare (f . fst $ l) i + pd <- Ly.parseComparer a1 getPd + let tok = Exp.operand pd + return $ st { tokens = tokens st ++ [tok] } + +optFilteredNum :: C.OptSpec (State -> Ex.Exceptional Error State) +optFilteredNum = optBoxSerial "filtered" f + where + f = L.forward . Ly.unFilteredNum . Ly.filteredNum + +optRevFilteredNum :: C.OptSpec (State -> Ex.Exceptional Error State) +optRevFilteredNum = optBoxSerial "revFiltered" f + where + f = L.backward . Ly.unFilteredNum . Ly.filteredNum + +optSortedNum :: C.OptSpec (State -> Ex.Exceptional Error State) +optSortedNum = optBoxSerial "sorted" f + where + f = L.forward . Ly.unSortedNum . Ly.sortedNum + +optRevSortedNum :: C.OptSpec (State -> Ex.Exceptional Error State) +optRevSortedNum = optBoxSerial "revSorted" f + where + f = L.backward . Ly.unSortedNum . Ly.sortedNum + +boxFilters :: [C.OptSpec (State -> Ex.Exceptional Error State)] +boxFilters = + [ optFilteredNum + , optRevFilteredNum + , optSortedNum + , optRevSortedNum + ] + + +parsePostFilter :: [C.OptSpec (State -> Ex.Exceptional Error State)] +parsePostFilter = [fmap f optH, fmap f optT] + where + (optH, optT) = Ly.postFilterSpecs + f exc st = fmap g exc + where + g pff = st { postFilter = postFilter st ++ [pff] } + + +matcherSelect :: [C.OptSpec (State -> State)] +matcherSelect = map (fmap f) Ly.matcherSelectSpecs + where + f mf st = st { factory = mf } + + +caseSelect :: [C.OptSpec (State -> State)] +caseSelect = map (fmap f) Ly.caseSelectSpecs + where + f cs st = st { sensitive = cs } + +operator :: [C.OptSpec (State -> State)] +operator = map (fmap f) Ly.operatorSpecs + where + f oo st = st { tokens = tokens st ++ [oo] } + +parseWidth :: C.OptSpec (State -> Ex.Exceptional Error State) +parseWidth = C.OptSpec ["width"] "" (C.OneArg f) + where + f a1 st = do + i <- Ly.parseInt a1 + return $ st { width = Ty.ReportWidth i } + +parseField :: String -> Ex.Exceptional Error (F.Fields Bool) +parseField str = + let lower = map toLower str + checkField s = + if (map toLower s) == lower + then (s, True) + else (s, False) + flds = checkField <$> F.fieldNames + in case checkFields flds of + Ex.Exception e -> case e of + NoMatchingFields -> Ex.throw + $ "no field matches the name \"" <> X.pack str <> "\"\n" + MultipleMatchingFields ts -> Ex.throw + $ "multiple fields match the name \"" <> X.pack str + <> "\" matches: " <> mtchs <> "\n" + where + mtchs = X.intercalate " " + . map (\x -> "\"" <> x <> "\"") + $ ts + Ex.Success g -> return g + + +-- | Turns a field on if it is True. +fieldOn :: + F.Fields Bool + -- ^ Fields as seen so far + + -> F.Fields Bool + -- ^ Record that should have one True element indicating a field + -- name seen on the command line; other elements should be False + + -> F.Fields Bool + -- ^ Fields as seen so far, with new field added + +fieldOn old new = (||) <$> old <*> new + +-- | Turns off a field if it is True. +fieldOff :: + F.Fields Bool + -- ^ Fields seen so far + + -> F.Fields Bool + -- ^ Record that should have one True element indicating a field + -- name seen on the command line; other elements should be False + + -> F.Fields Bool + -- ^ Fields as seen so far, with new field added + +fieldOff old new = f <$> old <*> new + where + f o False = o + f _ True = False + +showField :: C.OptSpec (State -> Ex.Exceptional Error State) +showField = C.OptSpec ["show"] "" (C.OneArg f) + where + f a1 st = do + fl <- parseField a1 + let newFl = fieldOn (fields st) fl + return $ st { fields = newFl } + +hideField :: C.OptSpec (State -> Ex.Exceptional Error State) +hideField = C.OptSpec ["hide"] "" (C.OneArg f) + where + f a1 st = do + fl <- parseField a1 + let newFl = fieldOff (fields st) fl + return $ st { fields = newFl } + +showAllFields :: C.OptSpec (State -> State) +showAllFields = C.OptSpec ["show-all"] "" (C.NoArg f) + where + f st = st {fields = pure True} + +hideAllFields :: C.OptSpec (State -> State) +hideAllFields = C.OptSpec ["hide-all"] "" (C.NoArg f) + where + f st = st {fields = pure False} + +parseZeroBalances :: C.OptSpec (State -> State) +parseZeroBalances = fmap f P.zeroBalances + where + f szb st = st { showZeroBalances = szb } + +parseExprType :: [C.OptSpec (State -> State)] +parseExprType = map (fmap f) [Ly.parseInfix, Ly.parseRPN] + where + f d st = st { exprDesc = d } + +parseShowExpression :: C.OptSpec (State -> State) +parseShowExpression = fmap f Ly.showExpression + where + f _ st = st { showExpression = ShowExpression True } + +parseVerboseFilter :: C.OptSpec (State -> State) +parseVerboseFilter = fmap f Ly.verboseFilter + where + f _ st = st { verboseFilter = VerboseFilter True } + +data BadFieldError + = NoMatchingFields + | MultipleMatchingFields [Text] + deriving Show + +-- | Checks the fields with the True value to ensure there is only one. +checkFields :: + F.Fields (String, Bool) + -> Ex.Exceptional BadFieldError (F.Fields Bool) +checkFields fs = + let f (s, b) ls = if b then s:ls else ls + in case Fdbl.foldr f [] fs of + [] -> Ex.throw NoMatchingFields + _:[] -> return (snd <$> fs) + ms -> Ex.throw . MultipleMatchingFields . map X.pack $ ms + + diff --git a/lib/Penny/Cabin/Posts/Spacers.hs b/lib/Penny/Cabin/Posts/Spacers.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Cabin/Posts/Spacers.hs @@ -0,0 +1,32 @@ +-- | Spacer fields in the report. They don't contain any data; they +-- just provide whitespace. Each spacer immediately follows the named +-- field. +module Penny.Cabin.Posts.Spacers where + +data Spacers a = Spacers + { globalTransaction :: a + , revGlobalTransaction :: a + , globalPosting :: a + , revGlobalPosting :: a + , fileTransaction :: a + , revFileTransaction :: a + , filePosting :: a + , revFilePosting :: a + , filtered :: a + , revFiltered :: a + , sorted :: a + , revSorted :: a + , visible :: a + , revVisible :: a + , lineNum :: a + , date :: a + , flag :: a + , number :: a + , payee :: a + , account :: a + , postingDrCr :: a + , postingCmdty :: a + , postingQty :: a + , totalDrCr :: a + , totalCmdty :: a + } deriving (Show, Eq) diff --git a/lib/Penny/Cabin/Posts/Types.hs b/lib/Penny/Cabin/Posts/Types.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Cabin/Posts/Types.hs @@ -0,0 +1,4 @@ +module Penny.Cabin.Posts.Types where + +newtype ReportWidth = ReportWidth { unReportWidth :: Int } + deriving (Eq, Show, Ord) diff --git a/lib/Penny/Cabin/Row.hs b/lib/Penny/Cabin/Row.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Cabin/Row.hs @@ -0,0 +1,138 @@ +-- | Displays a single on-screen row. A row may contain multiple +-- screen lines and multiple columns. +-- +-- This module only deals with a single row at a time. Each cell in +-- the row can have more than one screen line; this module will make +-- sure that the cells have appropriate padding on the bottom so that +-- the row appears nicely. This module will also justify each cell so +-- that its left side or right side is ragged; however, you first have +-- to specify how wide you want the cell to be. +-- +-- This module is a little dumber than you might first think it could +-- be. For instance it would be possible to write a function that +-- takes a number of rows and automatically justifies all the cells by +-- finding the widest cell in a column. Indeed I might eventually +-- write such a function because it might be useful in, for example, +-- the multi-commodity balance report. However, such a function would +-- not be useful in all cases; in particular, the Posts report is very +-- complicated to lay out, and the automatic function described above +-- would not do the right thing. +-- +-- So this module offers some useful automation, even if it is at a +-- level that is apparently lower that what is possible. Thus the +-- present 'row' function likely will not change, even if eventually I +-- add a 'table' function that automatically justifies many rows. +module Penny.Cabin.Row ( + Justification(LeftJustify, RightJustify), + ColumnSpec(ColumnSpec, justification, width, padSpec, bits), + Width(Width, unWidth), + row ) where + +import Data.List (transpose) +import qualified Data.Text as X +import qualified Penny.Cabin.Scheme as E +import qualified System.Console.Rainbow as R + +-- | How to justify cells. LeftJustify leaves the right side +-- ragged. RightJustify leaves the left side ragged. +data Justification = + LeftJustify + | RightJustify + deriving Show + +-- | A cell of text output. You tell the cell how to justify itself +-- and how wide it is. You also tell it the background colors to +-- use. The cell will be appropriately justified (that is, text +-- aligned between left and right margins) and padded (with lines of +-- blank text added on the bottom as needed) when joined with other +-- cells into a Row. +data ColumnSpec = + ColumnSpec { justification :: Justification + , width :: Width + , padSpec :: (E.Label, E.EvenOdd) + , bits :: [R.Chunk] } + +newtype JustifiedCell = JustifiedCell (R.Chunk, R.Chunk) + +data JustifiedColumn = JustifiedColumn { + justifiedCells :: [JustifiedCell] + , _justifiedWidth :: Width + , _justifiedPadSpec :: (E.Label, E.EvenOdd) } + +newtype PaddedColumns = PaddedColumns [[JustifiedCell]] +newtype CellsByRow = CellsByRow [[JustifiedCell]] +newtype CellRowsWithNewlines = CellRowsWithNewlines [[JustifiedCell]] +newtype Width = Width { unWidth :: Int } + deriving (Eq, Ord, Show) + +justify + :: Width + -> Justification + -> E.Label + -> E.EvenOdd + -> E.Changers + -> R.Chunk + -> JustifiedCell +justify (Width w) j l eo chgrs pc = JustifiedCell (left, right) + where + origWidth = X.length . R.chunkText $ pc + pad = E.getEvenOddLabelValue l eo chgrs $ R.plain t + t = X.replicate (max 0 (w - origWidth)) (X.singleton ' ') + (left, right) = case j of + LeftJustify -> (pc, pad) + RightJustify -> (pad, pc) + +newtype Height = Height Int + deriving (Show, Eq, Ord) + +height :: [[a]] -> Height +height xs = case xs of + [] -> Height 0 + ls -> Height . maximum . map length $ ls + +row :: E.Changers -> [ColumnSpec] -> [R.Chunk] +row chgrs = + concat + . concat + . toBits + . toCellRowsWithNewlines + . toCellsByRow + . bottomPad chgrs + . map (justifiedColumn chgrs) + +justifiedColumn :: E.Changers -> ColumnSpec -> JustifiedColumn +justifiedColumn chgrs (ColumnSpec j w (l, eo) bs) + = JustifiedColumn cs w (l, eo) + where + cs = map (justify w j l eo chgrs) bs + +bottomPad :: E.Changers -> [JustifiedColumn] -> PaddedColumns +bottomPad chgrs jcs = PaddedColumns pcs where + justCells = map justifiedCells jcs + (Height h) = height justCells + pcs = map toPaddedColumn jcs + toPaddedColumn (JustifiedColumn cs (Width w) (lbl, eo)) = + let l = length cs + nPads = max 0 $ h - l + pad = E.getEvenOddLabelValue lbl eo chgrs $ R.plain t + t = X.replicate w (X.singleton ' ') + pads = replicate nPads $ JustifiedCell (R.plain X.empty, pad) + in cs ++ pads + + +toCellsByRow :: PaddedColumns -> CellsByRow +toCellsByRow (PaddedColumns cs) = CellsByRow (transpose cs) + + +toCellRowsWithNewlines :: CellsByRow -> CellRowsWithNewlines +toCellRowsWithNewlines (CellsByRow bs) = + CellRowsWithNewlines bs' where + bs' = foldr f [] bs + newline = JustifiedCell (R.plain X.empty, R.plain (X.singleton '\n')) + f cells acc = (cells ++ [newline]) : acc + + +toBits :: CellRowsWithNewlines -> [[[R.Chunk]]] +toBits (CellRowsWithNewlines cs) = map (map toB) cs where + toB (JustifiedCell (c1, c2)) = [c1, c2] + diff --git a/lib/Penny/Cabin/Scheme.hs b/lib/Penny/Cabin/Scheme.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Cabin/Scheme.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Cabin color schemes +-- +-- Each element of a Cabin report identifies what it is--a debit on an +-- even line, a credit on an odd line, etc. The user can have several +-- color schemes; the scheme contains color assignments for 8 and 256 +-- color terminals. This allows the use of different schemes for light +-- and dark terminals or for any other reason. + +module Penny.Cabin.Scheme where + +import qualified Penny.Cabin.Meta as M +import qualified Penny.Lincoln as L +import qualified Data.Text as X +import qualified System.Console.Rainbow as R + +data Label + = Debit + | Credit + | Zero + | Other + deriving (Eq, Ord, Show) + +data EvenOdd = Even | Odd deriving (Eq, Ord, Show) + +data Labels a = Labels + { debit :: a + , credit :: a + , zero :: a + , other :: a + } deriving Show + +getLabelValue :: Label -> Labels a -> a +getLabelValue l ls = case l of + Debit -> debit ls + Credit -> credit ls + Zero -> zero ls + Other -> other ls + +data EvenAndOdd a = EvenAndOdd + { eoEven :: a + , eoOdd :: a + } deriving Show + +type Changers = Labels (EvenAndOdd (R.Chunk -> R.Chunk)) + +data Scheme = Scheme + { name :: String + -- ^ The name of this scheme. How it will be identified on the + -- command line. + + , description :: String + -- ^ A brief (one-line) description of what this scheme is, such + -- as @for dark background terminals@ + + , changers :: Changers + } deriving Show + + +getEvenOdd :: EvenOdd -> EvenAndOdd a -> a +getEvenOdd eo eao = case eo of + Even -> eoEven eao + Odd -> eoOdd eao + +getEvenOddLabelValue + :: Label + -> EvenOdd + -> Labels (EvenAndOdd a) + -> a +getEvenOddLabelValue l eo ls = + getEvenOdd eo (getLabelValue l ls) + +fromVisibleNum :: M.VisibleNum -> EvenOdd +fromVisibleNum vn = + let s = M.unVisibleNum vn in + if even . L.forward $ s then Even else Odd + +dcToLbl :: L.DrCr -> Label +dcToLbl L.Debit = Debit +dcToLbl L.Credit = Credit + +bottomLineToDrCr :: L.BottomLine -> EvenOdd -> Changers -> R.Chunk +bottomLineToDrCr bl eo chgrs = md c + where + (c, md) = case bl of + L.Zero -> (R.plain "--", getEvenOddLabelValue Zero eo chgrs) + L.NonZero (L.Column clmDrCr _) -> case clmDrCr of + L.Debit -> (R.plain "<", getEvenOddLabelValue Debit eo chgrs) + L.Credit -> (R.plain ">", getEvenOddLabelValue Credit eo chgrs) + + +balancesToCmdtys + :: Changers + -> EvenOdd + -> [(L.Commodity, L.BottomLine)] + -> [R.Chunk] +balancesToCmdtys chgrs eo ls = + if null ls + then [getEvenOddLabelValue Zero eo chgrs $ R.plain "--"] + else map (bottomLineToCmdty chgrs eo) ls + +bottomLineToCmdty + :: Changers + -> EvenOdd + -> (L.Commodity, L.BottomLine) + -> R.Chunk +bottomLineToCmdty chgrs eo (cy, bl) = md c + where + c = R.plain . L.unCommodity $ cy + lbl = case bl of + L.Zero -> Zero + L.NonZero (L.Column clmDrCr _) -> dcToLbl clmDrCr + md = getEvenOddLabelValue lbl eo chgrs + +balanceToQtys + :: Changers + -> (L.Commodity -> L.Qty -> X.Text) + -> EvenOdd + -> [(L.Commodity, L.BottomLine)] + -> [R.Chunk] +balanceToQtys chgrs getTxt eo ls = + if null ls + then let md = getEvenOddLabelValue Zero eo chgrs + in [md (R.plain "--")] + else map (bottomLineToQty chgrs getTxt eo) ls + + +bottomLineToQty + :: Changers + -> (L.Commodity -> L.Qty -> X.Text) + -> EvenOdd + -> (L.Commodity, L.BottomLine) + -> R.Chunk +bottomLineToQty chgrs getTxt eo (cy, bl) = md (R.plain t) + where + (lbl, t) = case bl of + L.Zero -> (Zero, X.pack "--") + L.NonZero (L.Column clmDrCr qt) -> (dcToLbl clmDrCr, getTxt cy qt) + md = getEvenOddLabelValue lbl eo chgrs + diff --git a/lib/Penny/Cabin/Scheme/Schemes.hs b/lib/Penny/Cabin/Scheme/Schemes.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Cabin/Scheme/Schemes.hs @@ -0,0 +1,87 @@ +-- | Some schemes you can use. + +module Penny.Cabin.Scheme.Schemes where + +import qualified Penny.Cabin.Scheme as E +import qualified System.Console.Rainbow as R +import System.Console.Rainbow ((.+.)) + +-- | The light color scheme. You can change various values below to +-- affect the color scheme. +light :: E.Scheme +light = E.Scheme "light" "for light background terminals" + lightLabels + +lightLabels :: E.Labels (E.EvenAndOdd (R.Chunk -> R.Chunk)) +lightLabels = E.Labels + { E.debit = E.EvenAndOdd { E.eoEven = lightDebit lightEvenTextSpec + , E.eoOdd = lightDebit lightOddTextSpec } + , E.credit = E.EvenAndOdd { E.eoEven = lightCredit lightEvenTextSpec + , E.eoOdd = lightCredit lightOddTextSpec } + , E.zero = E.EvenAndOdd { E.eoEven = lightZero lightEvenTextSpec + , E.eoOdd = lightZero lightOddTextSpec } + , E.other = E.EvenAndOdd { E.eoEven = lightEvenTextSpec + , E.eoOdd = lightOddTextSpec } + } + +lightEvenTextSpec :: R.Chunk -> R.Chunk +lightEvenTextSpec = id + +lightOddTextSpec :: R.Chunk -> R.Chunk +lightOddTextSpec = id .+. R.color8_b_default .+. R.color256_b_255 + +lightDebit :: (R.Chunk -> R.Chunk) -> R.Chunk -> R.Chunk +lightDebit f = f .+. R.color8_f_magenta .+. R.color256_f_52 + +lightCredit :: (R.Chunk -> R.Chunk) -> R.Chunk -> R.Chunk +lightCredit f = f .+. R.color8_f_cyan .+. R.color256_f_21 + +lightZero :: (R.Chunk -> R.Chunk) -> R.Chunk -> R.Chunk +lightZero f = f .+. R.color8_f_black .+. R.color256_f_0 + +-- | The dark color scheme. You can change various values below to +-- affect the color scheme. +dark :: E.Scheme +dark = E.Scheme "dark" "for dark background terminals" + darkLabels + +darkLabels :: E.Labels (E.EvenAndOdd (R.Chunk -> R.Chunk)) +darkLabels = E.Labels + { E.debit = E.EvenAndOdd { E.eoEven = darkDebit darkEvenTextSpec + , E.eoOdd = darkDebit darkOddTextSpec } + , E.credit = E.EvenAndOdd { E.eoEven = darkCredit darkEvenTextSpec + , E.eoOdd = darkCredit darkOddTextSpec } + , E.zero = E.EvenAndOdd { E.eoEven = darkZero darkEvenTextSpec + , E.eoOdd = darkZero darkOddTextSpec } + , E.other = E.EvenAndOdd { E.eoEven = darkEvenTextSpec + , E.eoOdd = darkOddTextSpec } + } + +darkEvenTextSpec :: R.Chunk -> R.Chunk +darkEvenTextSpec = id + +darkOddTextSpec :: R.Chunk -> R.Chunk +darkOddTextSpec = id .+. R.color8_b_default .+. R.color256_b_235 + +darkDebit :: (R.Chunk -> R.Chunk) -> R.Chunk -> R.Chunk +darkDebit f = f .+. R.color8_f_magenta .+. R.color256_f_208 + +darkCredit :: (R.Chunk -> R.Chunk) -> R.Chunk -> R.Chunk +darkCredit f = f .+. R.color8_f_cyan .+. R.color256_f_45 + +darkZero :: (R.Chunk -> R.Chunk) -> R.Chunk -> R.Chunk +darkZero f = f .+. R.color8_f_white .+. R.color256_f_15 + +-- | Plain scheme has no colors at all. +plain :: E.Scheme +plain = E.Scheme "plain" "uses default terminal colors" + plainLabels + +plainLabels :: E.Labels (E.EvenAndOdd (R.Chunk -> R.Chunk)) +plainLabels = E.Labels + { E.debit = E.EvenAndOdd id id + , E.credit = E.EvenAndOdd id id + , E.zero = E.EvenAndOdd id id + , E.other = E.EvenAndOdd id id + } + diff --git a/lib/Penny/Cabin/TextFormat.hs b/lib/Penny/Cabin/TextFormat.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Cabin/TextFormat.hs @@ -0,0 +1,173 @@ +module Penny.Cabin.TextFormat ( + Lines(Lines, unLines), + Words(Words, unWords), + CharsPerLine(unCharsPerLine), + txtWords, + wordWrap, + Target(Target, unTarget), + Shortest(Shortest, unShortest), + shorten) where + +import qualified Control.Monad.Trans.State as St +import qualified Data.Foldable as F +import Data.Sequence ((|>), ViewR((:>)), ViewL((:<))) +import qualified Data.Sequence as S +import qualified Data.Text as X +import qualified Data.Traversable as T + +data Lines = Lines { unLines :: S.Seq Words } deriving Show +data Words = Words { unWords :: S.Seq X.Text } deriving Show +newtype CharsPerLine = + CharsPerLine { unCharsPerLine :: Int } deriving Show + +-- | Splits a blank-separated text into words. +txtWords :: X.Text -> Words +txtWords = Words . S.fromList . X.words + +-- | Wraps a sequence of words into a sequence of lines, where each +-- line is no more than a given maximum number of characters long. +-- +-- If the maximum number of characters per line is less than 1, +-- returns a Lines that is empty. +-- +-- An individual word will be split across multiple lines only if that +-- word is too long to fit into a single line. No hyphenation is done; +-- the word is simply broken across two lines. +wordWrap :: Int -> Words -> Lines +wordWrap l (Words wsq) = + if l < 1 + then Lines (S.empty) + else F.foldl f (Lines S.empty) wsq where + f (Lines sws) w = let + (back, ws) = case S.viewr sws of + S.EmptyR -> (S.empty, Words S.empty) + (b :> x) -> (b, x) + in case addWord l ws w of + (Just ws') -> Lines $ back |> ws' + Nothing -> + if X.length w > l + then addPartialWords l (Lines sws) w + else Lines (back |> ws |> (Words (S.singleton w))) + +lenWords :: Words -> Int +lenWords (Words s) = case S.length s of + 0 -> 0 + l -> (F.sum . fmap X.length $ s) + (l - 1) + +-- | Adds a word to a Words, but only if it will not make the Words +-- exceed the given length. +addWord :: Int -> Words -> X.Text -> Maybe Words +addWord l (Words ws) w = + let words' = Words (ws |> w) + in if lenWords words' > l + then Nothing + else Just words' + +-- | Adds a word to a Words. If the word is too long to fit, breaks it +-- and adds the longest portion possible. Returns the new Words, and a +-- Text with the part of the word that was not added (if any; if all +-- of the word was added, return an empty Text.) +addPartialWord :: Int -> Words -> X.Text -> (Words, X.Text) +addPartialWord l (Words ws) t = case addWord l (Words ws) t of + (Just ws') -> (ws', X.empty) + Nothing -> + let maxChars = + if S.null ws then l + else max 0 (l - lenWords (Words ws) - 1) + (begin, end) = X.splitAt maxChars t + in (Words (if X.null begin then ws else ws |> begin), end) + +addPartialWords :: Int -> Lines -> X.Text -> Lines +addPartialWords l (Lines wsq) t = let + (back, ws) = case S.viewr wsq of + S.EmptyR -> (S.empty, Words S.empty) + (b :> x) -> (b, x) + (rw, rt) = addPartialWord l ws t + in if X.null rt + then Lines (back |> rw) + else addPartialWords l (Lines (back |> rw |> Words (S.empty))) rt + +newtype Target = Target { unTarget :: Int } deriving Show +newtype Shortest = Shortest { unShortest :: Int } deriving Show + +-- | Takes a list of words and shortens it so that it fits in the +-- space allotted. You specify the minimum length for each word, x. It +-- will shorten the farthest left word first, until it is only x +-- characters long; then it will shorten the next word until it is +-- only x characters long, etc. This proceeds until all words are just +-- x characters long. Then words are shortened to one +-- character. Then the leftmost words are deleted as necessary. +-- +-- Assumes that the words will be printed with a separator, which +-- matters when lengths are calculated. +shorten :: Shortest -> Target -> Words -> Words +shorten (Shortest s) (Target t) wsa@(Words wsq) = let + nToRemove = max (lenWords wsa - t) 0 + (allWords, _) = shortenUntilOne s nToRemove wsq + in stripWordsUntil t (Words allWords) + +-- | Shorten a word by x characters or until it is y characters long, +-- whichever comes first. Returns the word and the number of +-- characters removed. +shortenUntil :: Int -> Int -> X.Text -> (X.Text, Int) +shortenUntil by shortest t = let + removable = max (X.length t - shortest) 0 + toRemove = min removable (max by 0) + prefix = X.length t - toRemove + in (X.take prefix t, toRemove) + +-- | Shortens a word until it is x characters long or by the number of +-- characters indicated in the state, whichever is less. Subtracts the +-- number of characters removed from the state. +shortenSt :: Int -> X.Text -> St.State Int X.Text +shortenSt shortest t = do + by <- St.get + let (r, nRemoved) = shortenUntil by shortest t + St.put (by - nRemoved) + return r + +-- | Shortens each word in a list, from left to right, until a +-- particular number of characters have been reduced or until each +-- word is x characters long, whichever happens first. Returns the new +-- list and the number of characters that still need to be reduced. +shortenEachInList :: + T.Traversable t + => Int -- ^ Shortest word length + -> Int -- ^ Total number to remove + -> t X.Text + -> (t X.Text, Int) +shortenEachInList shortest by ts = (r, left) where + k = T.mapM (shortenSt shortest) ts + (r, left) = St.runState k by + +shortenUntilOne :: + T.Traversable t + => Int -- ^ Shortest word length to start with + -> Int -- ^ Total number of characters to remove + -> t X.Text + -> (t X.Text, Int) +shortenUntilOne shortest by ts = let + r@(ts', left) = shortenEachInList shortest by ts + in if shortest == 1 || left == 0 + then r + else shortenUntilOne (pred shortest) left ts' + +-- | Eliminates words until the length of the words, as indicated by +-- lenWords, is less than or equal to the value given. +stripWordsUntil :: Int -> Words -> Words +stripWordsUntil i wsa@(Words ws) = case S.viewl ws of + S.EmptyL -> Words (S.empty) + (_ :< rest) -> + if lenWords wsa <= (max i 0) + then wsa + else stripWordsUntil (max i 0) (Words rest) + + +-- +-- Testing +-- +_words :: Words +_words = Words . S.fromList . map X.pack $ ws where + ws = [ "these", "are", "fragilisticwonderfulgood", + "good", "", "x", "xy", "xyza", + "longlonglongword" ] diff --git a/lib/Penny/Copper.hs b/lib/Penny/Copper.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Copper.hs @@ -0,0 +1,163 @@ +-- | Copper - the Penny parser. +-- +-- The parse functions in this module only accept lists of files +-- rather than individual files because in order to correctly assign +-- the global serials a single function must be able to see all the +-- transactions, not just the transactions in a single file. +module Penny.Copper + ( + -- * Convenience functions to read and parse files + open + + -- * Types for things found in ledger files + , module Penny.Copper.Interface + + -- * Rendering + , R.GroupSpec(..) + , R.GroupSpecs(..) + , R.item + + + ) where + +import Control.Arrow (second) +import qualified Data.Traversable as Tr +import qualified Penny.Copper.Parsec as CP +import qualified Penny.Steel.Sums as S +import Penny.Copper.Interface +import qualified Penny.Copper.Interface as I + +import qualified Penny.Lincoln as L +import qualified Penny.Copper.Render as R + +-- | Reads and parses the given files. If any of the files is @-@, +-- reads standard input. If the list of files is empty, reads standard +-- input. IO errors are not caught. Parse errors are printed to +-- standard error and the program will exit with a failure. +open :: [String] -> IO [I.LedgerItem] +open ss = fmap parsedToWrapped $ mapM CP.parse ss + +addFilePosting + :: Tr.Traversable f + => [S.S4 (a, f b) x y z] + -> [S.S4 (a, f (L.FilePosting, b)) x y z] +addFilePosting = L.serialNestedItems f where + f i = case i of + S.S4a (a, ctnr) -> + Right ( ctnr + , (\ser ii -> (L.FilePosting ser, ii)) + , (\res -> S.S4a (a, res)) + ) + S.S4b x -> Left (S.S4b x) + S.S4c x -> Left (S.S4c x) + S.S4d x -> Left (S.S4d x) + +addFileTransaction + :: [S.S4 (a, b) x y z] + -> [S.S4 ((L.FileTransaction, a), b) x y z] +addFileTransaction = L.serialSomeItems f where + f i = case i of + S.S4a (a, b) -> Right (\ser -> S.S4a ((L.FileTransaction ser, a), b)) + S.S4b x -> Left (S.S4b x) + S.S4c x -> Left (S.S4c x) + S.S4d x -> Left (S.S4d x) + +addGlobalTransaction + :: [S.S4 (a, b) x y z] + -> [S.S4 ((L.GlobalTransaction, a), b) x y z] +addGlobalTransaction = L.serialSomeItems f where + f i = case i of + S.S4a (a, b) -> Right (\ser -> S.S4a ((L.GlobalTransaction ser, a), b)) + S.S4b x -> Left (S.S4b x) + S.S4c x -> Left (S.S4c x) + S.S4d x -> Left (S.S4d x) + +addGlobalPosting + :: Tr.Traversable f + => [S.S4 (a, f b) x y z] + -> [S.S4 (a, f (L.GlobalPosting, b)) x y z] +addGlobalPosting = L.serialNestedItems f where + f i = case i of + S.S4a (a, ctnr) -> + Right ( ctnr + , (\ser ii -> (L.GlobalPosting ser, ii)) + , (\res -> S.S4a (a, res)) + ) + S.S4b x -> Left (S.S4b x) + S.S4c x -> Left (S.S4c x) + S.S4d x -> Left (S.S4d x) + +addFilename + :: L.Filename + -> [S.S4 (a, b) x y z] + -> [S.S4 ((L.Filename, a), b) x y z] +addFilename fn = map f where + f i = case i of + S.S4a (a, b) -> S.S4a ((fn, a), b) + S.S4b x -> S.S4b x + S.S4c x -> S.S4c x + S.S4d x -> S.S4d x + +addFileSerials + :: Tr.Traversable f + => [S.S4 (a, f b) x y z] + -> [S.S4 ((L.FileTransaction, a), f (L.FilePosting, b)) x y z] +addFileSerials + = addFilePosting + . addFileTransaction + +addFileData + :: Tr.Traversable f + => (L.Filename, [S.S4 (a, f b) x y z]) + -> [S.S4 ((L.Filename, (L.FileTransaction, a)), f (L.FilePosting, b)) x y z] +addFileData = uncurry addFilename . second addFileSerials + +addGlobalSerials + :: Tr.Traversable f + => [S.S4 (a, f b) x y z] + -> [S.S4 ((L.GlobalTransaction, a), f (L.GlobalPosting, b)) x y z] +addGlobalSerials + = addGlobalTransaction + . addGlobalPosting + +addAllMetadata + :: Tr.Traversable f + => [(L.Filename, [S.S4 (a, f b) x y z])] + -> [S.S4 ((L.GlobalTransaction, (L.Filename, (L.FileTransaction, a))), + f (L.GlobalPosting, (L.FilePosting, b))) x y z] +addAllMetadata + = addGlobalSerials + . concat + . map addFileData + +rewrapMetadata + :: Functor f + => ( (L.GlobalTransaction, (L.Filename, (L.FileTransaction, I.ParsedTopLine))) + , f (L.GlobalPosting, (L.FilePosting, (L.PostingCore, L.PostingLine)))) + -> (L.TopLineData, f (L.PostingData)) +rewrapMetadata ((gt, (fn, (ft, ptl))), ctr) = (tld, fmap f ctr) + where + tld = L.TopLineData + tlc + (Just (L.TopLineFileMeta fn (I.ptlTopLineLine ptl) + (fmap snd $ I.ptlMemo ptl) + ft)) + (Just gt) + tlc = L.TopLineCore (I.ptlDateTime ptl) (I.ptlNumber ptl) + (I.ptlFlag ptl) (I.ptlPayee ptl) + (fmap fst $ I.ptlMemo ptl) + f (gp, (fp, (pc, pl))) = L.PostingData + pc + (Just (L.PostingFileMeta pl fp)) + (Just gp) + +parsedToWrapped + :: [(L.Filename, [I.ParsedItem])] + -> [I.LedgerItem] +parsedToWrapped = map rewrap . addAllMetadata where + rewrap i = case i of + S.S4a x -> S.S4a (L.Transaction . rewrapMetadata $ x) + S.S4b x -> S.S4b x + S.S4c x -> S.S4c x + S.S4d x -> S.S4d x + diff --git a/lib/Penny/Copper/Interface.hs b/lib/Penny/Copper/Interface.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Copper/Interface.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Penny.Copper.Interface where + +import qualified Penny.Lincoln as L +import qualified Data.Text as X +import qualified Data.Text.Encoding as XE +import GHC.Generics (Generic) +import qualified Data.Binary as B +import qualified Penny.Steel.Sums as S + +data ParsedTopLine = ParsedTopLine + { ptlDateTime :: L.DateTime + , ptlNumber :: Maybe L.Number + , ptlFlag :: Maybe L.Flag + , ptlPayee :: Maybe L.Payee + , ptlMemo :: Maybe (L.Memo, L.TopMemoLine) + , ptlTopLineLine :: L.TopLineLine + } deriving (Show, Generic) + +toTopLineCore :: ParsedTopLine -> L.TopLineCore +toTopLineCore (ParsedTopLine dt nu fl pa me _) + = L.TopLineCore dt nu fl pa (fmap fst me) + +instance B.Binary ParsedTopLine + +type ParsedTxn = (ParsedTopLine , L.Ents (L.PostingCore, L.PostingLine)) + +data BlankLine = BlankLine + deriving (Eq, Show, Generic) + +instance B.Binary BlankLine + +newtype Comment = Comment { unComment :: X.Text } + deriving (Eq, Show) + +instance B.Binary Comment where + get = fmap (Comment . XE.decodeUtf8) B.get + put = B.put . XE.encodeUtf8 . unComment + +type ParsedItem = + S.S4 ParsedTxn L.PricePoint Comment BlankLine + +type LedgerItem = + S.S4 L.Transaction L.PricePoint Comment BlankLine + +type Parser + = String + -- ^ Filename of the file to be parsed + -> IO (L.Filename, [ParsedItem]) + +-- | Changes a ledger item to remove metadata. +stripMeta + :: LedgerItem + -> S.S4 (L.TopLineCore, L.Ents L.PostingCore) + L.PricePoint + Comment + BlankLine +stripMeta = S.mapS4 f id id id where + f t = let (tl, es) = L.unTransaction t + in (L.tlCore tl, fmap L.pdCore es) + diff --git a/lib/Penny/Copper/Parsec.hs b/lib/Penny/Copper/Parsec.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Copper/Parsec.hs @@ -0,0 +1,415 @@ +-- | Parsec parsers for the ledger file format. The format is +-- documented in EBNF in the file @doc\/ledger-grammar.org@. +module Penny.Copper.Parsec where + +import qualified Penny.Copper.Interface as I +import qualified Penny.Copper.Terminals as T +import Text.Parsec.Text (Parser) +import Text.Parsec (many, many1, satisfy) +import qualified Text.Parsec as P +import qualified Text.Parsec.Pos as Pos +import Control.Applicative.Permutation (runPerms, maybeAtom) +import Control.Applicative ((<$>), (<$), (<*>), (*>), (<*), + (<|>), optional) +import Control.Monad (replicateM, when) +import qualified Penny.Lincoln as L +import qualified Penny.Steel.Sums as S +import Data.Maybe (fromMaybe) +import Data.Text (Text, pack) +import qualified Data.Text as X +import qualified Data.Time as Time +import qualified System.Exit as Exit +import System.Environment (getProgName) +import qualified System.IO as IO +import qualified Data.Text.IO as TIO + +lvl1SubAcct :: Parser L.SubAccount +lvl1SubAcct = + (L.SubAccount . pack) <$> many1 (satisfy T.lvl1AcctChar) + +lvl1FirstSubAcct :: Parser L.SubAccount +lvl1FirstSubAcct = lvl1SubAcct + +lvl1OtherSubAcct :: Parser L.SubAccount +lvl1OtherSubAcct = satisfy T.colon *> lvl1SubAcct + +lvl1Acct :: Parser L.Account +lvl1Acct = f <$> lvl1FirstSubAcct <*> many lvl1OtherSubAcct + where + f a as = L.Account (a:as) + +quotedLvl1Acct :: Parser L.Account +quotedLvl1Acct = + satisfy T.openCurly *> lvl1Acct <* satisfy T.closeCurly + +lvl2FirstSubAcct :: Parser L.SubAccount +lvl2FirstSubAcct = + (\c cs -> L.SubAccount (pack (c:cs))) + <$> satisfy T.letter + <*> many (satisfy T.lvl2AcctOtherChar) + +lvl2OtherSubAcct :: Parser L.SubAccount +lvl2OtherSubAcct = + (L.SubAccount . pack) + <$ satisfy T.colon + <*> many1 (satisfy T.lvl2AcctOtherChar) + +lvl2Acct :: Parser L.Account +lvl2Acct = + (\a as -> L.Account (a:as)) + <$> lvl2FirstSubAcct + <*> many lvl2OtherSubAcct + +ledgerAcct :: Parser L.Account +ledgerAcct = quotedLvl1Acct <|> lvl2Acct + +lvl1Cmdty :: Parser L.Commodity +lvl1Cmdty = (L.Commodity . pack) <$> many1 (satisfy T.lvl1CmdtyChar) + +quotedLvl1Cmdty :: Parser L.Commodity +quotedLvl1Cmdty = + satisfy T.doubleQuote *> lvl1Cmdty <* satisfy (T.doubleQuote) + +lvl2Cmdty :: Parser L.Commodity +lvl2Cmdty = + (\c cs -> L.Commodity (pack (c:cs))) + <$> satisfy T.lvl2CmdtyFirstChar + <*> many (satisfy T.lvl2CmdtyOtherChar) + +lvl3Cmdty :: Parser L.Commodity +lvl3Cmdty = (L.Commodity . pack) <$> many1 (satisfy T.lvl3CmdtyChar) + +digitGroup :: Parser [Char] +digitGroup = satisfy T.thinSpace *> many1 (satisfy T.digit) + +digitSequence :: Parser [Char] +digitSequence = + (++) <$> many1 (satisfy T.digit) + <*> (concat <$> (many digitGroup)) + +digitPostSequence :: Parser (Maybe [Char]) +digitPostSequence = satisfy T.period *> optional digitSequence + +quantity :: Parser L.Qty +quantity = p >>= failOnErr + where + p = (L.RadFrac <$> (satisfy T.period *> digitSequence)) + <|> (f <$> digitSequence <*> optional digitPostSequence) + f digSeq maybePostSeq = case maybePostSeq of + Nothing -> L.Whole digSeq + Just ps -> + maybe (L.WholeRad digSeq) (L.WholeRadFrac digSeq) ps + failOnErr = maybe (fail msg) return . L.toQty + msg = "could not read quantity; zero quantities not allowed" + +spaceBetween :: Parser L.SpaceBetween +spaceBetween = f <$> optional (many1 (satisfy T.white)) + where + f = maybe L.NoSpaceBetween (const L.SpaceBetween) + +leftCmdtyLvl1Amt :: Parser (L.Amount, L.Side, L.SpaceBetween) +leftCmdtyLvl1Amt = + f <$> quotedLvl1Cmdty <*> spaceBetween <*> quantity + where + f c s q = (L.Amount q c , L.CommodityOnLeft, s) + +leftCmdtyLvl3Amt :: Parser (L.Amount, L.Side, L.SpaceBetween) +leftCmdtyLvl3Amt = f <$> lvl3Cmdty <*> spaceBetween <*> quantity + where + f c s q = (L.Amount q c, L.CommodityOnLeft, s) + +leftSideCmdtyAmt :: Parser (L.Amount, L.Side, L.SpaceBetween) +leftSideCmdtyAmt = leftCmdtyLvl1Amt <|> leftCmdtyLvl3Amt + +rightSideCmdty :: Parser L.Commodity +rightSideCmdty = quotedLvl1Cmdty <|> lvl2Cmdty + +rightSideCmdtyAmt :: Parser (L.Amount, L.Side, L.SpaceBetween) +rightSideCmdtyAmt = + f <$> quantity <*> spaceBetween <*> rightSideCmdty + where + f q s c = (L.Amount q c ,L.CommodityOnRight, s) + + +amount :: Parser (L.Amount, L.Side, L.SpaceBetween) +amount = leftSideCmdtyAmt <|> rightSideCmdtyAmt + +comment :: Parser I.Comment +comment = + (I.Comment . pack) + <$ satisfy T.hash + <*> many (satisfy T.nonNewline) + <* satisfy T.newline + <* many (satisfy T.white) + +year :: Parser Integer +year = read <$> replicateM 4 P.digit + +month :: Parser Int +month = read <$> replicateM 2 P.digit + +day :: Parser Int +day = read <$> replicateM 2 P.digit + +date :: Parser Time.Day +date = p >>= failOnErr + where + p = Time.fromGregorianValid + <$> year <* satisfy T.dateSep + <*> month <* satisfy T.dateSep + <*> day + failOnErr = maybe (fail "could not parse date") return + +hours :: Parser L.Hours +hours = p >>= (maybe (fail "could not parse hours") return) + where + p = f <$> satisfy T.digit <*> satisfy T.digit + f d1 d2 = L.intToHours . read $ [d1,d2] + + +minutes :: Parser L.Minutes +minutes = p >>= maybe (fail "could not parse minutes") return + where + p = f <$ satisfy T.colon <*> satisfy T.digit <*> satisfy T.digit + f d1 d2 = L.intToMinutes . read $ [d1, d2] + +seconds :: Parser L.Seconds +seconds = p >>= maybe (fail "could not parse seconds") return + where + p = f <$ satisfy T.colon <*> satisfy T.digit <*> satisfy T.digit + f d1 d2 = L.intToSeconds . read $ [d1, d2] + +time :: Parser (L.Hours, L.Minutes, Maybe L.Seconds) +time = (,,) <$> hours <*> minutes <*> optional seconds + +tzSign :: Parser (Int -> Int) +tzSign = (id <$ satisfy T.plus) <|> (negate <$ satisfy T.minus) + +tzNumber :: Parser Int +tzNumber = read <$> replicateM 4 (satisfy T.digit) + +timeZone :: Parser L.TimeZoneOffset +timeZone = p >>= maybe (fail "could not parse time zone") return + where + p = f <$> tzSign <*> tzNumber + f s = L.minsToOffset . s + +timeWithZone + :: Parser (L.Hours, L.Minutes, + Maybe L.Seconds, Maybe L.TimeZoneOffset) +timeWithZone = + f <$> time <* many (satisfy T.white) <*> optional timeZone + where + f (h, m, s) tz = (h, m, s, tz) + +dateTime :: Parser L.DateTime +dateTime = + f <$> date <* many (satisfy T.white) <*> optional timeWithZone + where + f d mayTwithZ = L.DateTime d h m s tz + where + ((h, m, s), tz) = case mayTwithZ of + Nothing -> (L.midnight, L.noOffset) + Just (hr, mn, mayS, mayTz) -> + let sec = fromMaybe L.zeroSeconds mayS + z = fromMaybe L.noOffset mayTz + in ((hr, mn, sec), z) + +debit :: Parser L.DrCr +debit = L.Debit <$ satisfy T.lessThan + +credit :: Parser L.DrCr +credit = L.Credit <$ satisfy T.greaterThan + +drCr :: Parser L.DrCr +drCr = debit <|> credit + +entry :: Parser (L.Entry, L.Side, L.SpaceBetween) +entry = f <$> drCr <* (many (satisfy T.white)) <*> amount + where + f dc (am, sd, sb) = (L.Entry dc am, sd, sb) + +flag :: Parser L.Flag +flag = (L.Flag . pack) <$ satisfy T.openSquare + <*> many (satisfy T.flagChar) <* satisfy (T.closeSquare) + +postingMemoLine :: Parser Text +postingMemoLine = + pack + <$ satisfy T.apostrophe + <*> many (satisfy T.nonNewline) + <* satisfy T.newline <* many (satisfy T.white) + +postingMemo :: Parser L.Memo +postingMemo = L.Memo <$> many1 postingMemoLine + +transactionMemoLine :: Parser Text +transactionMemoLine = + pack + <$ satisfy T.semicolon <*> many (satisfy T.nonNewline) + <* satisfy T.newline <* skipWhite + +transactionMemo :: Parser (L.TopMemoLine, L.Memo) +transactionMemo = f <$> lineNum <*> many1 transactionMemoLine + where + f tml ls = (L.TopMemoLine tml + , L.Memo ls) + + +number :: Parser L.Number +number = + L.Number . pack <$ satisfy T.openParen + <*> many (satisfy T.numberChar) <* satisfy T.closeParen + +lvl1Payee :: Parser L.Payee +lvl1Payee = L.Payee . pack <$> many (satisfy T.quotedPayeeChar) + +quotedLvl1Payee :: Parser L.Payee +quotedLvl1Payee = satisfy T.tilde *> lvl1Payee <* satisfy T.tilde + +lvl2Payee :: Parser L.Payee +lvl2Payee = (\c cs -> L.Payee (pack (c:cs))) <$> satisfy T.letter + <*> many (satisfy T.nonNewline) + +fromCmdty :: Parser L.From +fromCmdty = L.From <$> (quotedLvl1Cmdty <|> lvl2Cmdty) + +lineNum :: Parser Int +lineNum = Pos.sourceLine <$> P.getPosition + +price :: Parser L.PricePoint +price = p >>= maybe (fail msg) return + where + f li dt fr (L.Amount qt to, sd, sb) = + let cpu = L.CountPerUnit qt + in case L.newPrice fr (L.To to) cpu of + Nothing -> Nothing + Just pr -> Just $ L.PricePoint dt pr + (Just sd) (Just sb) (Just $ L.PriceLine li) + p = f <$> lineNum <* satisfy T.atSign <* skipWhite + <*> dateTime <* skipWhite + <*> fromCmdty <* skipWhite + <*> amount <* satisfy T.newline <* skipWhite + msg = "could not parse price, make sure the from and to commodities " + ++ "are different" + +tag :: Parser L.Tag +tag = L.Tag . pack <$ satisfy T.asterisk <*> many (satisfy T.tagChar) + <* many (satisfy T.white) + +tags :: Parser L.Tags +tags = (\t ts -> L.Tags (t:ts)) <$> tag <*> many tag + +topLinePayee :: Parser L.Payee +topLinePayee = quotedLvl1Payee <|> lvl2Payee + +topLineFlagNum :: Parser (Maybe L.Flag, Maybe L.Number) +topLineFlagNum = p1 <|> p2 + where + p1 = ( (,) <$> optional flag + <* many (satisfy T.white) <*> optional number) + p2 = ( flip (,) + <$> optional number + <* many (satisfy T.white) <*> optional flag) + +skipWhite :: Parser () +skipWhite = () <$ many (satisfy T.white) + +topLine :: Parser I.ParsedTopLine +topLine = + f <$> optional transactionMemo + <*> lineNum + <*> dateTime + <* skipWhite + <*> topLineFlagNum + <* skipWhite + <*> optional topLinePayee + <* satisfy T.newline + <* skipWhite + where + f mayMe lin dt (mayFl, mayNum) mayPy = + I.ParsedTopLine dt mayNum mayFl mayPy me (L.TopLineLine lin) + where + me = fmap (\(a, b) -> (b, a)) mayMe + +flagNumPayee :: Parser (Maybe L.Flag, Maybe L.Number, Maybe L.Payee) +flagNumPayee = runPerms + ( (,,) <$> maybeAtom (flag <* skipWhite) + <*> maybeAtom (number <* skipWhite) + <*> maybeAtom (quotedLvl1Payee <* skipWhite) ) + +postingAcct :: Parser L.Account +postingAcct = quotedLvl1Acct <|> lvl2Acct + +posting :: Parser (L.PostingCore, L.PostingLine, Maybe L.Entry) +posting = f <$> lineNum <* skipWhite + <*> optional flagNumPayee <* skipWhite + <*> postingAcct <* skipWhite + <*> optional tags <* skipWhite + <*> optional entry <* skipWhite + <* satisfy T.newline <* skipWhite + <*> optional postingMemo <* skipWhite + where + f li mayFnp ac ta mayEn me = + (L.PostingCore pa nu fl ac tgs me sd sb, pl, en) + where + tgs = fromMaybe (L.Tags []) ta + pl = L.PostingLine li + (fl, nu, pa) = fromMaybe (Nothing, Nothing, Nothing) mayFnp + (en, sd, sb) = maybe (Nothing, Nothing, Nothing) + (\(a, b, c) -> (Just a, Just b, Just c)) mayEn + +transaction :: Parser I.ParsedTxn +transaction = do + ptl <- topLine + let getEntPair (core, lin, mayEn) = (mayEn, (core, lin)) + ts <- fmap (map getEntPair) $ many posting + ents <- maybe (fail "unbalanced transaction") return $ L.ents ts + return (ptl, ents) + + +blankLine :: Parser () +blankLine = () <$ satisfy T.newline <* skipWhite + +item :: Parser I.ParsedItem +item + = fmap S.S4a transaction + <|> fmap S.S4b price + <|> fmap S.S4c comment + <|> (S.S4d I.BlankLine) <$ blankLine + +parse + :: String + -- ^ Name of the file to be parsed + -> IO (L.Filename, [I.ParsedItem]) + -- ^ Returns items if successfully parsed. Quits and exits if the + -- parse fails. + +parse s = do + (fn, txt) <- getFileContentsStdin s + let parser = P.spaces *> P.many item <* P.spaces <* P.eof + filename = X.unpack . L.unFilename $ fn + case P.parse parser filename txt of + Left err -> do + pn <- getProgName + let msg = pn ++ ": error: could not parse file " + ++ filename ++ "\n" ++ show err + IO.hPutStr IO.stderr msg + Exit.exitFailure + Right g -> return (fn, g) + + +getFileContentsStdin :: String -> IO (L.Filename, Text) +getFileContentsStdin s = do + pn <- getProgName + txt <- if s == "-" + then do + isTerm <- IO.hIsTerminalDevice IO.stdin + when isTerm + (IO.hPutStrLn IO.stderr $ + pn ++ ": warning: reading from standard input, which" + ++ "is a terminal.") + TIO.hGetContents IO.stdin + else TIO.readFile s + let fn = L.Filename . X.pack $ if s == "-" then "" else s + return (fn, txt) diff --git a/lib/Penny/Copper/Render.hs b/lib/Penny/Copper/Render.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Copper/Render.hs @@ -0,0 +1,530 @@ +-- | Renders Penny data in a format that can be parsed by +-- "Penny.Copper.Parsec". These functions render text that is +-- compliant with the EBNF grammar which is at +-- @doc\/ledger-grammar.org@. +module Penny.Copper.Render where + +import Control.Monad (guard) +import Control.Applicative ((<$>), (<|>), (<*>), pure) +import Data.List (intersperse, intercalate) +import Data.List.Split (chunksOf, splitOn) +import qualified Data.Text as X +import Data.Text (Text, cons, snoc) +import qualified Penny.Copper.Terminals as T +import qualified Data.Time as Time +import qualified Penny.Copper.Interface as I +import qualified Penny.Lincoln as L +import qualified Penny.Steel.Sums as S + +-- * Helpers + +-- | Merges a list of words into one Text; however, if any given Text +-- is empty, that Text is first dropped from the list. +txtWords :: [X.Text] -> X.Text +txtWords xs = case filter (not . X.null) xs of + [] -> X.empty + rs -> X.unwords rs + +-- | Takes a field that may or may not be present and a function that +-- renders it. If the field is not present at all, returns an empty +-- Text. Otherwise will succeed or fail depending upon whether the +-- rendering function succeeds or fails. +renMaybe :: Maybe a -> (a -> Maybe X.Text) -> Maybe X.Text +renMaybe mx f = case mx of + Nothing -> Just X.empty + Just a -> f a + + +-- * Accounts + +-- | Is True if a sub account can be rendered at Level 1; +-- False otherwise. +isSubAcctLvl1 :: L.SubAccount -> Bool +isSubAcctLvl1 (L.SubAccount x) = + X.all T.lvl1AcctChar x && not (X.null x) + +isAcctLvl1 :: L.Account -> Bool +isAcctLvl1 (L.Account ls) = + (not . null $ ls) + && (all isSubAcctLvl1 ls) + +quotedLvl1Acct :: L.Account -> Maybe Text +quotedLvl1Acct a@(L.Account ls) = do + guard (isAcctLvl1 a) + let txt = X.concat . intersperse (X.singleton ':') + . map L.unSubAccount $ ls + return $ '{' `X.cons` txt `X.snoc` '}' + +isFirstSubAcctLvl2 :: L.SubAccount -> Bool +isFirstSubAcctLvl2 (L.SubAccount x) = case X.uncons x of + Nothing -> False + Just (c, r) -> T.letter c && (X.all T.lvl2AcctOtherChar r) + +isOtherSubAcctLvl2 :: L.SubAccount -> Bool +isOtherSubAcctLvl2 (L.SubAccount x) = + (not . X.null $ x) + && (X.all T.lvl2AcctOtherChar x) + +isAcctLvl2 :: L.Account -> Bool +isAcctLvl2 (L.Account ls) = case ls of + [] -> False + x:xs -> isFirstSubAcctLvl2 x && all isOtherSubAcctLvl2 xs + +lvl2Acct :: L.Account -> Maybe Text +lvl2Acct a@(L.Account ls) = do + guard $ isAcctLvl2 a + return . X.concat . intersperse (X.singleton ':') + . map L.unSubAccount $ ls + +-- | Shows an account, with the minimum level of quoting +-- possible. Fails with an error if any one of the characters in the +-- account name does not satisfy the 'lvl1Char' predicate. Otherwise +-- returns a rendered account, quoted if necessary. +ledgerAcct :: L.Account -> Maybe Text +ledgerAcct a = lvl2Acct a <|> quotedLvl1Acct a + +-- * Commodities + +-- | Render a quoted Level 1 commodity. Fails if any character does +-- not satisfy lvl1Char. +quotedLvl1Cmdty :: L.Commodity -> Maybe Text +quotedLvl1Cmdty (L.Commodity c) = + if X.all T.lvl1CmdtyChar c + then Just $ '"' `cons` c `snoc` '"' + else Nothing + + +-- | Render a Level 2 commodity. Fails if the first character is not a +-- letter or a symbol, or if any other character is a space. +lvl2Cmdty :: L.Commodity -> Maybe Text +lvl2Cmdty (L.Commodity c) = do + (f, rs) <- X.uncons c + guard $ T.lvl2CmdtyFirstChar f + guard . X.all T.lvl2CmdtyOtherChar $ rs + return c + + +-- | Render a Level 3 commodity. Fails if any character is not a +-- letter or a symbol. +lvl3Cmdty :: L.Commodity -> Maybe Text +lvl3Cmdty (L.Commodity c) = + if (not . X.null $ c) && (X.all T.lvl3CmdtyChar c) + then return c + else Nothing + + +-- * Quantities + +-- | Specifies how to perform digit grouping when rendering a +-- quantity. All grouping groups into groups of 3 digits. +data GroupSpec = + NoGrouping + -- ^ Do not perform any digit grouping + | GroupLarge + -- ^ Group digits, but only if the number to be grouped is greater + -- than 9,999 (if grouping the whole part) or if there are more + -- than 4 decimal places (if grouping the fractional part). + | GroupAll + -- ^ Group digits whenever there are at least four decimal places. + deriving (Eq, Show) + + +data GroupSpecs = GroupSpecs + { left :: GroupSpec + , right :: GroupSpec + } deriving Show + + +grouper :: String +grouper = "\x2009" + +radix :: String +radix = "." + +-- | Performs grouping for amounts to the left of the radix point. +groupWhole :: GroupSpec -> String -> String +groupWhole gs o = let + grouped = intercalate grouper + . reverse + . map reverse + . chunksOf 3 + . reverse + $ o + in case gs of + NoGrouping -> o + GroupLarge -> if length o > 4 then grouped else o + GroupAll -> grouped + +-- | Performs grouping for amounts to the right of the radix point. +groupDecimal :: GroupSpec -> String -> String +groupDecimal gs o = let + grouped = intercalate grouper + . chunksOf 3 + $ o + in case gs of + NoGrouping -> o + GroupLarge -> if length o > 4 then grouped else o + GroupAll -> grouped + +-- | Renders an unquoted Qty. Performs digit grouping as requested. +quantity + :: GroupSpecs + -- ^ Group for the portion to the left and right of the radix point? + + -> L.Qty + -> X.Text +quantity gs q = + let qs = L.prettyShowQty q + in X.pack $ case splitOn "." qs of + w:[] -> groupWhole (left gs) w + w:d:[] -> + groupWhole (left gs) w ++ radix ++ groupDecimal (right gs) d + _ -> error "Qty.hs: rendering error" + +-- * Amounts + +-- | Render an Amount. The Format is required so that the commodity +-- can be displayed in the right place. +amount + :: GroupSpecs + -> Maybe L.Side + -> Maybe L.SpaceBetween + -> L.Amount + -> Maybe X.Text +amount gs maySd maySb (L.Amount qt c) = + let q = quantity gs qt + in do + sd <- maySd + sb <- maySb + let ws = case sb of + L.SpaceBetween -> X.singleton ' ' + L.NoSpaceBetween -> X.empty + (l, r) <- case sd of + L.CommodityOnLeft -> do + cx <- lvl3Cmdty c <|> quotedLvl1Cmdty c + return (cx, q) + L.CommodityOnRight -> do + cx <- lvl2Cmdty c <|> quotedLvl1Cmdty c + return (q, cx) + return $ X.concat [l, ws, r] + +-- * Comments + +comment :: I.Comment -> Maybe X.Text +comment (I.Comment x) = + if (not . X.all T.nonNewline $ x) + then Nothing + else Just $ '#' `cons` x `snoc` '\n' + +-- * DateTime + +-- | Render a DateTime. The day is always printed. If the time zone +-- offset is not zero, then the time and time zone offset are both +-- printed. If the time zone offset is zero, then the hours and +-- minutes are printed, but only if the time is not midnight. If the +-- seconds are not zero, they are also printed. + +dateTime :: L.DateTime -> X.Text +dateTime (L.DateTime d h m s z) = X.append xd xr + where + (iYr, iMo, iDy) = Time.toGregorian d + xr = hoursMinsSecsZone h m s z + dash = X.singleton '-' + xd = X.concat [ showX iYr, dash, pad2 . showX $ iMo, dash, + pad2 . showX $ iDy ] + +pad2 :: X.Text -> X.Text +pad2 = X.justifyRight 2 '0' + +pad4 :: X.Text -> X.Text +pad4 = X.justifyRight 4 '0' + +showX :: Show a => a -> X.Text +showX = X.pack . show + +hoursMinsSecsZone + :: L.Hours -> L.Minutes -> L.Seconds -> L.TimeZoneOffset -> X.Text +hoursMinsSecsZone h m s z = + if z == L.noOffset && (h, m, s) == L.midnight + then X.empty + else let xhms = X.concat [xh, colon, xm, xs] + xh = pad2 . showX . L.unHours $ h + xm = pad2 . showX . L.unMinutes $ m + xs = let secs = L.unSeconds s + in if secs == 0 + then X.empty + else ':' `X.cons` (pad2 . showX $ secs) + off = L.offsetToMins z + sign = X.singleton $ if off < 0 then '-' else '+' + padded = pad4 . showX . abs $ off + xz = if off == 0 + then X.empty + else ' ' `X.cons` sign `X.append` padded + colon = X.singleton ':' + in ' ' `X.cons` xhms `X.append` xz + +-- * Entries + +entry + :: GroupSpecs + -> Maybe L.Side + -> Maybe L.SpaceBetween + -> L.Entry + -> Maybe X.Text +entry gs sd sb (L.Entry dc a) = do + amt <- amount gs sd sb a + let dcTxt = X.pack $ case dc of + L.Debit -> "<" + L.Credit -> ">" + return $ X.append (X.snoc dcTxt ' ') amt + +-- * Flags + +flag :: L.Flag -> Maybe X.Text +flag (L.Flag fl) = + if X.all T.flagChar fl + then Just $ '[' `cons` fl `snoc` ']' + else Nothing + +-- * Memos + +-- | Renders a postingMemoLine, optionally with trailing +-- whitespace. The trailing whitespace allows the next line to be +-- indented properly if is also a postingMemoLine. This is handled +-- using trailing whitespace rather than leading whitespace because +-- leading whitespace is inconsistent with the grammar. +postingMemoLine + :: Int + -- ^ Pad the end of the output with this many spaces + -> X.Text + -> Maybe X.Text +postingMemoLine p x = + if X.all T.nonNewline x + then let trailing = X.replicate p (X.singleton ' ') + ls = [X.singleton '\'', x, X.singleton '\n', trailing] + in Just $ X.concat ls + else Nothing + +-- | Renders a postingMemo. Fails if the postingMemo is empty, as the +-- grammar requires that they have at least one line. +-- +-- If the boolean is True, inserts padding after the last +-- postingMemoLine so that the next line is indented by four +-- columns. Use this if the posting memo is followed by another +-- posting. If the last boolean if False, there is no indenting after +-- the last postingMemoLine. +postingMemo :: Bool -> L.Memo -> Maybe X.Text +postingMemo iLast (L.Memo ls) = + if null ls + then Nothing + else let bs = replicate (length ls - 1) 8 ++ [if iLast then 4 else 0] + in fmap X.concat . sequence $ zipWith postingMemoLine bs ls + + +transactionMemoLine :: X.Text -> Maybe X.Text +transactionMemoLine x = + if X.all T.nonNewline x + then Just $ ';' `cons` x `snoc` '\n' + else Nothing + +transactionMemo :: L.Memo -> Maybe X.Text +transactionMemo (L.Memo ls) = + if null ls + then Nothing + else fmap X.concat . mapM transactionMemoLine $ ls + +-- * Numbers + +number :: L.Number -> Maybe Text +number (L.Number t) = + if X.all T.numberChar t + then Just $ '(' `cons` t `snoc` ')' + else Nothing + +-- * Payees + +quotedLvl1Payee :: L.Payee -> Maybe Text +quotedLvl1Payee (L.Payee p) = do + guard (X.all T.quotedPayeeChar p) + return $ '~' `X.cons` p `X.snoc` '~' + +lvl2Payee :: L.Payee -> Maybe Text +lvl2Payee (L.Payee p) = do + (c1, cs) <- X.uncons p + guard (T.letter c1) + guard (X.all T.nonNewline cs) + return p + +payee :: L.Payee -> Maybe Text +payee p = lvl2Payee p <|> quotedLvl1Payee p + +-- * Prices + +price :: + GroupSpecs + -> L.PricePoint + -> Maybe X.Text +price gs pp = let + dateTxt = dateTime (L.dateTime pp) + (L.From from) = L.from . L.price $ pp + (L.To to) = L.to . L.price $ pp + (L.CountPerUnit q) = L.countPerUnit . L.price $ pp + mayFromTxt = lvl3Cmdty from <|> quotedLvl1Cmdty from + in do + amtTxt <- amount gs (L.ppSide pp) (L.ppSpaceBetween pp) + (L.Amount q to) + fromTxt <- mayFromTxt + return $ + (X.intercalate (X.singleton ' ') + [X.singleton '@', dateTxt, fromTxt, amtTxt]) + `snoc` '\n' + +-- * Tags + +tag :: L.Tag -> Maybe X.Text +tag (L.Tag t) = + if X.all T.tagChar t + then Just $ X.cons '*' t + else Nothing + +tags :: L.Tags -> Maybe X.Text +tags (L.Tags ts) = + X.intercalate (X.singleton ' ') + <$> mapM tag ts + +-- * TopLine + +-- | Renders the TopLine. Emits trailing whitespace after the newline +-- so that the first posting is properly indented. +topLine :: L.TopLineCore -> Maybe X.Text +topLine tl = + f + <$> pure (dateTime (L.tDateTime tl)) + <*> renMaybe (L.tMemo tl) transactionMemo + <*> renMaybe (L.tFlag tl) flag + <*> renMaybe (L.tNumber tl) number + <*> renMaybe (L.tPayee tl) payee + where + f dtX meX flX nuX paX = + X.concat [ meX, txtWords [dtX, flX, nuX, paX], + X.singleton '\n', + X.replicate 4 (X.singleton ' ') ] + +-- * Posting + +-- | Renders a Posting. Fails if any of the components +-- fail to render. In addition, if the unverified Posting has an +-- Entry, a Format must be provided, otherwise render fails. +-- +-- The columns look like this. Column numbers begin with 0 (like they +-- do in Emacs) rather than with column 1 (like they do in +-- Vim). (Really Emacs is the strange one; most CLI utilities seem to +-- start with column 1 too...) +-- +-- > ID COLUMN WIDTH WHAT +-- > --------------------------------------------------- +-- > A 0 4 Blank spaces for indentation +-- > B 4 50 Flag, Number, Payee, Account, Tags +-- > C 54 2 Blank spaces for padding +-- > D 56 NA Entry +-- +-- Omit the padding after column B if there is no entry; also omit +-- columns C and D entirely if there is no Entry. (It is annoying to +-- have extraneous blank space in a file). +-- +-- This table is a bit of a lie, because the blank spaces for +-- indentation are emitted either by the posting previous to this one +-- (either after the posting itself or after its postingMemo) or by +-- the TopLine. +-- +-- Also emits an additional eight spaces after the trailing newline if +-- the posting has a memo. That way the memo will be indented +-- properly. (There are trailing spaces here, as opposed to leading +-- spaces in the posting memo, because the latter would be +-- inconsistent with the grammar.) +-- +-- Emits an extra four spaces after the first line if the first +-- paramter is True. However, this is overriden if there is a memo, in +-- which case eight spaces will be emitted. (This allows the next +-- posting to be indented properly.) +posting + :: GroupSpecs + -> Bool + -- ^ If True, emit four spaces after the trailing newline. + -> L.Ent L.PostingCore + -> Maybe X.Text +posting gs pad ent = do + let p = L.meta ent + fl <- renMaybe (L.pFlag p) flag + nu <- renMaybe (L.pNumber p) number + pa <- renMaybe (L.pPayee p) quotedLvl1Payee + ac <- ledgerAcct (L.pAccount p) + ta <- tags (L.pTags p) + me <- renMaybe (L.pMemo p) (postingMemo pad) + let mayEn = case L.inferred ent of + L.Inferred -> Nothing + L.NotInferred -> (Just . L.entry $ ent) + en <- renMaybe mayEn (entry gs (L.pSide p) (L.pSpaceBetween p)) + return $ formatter pad fl nu pa ac ta en me + +formatter :: + Bool -- ^ If True, emit four trailing spaces if no memo or + -- eight trailing spaces if there is a memo. + -> X.Text -- ^ Flag + -> X.Text -- ^ Number + -> X.Text -- ^ Payee + -> X.Text -- ^ Account + -> X.Text -- ^ Tags + -> X.Text -- ^ Entry + -> X.Text -- ^ Memo + -> X.Text +formatter pad fl nu pa ac ta en me = let + colBnoPad = txtWords [fl, nu, pa, ac, ta] + colD = en + colB = if X.null en + then colBnoPad + else X.justifyLeft 50 ' ' colBnoPad + colC = if X.null en + then X.empty + else X.pack (replicate 2 ' ') + rtn = '\n' `X.cons` trailingWhite + trailingWhite = case (X.null me, pad) of + (True, False) -> X.empty + (True, True) -> X.replicate 4 (X.singleton ' ') + (False, _) -> X.replicate 8 (X.singleton ' ') + in X.concat [colB, colC, colD, rtn, me] + + +-- * Transaction + +transaction + :: GroupSpecs + -> (L.TopLineCore, L.Ents L.PostingCore) + -> Maybe X.Text +transaction gs txn = do + tlX <- topLine . fst $ txn + let (p1, p2, ps) = L.tupleEnts . snd $ txn + p1X <- posting gs True p1 + p2X <- posting gs (not . null $ ps) p2 + psX <- if null ps + then return X.empty + else let bs = replicate (length ps - 1) True ++ [False] + in fmap X.concat . sequence + $ zipWith (posting gs) bs ps + return $ X.concat [tlX, p1X, p2X, psX] + +-- * Item + +item + :: GroupSpecs + -> S.S4 (L.TopLineCore, L.Ents L.PostingCore) + L.PricePoint + I.Comment + I.BlankLine + -> Maybe X.Text +item gs = + S.caseS4 (transaction gs) + (price gs) + comment + (const (Just (X.pack "\n"))) + diff --git a/lib/Penny/Copper/Terminals.hs b/lib/Penny/Copper/Terminals.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Copper/Terminals.hs @@ -0,0 +1,145 @@ +module Penny.Copper.Terminals where + +invalid :: Char -> Bool +invalid c = c >= '\xD800' && c <= '\xDFFF' + +unicode :: Char -> Bool +unicode = not . invalid + +newline :: Char -> Bool +newline = (== '\x0A') + +space :: Char -> Bool +space = (== '\x20') + +tab :: Char -> Bool +tab = (== '\x09') + +white :: Char -> Bool +white c = space c || tab c + +nonNewline :: Char -> Bool +nonNewline c = unicode c && (not . newline $ c) + +nonNewlineNonSpace :: Char -> Bool +nonNewlineNonSpace c = nonNewline c && (not . white $ c) + +upperCaseAscii :: Char -> Bool +upperCaseAscii c = c >= 'A' && c <= 'Z' + +lowerCaseAscii :: Char -> Bool +lowerCaseAscii c = c >= 'a' && c <= 'z' + +digit :: Char -> Bool +digit c = c >= '0' && c <= '9' + +nonAscii :: Char -> Bool +nonAscii c = nonNewline c && c > '\x7F' + +letter :: Char -> Bool +letter c = upperCaseAscii c || lowerCaseAscii c || nonAscii c + +dollar :: Char -> Bool +dollar = (== '$') + +colon :: Char -> Bool +colon = (== ':') + +openCurly :: Char -> Bool +openCurly = (== '{') + +closeCurly :: Char -> Bool +closeCurly = (== '}') + +openSquare :: Char -> Bool +openSquare = (== '[') + +closeSquare :: Char -> Bool +closeSquare = (== ']') + +doubleQuote :: Char -> Bool +doubleQuote = (== '"') + +period :: Char -> Bool +period = (== '.') + +hash :: Char -> Bool +hash = (== '#') + +thinSpace :: Char -> Bool +thinSpace = (== '\x2009') + +dateSep :: Char -> Bool +dateSep c = c == '/' || c == '-' + +plus :: Char -> Bool +plus = (== '+') + +minus :: Char -> Bool +minus = (== '-') + +lessThan :: Char -> Bool +lessThan = (== '<') + +greaterThan :: Char -> Bool +greaterThan = (== '>') + +openParen :: Char -> Bool +openParen = (== '(') + +closeParen :: Char -> Bool +closeParen = (== ')') + +semicolon :: Char -> Bool +semicolon = (== ';') + +apostrophe :: Char -> Bool +apostrophe = (== '\x27') + +tilde :: Char -> Bool +tilde = (== '~') + +underscore :: Char -> Bool +underscore = (== '_') + +asterisk :: Char -> Bool +asterisk = (== '*') + +lvl1AcctChar :: Char -> Bool +lvl1AcctChar c = nonNewline c && (not . closeCurly $ c) + && (not . colon $ c) + +lvl2AcctOtherChar :: Char -> Bool +lvl2AcctOtherChar c = + nonNewline c && (not . white $ c) && (not . colon $ c) + && (not . asterisk $ c) && (not . greaterThan $ c) + && (not . lessThan $ c) + +lvl1CmdtyChar :: Char -> Bool +lvl1CmdtyChar c = + nonNewline c && (not . doubleQuote $ c) + +lvl2CmdtyFirstChar :: Char -> Bool +lvl2CmdtyFirstChar c = letter c || dollar c + +lvl2CmdtyOtherChar :: Char -> Bool +lvl2CmdtyOtherChar c = nonNewline c && (not . white $ c) + +lvl3CmdtyChar :: Char -> Bool +lvl3CmdtyChar c = letter c || dollar c + +flagChar :: Char -> Bool +flagChar c = nonNewline c && (not . closeSquare $ c) + +numberChar :: Char -> Bool +numberChar c = nonNewline c && (not . closeParen $ c) + +quotedPayeeChar :: Char -> Bool +quotedPayeeChar c = nonNewline c && (not . tilde $ c) + +tagChar :: Char -> Bool +tagChar c = nonNewlineNonSpace c && (not . asterisk $ c) + && (not . greaterThan $ c) && (not . lessThan $ c) + +atSign :: Char -> Bool +atSign = (== '@') diff --git a/lib/Penny/Liberty.hs b/lib/Penny/Liberty.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Liberty.hs @@ -0,0 +1,777 @@ +{-# LANGUAGE OverloadedStrings, CPP #-} + +-- | Liberty - Penny command line parsing utilities +-- +-- Both Cabin and Zinc share various functions that aid in parsing +-- command lines. For instance both the Postings report and the Zinc +-- postings filter use common command-line options. However, Zinc +-- already depends on Cabin. To avoid a cyclic dependency whereby +-- Cabin would also depend on Zinc, functions formerly in Zinc that +-- Cabin will also find useful are relocated here, to Liberty. + +module Penny.Liberty ( + MatcherFactory, + FilteredNum(FilteredNum, unFilteredNum), + SortedNum(SortedNum, unSortedNum), + LibertyMeta(filteredNum, sortedNum), + xactionsToFiltered, + ListLength(ListLength, unListLength), + ItemIndex(ItemIndex, unItemIndex), + PostFilterFn, + parseComparer, + processPostFilters, + parsePredicate, + parseInt, + parseInfix, + parseRPN, + exprDesc, + showExpression, + verboseFilter, + + -- * Parsers + Operand, + operandSpecs, + postFilterSpecs, + matcherSelectSpecs, + caseSelectSpecs, + operatorSpecs, + + -- * Version + version, + + + -- * Output + output, + processOutput, + + -- * Errors + Error + + ) where + +import Control.Arrow (first, second) +import Control.Applicative ((<*>), (<$>), pure, Applicative) +import qualified Control.Monad.Exception.Synchronous as Ex +import Data.Char (toUpper) +import Data.Monoid ((<>)) +import Data.List (sortBy) +import Data.Text (Text, pack) +import qualified Data.Text as X +import qualified Data.Text.IO as TIO +import qualified Data.Time as Time +import Data.Tuple (swap) +import qualified System.Console.MultiArg as MA +import qualified System.Console.MultiArg.Combinator as C +import System.Console.MultiArg.Combinator (OptSpec) +import Text.Parsec (parse) + +import qualified Penny.Copper.Parsec as Pc + +import qualified Penny.Lincoln.Predicates as P +import qualified Penny.Lincoln.Queries as Q +import qualified Penny.Lincoln.Predicates.Siblings as PS +import qualified Data.Prednote.Pdct as E +import qualified Penny.Lincoln as L +import qualified System.Console.Rainbow as C +import qualified Data.Prednote.Expressions as X + +import Text.Matchers ( + CaseSensitive(Sensitive, Insensitive)) +import qualified Text.Matchers as TM + +#ifdef incabal +import qualified Paths_penny_lib as PPL +#endif +import qualified Data.Version as V +import qualified System.Exit as Exit + +-- | A multiline Text that holds an error message. +type Error = Text + +-- | A serial indicating how a post relates to all other postings that +-- made it through the filtering phase. +newtype FilteredNum = FilteredNum { unFilteredNum :: L.Serial } + deriving Show + +-- | A serial indicating how a posting relates to all other postings +-- that have been sorted. +newtype SortedNum = SortedNum { unSortedNum :: L.Serial } + deriving Show + +-- | All metadata from Liberty. +data LibertyMeta = + LibertyMeta { filteredNum :: FilteredNum + , sortedNum :: SortedNum } + deriving Show + + +-- | Parses a list of tokens to obtain a predicate. Deals with an +-- empty list of tokens by returning a predicate that is always +-- True. Fails if the list of tokens is not empty and the parse fails. +parsePredicate + :: X.ExprDesc + -> [X.Token a] + -> Ex.Exceptional Error (E.Pdct a) +parsePredicate d ls = case ls of + [] -> return E.always + _ -> X.parseExpression d ls + +-- | Takes a list of transactions, splits them into PostingChild +-- instances, filters them, post-filters them, sorts them, and places +-- them in Box instances with Filtered serials. Also returns Chunks +-- containing a description of the evalutation process. + +xactionsToFiltered + + :: P.LPdct + -- ^ The predicate to filter the transactions + + -> [PostFilterFn] + -- ^ Post filter specs + + -> (L.Posting -> L.Posting -> Ordering) + -- ^ The sorter + + -> [L.Transaction] + -- ^ The transactions to work on (probably parsed in from Copper) + + -> ([C.Chunk], [(LibertyMeta, L.Posting)]) + -- ^ Sorted, filtered postings + +xactionsToFiltered pdct postFilts srtr + = second (processPostings srtr postFilts) + . mainFilter pdct + . concatMap L.transactionToPostings + +processPostings + :: (L.Posting -> L.Posting -> Ordering) + -> [PostFilterFn] + -> [L.Posting] + -> [(LibertyMeta, L.Posting)] +processPostings srtr postFilters + = (map . first . uncurry $ LibertyMeta) + . addSortedNum + . sortBy (\p1 p2 -> srtr (snd p1) (snd p2)) + . processPostFilters postFilters + . addFilteredNum + +mainFilter :: P.LPdct -> [L.Posting] -> ([C.Chunk], [L.Posting]) +mainFilter pdct = swap . E.filter indentAmt True 0 L.display pdct + +addFilteredNum :: [a] -> [(FilteredNum, a)] +addFilteredNum = L.serialItems (\s p -> (FilteredNum s, p)) + +addSortedNum :: [(a, b)] -> [((a, SortedNum), b)] +addSortedNum = L.serialItems (\s (a, b) -> ((a, SortedNum s), b)) + +indentAmt :: E.IndentAmt +indentAmt = 4 + +type MatcherFactory + = CaseSensitive + -> Text + -> Ex.Exceptional Text TM.Matcher + +newtype ListLength = ListLength { unListLength :: Int } + deriving (Eq, Ord, Show) +newtype ItemIndex = ItemIndex { unItemIndex :: Int } + deriving (Eq, Ord, Show) + +-- | Specifies options for the post-filter stage. +type PostFilterFn = ListLength -> ItemIndex -> Bool + + +processPostFilters :: [PostFilterFn] -> [a] -> [a] +processPostFilters pfs ls = foldl processPostFilter ls pfs + + +processPostFilter :: [a] -> PostFilterFn -> [a] +processPostFilter as fn = map fst . filter fn' $ zipped where + len = ListLength $ length as + fn' (_, idx) = fn len (ItemIndex idx) + zipped = zip as [0..] + + +------------------------------------------------------------ +-- Operands +------------------------------------------------------------ + +-- | Given a String from the command line which represents a pattern, +-- the current case sensitivity, and a MatcherFactory, return a +-- Matcher. Fails if the pattern is bad (e.g. it is not a valid +-- regular expression). +getMatcher + :: String + -> CaseSensitive + -> MatcherFactory + -> Ex.Exceptional Error TM.Matcher + +getMatcher s cs f + = Ex.mapException mkError + $ f cs (pack s) + where + mkError eMsg = "bad pattern: \"" <> pack s <> " - " <> eMsg + <> "\n" + + +-- | Parses comparers given on command line to a function. Fails if +-- the string given is invalid. +parseComparer + :: String + -> (Ordering -> E.Pdct a) + -> Ex.Exceptional Error (E.Pdct a) +parseComparer s f = Ex.fromMaybe ("bad comparer: " <> pack s <> "\n") + $ E.parseComparer (pack s) f + +-- | Parses a date from the command line. On failure, throws back the +-- error message from the failed parse. +parseDate :: String -> Ex.Exceptional Error Time.UTCTime +parseDate arg = + Ex.mapExceptional err L.toUTC + . Ex.fromEither + . parse Pc.dateTime "" + . pack + $ arg + where + err msg = "bad date: \"" <> pack arg <> "\" - " <> (pack . show $ msg) + +type Operand = E.Pdct L.Posting + +-- | OptSpec for a date. +date :: OptSpec (Ex.Exceptional Error Operand) +date = C.OptSpec ["date"] ['d'] (C.TwoArg f) + where + f a1 a2 = do + utct <- parseDate a2 + parseComparer a1 (flip P.date utct) + + +current :: L.DateTime -> OptSpec Operand +current dt = C.OptSpec ["current"] [] (C.NoArg f) + where + f = E.or [P.date LT (L.toUTC dt), P.date EQ (L.toUTC dt)] + +-- | Parses exactly one integer; fails if it cannot read exactly one. +parseInt :: String -> Ex.Exceptional Error Int +parseInt t = + case reads t of + ((i, ""):[]) -> return i + _ -> Ex.throw $ "could not parse integer: \"" <> pack t <> "\"\n" + + +-- | Creates options that add an operand that matches the posting if a +-- particluar field matches the pattern given. +patternOption :: + String + -- ^ Long option + + -> Maybe Char + -- ^ Short option, if included + + -> (TM.Matcher -> P.LPdct) + -- ^ When applied to a Matcher, this function returns a predicate. + + -> OptSpec ( CaseSensitive + -> MatcherFactory + -> Ex.Exceptional Error Operand ) +patternOption str mc f = C.OptSpec [str] so (C.OneArg g) + where + so = maybe [] (:[]) mc + g a1 cs fty = f <$> getMatcher a1 cs fty + + +-- | The account option; matches if the pattern given matches the +-- colon-separated account name. +account :: OptSpec ( CaseSensitive + -> MatcherFactory + -> Ex.Exceptional Error Operand ) +account = C.OptSpec ["account"] "a" (C.OneArg f) + where + f a1 cs fty + = fmap P.account + $ getMatcher a1 cs fty + + +-- | The account-level option; matches if the account at the given +-- level matches. +accountLevel :: OptSpec ( CaseSensitive + -> MatcherFactory + -> Ex.Exceptional Error Operand) +accountLevel = C.OptSpec ["account-level"] "" (C.TwoArg f) + where + f a1 a2 cs fty + = P.accountLevel <$> parseInt a1 <*> getMatcher a2 cs fty + + +-- | The accountAny option; returns True if the matcher given matches +-- a single sub-account name at any level. +accountAny :: OptSpec ( CaseSensitive + -> MatcherFactory + -> Ex.Exceptional Error Operand ) +accountAny = patternOption "account-any" Nothing P.accountAny + +-- | The payee option; returns True if the matcher matches the payee +-- name. +payee :: OptSpec ( CaseSensitive + -> MatcherFactory + -> Ex.Exceptional Error Operand ) +payee = patternOption "payee" (Just 'p') P.payee + +tag :: OptSpec ( CaseSensitive + -> MatcherFactory + -> Ex.Exceptional Error Operand) +tag = patternOption "tag" (Just 't') P.tag + +number :: OptSpec ( CaseSensitive + -> MatcherFactory + -> Ex.Exceptional Error Operand ) +number = patternOption "number" (Just 'n') P.number + +flag :: OptSpec ( CaseSensitive + -> MatcherFactory + -> Ex.Exceptional Error Operand) +flag = patternOption "flag" (Just 'f') P.flag + +commodity :: OptSpec ( CaseSensitive + -> MatcherFactory + -> Ex.Exceptional Error Operand) +commodity = patternOption "commodity" (Just 'y') P.commodity + +filename :: OptSpec ( CaseSensitive + -> MatcherFactory + -> Ex.Exceptional Error Operand ) +filename = patternOption "filename" Nothing P.filename + +postingMemo :: OptSpec ( CaseSensitive + -> MatcherFactory + -> Ex.Exceptional Error Operand) +postingMemo = patternOption "posting-memo" Nothing P.postingMemo + +transactionMemo :: OptSpec ( CaseSensitive + -> MatcherFactory + -> Ex.Exceptional Error Operand) +transactionMemo = patternOption "transaction-memo" + Nothing P.transactionMemo + +debit :: OptSpec Operand +debit = C.OptSpec ["debit"] [] (C.NoArg P.debit) + +credit :: OptSpec Operand +credit = C.OptSpec ["credit"] [] (C.NoArg P.credit) + +qtyOption :: OptSpec (Ex.Exceptional Error Operand) +qtyOption = C.OptSpec ["qty"] "q" (C.TwoArg f) + where + f a1 a2 = do + qt <- parseQty a2 + parseComparer a1 (flip P.qty qt) + parseQty a = case parse Pc.quantity "" (pack a) of + Left e -> Ex.throw $ "could not parse quantity: " + <> pack a <> " - " + <> (pack . show $ e) + Right g -> pure g + + +-- | Creates two options suitable for comparison of serial numbers, +-- one for ascending, one for descending. +serialOption :: + + (L.Posting -> Maybe L.Serial) + -- ^ Function that, when applied to a Posting, returns the serial + -- you are interested in. + + -> String + -- ^ Name of the command line option, such as @global-transaction@ + + -> ( OptSpec (Ex.Exceptional Error Operand) + , OptSpec (Ex.Exceptional Error Operand) ) + -- ^ Parses both descending and ascending serial options. + +serialOption getSerial n = (osA, osD) + where + osA = C.OptSpec [n] [] + (C.TwoArg (f n L.forward)) + osD = let name = addPrefix "rev" n + in C.OptSpec [name] [] + (C.TwoArg (f name L.backward)) + f name getInt a1 a2 = do + num <- parseInt a2 + let getPdct = E.compareByMaybe (pack . show $ num) (pack name) cmp + cmp l = case getSerial l of + Nothing -> Nothing + Just ser -> Just $ compare (getInt ser) num + parseComparer a1 getPdct + + +-- | Creates two options suitable for comparison of sibling serial +-- numbers. Similar to serialOption. +siblingSerialOption + :: String + -- ^ Name of the command line option, such as @global-posting@ + + -> (Int -> Ordering -> E.Pdct L.Posting) + -- ^ Function that returns a Pdct for forward serial + + -> (Int -> Ordering -> E.Pdct L.Posting) + -- ^ Function that returns a Pdct for reverse serial + + -> ( OptSpec (Ex.Exceptional Error Operand) + , OptSpec (Ex.Exceptional Error Operand) ) + -- ^ Parses both descending and ascending serial options. + +siblingSerialOption n fFwd fBak = (osA, osD) + where + osA = C.OptSpec ["s-" ++ n] [] (C.TwoArg (f fFwd)) + osD = let name = addPrefix "rev" n + in C.OptSpec ["s-" ++ name] [] (C.TwoArg (f fBak)) + f getPdct a1 a2 = do + num <- parseInt a2 + parseComparer a1 (getPdct num) + + +-- | Takes a string, adds a prefix and capitalizes the first letter of +-- the old string. e.g. applied to "rev" and "globalTransaction", +-- returns "revGlobalTransaction". +addPrefix :: String -> String -> String +addPrefix pre suf = pre ++ suf' where + suf' = case suf of + "" -> "" + x:xs -> toUpper x : xs + +globalTransaction :: ( OptSpec (Ex.Exceptional Error Operand) + , OptSpec (Ex.Exceptional Error Operand) ) +globalTransaction = + let f = fmap L.unGlobalTransaction . Q.globalTransaction + in serialOption f "globalTransaction" + +globalPosting :: ( OptSpec (Ex.Exceptional Error Operand) + , OptSpec (Ex.Exceptional Error Operand) ) +globalPosting = + let f = fmap L.unGlobalPosting . Q.globalPosting + in serialOption f "globalPosting" + +filePosting :: ( OptSpec (Ex.Exceptional Error Operand) + , OptSpec (Ex.Exceptional Error Operand) ) +filePosting = + let f = fmap L.unFilePosting . Q.filePosting + in serialOption f "filePosting" + +fileTransaction :: ( OptSpec (Ex.Exceptional Error Operand) + , OptSpec (Ex.Exceptional Error Operand) ) +fileTransaction = + let f = fmap L.unFileTransaction . Q.fileTransaction + in serialOption f "fileTransaction" + +-- | All operand OptSpec. +operandSpecs + :: L.DateTime + -> [OptSpec (CaseSensitive + -> MatcherFactory + -> Ex.Exceptional Error Operand)] + +operandSpecs dt = + [ fmap (const . const) date + , fmap (const . const . pure) (current dt) + , account + , accountLevel + , accountAny + , payee + , tag + , number + , flag + , commodity + , postingMemo + , transactionMemo + , filename + , fmap (const . const . pure) debit + , fmap (const . const . pure) credit + , fmap (const . const) qtyOption + + , sAccount + , sAccountLevel + , sAccountAny + , sPayee + , sTag + , sNumber + , sFlag + , sCommodity + , sPostingMemo + , fmap (const . const . pure) sDebit + , fmap (const . const. pure) sCredit + , fmap (const . const) sQtyOption + ] + ++ serialSpecs + +serialSpecs :: [OptSpec (CaseSensitive + -> MatcherFactory + -> Ex.Exceptional Error Operand)] +serialSpecs + = concat + $ [unDouble] + <*> [ globalTransaction, globalPosting, + filePosting, fileTransaction, + sGlobalPosting, sFilePosting, + sGlobalTransaction, sFileTransaction ] + +unDouble + :: Functor f + => (f (Ex.Exceptional Error a), + f (Ex.Exceptional Error a )) + -> [ f (x -> y -> Ex.Exceptional Error a) ] +unDouble (o1, o2) = [fmap (const . const) o1, fmap (const . const) o2] + + +------------------------------------------------------------ +-- Post filters +------------------------------------------------------------ + +-- | The user passed a bad number for the head or tail option. The +-- argument is the bad number passed. +data BadHeadTailError = BadHeadTailError Text + deriving Show + +optHead :: OptSpec (Ex.Exceptional Error PostFilterFn) +optHead = C.OptSpec ["head"] [] (C.OneArg f) + where + f a = do + num <- parseInt a + let g _ ii = ii < (ItemIndex num) + return g + +optTail :: OptSpec (Ex.Exceptional Error PostFilterFn) +optTail = C.OptSpec ["tail"] [] (C.OneArg f) + where + f a = do + num <- parseInt a + let g (ListLength len) (ItemIndex ii) = ii >= len - num + return g + +postFilterSpecs + :: ( OptSpec (Ex.Exceptional Error PostFilterFn) + , OptSpec (Ex.Exceptional Error PostFilterFn)) +postFilterSpecs = (optHead, optTail) + +------------------------------------------------------------ +-- Matcher control +------------------------------------------------------------ + +parseInsensitive :: OptSpec CaseSensitive +parseInsensitive = + C.OptSpec ["case-insensitive"] ['i'] (C.NoArg Insensitive) + + +parseSensitive :: OptSpec CaseSensitive +parseSensitive = + C.OptSpec ["case-sensitive"] ['I'] (C.NoArg Sensitive) + + +within :: OptSpec MatcherFactory +within = + C.OptSpec ["within"] "w" . C.NoArg $ \c t -> + return (TM.within c t) + +pcre :: OptSpec MatcherFactory +pcre = C.OptSpec ["pcre"] "r" (C.NoArg TM.pcre) + +posix :: OptSpec MatcherFactory +posix = C.OptSpec ["posix"] "" (C.NoArg TM.tdfa) + +exact :: OptSpec MatcherFactory +exact = C.OptSpec ["exact"] "x" . C.NoArg $ \c t -> + return (TM.exact c t) + +matcherSelectSpecs :: [OptSpec MatcherFactory] +matcherSelectSpecs = [within, pcre, posix, exact] + +caseSelectSpecs :: [OptSpec CaseSensitive] +caseSelectSpecs = [parseInsensitive, parseSensitive] + +------------------------------------------------------------ +-- Operators +------------------------------------------------------------ + +-- | Open parentheses +open :: OptSpec (X.Token a) +open = C.OptSpec ["open"] "(" (C.NoArg X.openParen) + +-- | Close parentheses +close :: OptSpec (X.Token a) +close = C.OptSpec ["close"] ")" (C.NoArg X.closeParen) + +-- | and operator +parseAnd :: OptSpec (X.Token a) +parseAnd = C.OptSpec ["and"] "A" (C.NoArg X.opAnd) + +-- | or operator +parseOr :: OptSpec (X.Token a) +parseOr = C.OptSpec ["or"] "O" (C.NoArg X.opOr) + +-- | not operator +parseNot :: OptSpec (X.Token a) +parseNot = C.OptSpec ["not"] "N" (C.NoArg X.opNot) + +operatorSpecs :: [OptSpec (X.Token a)] +operatorSpecs = + [open, close, parseAnd, parseOr, parseNot] + +-- Infix and RPN expression selectors + +parseInfix :: OptSpec X.ExprDesc +parseInfix = C.OptSpec ["infix"] "" (C.NoArg X.Infix) + +parseRPN :: OptSpec X.ExprDesc +parseRPN = C.OptSpec ["rpn"] "" (C.NoArg X.RPN) + +-- | Both Infix and RPN options. +exprDesc :: [OptSpec X.ExprDesc] +exprDesc = [ parseInfix, parseRPN ] + +showExpression :: OptSpec () +showExpression = C.OptSpec ["show-expression"] "" (C.NoArg ()) + +verboseFilter :: OptSpec () +verboseFilter = C.OptSpec ["verbose-filter"] "" (C.NoArg ()) + +-- +-- Siblings +-- + +sGlobalPosting :: ( OptSpec (Ex.Exceptional Error Operand) + , OptSpec (Ex.Exceptional Error Operand) ) +sGlobalPosting = + siblingSerialOption "globalPosting" + PS.fwdGlobalPosting PS.backGlobalPosting + +sFilePosting :: ( OptSpec (Ex.Exceptional Error Operand) + , OptSpec (Ex.Exceptional Error Operand) ) +sFilePosting = + siblingSerialOption "filePosting" + PS.fwdFilePosting PS.backFilePosting + +sGlobalTransaction :: ( OptSpec (Ex.Exceptional Error Operand) + , OptSpec (Ex.Exceptional Error Operand) ) +sGlobalTransaction = + siblingSerialOption "globalTransaction" + PS.fwdGlobalTransaction PS.backGlobalTransaction + +sFileTransaction :: ( OptSpec (Ex.Exceptional Error Operand) + , OptSpec (Ex.Exceptional Error Operand) ) +sFileTransaction = + siblingSerialOption "filePosting" + PS.fwdFileTransaction PS.backFileTransaction + + +sAccount :: OptSpec ( CaseSensitive + -> MatcherFactory + -> Ex.Exceptional Error Operand ) +sAccount = C.OptSpec ["s-account"] "" (C.OneArg f) + where + f a1 cs fty = fmap PS.account + $ getMatcher a1 cs fty + +sAccountLevel :: OptSpec ( CaseSensitive + -> MatcherFactory + -> Ex.Exceptional Error Operand ) +sAccountLevel = C.OptSpec ["s-account-level"] "" (C.TwoArg f) + where + f a1 a2 cs fty + = PS.accountLevel <$> parseInt a1 <*> getMatcher a2 cs fty + +sAccountAny :: OptSpec ( CaseSensitive + -> MatcherFactory + -> Ex.Exceptional Error Operand ) +sAccountAny = patternOption "s-account-any" Nothing PS.accountAny + +-- | The payee option; returns True if the matcher matches the payee +-- name. +sPayee :: OptSpec ( CaseSensitive + -> MatcherFactory + -> Ex.Exceptional Error Operand ) +sPayee = patternOption "s-payee" (Just 'p') PS.payee + +sTag :: OptSpec ( CaseSensitive + -> MatcherFactory + -> Ex.Exceptional Error Operand) +sTag = patternOption "s-tag" (Just 't') PS.tag + +sNumber :: OptSpec ( CaseSensitive + -> MatcherFactory + -> Ex.Exceptional Error Operand ) +sNumber = patternOption "s-number" Nothing PS.number + +sFlag :: OptSpec ( CaseSensitive + -> MatcherFactory + -> Ex.Exceptional Error Operand) +sFlag = patternOption "s-flag" Nothing PS.flag + +sCommodity :: OptSpec ( CaseSensitive + -> MatcherFactory + -> Ex.Exceptional Error Operand) +sCommodity = patternOption "s-commodity" Nothing PS.commodity + +sPostingMemo :: OptSpec ( CaseSensitive + -> MatcherFactory + -> Ex.Exceptional Error Operand) +sPostingMemo = patternOption "s-posting-memo" Nothing PS.postingMemo + +sDebit :: OptSpec Operand +sDebit = C.OptSpec ["s-debit"] [] (C.NoArg PS.debit) + +sCredit :: OptSpec Operand +sCredit = C.OptSpec ["s-credit"] [] (C.NoArg PS.credit) + +sQtyOption :: OptSpec (Ex.Exceptional Error Operand) +sQtyOption = C.OptSpec ["s-qty"] [] (C.TwoArg f) + where + f a1 a2 = do + qt <- parseQty a2 + parseComparer a1 (flip PS.qty qt) + parseQty a = case parse Pc.quantity "" (pack a) of + Left e -> Ex.throw $ "could not parse quantity: " + <> pack a <> " - " + <> (pack . show $ e) + Right g -> pure g + +-- +-- Versions +-- + +-- | Parses the @--version@ option and returns an IO action that +-- prints it and exits successfully. You supply the version of the +-- executable, as there is no easy way to get that automatically. + +version + :: V.Version + -- ^ Version of binary + -> OptSpec (IO a) +version v = C.OptSpec ["version"] [] (C.NoArg f) + where + f = do + pn <- MA.getProgName + putStrLn $ pn ++ " version " ++ V.showVersion v +#ifdef incabal + putStrLn $ "using version " ++ V.showVersion PPL.version +#else + putStrLn $ "using testing version" +#endif + ++ " of penny-lib" + Exit.exitSuccess + +-- | An option for where the user would like to send output. +output :: MA.OptSpec (X.Text -> IO ()) +output = MA.OptSpec ["output"] "o" . MA.OneArg $ \s -> + if s == "-" + then TIO.putStr + else TIO.writeFile s + + +-- | Given a list of output options, returns a single IO action to +-- write to all given files. If the list was empty, returns an IO +-- action that writes to standard output. + +processOutput :: [X.Text -> IO ()] -> X.Text -> IO () +processOutput ls x = + if null ls + then TIO.putStr x + else sequence_ . map ($ x) $ ls + diff --git a/lib/Penny/Lincoln.hs b/lib/Penny/Lincoln.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Lincoln.hs @@ -0,0 +1,72 @@ +-- | Lincoln - the Penny core +-- +-- Penny's core types and classes are here. This module re-exports the +-- most useful things. For more details you will want to look at the +-- sub-modules. Also, not all types and functions are re-exported due +-- to naming conflicts. In particular, neither +-- "Penny.Lincoln.Predicates" nor "Penny.Lincoln.Queries" is exported +-- from here due to the blizzard of name conflicts that would result. +module Penny.Lincoln + ( module Penny.Lincoln.Balance + , module Penny.Lincoln.Bits + , module Penny.Lincoln.Builders + , module Penny.Lincoln.Ents + , module Penny.Lincoln.Equivalent + , module Penny.Lincoln.HasText + , module Penny.Lincoln.Matchers + , module Penny.Lincoln.PriceDb + , module Penny.Lincoln.Serial + , display + ) where + +import Penny.Lincoln.Bits +import Penny.Lincoln.Ents +import Penny.Lincoln.Balance +import Penny.Lincoln.Builders +import Penny.Lincoln.Equivalent +import Penny.Lincoln.HasText +import Penny.Lincoln.Matchers +import Penny.Lincoln.PriceDb +import Penny.Lincoln.Serial + +import Data.List (intersperse) +import Data.Text (Text) +import qualified Data.Text as X +import qualified Penny.Lincoln.Queries as Q +import qualified Data.Time as Time +import System.Locale (defaultTimeLocale) + +-- +-- Display +-- + +-- | Displays a PostFam in a one line format. +-- +-- Format: +-- +-- File LineNo Date Payee Acct DrCr Cmdty Qty +display :: Posting -> Text +display p = X.pack $ concat (intersperse " " ls) + where + ls = [file, lineNo, dt, pye, acct, dc, cmdty, qt] + file = maybe (labelNo "filename") (X.unpack . unFilename) + (fmap tFilename . tlFileMeta . fst . unPosting $ p) + lineNo = maybe (labelNo "line number") + (show . unPostingLine) + (Q.postingLine p) + dateFormat = "%Y-%m-%d %T %z" + dt = Time.formatTime defaultTimeLocale dateFormat + . Time.utctDay + . toUTC + . Q.dateTime + $ p + pye = maybe (labelNo "payee") + (X.unpack . text) (Q.payee p) + acct = X.unpack . X.intercalate (X.singleton ':') + . map unSubAccount . unAccount . Q.account $ p + dc = case Q.drCr p of + Debit -> "Dr" + Credit -> "Cr" + cmdty = X.unpack . unCommodity . Q.commodity $ p + qt = show . Q.qty $ p + labelNo s = "(no " ++ s ++ ")" diff --git a/lib/Penny/Lincoln/Balance.hs b/lib/Penny/Lincoln/Balance.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Lincoln/Balance.hs @@ -0,0 +1,109 @@ +module Penny.Lincoln.Balance ( + Balance + , unBalance + , Balanced(Balanced, Inferable, NotInferable) + , isBalanced + , entryToBalance + , addBalances + , removeZeroCommodities + , BottomLine(Zero, NonZero) + , Column(Column, colDrCr, colQty) + ) where + +import Data.Map ( Map ) +import qualified Data.Map as M +import Data.Monoid ( Monoid, mempty, mappend ) +import qualified Data.Semigroup as Semi + +import Penny.Lincoln.Bits ( + add, difference, Difference(LeftBiggerBy, RightBiggerBy, Equal)) +import qualified Penny.Lincoln.Bits as B + +-- | A balance summarizes several entries. You do not create a Balance +-- directly. Instead, use 'entryToBalance'. +newtype Balance = Balance (Map B.Commodity BottomLine) + deriving (Show, Eq) + +-- | Returns a map where the keys are the commodities in the balance +-- and the values are the balance for each commodity. If there is no +-- balance at all, this map can be empty. +unBalance :: Balance -> Map B.Commodity BottomLine +unBalance (Balance m) = m + +-- | Returned by 'isBalanced'. +data Balanced = Balanced + | Inferable B.Entry + | NotInferable + deriving (Show, Eq) + +-- | Is this balance balanced? +isBalanced :: Balance -> Balanced +isBalanced (Balance m) = M.foldrWithKey f Balanced m where + f c n b = case n of + Zero -> b + (NonZero col) -> case b of + Balanced -> let + e = B.Entry dc a + dc = case colDrCr col of + B.Debit -> B.Credit + B.Credit -> B.Debit + q = colQty col + a = B.Amount q c + in Inferable e + _ -> NotInferable + +-- | Converts an Entry to a Balance. +entryToBalance :: B.Entry -> Balance +entryToBalance (B.Entry dc am) = Balance $ M.singleton c no where + c = B.commodity am + no = NonZero (Column dc (B.qty am)) + +data BottomLine = Zero + | NonZero Column + deriving (Show, Eq) + +instance Monoid BottomLine where + mempty = Zero + mappend n1 n2 = case (n1, n2) of + (Zero, Zero) -> Zero + (Zero, (NonZero c)) -> NonZero c + ((NonZero c), Zero) -> NonZero c + ((NonZero c1), (NonZero c2)) -> + let (Column dc1 q1) = c1 + (Column dc2 q2) = c2 + in if dc1 == dc2 + then NonZero $ Column dc1 (q1 `add` q2) + else case difference q1 q2 of + LeftBiggerBy diff -> + NonZero $ Column dc1 diff + RightBiggerBy diff -> + NonZero $ Column dc2 diff + Equal -> Zero + +data Column = Column { colDrCr :: B.DrCr + , colQty :: B.Qty } + deriving (Show, Eq) + +-- | Add two Balances together. Commodities are never removed from the +-- balance, even if their balance is zero. Instead, they are left in +-- the balance. Sometimes you want to know that a commodity was in the +-- account but its balance is now zero. +addBalances :: Balance -> Balance -> Balance +addBalances (Balance t1) (Balance t2) = + Balance $ M.unionWith mappend t1 t2 + +instance Semi.Semigroup Balance where + (<>) = addBalances + +instance Monoid Balance where + mempty = Balance M.empty + mappend = addBalances + +-- | Removes zero balances from a Balance. +removeZeroCommodities :: Balance -> Balance +removeZeroCommodities (Balance m) = + let p b = case b of + Zero -> False + _ -> True + m' = M.filter p m + in Balance m' diff --git a/lib/Penny/Lincoln/Bits.hs b/lib/Penny/Lincoln/Bits.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Lincoln/Bits.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE DeriveGeneric #-} + +-- | Essential data types used to make Transactions and Postings. +module Penny.Lincoln.Bits + ( module Penny.Lincoln.Bits.Open + , module Penny.Lincoln.Bits.DateTime + , module Penny.Lincoln.Bits.Price + , module Penny.Lincoln.Bits.Qty + , PricePoint ( .. ) + + -- * Aggregates + , TopLineCore(..) + , emptyTopLineCore + , TopLineFileMeta(..) + , TopLineData(..) + , emptyTopLineData + , PostingCore(..) + , emptyPostingCore + , PostingFileMeta(..) + , PostingData(..) + , emptyPostingData + ) where + + +import Data.Monoid (mconcat) +import Penny.Lincoln.Bits.Open +import Penny.Lincoln.Bits.DateTime +import Penny.Lincoln.Bits.Qty +import Penny.Lincoln.Bits.Price + +import qualified Penny.Lincoln.Bits.Open as O +import qualified Penny.Lincoln.Bits.DateTime as DT +import qualified Penny.Lincoln.Bits.Price as Pr +import qualified Penny.Lincoln.Equivalent as Ev +import Penny.Lincoln.Equivalent ((==~)) +import qualified Data.Binary as B +import GHC.Generics (Generic) + +data PricePoint = PricePoint { dateTime :: DT.DateTime + , price :: Pr.Price + , ppSide :: Maybe O.Side + , ppSpaceBetween :: Maybe O.SpaceBetween + , priceLine :: Maybe O.PriceLine } + deriving (Eq, Show, Generic) + +instance B.Binary PricePoint + +-- | PricePoint are equivalent if the dateTime and the Price are +-- equivalent. Other elements of the PricePoint are ignored. +instance Ev.Equivalent PricePoint where + equivalent (PricePoint dx px _ _ _) (PricePoint dy py _ _ _) = + dx ==~ dy && px ==~ py + compareEv (PricePoint dx px _ _ _) (PricePoint dy py _ _ _) = + mconcat [ Ev.compareEv dx dy + , Ev.compareEv px py ] + +-- | All the data that a TopLine might have. +data TopLineData = TopLineData + { tlCore :: TopLineCore + , tlFileMeta :: Maybe TopLineFileMeta + , tlGlobal :: Maybe O.GlobalTransaction + } deriving (Eq, Show, Generic) + +emptyTopLineData :: DT.DateTime -> TopLineData +emptyTopLineData dt = TopLineData (emptyTopLineCore dt) Nothing Nothing + +instance B.Binary TopLineData + +-- | Every TopLine has this data. +data TopLineCore = TopLineCore + { tDateTime :: DT.DateTime + , tNumber :: Maybe O.Number + , tFlag :: Maybe O.Flag + , tPayee :: Maybe O.Payee + , tMemo :: Maybe O.Memo + } deriving (Eq, Show, Generic) + +-- | TopLineCore are equivalent if their dates are equivalent and if +-- everything else is equal. +instance Ev.Equivalent TopLineCore where + equivalent x y = + tDateTime x ==~ tDateTime y + && tNumber x == tNumber y + && tFlag x == tFlag y + && tPayee x == tPayee y + && tMemo x == tMemo y + + compareEv x y = mconcat + [ Ev.compareEv (tDateTime x) (tDateTime y) + , compare (tNumber x) (tNumber y) + , compare (tFlag x) (tFlag y) + , compare (tPayee x) (tPayee y) + , compare (tMemo x) (tMemo y) + ] + +emptyTopLineCore :: DT.DateTime -> TopLineCore +emptyTopLineCore dt = TopLineCore dt Nothing Nothing Nothing Nothing + +instance B.Binary TopLineCore + +-- | TopLines from files have this metadata. +data TopLineFileMeta = TopLineFileMeta + { tFilename :: O.Filename + , tTopLineLine :: O.TopLineLine + , tTopMemoLine :: Maybe O.TopMemoLine + , tFileTransaction :: O.FileTransaction + } deriving (Eq, Show, Generic) + +instance B.Binary TopLineFileMeta + + +-- | All Postings have this data. +data PostingCore = PostingCore + { pPayee :: Maybe O.Payee + , pNumber :: Maybe O.Number + , pFlag :: Maybe O.Flag + , pAccount :: O.Account + , pTags :: O.Tags + , pMemo :: Maybe O.Memo + , pSide :: Maybe O.Side + , pSpaceBetween :: Maybe O.SpaceBetween + } deriving (Eq, Show, Generic) + +-- | Two PostingCore are equivalent if the Tags are equivalent and the +-- other data is equal, exlucing the Side and the SpaceBetween, which are not considered at all. +instance Ev.Equivalent PostingCore where + equivalent (PostingCore p1 n1 f1 a1 t1 m1 _ _) + (PostingCore p2 n2 f2 a2 t2 m2 _ _) + = p1 == p2 && n1 == n2 && f1 == f2 + && a1 == a2 && t1 ==~ t2 && m1 == m2 + + compareEv (PostingCore p1 n1 f1 a1 t1 m1 _ _) + (PostingCore p2 n2 f2 a2 t2 m2 _ _) + = mconcat + [ compare p1 p2 + , compare n1 n2 + , compare f1 f2 + , compare a1 a2 + , Ev.compareEv t1 t2 + , compare m1 m2 + ] + +emptyPostingCore :: O.Account -> PostingCore +emptyPostingCore ac = PostingCore + { pPayee = Nothing + , pNumber = Nothing + , pFlag = Nothing + , pAccount = ac + , pTags = O.Tags [] + , pMemo = Nothing + , pSide = Nothing + , pSpaceBetween = Nothing + } + +instance B.Binary PostingCore + +-- | Postings from files have this additional data. +data PostingFileMeta = PostingFileMeta + { pPostingLine :: O.PostingLine + , pFilePosting :: O.FilePosting + } deriving (Eq, Show, Generic) + +instance B.Binary PostingFileMeta + +-- | All the data that a Posting might have. +data PostingData = PostingData + { pdCore :: PostingCore + , pdFileMeta :: Maybe PostingFileMeta + , pdGlobal :: Maybe O.GlobalPosting + } deriving (Eq, Show, Generic) + +emptyPostingData :: O.Account -> PostingData +emptyPostingData ac = PostingData + { pdCore = emptyPostingCore ac + , pdFileMeta = Nothing + , pdGlobal = Nothing + } + +instance B.Binary PostingData + diff --git a/lib/Penny/Lincoln/Bits/DateTime.hs b/lib/Penny/Lincoln/Bits/DateTime.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Lincoln/Bits/DateTime.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Penny.Lincoln.Bits.DateTime + ( TimeZoneOffset ( offsetToMins ) + , minsToOffset + , noOffset + , Hours ( unHours ) + , intToHours + , zeroHours + , Minutes ( unMinutes ) + , intToMinutes + , zeroMinutes + , Seconds ( unSeconds ) + , intToSeconds + , zeroSeconds + , midnight + , DateTime ( .. ) + , dateTimeMidnightUTC + , toUTC + , toZonedTime + , fromZonedTime + , sameInstant + , showDateTime + ) where + +import qualified Control.Monad as M +import qualified Data.Time as T +import qualified Data.Binary as B +import Data.Binary (get, put) +import GHC.Generics (Generic) +import qualified Penny.Lincoln.Equivalent as Ev + +-- | The number of minutes that this timezone is offset from UTC. Can +-- be positive, negative, or zero. +newtype TimeZoneOffset = TimeZoneOffset { offsetToMins :: Int } + deriving (Eq, Ord, Show, Generic) + +instance B.Binary TimeZoneOffset + +-- | Convert minutes to a time zone offset. I'm having a hard time +-- deciding whether to be liberal or strict in what to accept +-- here. Currently it is somewhat strict in that it will fail if +-- absolute value is greater than 840 minutes; currently the article +-- at http://en.wikipedia.org/wiki/List_of_time_zones_by_UTC_offset +-- says there is no offset greater than 14 hours, or 840 minutes. +minsToOffset :: Int -> Maybe TimeZoneOffset +minsToOffset m = if abs m > 840 + then Nothing + else Just $ TimeZoneOffset m + +noOffset :: TimeZoneOffset +noOffset = TimeZoneOffset 0 + +newtype Hours = Hours { unHours :: Int } + deriving (Eq, Ord, Show, Generic) + +instance B.Binary Hours + +newtype Minutes = Minutes { unMinutes :: Int } + deriving (Eq, Ord, Show, Generic) + +instance B.Binary Minutes + +newtype Seconds = Seconds { unSeconds :: Int } + deriving (Eq, Ord, Show, Generic) + +instance B.Binary Seconds + +-- | succeeds if 0 <= x < 24 +intToHours :: Int -> Maybe Hours +intToHours h = + if h >= 0 && h < 24 then Just . Hours $ h else Nothing + +zeroHours :: Hours +zeroHours = Hours 0 + +-- | succeeds if 0 <= x < 60 +intToMinutes :: Int -> Maybe Minutes +intToMinutes m = + if m >= 0 && m < 60 then Just . Minutes $ m else Nothing + +zeroMinutes :: Minutes +zeroMinutes = Minutes 0 + +-- | succeeds if 0 <= x < 61 (to allow for leap seconds) +intToSeconds :: Int -> Maybe Seconds +intToSeconds s = + if s >= 0 && s < 61 + then Just . Seconds $ s + else Nothing + +zeroSeconds :: Seconds +zeroSeconds = Seconds 0 + +midnight :: (Hours, Minutes, Seconds) +midnight = (zeroHours, zeroMinutes, zeroSeconds) + +-- | A DateTime is a a local date and time, along with a time zone +-- offset. The Eq and Ord instances are derived; therefore, two +-- DateTime instances will not be equivalent if the time zone offsets +-- are different, even if they are the same instant. To compare one +-- DateTime to another, you probably want to use 'toUTC' and compare +-- those. To see if two DateTime are the same instant, use +-- 'sameInstant'. +data DateTime = DateTime + { day :: T.Day + , hours :: Hours + , minutes :: Minutes + , seconds :: Seconds + , timeZone :: TimeZoneOffset + } deriving (Eq, Ord, Show) + +instance B.Binary DateTime where + get = M.liftM5 DateTime (fmap T.ModifiedJulianDay B.get) + get get get get + put (DateTime d h m s t) = + put (T.toModifiedJulianDay d) >> put h >> put m >> put s >> put t + +dateTimeMidnightUTC :: T.Day -> DateTime +dateTimeMidnightUTC d = DateTime d h m s z + where + (h, m, s) = midnight + z = noOffset + +toZonedTime :: DateTime -> T.ZonedTime +toZonedTime dt = T.ZonedTime lt tz + where + d = day dt + lt = T.LocalTime d tod + tod = T.TimeOfDay (unHours . hours $ dt) (unMinutes . minutes $ dt) + (fromIntegral . unSeconds . seconds $ dt) + tz = T.TimeZone (offsetToMins . timeZone $ dt) False "" + +fromZonedTime :: T.ZonedTime -> Maybe DateTime +fromZonedTime (T.ZonedTime (T.LocalTime d tod) tz) = do + h <- intToHours . T.todHour $ tod + m <- intToMinutes . T.todMin $ tod + let (sWhole, _) = properFraction . T.todSec $ tod + s <- intToSeconds sWhole + tzo <- minsToOffset . T.timeZoneMinutes $ tz + return $ DateTime d h m s tzo + +toUTC :: DateTime -> T.UTCTime +toUTC dt = T.localTimeToUTC tz lt + where + tz = T.minutesToTimeZone . offsetToMins . timeZone $ dt + tod = T.TimeOfDay (unHours h) (unMinutes m) + (fromIntegral . unSeconds $ s) + DateTime d h m s _ = dt + lt = T.LocalTime d tod + +-- | Are these DateTimes the same instant in time, after adjusting for +-- local timezones? + +sameInstant :: DateTime -> DateTime -> Bool +sameInstant t1 t2 = toUTC t1 == toUTC t2 + +instance Ev.Equivalent DateTime where + equivalent = sameInstant + compareEv x y = compare (toUTC x) (toUTC y) + +-- | Shows a DateTime in a pretty way. +showDateTime :: DateTime -> String +showDateTime (DateTime d h m s tz) = + ds ++ " " ++ hmss ++ " " ++ showOffset + where + ds = show d + hmss = hs ++ ":" ++ ms ++ ":" ++ ss + hs = pad0 . show . unHours $ h + ms = pad0 . show . unMinutes $ m + ss = pad0 . show . unSeconds $ s + pad0 str = if length str < 2 then '0':str else str + showOffset = + let (zoneHr, zoneMin) = abs (offsetToMins tz) `divMod` 60 + sign = if offsetToMins tz < 0 then "-" else "+" + in sign ++ pad0 (show zoneHr) ++ pad0 (show zoneMin) + diff --git a/lib/Penny/Lincoln/Bits/Open.hs b/lib/Penny/Lincoln/Bits/Open.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Lincoln/Bits/Open.hs @@ -0,0 +1,214 @@ +{-# LANGUAGE DeriveGeneric #-} + +-- | These are the bits that are "open"; that is, their constructors +-- are exported. This includes most bits. Some bits that have open +-- constructors are not in this module because they include other bits +-- that do not have exported constructors. + +module Penny.Lincoln.Bits.Open where + +import Data.List (sort) +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as X +import qualified Data.Text.Encoding as XE +import GHC.Generics (Generic) +import qualified Penny.Lincoln.Equivalent as Ev +import Penny.Lincoln.Equivalent ((==~)) +import qualified Penny.Lincoln.Serial as S +import qualified Penny.Lincoln.Bits.Qty as Q +import qualified Data.Binary as B + +newtype SubAccount = + SubAccount { unSubAccount :: Text } + deriving (Eq, Ord, Show) + +instance B.Binary SubAccount where + put = B.put . XE.encodeUtf8 . unSubAccount + get = fmap (SubAccount . XE.decodeUtf8) B.get + +newtype Account = Account { unAccount :: [SubAccount] } + deriving (Eq, Show, Ord, Generic) + +instance B.Binary Account + +data Amount = Amount { qty :: Q.Qty + , commodity :: Commodity } + deriving (Eq, Show, Ord, Generic) + +instance B.Binary Amount + +instance Ev.Equivalent Amount where + equivalent (Amount q1 c1) (Amount q2 c2) = + q1 ==~ q2 && c1 == c2 + compareEv (Amount q1 c1) (Amount q2 c2) = + Ev.compareEv q1 q2 <> c1 `compare` c2 + +newtype Commodity = + Commodity { unCommodity :: Text } + deriving (Eq, Ord, Show) + +instance B.Binary Commodity where + get = fmap (Commodity . XE.decodeUtf8) B.get + put = B.put . XE.encodeUtf8 . unCommodity + +data DrCr = Debit | Credit deriving (Eq, Show, Ord, Generic) + +instance B.Binary DrCr + +-- | Debit returns Credit; Credit returns Debit +opposite :: DrCr -> DrCr +opposite d = case d of + Debit -> Credit + Credit -> Debit + +data Entry = Entry { drCr :: DrCr + , amount :: Amount } + deriving (Eq, Show, Ord, Generic) + +instance B.Binary Entry + +instance Ev.Equivalent Entry where + equivalent (Entry d1 a1) (Entry d2 a2) = + d1 == d2 && a1 ==~ a2 + compareEv (Entry d1 a1) (Entry d2 a2) = + d1 `compare` d2 <> Ev.compareEv a1 a2 + +newtype Flag = Flag { unFlag :: Text } + deriving (Eq, Show, Ord) + +instance B.Binary Flag where + get = fmap (Flag . XE.decodeUtf8) B.get + put = B.put . XE.encodeUtf8 . unFlag + +-- | There is one item in the list for each line of the memo. Do not +-- include newlines in the texts themselves. However there is nothing +-- to enforce this convention. +newtype Memo = Memo { unMemo :: [Text] } + deriving (Eq, Show, Ord) + +instance B.Binary Memo where + get = fmap (Memo . map XE.decodeUtf8) B.get + put = B.put . map XE.encodeUtf8 . unMemo + +newtype Number = Number { unNumber :: Text } + deriving (Eq, Show, Ord) + +instance B.Binary Number where + get = fmap (Number . XE.decodeUtf8) B.get + put = B.put . XE.encodeUtf8 . unNumber + + +newtype Payee = Payee { unPayee :: Text } + deriving (Eq, Show, Ord) + +instance B.Binary Payee where + get = fmap (Payee . XE.decodeUtf8) B.get + put = B.put . XE.encodeUtf8 . unPayee + +newtype Tag = Tag { unTag :: Text } + deriving (Eq, Show, Ord) + +instance B.Binary Tag where + get = fmap (Tag . XE.decodeUtf8) B.get + put = B.put . XE.encodeUtf8 . unTag + +newtype Tags = Tags { unTags :: [Tag] } + deriving (Eq, Show, Ord, Generic) + +-- | Tags are equivalent if they have the same tags (even if in a +-- different order). +instance Ev.Equivalent Tags where + equivalent (Tags t1) (Tags t2) = sort t1 == sort t2 + compareEv (Tags t1) (Tags t2) = + compare (sort t1) (sort t2) + +instance B.Binary Tags + +-- Metadata + +-- | The line number that the TopLine starts on (excluding the memo +-- accompanying the TopLine). +newtype TopLineLine = TopLineLine { unTopLineLine :: Int } + deriving (Eq, Show, Generic) + +instance B.Binary TopLineLine + +-- | The line number that the memo accompanying the TopLine starts on. +newtype TopMemoLine = TopMemoLine { unTopMemoLine :: Int } + deriving (Eq, Show, Generic) + +instance B.Binary TopMemoLine + +-- | The commodity and and the quantity may appear with the commodity +-- on the left (e.g. USD 2.14) or with the commodity on the right +-- (e.g. 2.14 USD). +data Side + = CommodityOnLeft + | CommodityOnRight + deriving (Eq, Show, Ord, Generic) + +instance B.Binary Side + +-- | There may or may not be a space in between the commodity and the +-- quantity. +data SpaceBetween + = SpaceBetween + | NoSpaceBetween + deriving (Eq, Show, Ord, Generic) + +instance B.Binary SpaceBetween + +-- | The name of the file in which a transaction appears. +newtype Filename = Filename { unFilename :: X.Text } + deriving (Eq, Show) + +instance B.Binary Filename where + get = fmap (Filename . XE.decodeUtf8) B.get + put = B.put . XE.encodeUtf8 . unFilename + + +-- | The line number on which a price appears. +newtype PriceLine = PriceLine { unPriceLine :: Int } + deriving (Eq, Show, Generic) + +instance B.Binary PriceLine + +-- | The line number on which a posting appears. +newtype PostingLine = PostingLine { unPostingLine :: Int } + deriving (Eq, Show, Generic) + +instance B.Binary PostingLine + +-- | All postings are numbered in order, beginning with the first +-- posting in the first file and ending with the last posting +-- in the last file. +newtype GlobalPosting = + GlobalPosting { unGlobalPosting :: S.Serial } + deriving (Eq, Show, Generic) + +instance B.Binary GlobalPosting + +-- | The postings in each file are numbered in order. +newtype FilePosting = + FilePosting { unFilePosting :: S.Serial } + deriving (Eq, Show, Generic) + +instance B.Binary FilePosting + +-- | All transactions are numbered in order, beginning with the first +-- transaction in the first file and ending with the last transaction +-- in the last file. +newtype GlobalTransaction = + GlobalTransaction { unGlobalTransaction :: S.Serial } + deriving (Eq, Show, Generic) + +instance B.Binary GlobalTransaction + +-- | The transactions in each file are numbered in order. +newtype FileTransaction = + FileTransaction { unFileTransaction :: S.Serial } + deriving (Eq, Show, Generic) + +instance B.Binary FileTransaction + diff --git a/lib/Penny/Lincoln/Bits/Price.hs b/lib/Penny/Lincoln/Bits/Price.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Lincoln/Bits/Price.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-} + +module Penny.Lincoln.Bits.Price ( + From ( From, unFrom ) + , To ( To, unTo ) + , CountPerUnit ( CountPerUnit, unCountPerUnit ) + , Price ( from, to, countPerUnit ) + , newPrice + ) where + +import Data.Monoid (mconcat) +import qualified Penny.Lincoln.Equivalent as Ev +import Penny.Lincoln.Equivalent ((==~)) +import qualified Penny.Lincoln.Bits.Open as O +import Penny.Lincoln.Bits.Qty (Qty) +import GHC.Generics (Generic) +import qualified Data.Binary as B + +newtype From = From { unFrom :: O.Commodity } + deriving (Eq, Ord, Show, Generic) + +instance B.Binary From + +newtype To = To { unTo :: O.Commodity } + deriving (Eq, Ord, Show, Generic) + +instance B.Binary To + +newtype CountPerUnit = CountPerUnit { unCountPerUnit :: Qty } + deriving (Eq, Ord, Show, Generic) + +instance Ev.Equivalent CountPerUnit where + equivalent (CountPerUnit x) (CountPerUnit y) = x ==~ y + compareEv (CountPerUnit x) (CountPerUnit y) = Ev.compareEv x y + +instance B.Binary CountPerUnit + +data Price = Price { from :: From + , to :: To + , countPerUnit :: CountPerUnit } + deriving (Eq, Ord, Show, Generic) + +instance B.Binary Price + +-- | Two Price are equivalent if the From and To are equal and the +-- CountPerUnit is equivalent. + +instance Ev.Equivalent Price where + equivalent (Price xf xt xc) (Price yf yt yc) = + xf == yf && xt == yt && xc ==~ yc + + compareEv (Price xf xt xc) (Price yf yt yc) = mconcat + [ compare xf yf + , compare xt yt + , Ev.compareEv xc yc + ] + +-- | Succeeds only if From and To are different commodities. +newPrice :: From -> To -> CountPerUnit -> Maybe Price +newPrice f t cpu = + if unFrom f == unTo t + then Nothing + else Just $ Price f t cpu diff --git a/lib/Penny/Lincoln/Bits/Qty.hs b/lib/Penny/Lincoln/Bits/Qty.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Lincoln/Bits/Qty.hs @@ -0,0 +1,360 @@ +{-# LANGUAGE DeriveGeneric #-} +-- | Penny quantities. A quantity is simply a count (possibly +-- fractional) of something. It does not have a commodity or a +-- Debit/Credit. +module Penny.Lincoln.Bits.Qty + ( Qty + , NumberStr(..) + , toQty + , mantissa + , places + , prettyShowQty + , compareQty + , newQty + , Mantissa + , Places + , add + , mult + , Difference(LeftBiggerBy, RightBiggerBy, Equal) + , difference + , allocate + , TotSeats + , PartyVotes + , SeatsWon + , largestRemainderMethod + , qtyOne + ) where + +import qualified Control.Monad.Exception.Synchronous as Ex +import qualified Data.Binary as B +import GHC.Generics (Generic) +import Data.List (genericLength, genericReplicate, genericSplitAt, sortBy) +import Data.Ord (comparing) +import qualified Penny.Lincoln.Equivalent as Ev + +data NumberStr = + Whole String + -- ^ A whole number only. No radix point. + | WholeRad String + -- ^ A whole number and a radix point, but nothing after the radix + -- point. + | WholeRadFrac String String + -- ^ A whole number and something after the radix point. + | RadFrac String + -- ^ A radix point and a fractional value after it, but nothing + -- before the radix point. + deriving Show + + +-- | Converts strings to Qty. Fails if any of the strings have +-- non-digits, or if any are negative, or if the result is not greater +-- than zero, or if the strings are empty. +toQty :: NumberStr -> Maybe Qty +toQty ns = case ns of + Whole s -> fmap (\m -> Qty m 0) (readInteger s) + WholeRad s -> fmap (\m -> Qty m 0) (readInteger s) + WholeRadFrac w f -> fromWholeRadFrac w f + RadFrac f -> fromWholeRadFrac "0" f + where + fromWholeRadFrac w f = + fmap (\m -> Qty m (genericLength f)) (readInteger (w ++ f)) + +-- | Reads non-negative integers only. +readInteger :: String -> Maybe Integer +readInteger s = case reads s of + (i, ""):[] -> if i < 0 then Nothing else Just i + _ -> Nothing + +-- | A quantity is always greater than zero. Various odd questions +-- happen if quantities can be zero. For instance, what if you have a +-- debit whose quantity is zero? Does it require a balancing credit +-- that is also zero? And how can you have a debit of zero anyway? +-- +-- I can imagine situations where a quantity of zero might be useful; +-- for instance maybe you want to specifically indicate that a +-- particular posting in a transaction did not happen (for instance, +-- that a paycheck deduction did not take place). I think the better +-- way to handle that though would be through an addition to +-- Debit\/Credit - maybe Debit\/Credit\/Zero. Barring the addition of +-- that, though, the best way to indicate a situation such as this +-- would be through transaction memos. +-- +-- /WARNING/ - before doing comparisons or equality tests +-- +-- The Eq instance is derived. Therefore q1 == q2 only if q1 and q2 +-- have both the same mantissa and the same exponent. You may instead +-- want 'equivalent'. Similarly, the Ord instance is derived. It +-- compares based on the integral value of the mantissa and of the +-- exponent. You may instead want 'compareQty', which compares after +-- equalizing the exponents. +data Qty = Qty { mantissa :: !Integer + , places :: !Integer + } deriving (Eq, Generic, Show, Ord) + +-- | Shows a quantity, nicely formatted after accounting for both the +-- mantissa and decimal places, e.g. @0.232@ or @232.12@ or whatever. +prettyShowQty :: Qty -> String +prettyShowQty q = + let man = show . mantissa $ q + e = places q + len = genericLength man + small = "0." ++ ((genericReplicate (e - len) '0') ++ man) + in case compare e len of + GT -> small + EQ -> small + LT -> + let (b, end) = genericSplitAt (len - e) man + in if e == 0 + then man + else b ++ ['.'] ++ end + +instance Ev.Equivalent Qty where + equivalent x y = x' == y' + where + (x', y') = equalizeExponents x y + compareEv x y = compare x' y' + where + (x', y') = equalizeExponents x y + +instance B.Binary Qty + +type Mantissa = Integer +type Places = Integer + +-- | Mantissa 1, exponent 0 +qtyOne :: Qty +qtyOne = Qty 1 0 + + + + +newQty :: Mantissa -> Places -> Maybe Qty +newQty m p + | m > 0 && p >= 0 = Just $ Qty m p + | otherwise = Nothing + + + +-- | Compares Qty after equalizing their exponents. +-- +-- > compareQty (newQty 15 1) (newQty 1500 3) == EQ +compareQty :: Qty -> Qty -> Ordering +compareQty q1 q2 = compare (mantissa q1') (mantissa q2') + where + (q1', q2') = equalizeExponents q1 q2 + + +-- | Adjust the exponents on two Qty so they are equivalent +-- before, but now have the same exponent. +equalizeExponents :: Qty -> Qty -> (Qty, Qty) +equalizeExponents x y = (x', y') + where + (ex, ey) = (places x, places y) + (x', y') = case compare ex ey of + GT -> (x, increaseExponent (ex - ey) y) + LT -> (increaseExponent (ey - ex) x, y) + EQ -> (x, y) + +-- | Increase the exponent by the amount given, so that the new Qty is +-- equivalent to the old one. Takes the absolute value of the +-- adjustment argument. +increaseExponent :: Integer -> Qty -> Qty +increaseExponent i (Qty m e) = Qty m' e' + where + amt = abs i + m' = m * 10 ^ amt + e' = e + amt + +-- | Increases the exponent to the given amount. Does nothing if the +-- exponent is already at or higher than this amount. +increaseExponentTo :: Integer -> Qty -> Qty +increaseExponentTo i q@(Qty _ e) = + let diff = i - e + in if diff >= 0 then increaseExponent diff q else q + +data Difference = + LeftBiggerBy Qty + | RightBiggerBy Qty + | Equal + deriving (Eq, Show) + +-- | Subtract the second Qty from the first, after equalizing their +-- exponents. +difference :: Qty -> Qty -> Difference +difference x y = + let (x', y') = equalizeExponents x y + (mx, my) = (mantissa x', mantissa y') + in case compare mx my of + GT -> LeftBiggerBy (Qty (mx - my) (places x')) + LT -> RightBiggerBy (Qty (my - mx) (places x')) + EQ -> Equal + +add :: Qty -> Qty -> Qty +add x y = + let ((Qty xm e), (Qty ym _)) = equalizeExponents x y + in Qty (xm + ym) e + + + +mult :: Qty -> Qty -> Qty +mult (Qty xm xe) (Qty ym ye) = Qty (xm * ym) (xe + ye) + + +-- +-- Allocation +-- +-- The steps of allocation: +-- +-- Adjust all exponents, both on the amount to be allocated and on all +-- the votes, so that the exponents are all equal. +-- +-- Allocate the mantissas. +-- +-- Return the quantities with the original exponents. + +-- | Allocate a Qty proportionally so that the sum of the results adds +-- up to a given Qty. Fails if the allocation cannot be made (e.g. if +-- it is impossible to allocate without overflowing Decimal.) The +-- result will always add up to the given sum. +allocate :: Qty -> (Qty, [Qty]) -> (Qty, [Qty]) +allocate tot (q1, qs) = case allocate' tot (q1:qs) of + [] -> error "allocate error" + x:xs -> (x, xs) + +allocate' + :: Qty + -- ^ The result will add up to this Qty. + + -> [Qty] + -- ^ Allocate using these Qty (there must be at least one). + + -> [Qty] + -- ^ The length of this list will be equal to the length of the list + -- of allocations. Each item will correspond to the original + -- allocation. + +allocate' tot ls = + let ((tot':ls'), e) = sameExponent (tot:ls) + (moreE, (_, ss)) = + multRemainderAllResultsAtLeast1 (mantissa tot') + (map mantissa ls') + totE = e + moreE + in map (\m -> Qty m totE) ss + + + +-- | Given a list of Decimals, and a single Decimal, return Decimals +-- that are equivalent to the original Decimals, but where all +-- Decimals have the same exponent. Also returns new exponent. +sameExponent + :: [Qty] + -> ([Qty], Integer) +sameExponent ls = + let newExp = maximum . fmap places $ ls + in (map (increaseExponentTo newExp) ls, newExp) + + + + + +type Multiplier = Integer + +multLargestRemainder + :: TotSeats + -> [PartyVotes] + -> Multiplier + -> (TotSeats, [SeatsWon]) +multLargestRemainder ts pv m = + let ts' = ts * 10 ^ m + pv' = map (\x -> x * 10 ^ m) pv + in (ts', largestRemainderMethod ts' pv') + +increasingMultRemainder + :: TotSeats + -> [PartyVotes] + -> [(Multiplier, (TotSeats, [SeatsWon]))] +increasingMultRemainder ts pv = + zip [0..] (map (multLargestRemainder ts pv) [0..]) + +multRemainderAllResultsAtLeast1 + :: TotSeats + -> [PartyVotes] + -> (Multiplier, (TotSeats, [SeatsWon])) +multRemainderAllResultsAtLeast1 ts pv + = head + . dropWhile (any (< 1) . snd . snd) + $ increasingMultRemainder ts pv + +-- Largest remainder method: votes for one party is divided by +-- (total votes / number of seats). Result is an integer and a +-- remainder. Each party gets the number of seats indicated by its +-- integer. Parties are then ranked on the basis of the remainders, and +-- those with the largest remainders get an additional seat until all +-- seats have been distributed. +type AutoSeats = Integer +type PartyVotes = Integer +type TotVotes = Integer +type TotSeats = Integer +type Remainder = Rational +type SeatsWon = Integer + +-- | Allocates integers using the largest remainder method. This is +-- the method used to allocate parliamentary seats in many countries, +-- so the types are named accordingly. +largestRemainderMethod + :: TotSeats + -- ^ Total number of seats in the legislature. This is the integer + -- that will be allocated. This number must be positive or this + -- function will fail at runtime. + + -> [PartyVotes] + -- ^ The total seats will be allocated proportionally depending on + -- how many votes each party received. The sum of this list must be + -- positive, and each member of the list must be at least zero; + -- otherwise a runtime error will occur. + + -> [SeatsWon] + -- ^ The sum of this list will always be equal to the total number + -- of seats, and its length will always be equal to length of the + -- PartyVotes list. + +largestRemainderMethod ts pvs = + let err s = error $ "largestRemainderMethod: error: " ++ s + in Ex.resolve err $ do + Ex.assert "TotalSeats not positive" (ts > 0) + Ex.assert "sum of [PartyVotes] not positive" (sum pvs > 0) + Ex.assert "negative member of [PartyVotes]" (minimum pvs >= 0) + return (allocRemainder ts . allocAuto ts $ pvs) + + +autoAndRemainder + :: TotSeats -> TotVotes -> PartyVotes -> (AutoSeats, Remainder) +autoAndRemainder ts tv pv = + let fI = fromIntegral :: Integer -> Rational + quota = if ts == 0 + then error "autoAndRemainder: zero total seats" + else if tv == 0 + then error "autoAndRemainder: zero total votes" + else fI tv / fI ts + in properFraction (fI pv / quota) + + +allocAuto :: TotSeats -> [PartyVotes] -> [(AutoSeats, Remainder)] +allocAuto ts pvs = map (autoAndRemainder ts (sum pvs)) pvs + +allocRemainder + :: TotSeats + -> [(AutoSeats, Remainder)] + -> [SeatsWon] +allocRemainder ts ls = + let totLeft = ts - (sum . map fst $ ls) + (leftForEach, stillLeft) = totLeft `divMod` genericLength ls + wIndex = zip ([0..] :: [Integer]) ls + sorted = sortBy (comparing (snd . snd)) wIndex + wOrder = zip [0..] sorted + awarder (ord, (ix, (as, _))) = + if ord < stillLeft + then (ix, as + leftForEach + 1) + else (ix, as + leftForEach) + awarded = map awarder wOrder + in map snd . sortBy (comparing fst) $ awarded diff --git a/lib/Penny/Lincoln/Builders.hs b/lib/Penny/Lincoln/Builders.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Lincoln/Builders.hs @@ -0,0 +1,28 @@ +-- | Partial functions that make common types in Lincoln. Some data +-- types in Lincoln are deeply nested, with TextNonEmpty nested inside +-- of a newtype, nested inside of a NonEmptyList, nested inside +-- of... :) All the nesting ensures to the maximum extent possible +-- that the type system reflects the restrictions that exist on +-- Penny's data. For example, it would make no sense to have an empty +-- account (that is, an account with no sub-accounts) or a sub-account +-- whose name is an empty Text. +-- +-- The disadvantage of the nesting is that building these data types +-- can be tedious if, for example, you want to build some data within +-- a short custom Haskell program. Thus, this module. + +module Penny.Lincoln.Builders + ( account + ) where + +import qualified Penny.Lincoln.Bits as B +import qualified Data.Text as X + +-- | Create an Account. You supply a single Text, with colons to +-- separate the different sub-accounts. +account :: X.Text -> B.Account +account s = + if X.null s + then B.Account [] + else B.Account . map B.SubAccount . X.splitOn (X.singleton ':') $ s + diff --git a/lib/Penny/Lincoln/Ents.hs b/lib/Penny/Lincoln/Ents.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Lincoln/Ents.hs @@ -0,0 +1,278 @@ +{-# LANGUAGE DeriveGeneric, DeriveFunctor #-} + +-- | Containers for entries. +-- +-- This module is the key guardian of the core principle of +-- double-entry accounting, which is that debits and credits must +-- always balance. An 'Ent' is a container for an 'Entry'. An 'Entry' +-- holds a 'DrCr' and an 'Amount' which, in turn, holds a 'Commodity' +-- and a 'Qty'. For a given 'Commodity' in a particular transaction, +-- the sum of the debits must always be equal to the sum of the +-- credits. +-- +-- In addition to the 'Entry', the 'Ent' holds information about +-- whether the particular 'Entry' it holds is inferred or not. An Ent +-- is @inferred@ if the user did not supply the entry, but Penny was +-- able to deduce its 'Entry' because proper entries were supplied for +-- all the other postings in the transaction. The 'Ent' also holds +-- arbitrary metadata--which will typically be other information about +-- the particular posting, such as the payee, account, etc. +-- +-- A collection of 'Ent' is an 'Ents'. This module will only create an +-- 'Ent' as part of an 'Ents' (though you can later separate the 'Ent' +-- from its other 'Ents' if you like.) In any given 'Ents', all of the +-- 'Ent' collectively have a zero balance. +-- +-- This module also contains type synonyms used to represent a +-- Posting, which is an Ent bundled with its sibling Ents, and a +-- Transaction. + +module Penny.Lincoln.Ents + ( -- * Ent + Inferred(..) + , Ent + , entry + , inferred + , meta + + -- * Ents + , Ents + , unEnts + , tupleEnts + , mapEnts + , traverseEnts + , ents + , rEnts + , headEnt + , tailEnts + + -- * Postings and transactions + , Posting(..) + , Transaction(..) + , transactionToPostings + , views + , unrollSnd + ) where + +import Control.Applicative +import Control.Arrow (second) +import Data.Binary (Binary) +import GHC.Generics (Generic) +import qualified Penny.Lincoln.Bits as B +import qualified Penny.Lincoln.Balance as Bal +import Control.Monad (guard) +import qualified Penny.Lincoln.Equivalent as Ev +import Penny.Lincoln.Equivalent ((==~)) +import Data.Monoid (mconcat, (<>)) +import Data.List (foldl', unfoldr, sortBy) +import Data.Maybe (isNothing, catMaybes) +import qualified Data.Traversable as Tr +import qualified Data.Foldable as Fdbl + +-- | An Ent is inferred if the user did not supply an entry for it and +-- Penny was able to infer the correct entry. Otherwise it is not +-- inferred. +data Inferred = Inferred | NotInferred + deriving (Eq, Ord, Show, Generic) + +instance Binary Inferred + +-- | Information about an entry, along with whether it is inferred and +-- its metadata. +data Ent m = Ent + { entry :: B.Entry + -- ^ The entry from an Ent + , inferred :: Inferred + -- ^ Whether the entry was inferred + , meta :: m + -- ^ The metadata accompanying an Ent + } deriving (Eq, Ord, Show, Generic) + +-- | Two Ents are equivalent if the entries are equivalent and the +-- metadata is equivalent (whether the Ent is inferred or not is +-- ignored.) +instance Ev.Equivalent m => Ev.Equivalent (Ent m) where + equivalent (Ent e1 _ m1) (Ent e2 _ m2) = + e1 ==~ e2 && m1 ==~ m2 + compareEv (Ent e1 _ m1) (Ent e2 _ m2) = + Ev.compareEv e1 e2 <> Ev.compareEv m1 m2 + +instance Functor Ent where + fmap f (Ent e i m) = Ent e i (f m) + +instance Binary m => Binary (Ent m) + +newtype Ents m = Ents { unEnts :: [Ent m] } + deriving (Eq, Ord, Show, Generic, Functor) + +-- | Ents are equivalent if the content Ents of each are +-- equivalent. The order of the ents is insignificant. +instance Ev.Equivalent m => Ev.Equivalent (Ents m) where + equivalent (Ents e1) (Ents e2) = + let (e1', e2') = (sortBy Ev.compareEv e1, sortBy Ev.compareEv e2) + in and $ (length e1 == length e2) + : zipWith Ev.equivalent e1' e2' + + compareEv (Ents e1) (Ents e2) = + let (e1', e2') = (sortBy Ev.compareEv e1, sortBy Ev.compareEv e2) + in mconcat $ compare (length e1) (length e2) + : zipWith Ev.compareEv e1' e2' + +instance Fdbl.Foldable Ents where + foldr f z (Ents ls) = case ls of + [] -> z + x:xs -> f (meta x) (Fdbl.foldr f z (map meta xs)) + +instance Tr.Traversable Ents where + sequenceA = fmap Ents . Tr.sequenceA . map seqEnt . unEnts + +-- | Alter the metadata Ents, while examining the Ents themselves. If +-- you only want to change the metadata and you don't need to examine +-- the other contents of the Ent, use the Functor instance. You cannot +-- change non-metadata aspects of the Ent. +mapEnts :: (Ent a -> b) -> Ents a -> Ents b +mapEnts f = Ents . map f' . unEnts where + f' e = e { meta = f e } + +-- | Alter the metadata of Ents while examing their contents. If you +-- do not need to examine their contents, use the Traversable +-- instance. +traverseEnts :: Applicative f => (Ent a -> f b) -> Ents a -> f (Ents b) +traverseEnts f = fmap Ents . Tr.traverse f' . unEnts where + f' en@(Ent e i _) = Ent <$> pure e <*> pure i <*> f en + +seqEnt :: Applicative f => Ent (f a) -> f (Ent a) +seqEnt (Ent e i m) = Ent <$> pure e <*> pure i <*> m + +-- | Every Ents alwas contains at least two ents, and possibly +-- additional ones. +tupleEnts :: Ents m -> (Ent m, Ent m, [Ent m]) +tupleEnts (Ents ls) = case ls of + t1:t2:ts -> (t1, t2, ts) + _ -> error "tupleEnts: ents does not have two ents" + +instance Binary m => Binary (Ents m) + +-- | In a Posting, the Ent at the front of the list of Ents is the +-- main posting. There are additional postings. This function +-- rearranges the Ents multiple times so that each posting is at the +-- head of the list exactly once. +views :: Ents m -> [Ents m] +views = map Ents . orderedPermute . unEnts + +-- | > unrollSnd (undefined, []) == [] +-- > unrollSnd (1, [1,2,3]) = [(1,1), (1,2), (1,3)] + +unrollSnd :: (a, [b]) -> [(a, b)] +unrollSnd = unfoldr f where + f (_, []) = Nothing + f (a, b:bs) = Just ((a, b), (a, bs)) + +-- | Splits a Transaction into Postings. +transactionToPostings :: Transaction -> [Posting] +transactionToPostings = + map Posting . unrollSnd . second views . unTransaction + +-- | Get information from the head posting in the View, which is the +-- one you are most likely interested in. This never fails, as every +-- Ents has at least two postings. +headEnt :: Ents m -> Ent m +headEnt (Ents ls) = case ls of + [] -> error "ents: empty view" + x:_ -> x + +-- | Get information on sibling Ents. +tailEnts :: Ents m -> (Ent m, [Ent m]) +tailEnts (Ents ls) = case ls of + [] -> error "ents: tailEnts: empty view" + _:xs -> case xs of + [] -> error "ents: tailEnts: only one sibling" + s2:ss -> (s2, ss) + +-- | A Transaction and a Posting are identical on the inside, but they +-- have different semantic meanings so they are wrapped in newtypes. +newtype Transaction = Transaction + { unTransaction :: ( B.TopLineData, Ents B.PostingData ) } + deriving (Eq, Show) + +-- | In a Posting, the Ent yielded by 'headEnt' will be the posting of +-- interest. The other sibling postings are also available for +-- inspection. +newtype Posting = Posting + { unPosting :: ( B.TopLineData, Ents B.PostingData ) } + deriving (Eq, Show) + +-- | Returns a list of lists where each element in the original list +-- is in the front of a new list once. +-- +-- > orderedPermute [1,2,3] == [[1,2,3], [2,3,1], [3,1,2]] +orderedPermute :: [a] -> [[a]] +orderedPermute ls = take (length ls) (iterate toTheBack ls) + where + toTheBack [] = [] + toTheBack (a:as) = as ++ [a] + +-- | Creates an 'Ents'. At most, one of the Maybe Entry can be Nothing +-- and this function will infer the remaining Entry. This function +-- fails if it cannot create a balanced Ents. +ents + :: [(Maybe B.Entry, m)] + -> Maybe (Ents m) +ents ls = do + guard . not . null $ ls + let makePstg = makeEnt (inferredVal . map fst $ ls) + fmap Ents $ mapM makePstg ls + +-- | Creates 'Ents'. Unlike 'ents' this function never fails because +-- you are restricted in the inputs that you can give it. It will +-- always infer the last Entry. All Entries except one will have the +-- same DrCr; the last, inferred one will have the opposite DrCr. +rEnts + :: B.Commodity + -- ^ Commodity for all postings + -> B.DrCr + -- ^ DrCr for all non-inferred postings + -> (B.Qty, m) + -- ^ Non-inferred posting 1 + -> [(B.Qty, m)] + -- ^ Remaining non-inferred postings + -> m + -- ^ Metadata for inferred posting + -> Ents m +rEnts com dc (q1, m1) nonInfs lastMeta = + let tot = foldl' B.add q1 . map fst $ nonInfs + p1 = makePstg (q1, m1) + ps = map makePstg nonInfs + makePstg (q, m) = Ent (B.Entry dc (B.Amount q com)) + NotInferred m + lastPstg = Ent (B.Entry (B.opposite dc) (B.Amount tot com)) + Inferred lastMeta + in Ents $ p1:ps ++ [lastPstg] + + +-- | Changes Maybe Entries into Postings. Uses the inferred value if +-- the Maybe Entry is Nothing. If there is no inferred value, returns +-- Nothing. +makeEnt + :: Maybe B.Entry + -- ^ Inferred value + -> (Maybe B.Entry, m) + -> Maybe (Ent m) +makeEnt mayInf (mayEn, m) = case mayEn of + Nothing -> case mayInf of + Nothing -> Nothing + Just inf -> return $ Ent inf Inferred m + Just en -> return $ Ent en NotInferred m + + +-- | Gets a single inferred entry from a balance, if possible. +inferredVal :: [Maybe B.Entry] -> Maybe B.Entry +inferredVal ls = do + guard ((length . filter id . map isNothing $ ls) == 1) + let bal = mconcat + . map Bal.entryToBalance + . catMaybes + $ ls + case Bal.isBalanced bal of + Bal.Inferable e -> Just e + _ -> Nothing diff --git a/lib/Penny/Lincoln/Equivalent.hs b/lib/Penny/Lincoln/Equivalent.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Lincoln/Equivalent.hs @@ -0,0 +1,21 @@ +module Penny.Lincoln.Equivalent where + +import Data.Monoid ((<>)) + +-- | Comparisons for equivalency. Two items are equivalent if they +-- have the same semantic meaning, even if the data in the two items +-- is different. +class Equivalent a where + equivalent :: a -> a -> Bool + + -- | Compares based on equivalency. + compareEv :: a -> a -> Ordering + +(==~) :: Equivalent a => a -> a -> Bool +(==~) = equivalent +infix 4 ==~ + +instance (Equivalent a, Equivalent b) => Equivalent (a, b) where + equivalent (a1, b1) (a2, b2) = a1 ==~ a2 && b1 ==~ b2 + compareEv (a1, b1) (a2, b2) = + compareEv a1 a2 <> compareEv b1 b2 diff --git a/lib/Penny/Lincoln/HasText.hs b/lib/Penny/Lincoln/HasText.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Lincoln/HasText.hs @@ -0,0 +1,58 @@ +module Penny.Lincoln.HasText where + +import Data.Text (Text) +import qualified Data.Text as X + +import qualified Penny.Lincoln.Bits as B + +class HasText a where + text :: a -> Text + +instance HasText Text where + text = id + +instance HasText B.SubAccount where + text = B.unSubAccount + +instance HasText B.Flag where + text = B.unFlag + +instance HasText B.Commodity where + text = B.unCommodity + +instance HasText B.Number where + text = B.unNumber + +instance HasText B.Payee where + text = B.unPayee + +instance HasText B.Tag where + text = B.unTag + +instance HasText B.Filename where + text = B.unFilename + +class HasTextList a where + textList :: a -> [Text] + +-- | Wraps instances of HasTextList and provides a delimiter; the +-- result is an instance of HasText. +data Delimited a = Delimited + { delimiter :: Text + , delimited :: a + } deriving (Eq, Show) + +instance HasTextList a => HasTextList (Delimited a) where + textList = textList . delimited + +instance HasTextList a => HasText (Delimited a) where + text a = X.intercalate (delimiter a) . textList . delimited $ a + +instance HasTextList B.Account where + textList = map text . B.unAccount + +instance HasTextList B.Tags where + textList = map text . B.unTags + +instance HasTextList B.Memo where + textList = B.unMemo diff --git a/lib/Penny/Lincoln/Matchers.hs b/lib/Penny/Lincoln/Matchers.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Lincoln/Matchers.hs @@ -0,0 +1,21 @@ +-- | Type synonyms for functions dealing with text matching. + +module Penny.Lincoln.Matchers where + +import qualified Data.Text as X +import qualified Control.Monad.Exception.Synchronous as Ex +import qualified Text.Matchers as MT + +-- | A function that makes Matchers. +type Factory + = MT.CaseSensitive + -- ^ Will this matcher be case sensitive? + + -> X.Text + -- ^ The pattern to use when testing for a match. For example, this + -- might be a regular expression, or simply the text to be matched. + + -> Ex.Exceptional X.Text MT.Matcher + -- ^ Sometimes producing a matcher might fail; for example, the user + -- might have supplied a bad pattern. If so, an exception is + -- returned. On success, a Matcher is returned. diff --git a/lib/Penny/Lincoln/Predicates.hs b/lib/Penny/Lincoln/Predicates.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Lincoln/Predicates.hs @@ -0,0 +1,323 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Functions that return a boolean based upon some criterion that +-- matches something, often a PostFam. Useful when filtering +-- Postings. +module Penny.Lincoln.Predicates + ( LPdct + , MakePdct + , payee + , number + , flag + , postingMemo + , transactionMemo + , date + , qty + , drCr + , debit + , credit + , commodity + , account + , accountLevel + , accountAny + , tag + , reconciled + , filename + + -- * Serials + , serialPdct + , MakeSerialPdct + , fwdGlobalPosting + , backGlobalPosting + , fwdFilePosting + , backFilePosting + , fwdGlobalTransaction + , backGlobalTransaction + , fwdFileTransaction + , backFileTransaction + ) where + + +import Data.List (intersperse) +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as X +import qualified Data.Time as Time +import qualified Penny.Lincoln.Bits as B +import Penny.Lincoln.HasText (HasText, text, HasTextList, textList) +import qualified Penny.Lincoln.Queries as Q +import Penny.Lincoln.Ents (Posting) +import qualified Penny.Lincoln.Ents as E +import qualified Text.Matchers as M +import qualified Data.Prednote.Pdct as P +import Penny.Lincoln.Serial (forward, backward) + +type LPdct = P.Pdct Posting + +type MakePdct = M.Matcher -> LPdct + +-- * Matching helpers +match + :: HasText a + => Text + -- ^ Description of this field + -> (Posting -> a) + -- ^ Function that returns the field being matched + -> M.Matcher + -> LPdct +match t f m = P.operand desc pd + where + desc = makeDesc t m + pd = M.match m . text . f + +matchMaybe + :: HasText a + => Text + -- ^ Description of this field + -> (Posting -> Maybe a) + -> M.Matcher + -> LPdct +matchMaybe t f m = P.operand desc pd + where + desc = makeDesc t m + pd = maybe False (M.match m . text) . f + +makeDesc :: Text -> M.Matcher -> Text +makeDesc t m + = "subject: " <> t + <> " matcher: " <> M.matchDesc m + +-- | Does the given matcher match any of the elements of the Texts in +-- a HasTextList? +matchAny + :: HasTextList a + => Text + -> (Posting -> a) + -> M.Matcher + -> LPdct +matchAny t f m = P.operand desc pd + where + desc = makeDesc t m + pd = any (M.match m) . textList . f + +-- | Does the given matcher match the text that is at the given +-- element of a HasTextList? If the HasTextList does not have a +-- sufficent number of elements to perform this test, returns False. +matchLevel + :: HasTextList a + => Int + -> Text + -> (Posting -> a) + -> M.Matcher + -> LPdct +matchLevel l d f m = P.operand desc pd + where + desc = makeDesc ("level " <> X.pack (show l) <> " of " <> d) m + pd pf = let ts = textList (f pf) + in if l < 0 || l >= length ts + then False + else M.match m (ts !! l) + +-- | Does the matcher match the text of the memo? Joins each line of +-- the memo with a space. +matchMemo + :: Text + -> (Posting -> Maybe B.Memo) + -> M.Matcher + -> LPdct +matchMemo t f m = P.operand desc pd + where + desc = makeDesc t m + pd = maybe False doMatch . f + doMatch = M.match m + . X.intercalate (X.singleton ' ') + . B.unMemo + +matchDelimited + :: HasTextList a + => Text + -- ^ Separator + -> Text + -- ^ Label + -> (Posting -> a) + -> M.Matcher + -> LPdct +matchDelimited sep lbl f m = match lbl f' m + where + f' = X.concat . intersperse sep . textList . f + +-- * Pattern matching fields + +payee :: MakePdct +payee = matchMaybe "payee" Q.payee + +number :: MakePdct +number = matchMaybe "number" Q.number + +flag :: MakePdct +flag = matchMaybe "flag" Q.flag + +postingMemo :: MakePdct +postingMemo = matchMemo "posting memo" Q.postingMemo + +transactionMemo :: MakePdct +transactionMemo = matchMemo "transaction memo" Q.transactionMemo + +-- * Date + +date + :: Ordering + -> Time.UTCTime + -> LPdct +date ord u = P.compareBy (X.pack . show $ u) + "UTC date and time" + (\l -> compare (B.toUTC . Q.dateTime $ l) u) ord + + +qty :: Ordering -> B.Qty -> LPdct +qty o q = P.compareBy (X.pack . show $ q) "quantity" + (\l -> B.compareQty (Q.qty l) q) o + + +drCr :: B.DrCr -> LPdct +drCr dc = P.operand desc pd + where + desc = "entry is a " <> s + s = case dc of { B.Debit -> "debit"; B.Credit -> "credit" } + pd pf = Q.drCr pf == dc + +debit :: LPdct +debit = drCr B.Debit + +credit :: LPdct +credit = drCr B.Credit + +commodity :: M.Matcher -> LPdct +commodity = match "commodity" Q.commodity + +account :: M.Matcher -> LPdct +account = matchDelimited ":" "account" Q.account + +accountLevel :: Int -> M.Matcher -> LPdct +accountLevel i = matchLevel i "account" Q.account + +accountAny :: M.Matcher -> LPdct +accountAny = matchAny "any sub-account" Q.account + +tag :: M.Matcher -> LPdct +tag = matchAny "any tag" Q.tags + +-- | True if a posting is reconciled; that is, its flag is exactly +-- @R@. +reconciled :: LPdct +reconciled = P.operand d p + where + d = "posting flag is exactly \"R\" (is reconciled)" + p = maybe False ((== X.singleton 'R') . B.unFlag) . Q.flag + +filename :: M.Matcher -> LPdct +filename = matchMaybe "filename" Q.filename + +-- | Makes Pdct based on comparisons against a particular serial. + +serialPdct + :: Text + -- ^ Name of the serial, e.g. @globalPosting@ + + -> (a -> Maybe Int) + -- ^ How to obtain the serial from the item being examined + + -> Int + -- ^ The right hand side + + -> Ordering + -- ^ The Pdct returned will be Just True if the item has a serial + -- and @compare ser rhs@ returns this Ordering; Just False if the + -- item has a srerial and @compare@ does not return this Ordering; + -- Nothing if the item does not have a serial. + + -> P.Pdct a + +serialPdct name getSer i o = P.Pdct n (P.Operand f) + where + n = "serial " <> name <> " is " <> descCmp <> " " + <> X.pack (show i) + descCmp = case o of + EQ -> "equal to" + LT -> "less than" + GT -> "greater than" + f = fmap (\ser -> compare ser i == o) . getSer + +type MakeSerialPdct = Int -> Ordering -> P.Pdct Posting + +fwdGlobalPosting :: MakeSerialPdct +fwdGlobalPosting = + serialPdct "fwdGlobalPosting" + $ fmap (forward . B.unGlobalPosting) + . B.pdGlobal + . E.meta + . E.headEnt + . snd + . E.unPosting + +backGlobalPosting :: MakeSerialPdct +backGlobalPosting = + serialPdct "revGlobalPosting" + $ fmap (backward . B.unGlobalPosting) + . B.pdGlobal + . E.meta + . E.headEnt + . snd + . E.unPosting + +fwdFilePosting :: MakeSerialPdct +fwdFilePosting + = serialPdct "fwdFilePosting" + $ fmap (forward . B.unFilePosting . B.pFilePosting) + . B.pdFileMeta + . E.meta + . E.headEnt + . snd + . E.unPosting + +backFilePosting :: MakeSerialPdct +backFilePosting + = serialPdct "revFilePosting" + $ fmap (backward . B.unFilePosting . B.pFilePosting) + . B.pdFileMeta + . E.meta + . E.headEnt + . snd + . E.unPosting + +fwdGlobalTransaction :: MakeSerialPdct +fwdGlobalTransaction + = serialPdct "fwdGlobalTransaction" + $ fmap (forward . B.unGlobalTransaction) + . B.tlGlobal + . fst + . E.unPosting + +backGlobalTransaction :: MakeSerialPdct +backGlobalTransaction + = serialPdct "backGlobalTransaction" + $ fmap (backward . B.unGlobalTransaction) + . B.tlGlobal + . fst + . E.unPosting + +fwdFileTransaction :: MakeSerialPdct +fwdFileTransaction + = serialPdct "fwdFileTransaction" + $ fmap (forward . B.unFileTransaction . B.tFileTransaction) + . B.tlFileMeta + . fst + . E.unPosting + +backFileTransaction :: MakeSerialPdct +backFileTransaction + = serialPdct "backFileTransaction" + $ fmap (backward . B.unFileTransaction . B.tFileTransaction) + . B.tlFileMeta + . fst + . E.unPosting diff --git a/lib/Penny/Lincoln/Predicates/Siblings.hs b/lib/Penny/Lincoln/Predicates/Siblings.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Lincoln/Predicates/Siblings.hs @@ -0,0 +1,328 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Functions that return a boolean based upon some criterion that +-- matches something, often a PostFam. Useful when filtering +-- Postings. +module Penny.Lincoln.Predicates.Siblings + ( LPdct + , MakePdct + , payee + , number + , flag + , postingMemo + , qty + , parseQty + , drCr + , debit + , credit + , commodity + , account + , accountLevel + , accountAny + , tag + , reconciled + + -- * Serials + , serialPdct + , MakeSerialPdct + , fwdGlobalPosting + , backGlobalPosting + , fwdFilePosting + , backFilePosting + , fwdGlobalTransaction + , backGlobalTransaction + , fwdFileTransaction + , backFileTransaction + ) where + + +import Control.Arrow (second) +import Data.List (intersperse) +import Data.Maybe (catMaybes) +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as X +import qualified Penny.Lincoln.Bits as B +import qualified Penny.Lincoln.Ents as E +import Penny.Lincoln.Serial (forward, backward) +import Penny.Lincoln.HasText (HasText, text, HasTextList, textList) +import qualified Penny.Lincoln.Queries.Siblings as Q +import Penny.Lincoln.Ents (Posting) +import qualified Text.Matchers as M +import qualified Data.Prednote.Pdct as P + +type LPdct = P.Pdct Posting + +type MakePdct = M.Matcher -> LPdct + +-- * Matching helpers +match + :: HasText a + => Text + -- ^ Description of this field + -> (Posting -> [a]) + -- ^ Function that returns the field being matched + -> M.Matcher + -> LPdct +match t f m = P.operand desc pd + where + desc = makeDesc t m + pd = any (M.match m) . map text . f + +matchMaybe + :: HasText a + => Text + -- ^ Description of this field + -> (Posting -> [Maybe a]) + -> M.Matcher + -> LPdct +matchMaybe t f m = P.operand desc pd + where + desc = makeDesc t m + pd = any (== (Just True)) + . map (fmap (M.match m . text)) + . f + +makeDesc :: Text -> M.Matcher -> Text +makeDesc t m + = "subject: " <> t <> " (any sibling posting) matcher: " + <> M.matchDesc m + +-- | Does the given matcher match any of the elements of the Texts in +-- a HasTextList? +matchAny + :: HasTextList a + => Text + -> (Posting -> [a]) + -> M.Matcher + -> LPdct +matchAny t f m = P.operand desc pd + where + desc = makeDesc t m + pd = any (any (M.match m)) . map textList . f + +-- | Does the given matcher match the text that is at the given +-- element of a HasTextList? If the HasTextList does not have a +-- sufficent number of elements to perform this test, returns False. +matchLevel + :: HasTextList a + => Int + -> Text + -> (Posting -> [a]) + -> M.Matcher + -> LPdct +matchLevel l d f m = P.operand desc pd + where + desc = makeDesc ("level " <> X.pack (show l) <> " of " <> d) m + pd pf = let doMatch list = if l < 0 || l >= length list + then False + else M.match m (list !! l) + in any doMatch . map textList . f $ pf + +-- | Does the matcher match the text of the memo? Joins each line of +-- the memo with a space. +matchMemo + :: Text + -> (Posting -> [Maybe B.Memo]) + -> M.Matcher + -> LPdct +matchMemo t f m = P.operand desc pd + where + desc = makeDesc t m + pd = any (maybe False doMatch) . f + doMatch = M.match m + . X.intercalate (X.singleton ' ') + . B.unMemo + +matchDelimited + :: HasTextList a + => Text + -- ^ Separator + -> Text + -- ^ Label + -> (Posting -> [a]) + -> M.Matcher + -> LPdct +matchDelimited sep lbl f m = match lbl f' m + where + f' = map (X.concat . intersperse sep . textList) . f + +-- * Pattern matching fields + +payee :: MakePdct +payee = matchMaybe "payee" Q.payee + +number :: MakePdct +number = matchMaybe "number" Q.number + +flag :: MakePdct +flag = matchMaybe "flag" Q.flag + +postingMemo :: MakePdct +postingMemo = matchMemo "posting memo" Q.postingMemo + +-- | A Pdct that returns True if @compare subject qty@ returns the +-- given Ordering. +qty :: Ordering -> B.Qty -> LPdct +qty o q = P.operand desc pd + where + desc = "quantity of any sibling is " <> dd <> " " <> X.pack (show q) + dd = case o of + LT -> "less than" + GT -> "greater than" + EQ -> "equal to" + pd = any ((== o) . (`compare` q)) . Q.qty + +parseQty + :: X.Text + -> Maybe (B.Qty -> LPdct) +parseQty x + | x == "==" = Just (qty EQ) + | x == "=" = Just (qty EQ) + | x == ">" = Just (qty GT) + | x == "<" = Just (qty LT) + | x == "/=" = Just (\q -> P.not (qty EQ q)) + | x == "!=" = Just (\q -> P.not (qty EQ q)) + | x == ">=" = Just (\q -> P.or [qty GT q, qty EQ q]) + | x == "<=" = Just (\q -> P.or [qty LT q, qty EQ q]) + | otherwise = Nothing + +drCr :: B.DrCr -> LPdct +drCr dc = P.operand desc pd + where + desc = "entry of any sibling is a " <> s + s = case dc of { B.Debit -> "debit"; B.Credit -> "credit" } + pd = any (== dc) . Q.drCr + +debit :: LPdct +debit = drCr B.Debit + +credit :: LPdct +credit = drCr B.Credit + +commodity :: M.Matcher -> LPdct +commodity = match "commodity" Q.commodity + +account :: M.Matcher -> LPdct +account = matchDelimited ":" "account" Q.account + +accountLevel :: Int -> M.Matcher -> LPdct +accountLevel i = matchLevel i "account" Q.account + +accountAny :: M.Matcher -> LPdct +accountAny = matchAny "any sub-account" Q.account + +tag :: M.Matcher -> LPdct +tag = matchAny "any tag" Q.tags + +-- | True if a posting is reconciled; that is, its flag is exactly +-- @R@. +reconciled :: LPdct +reconciled = P.operand d p + where + d = "posting flag is exactly \"R\" (is reconciled)" + p = any (maybe False ((== X.singleton 'R') . B.unFlag)) + . Q.flag + +-- +-- Serials +-- + +-- | Makes Pdct based on comparisons against a particular serial. + +serialPdct + :: Text + -- ^ Name of the serial, e.g. @globalPosting@ + + -> ((B.TopLineData, E.Ent B.PostingData) -> Maybe Int) + -- ^ How to obtain the serial from the item being examined + + -> Int + -- ^ The right hand side + + -> Ordering + -- ^ The Pdct returned will be Just True if the item has a serial + -- and @compare ser rhs@ returns this Ordering; Just False if the + -- item has a srerial and @compare@ does not return this Ordering; + -- Nothing if the item does not have a serial. + + -> P.Pdct E.Posting + +serialPdct name getSer i o = P.Pdct n (P.Operand f) + where + n = "serial " <> name <> " is " <> descCmp <> " " + <> X.pack (show i) + descCmp = case o of + EQ -> "equal to" + LT -> "less than" + GT -> "greater than" + f = Just + . any (\ser -> compare ser i == o ) + . catMaybes + . map getSer + . E.unrollSnd + . second (\(x, xs) -> (x:xs)) + . second E.tailEnts + . E.unPosting + +type MakeSerialPdct = Int -> Ordering -> P.Pdct Posting + +fwdGlobalPosting :: MakeSerialPdct +fwdGlobalPosting = + serialPdct "fwdGlobalPosting" + $ fmap (forward . B.unGlobalPosting) + . B.pdGlobal + . E.meta + . snd + +backGlobalPosting :: MakeSerialPdct +backGlobalPosting = + serialPdct "revGlobalPosting" + $ fmap (backward . B.unGlobalPosting) + . B.pdGlobal + . E.meta + . snd + +fwdFilePosting :: MakeSerialPdct +fwdFilePosting + = serialPdct "fwdFilePosting" + $ fmap (forward . B.unFilePosting . B.pFilePosting) + . B.pdFileMeta + . E.meta + . snd + +backFilePosting :: MakeSerialPdct +backFilePosting + = serialPdct "revFilePosting" + $ fmap (backward . B.unFilePosting . B.pFilePosting) + . B.pdFileMeta + . E.meta + . snd + +fwdGlobalTransaction :: MakeSerialPdct +fwdGlobalTransaction + = serialPdct "fwdGlobalTransaction" + $ fmap (forward . B.unGlobalTransaction) + . B.tlGlobal + . fst + +backGlobalTransaction :: MakeSerialPdct +backGlobalTransaction + = serialPdct "backGlobalTransaction" + $ fmap (backward . B.unGlobalTransaction) + . B.tlGlobal + . fst + +fwdFileTransaction :: MakeSerialPdct +fwdFileTransaction + = serialPdct "fwdFileTransaction" + $ fmap (forward . B.unFileTransaction . B.tFileTransaction) + . B.tlFileMeta + . fst + +backFileTransaction :: MakeSerialPdct +backFileTransaction + = serialPdct "backFileTransaction" + $ fmap (backward . B.unFileTransaction . B.tFileTransaction) + . B.tlFileMeta + . fst diff --git a/lib/Penny/Lincoln/PriceDb.hs b/lib/Penny/Lincoln/PriceDb.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Lincoln/PriceDb.hs @@ -0,0 +1,98 @@ +-- | A database of price information. A PricePoint has a DateTime, a +-- From commodity, a To commodity, and a QtyPerUnit. The PriceDb holds +-- this information for several prices. You can query the database by +-- supplying a from commodity, a to commodity, and a DateTime, and the +-- database will give you the QtyPerUnit, if there is one. +module Penny.Lincoln.PriceDb ( + PriceDb, + emptyDb, + addPrice, + getPrice, + PriceDbError(FromNotFound, ToNotFound, CpuNotFound), + convertAsOf + ) where + +import qualified Control.Monad.Exception.Synchronous as Ex +import qualified Data.Map as M +import qualified Data.Time as T +import qualified Penny.Lincoln.Bits as B + +type CpuMap = M.Map T.UTCTime B.CountPerUnit +type ToMap = M.Map B.To CpuMap + +-- | The PriceDb holds information about prices. Create an empty one +-- using 'emptyDb' then fill it with values using foldl or similar. +newtype PriceDb = PriceDb (M.Map B.From ToMap) + +-- | An empty PriceDb +emptyDb :: PriceDb +emptyDb = PriceDb M.empty + +-- | Add a single price to the PriceDb. +addPrice :: PriceDb -> B.PricePoint -> PriceDb +addPrice (PriceDb db) (B.PricePoint dt pr _ _ _) = PriceDb m' + where + m' = M.alter f (B.from pr) db + utc = B.toUTC dt + cpu = B.countPerUnit pr + f k = case k of + Nothing -> Just $ M.singleton (B.to pr) cpuMap + where + cpuMap = M.singleton utc cpu + Just tm -> Just tm' + where + tm' = M.alter g (B.to pr) tm + g maybeTo = case maybeTo of + Nothing -> Just $ M.singleton utc cpu + Just cpuMap -> Just $ M.insert utc cpu cpuMap + + + +-- | Getting prices can fail; if it fails, an Error is returned. +data PriceDbError = FromNotFound | ToNotFound | CpuNotFound + +-- | Looks up values from the PriceDb. Throws "Error" if something +-- fails. +-- +-- The DateTime is the time at which to find a price. If a price +-- exists for that exact DateTime, that price is returned. If no price +-- exists for that exact DateTime, but there is a price for an earlier +-- DateTime, the latest possible price is returned. If there are no +-- earlier prices, CpuNotFound is thrown. + +getPrice :: + PriceDb + -> B.From + -> B.To + -> B.DateTime + -> Ex.Exceptional PriceDbError B.CountPerUnit +getPrice (PriceDb db) fr to dt = do + let utc = B.toUTC dt + toMap <- Ex.fromMaybe FromNotFound $ M.lookup fr db + cpuMap <- Ex.fromMaybe ToNotFound $ M.lookup to toMap + let (lower, exact, _) = M.splitLookup utc cpuMap + case exact of + Just c -> return c + Nothing -> + if M.null lower + then Ex.throw CpuNotFound + else return . snd . M.findMax $ lower + + +-- | Given an Amount and a Commodity to convert the amount to, +-- converts the Amount to the given commodity. If the Amount given is +-- already in the To commodity, simply returns what was passed in. Can +-- fail and throw PriceDbError. Internally uses 'getPrice', so read its +-- documentation for details on how price lookup works. +convertAsOf :: + PriceDb + -> B.DateTime + -> B.To + -> B.Amount + -> Ex.Exceptional PriceDbError B.Qty +convertAsOf db dt to (B.Amount qt fr) + | fr == B.unTo to = return qt + | otherwise = do + cpu <- fmap B.unCountPerUnit (getPrice db (B.From fr) to dt) + let qt' = B.mult cpu qt + return qt' diff --git a/lib/Penny/Lincoln/Queries.hs b/lib/Penny/Lincoln/Queries.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Lincoln/Queries.hs @@ -0,0 +1,104 @@ +-- | Examining a Posting for a particular component of the main +-- posting (as opposed to the sibling postings) in the Posting. For +-- some components, such as the payee, the posting might have one +-- piece of data while the TopLine has something else. These functions +-- will examine the Posting first and, if it has no information, use +-- the data from the TopLine if it is there. +module Penny.Lincoln.Queries where + +import qualified Penny.Lincoln.Bits as B +import qualified Penny.Lincoln.Ents as E +import Penny.Lincoln.Balance (Balance, entryToBalance) +import qualified Data.Time as Time + +-- | Uses the data from the Posting if it is set; otherwise, use the +-- data from the TopLine. +best + :: (B.TopLineData -> Maybe a) + -> (E.Ents B.PostingData -> Maybe a) + -> E.Posting + -> Maybe a +best fp ft vp = case fp . fst . E.unPosting $ vp of + Nothing -> ft . snd . E.unPosting $ vp + Just r -> Just r + +payee :: E.Posting -> Maybe B.Payee +payee = best (B.tPayee . B.tlCore) + (B.pPayee . B.pdCore . E.meta . E.headEnt) + +number :: E.Posting -> Maybe B.Number +number = best (B.tNumber . B.tlCore) + (B.pNumber . B.pdCore . E.meta . E.headEnt) + +flag :: E.Posting -> Maybe B.Flag +flag = best (B.tFlag . B.tlCore) + (B.pFlag . B.pdCore . E.meta . E.headEnt) + +postingMemo :: E.Posting -> Maybe B.Memo +postingMemo = B.pMemo . B.pdCore . E.meta . E.headEnt . snd . E.unPosting + +transactionMemo :: E.Posting -> Maybe B.Memo +transactionMemo = B.tMemo . B.tlCore . fst . E.unPosting + +dateTime :: E.Posting -> B.DateTime +dateTime = B.tDateTime . B.tlCore . fst . E.unPosting + +localDay :: E.Posting -> Time.Day +localDay = B.day . dateTime + +account :: E.Posting -> B.Account +account = B.pAccount . B.pdCore . E.meta . E.headEnt . snd . E.unPosting + +tags :: E.Posting -> B.Tags +tags = B.pTags . B.pdCore . E.meta . E.headEnt . snd . E.unPosting + +entry :: E.Posting -> B.Entry +entry = E.entry . E.headEnt . snd . E.unPosting + +balance :: E.Posting -> Balance +balance = entryToBalance . entry + +drCr :: E.Posting -> B.DrCr +drCr = B.drCr . entry + +amount :: E.Posting -> B.Amount +amount = B.amount . entry + +qty :: E.Posting -> B.Qty +qty = B.qty . amount + +commodity :: E.Posting -> B.Commodity +commodity = B.commodity . amount + +topMemoLine :: E.Posting -> Maybe B.TopMemoLine +topMemoLine p = (B.tlFileMeta . fst . E.unPosting $ p) >>= B.tTopMemoLine + +topLineLine :: E.Posting -> Maybe B.TopLineLine +topLineLine = fmap B.tTopLineLine . B.tlFileMeta . fst . E.unPosting + +globalTransaction :: E.Posting -> Maybe B.GlobalTransaction +globalTransaction = B.tlGlobal . fst . E.unPosting + +fileTransaction :: E.Posting -> Maybe B.FileTransaction +fileTransaction = fmap B.tFileTransaction . B.tlFileMeta . fst . E.unPosting + +globalPosting :: E.Posting -> Maybe B.GlobalPosting +globalPosting = B.pdGlobal . E.meta . E.headEnt . snd . E.unPosting + +filePosting :: E.Posting -> Maybe B.FilePosting +filePosting = fmap B.pFilePosting . B.pdFileMeta . E.meta + . E.headEnt . snd . E.unPosting + +postingLine :: E.Posting -> Maybe B.PostingLine +postingLine = fmap B.pPostingLine . B.pdFileMeta + . E.meta . E.headEnt . snd . E.unPosting + +side :: E.Posting -> Maybe B.Side +side = B.pSide . B.pdCore . E.meta . E.headEnt . snd . E.unPosting + +spaceBetween :: E.Posting -> Maybe B.SpaceBetween +spaceBetween = B.pSpaceBetween . B.pdCore + . E.meta . E.headEnt . snd . E.unPosting + +filename :: E.Posting -> Maybe B.Filename +filename = fmap B.tFilename . B.tlFileMeta . fst . E.unPosting diff --git a/lib/Penny/Lincoln/Queries/Siblings.hs b/lib/Penny/Lincoln/Queries/Siblings.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Lincoln/Queries/Siblings.hs @@ -0,0 +1,102 @@ +-- | Like 'Penny.Lincoln.Queries' but instead of querying the main +-- posting of the PostFam, queries the siblings. Therefore, these +-- functions return a list, with each entry in the list containing the +-- best answer for each sibling. There is one item in the list for +-- each sibling, even if all these items contain the same data (for +-- instance, a posting might have five siblings, but all five siblings +-- might have the same payee. Nonetheless the 'payee' function will +-- return a list of five items.) +module Penny.Lincoln.Queries.Siblings where + +import Control.Arrow (second, first) +import qualified Penny.Lincoln.Bits as B +import qualified Penny.Lincoln.Ents as E +import Penny.Lincoln.Balance (Balance, entryToBalance) + +-- | For all siblings, uses information from the Posting if it is set; +-- otherwise, uses data from the TopLine. +bestSibs + :: (B.PostingCore -> Maybe a) + -> (B.TopLineCore -> Maybe a) + -> E.Posting + -> [Maybe a] +bestSibs fp ft = + map f + . map (second (B.pdCore . E.meta)) + . E.unrollSnd + . second (\(x, xs) -> (x:xs)) + . second E.tailEnts + . first B.tlCore + . E.unPosting + where + f (tl, vw) = maybe (ft tl) Just (fp vw) + + +-- | For all siblings, get the information from the Posting if it +-- exists; otherwise Nothing. +sibs + :: (E.Ent B.PostingData -> a) + -> E.Posting + -> [a] +sibs fp = map fp . snd . fmap ((\(x, xs) -> (x:xs)) . E.tailEnts) + . E.unPosting + +payee :: E.Posting -> [Maybe B.Payee] +payee = bestSibs B.pPayee B.tPayee + +number :: E.Posting -> [Maybe B.Number] +number = bestSibs B.pNumber B.tNumber + +flag :: E.Posting -> [Maybe B.Flag] +flag = bestSibs B.pFlag B.tFlag + +postingMemo :: E.Posting -> [Maybe B.Memo] +postingMemo = sibs (B.pMemo . B.pdCore . E.meta) + +account :: E.Posting -> [B.Account] +account = sibs (B.pAccount . B.pdCore . E.meta) + +tags :: E.Posting -> [B.Tags] +tags = sibs (B.pTags . B.pdCore . E.meta) + +entry :: E.Posting -> [B.Entry] +entry = sibs E.entry + +balance :: E.Posting -> [Balance] +balance = map entryToBalance . entry + +drCr :: E.Posting -> [B.DrCr] +drCr = map B.drCr . entry + +amount :: E.Posting -> [B.Amount] +amount = map B.amount . entry + +qty :: E.Posting -> [B.Qty] +qty = map B.qty . amount + +commodity :: E.Posting -> [B.Commodity] +commodity = map B.commodity . amount + +postingLine :: E.Posting -> [Maybe B.PostingLine] +postingLine = sibs (fmap B.pPostingLine . B.pdFileMeta . E.meta) + +side :: E.Posting -> [Maybe B.Side] +side = sibs (B.pSide . B.pdCore . E.meta) + +spaceBetween :: E.Posting -> [Maybe B.SpaceBetween] +spaceBetween = sibs (B.pSpaceBetween . B.pdCore . E.meta) + +globalPosting :: E.Posting -> [Maybe B.GlobalPosting] +globalPosting = sibs (B.pdGlobal . E.meta) + +filePosting :: E.Posting -> [Maybe B.FilePosting] +filePosting = sibs (fmap B.pFilePosting . B.pdFileMeta . E.meta) + +globalTransaction :: E.Posting -> [Maybe B.GlobalTransaction] +globalTransaction = + map B.tlGlobal + . map fst + . E.unrollSnd + . second (\(x, xs) -> (x:xs)) + . second E.tailEnts + . E.unPosting diff --git a/lib/Penny/Lincoln/Serial.hs b/lib/Penny/Lincoln/Serial.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Lincoln/Serial.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Penny.Lincoln.Serial ( + Serial, forward, backward, serialItems, serialSomeItems, + serialNestedItems) where + +import Control.Applicative (Applicative, (<*>), pure, (*>)) +import Control.Monad (ap, liftM, replicateM_) +import Data.Traversable (Traversable) +import qualified Data.Traversable as Tr +import qualified Data.Foldable as Fdbl +import GHC.Generics (Generic) +import Data.Binary (Binary) + +data SerialSt = SerialSt + { nextFwd :: Int + , nextBack :: Int + } deriving Show + + +data Serial = Serial + { forward :: Int + , backward :: Int + } deriving (Eq, Show, Ord, Generic) + +instance Binary Serial + +newtype GenSerial a = GenSerial (SerialSt -> (a, SerialSt)) + +instance Functor GenSerial where + fmap = liftM + +instance Applicative GenSerial where + pure = return + (<*>) = ap + +instance Monad GenSerial where + return a = GenSerial $ \s -> (a, s) + (GenSerial k) >>= f = GenSerial $ \s -> + let (a, s') = k s + GenSerial g = f a + in g s' + +incrementBack :: GenSerial () +incrementBack = GenSerial $ \s -> + let s' = SerialSt (nextFwd s) (nextBack s + 1) + in ((), s') + +getSerial :: GenSerial Serial +getSerial = GenSerial $ \s -> + let s' = SerialSt (nextFwd s + 1) (nextBack s - 1) + in (Serial (nextFwd s) (nextBack s), s') + +makeSerials :: GenSerial a -> a +makeSerials (GenSerial k) = + let (r, _) = k (SerialSt 0 0) in r + +serialItems :: (Serial -> a -> b) -> [a] -> [b] +serialItems f as = zipWith f (nSerials (length as)) as + +nSerials :: Int -> [Serial] +nSerials n = + makeSerials $ + (sequence . replicate n $ incrementBack) + *> (sequence . replicate n $ getSerial) + +serialSomeItems + :: (a -> Either b (Serial -> b)) + -> [a] + -> [b] +serialSomeItems f as = makeSerials k + where + k = do + let doIncr i = case f i of + Left _ -> return () + Right _ -> incrementBack + mapM_ doIncr as + let addSer i = case f i of + Left b -> return b + Right add -> getSerial >>= return . add + mapM addSer as + +-- | Adds serials to items that are nested within other items. +serialNestedItems + :: Traversable f + => (a -> Either b ((f c), (Serial -> c -> d), (f d -> b))) + -- ^ When applied to each item, this function returns Left if the + -- item does not need a serial, or Right if it has items that need + -- serials. In the Right is the container with items that need + -- serials, the function that applies serials to each item, and a + -- function to re-wrap the container with the serialed items. + + -> [a] + -> [b] +serialNestedItems getEi as = makeSerials k + where + k = do + serialNestedIncrBack getEi as + mapM (serialNestedAddSerials getEi) as + +-- | Increments the back serial by the needed number of items. +serialNestedIncrBack + :: Fdbl.Foldable f + => (a -> Either b (f c, x, y)) + -> [a] + -> GenSerial () +serialNestedIncrBack f = mapM_ doIncr where + doIncr i = case f i of + Left _ -> return () + Right (ctnr, _, _) -> + let len = length . Fdbl.toList $ ctnr + in replicateM_ len incrementBack + +-- | Assigns serials to nested items. +serialNestedAddSerials + :: Tr.Traversable f + => (a -> Either b (f c, (Serial -> c -> d), f d -> b)) + -> a + -> GenSerial b +serialNestedAddSerials f a = case f a of + Left b -> return b + Right (ctnr, addSer, rewrap) -> do + let adder i = do + s <- getSerial + return $ addSer s i + fmap rewrap $ Tr.mapM adder ctnr diff --git a/lib/Penny/Shield.hs b/lib/Penny/Shield.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Shield.hs @@ -0,0 +1,106 @@ +-- | Shield - the Penny runtime environment +-- +-- Both Cabin and Copper can benefit from knowing information about +-- the Penny runtime environment, such as environment variables and +-- whether standard output is a terminal. That information is provided +-- by the Runtime type. In the future this module may also provide +-- information about the POSIX locale configuration. For now, that +-- information would require reaching into the FFI and so it is not +-- implemented. + +module Penny.Shield ( + ScreenLines, + unScreenLines, + ScreenWidth, + unScreenWidth, + Output(IsTTY, NotTTY), + Runtime, + environment, + currentTime, + output, + screenLines, + screenWidth, + Term, + term, + runtime, + termFromEnv, + autoTerm) + where + +import Control.Applicative ((<$>), (<*>)) +import qualified Data.Time as T +import System.Environment (getEnvironment) +import System.IO (hIsTerminalDevice, stdout) +import qualified System.Console.Rainbow as C + +import qualified Penny.Lincoln.Bits as B + +data ScreenLines = ScreenLines { unScreenLines :: Int } + deriving Show + +newtype ScreenWidth = ScreenWidth { unScreenWidth :: Int } + deriving Show + +data Output = IsTTY | NotTTY deriving (Eq, Ord, Show) + +newtype Term = Term { unTerm :: String } deriving Show + +-- | Information about the runtime environment. +data Runtime = Runtime { environment :: [(String, String)] + , currentTime :: B.DateTime + , output :: Output } + +runtime :: IO Runtime +runtime = Runtime + <$> getEnvironment + <*> (toDT <$> T.getZonedTime) + <*> findOutput + where + toDT t = case B.fromZonedTime t of + Nothing -> error "time conversion error" + Just ti -> ti + +findOutput :: IO Output +findOutput = do + isTerm <- hIsTerminalDevice stdout + return $ if isTerm then IsTTY else NotTTY + +screenLines :: Runtime -> Maybe ScreenLines +screenLines r = + (lookup "LINES" . environment $ r) + >>= safeRead + >>= return . ScreenLines + +screenWidth :: Runtime -> Maybe ScreenWidth +screenWidth r = + (lookup "COLUMNS" . environment $ r) + >>= safeRead + >>= return . ScreenWidth + +term :: Runtime -> Maybe Term +term r = + (lookup "TERM" . environment $ r) + >>= return . Term + +-- | Read, but without crashes. +safeRead :: (Read a) => String -> Maybe a +safeRead s = case reads s of + (a, []):[] -> Just a + _ -> Nothing + +-- | Determines which Chunk Term to use based on the TERM environment +-- variable, regardless of whether standard output is a terminal. Uses +-- Dumb if TERM is not set. +termFromEnv :: Runtime -> C.Term +termFromEnv rt = case term rt of + Just t -> C.TermName . unTerm $ t + Nothing -> C.Dumb + +-- | Determines which Chunk Term to use based on whether standard +-- output is a terminal. Uses Dumb if standard output is not a +-- terminal; otherwise, uses the TERM environment variable. +autoTerm :: Runtime -> C.Term +autoTerm rt = case output rt of + IsTTY -> termFromEnv rt + NotTTY -> C.Dumb + diff --git a/lib/Penny/Steel.hs b/lib/Penny/Steel.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Steel.hs @@ -0,0 +1,3 @@ +-- | Steel - independent Penny utilities + +module Penny.Steel where diff --git a/lib/Penny/Steel/NestedMap.hs b/lib/Penny/Steel/NestedMap.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Steel/NestedMap.hs @@ -0,0 +1,275 @@ +-- | A nested map. The values in each NestedMap are tuples, with the +-- first element of the tuple being a label that you select and the +-- second value being another NestedMap. Functions are provided so you +-- may query the map at any level or insert new labels (and, +-- therefore, new keys) at any level. +module Penny.Steel.NestedMap ( + NestedMap ( NestedMap, unNestedMap ), + empty, + relabel, + descend, + insert, + cumulativeTotal, + traverse, + traverseWithTrail, + toForest ) where + +import Control.Applicative ((<*>), (<$>)) +import Data.Map ( Map ) +import qualified Data.Foldable as F +import qualified Data.Traversable as T +import qualified Data.Tree as E +import qualified Data.Map as M +import Data.Monoid ( Monoid, mconcat, mappend, mempty ) + +newtype NestedMap k l = + NestedMap { unNestedMap :: Map k (l, NestedMap k l) } + deriving (Eq, Show, Ord) + +instance Functor (NestedMap k) where + fmap f (NestedMap m) = let + g (l, s) = (f l, fmap f s) + in NestedMap $ M.map g m + +instance (Ord k) => F.Foldable (NestedMap k) where + foldMap = T.foldMapDefault + +instance (Ord k) => T.Traversable (NestedMap k) where + -- traverse :: Applicative f + -- => (a -> f b) + -- -> NestedMap k a + -- -> f (NestedMap k b) + traverse f (NestedMap m) = let + f' (l, m') = (,) <$> f l <*> T.traverse f m' + in NestedMap <$> T.traverse f' m + +-- | An empty NestedMap. +empty :: NestedMap k l +empty = NestedMap (M.empty) + +-- | Helper function for relabel. For a given key and function +-- that modifies the label, return the new submap to insert into the +-- given map. Does not actually insert the submap though. That way, +-- relabel can then modify the returned submap before +-- inserting it into the mother map with the given label. +newSubmap :: + (Ord k) + => NestedMap k l + -> k + -> (Maybe l -> l) + -> (l, NestedMap k l) +newSubmap (NestedMap m) k g = (newL, NestedMap newM) where + (newL, newM) = case M.lookup k m of + Nothing -> (g Nothing, M.empty) + (Just (oldL, (NestedMap oldM))) -> (g (Just oldL), oldM) + +-- | Descends through a NestedMap with successive keys in the list, +-- proceeding from left to right. At any given level, if the key +-- given does not already exist, then inserts an empty submap and +-- applies the given label modification function to Nothing to +-- determine the new label. If the given key already does exist, then +-- preserves the existing submap and applies the given label +-- modification function to (Just oldlabel) to determine the new +-- label. +relabel :: + (Ord k) + => NestedMap k l + -> [(k, (Maybe l -> l))] + -> NestedMap k l +relabel m [] = m +relabel (NestedMap m) ((k, f):vs) = let + (newL, newM) = newSubmap (NestedMap m) k f + newM' = relabel newM vs + in NestedMap $ M.insert k (newL, newM') m + +-- | Given a list of keys, find the key that is furthest down in the +-- map that matches the requested list of keys. Returns [(k, l)], +-- where the first item in the list is the topmost key found and its +-- matching label, and the last item in the list is the deepest key +-- found and its matching label. (Often you will be most interested +-- in the deepest key.) +descend :: + Ord k + => [k] + -> NestedMap k l + -> [(k, l)] +descend keys (NestedMap mi) = descend' keys mi where + descend' [] _ = [] + descend' (k:ks) m = case M.lookup k m of + Nothing -> [] + Just (l, (NestedMap im)) -> (k, l) : descend' ks im + + +-- | Descends through the NestedMap one level at a time, proceeding +-- key by key from left to right through the list of keys given. At +-- the last key, appends the given label to the labels already +-- present; if no label is present, uses mempty and mappend to create +-- a new label. If the list of keys is empty, does nothing. +insert :: + (Ord k, Monoid l) + => NestedMap k l + -> [k] + -> l + -> NestedMap k l +insert m [] _ = m +insert m ks l = relabel m ts where + ts = firsts ++ [end] + firsts = map (\k -> (k, keepOld)) (init ks) where + keepOld mk = case mk of + (Just old) -> old + Nothing -> mempty + end = (key, newL) where + key = last ks + newL mk = case mk of + (Just old) -> old `mappend` l + Nothing -> mempty `mappend` l + +totalMap :: + (Monoid l) + => NestedMap k l + -> l +totalMap (NestedMap m) = + if M.null m + then mempty + else mconcat . map totalTuple . M.elems $ m + +totalTuple :: + (Monoid l) + => (l, NestedMap k l) + -> l +totalTuple (l, (NestedMap top)) = + if M.null top + then l + else mappend l (totalMap (NestedMap top)) + +remapWithTotals :: + (Monoid l) + => NestedMap k l + -> NestedMap k l +remapWithTotals (NestedMap top) = + if M.null top + then NestedMap M.empty + else NestedMap $ M.map f top where + f a@(_, m) = (totalTuple a, remapWithTotals m) + +-- | Leaves all keys of the map and submaps the same. Changes each +-- label to reflect the total of that label and of all the labels of +-- the maps within the NestedMap accompanying the label. Returns the +-- total of the entire NestedMap. +cumulativeTotal :: + (Monoid l) + => NestedMap k l + -> (l, NestedMap k l) +cumulativeTotal m = (totalMap m, remapWithTotals m) + +-- | Supply a function that takes a key, a label, and a +-- NestedMap. traverse will traverse the NestedMap. For each (label, +-- NestedMap) pair, traverse will first apply the given function to +-- the label before descending through the NestedMap. The function is +-- applied to the present key and label and the accompanying +-- NestedMap. The function you supply must return a Maybe. If the +-- result is Nothing, then the pair is deleted as a value from its +-- parent NestedMap. If the result is (Just s), then the label of this +-- level of the NestedMap is changed to s before descending to the +-- next level of the NestedMap. +-- +-- All this is done in a monad, so you can carry out arbitrary side +-- effects such as inspecting or changing a state or doing IO. If you +-- don't need a monad, just use Identity. +-- +-- Thus this function can be used to inspect, modify, and prune a +-- NestedMap. +-- +-- For a simpler traverse that does not provide you with so much +-- information, NestedMap is also an instance of Data.Traversable. +traverse :: + (Monad m, Ord k) + => (k -> l -> NestedMap k l -> m (Maybe a)) + -> NestedMap k l + -> m (NestedMap k a) +traverse f m = traverseWithTrail (\_ -> f) m + +-- | Like traverse, but the supplied function is also applied to a +-- list that tells it about the levels of NestedMap that are parents +-- to this NestedMap. +traverseWithTrail :: + (Monad m, Ord k) + => ( [(k, l)] -> k -> l -> NestedMap k l -> m (Maybe a) ) + -> NestedMap k l + -> m (NestedMap k a) +traverseWithTrail f = traverseWithTrail' f [] + +traverseWithTrail' :: + (Monad m, Ord k) + => ([(k, l)] -> k -> l -> NestedMap k l -> m (Maybe a)) + -> [(k, l)] + -> NestedMap k l + -> m (NestedMap k a) +traverseWithTrail' f ts (NestedMap m) = + if M.null m + then return $ NestedMap M.empty + else do + let ps = M.assocs m + mlsMaybes <- mapM (traversePairWithTrail f ts) ps + let ps' = zip (M.keys m) mlsMaybes + folder (k, ma) rs = case ma of + (Just r) -> (k, r):rs + Nothing -> rs + ps'' = foldr folder [] ps' + return (NestedMap (M.fromList ps'')) + +traversePairWithTrail :: + (Monad m, Ord k) + => ( [(k, l)] -> k -> l -> NestedMap k l -> m (Maybe a) ) + -> [(k, l)] + -> (k, (l, NestedMap k l)) + -> m (Maybe (a, NestedMap k a)) +traversePairWithTrail f ls (k, (l, m)) = do + ma <- f ls k l m + case ma of + Nothing -> return Nothing + (Just a) -> do + m' <- traverseWithTrail' f ((k, l):ls) m + return (Just (a, m')) + +-- | Convert a NestedMap to a Forest. +toForest :: Ord k => NestedMap k l -> E.Forest (k, l) +toForest = map toNode . M.assocs . unNestedMap + where + toNode (k, (l, m)) = E.Node (k, l) (toForest m) + +-- For testing +_new :: (k, l) -> (k, (Maybe l -> l)) +_new (k, l) = (k, const l) + +_map1, _map2, _map3, _map4 :: NestedMap Int String +_map1 = NestedMap M.empty +_map2 = relabel _map1 [_new (5, "hello"), _new (66, "goodbye"), _new (777, "yeah")] +_map3 = relabel _map2 [_new (6, "what"), _new (77, "zeke"), _new (888, "foo")] +_map4 = relabel _map3 + [ (6, (\m -> case m of Nothing -> "_new"; (Just s) -> s ++ "_new")) + , (77, (\m -> case m of Nothing -> "_new"; (Just s) -> s ++ "more _new")) ] + +_printer :: Int -> String -> a -> IO (Maybe ()) +_printer i s _ = do + putStrLn (show i) + putStrLn s + return $ Just () + +_printerWithTrail :: [(Int, String)] -> Int -> String -> a -> IO (Maybe ()) +_printerWithTrail ps n str _ = do + let ptr (i, s) = putStr ("(" ++ show i ++ ", " ++ s ++ ") ") + mapM_ ptr . reverse $ ps + ptr (n, str) + putStrLn "" + return $ Just () + +_showMap4 :: IO () +_showMap4 = do + _ <- traverse _printer _map4 + return () + +_showMapWithTrail :: IO () +_showMapWithTrail = do + _ <- traverseWithTrail _printerWithTrail _map4 + return () diff --git a/lib/Penny/Steel/Sums.hs b/lib/Penny/Steel/Sums.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Steel/Sums.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE DeriveGeneric #-} + +-- | Anonymous sum types. + +module Penny.Steel.Sums where + +import Data.Binary (Binary) +import GHC.Generics (Generic) + +data S3 a b c + = S3a a + | S3b b + | S3c c + deriving (Eq, Ord, Show, Generic) + +instance (Binary a, Binary b, Binary c) => Binary (S3 a b c) + +data S4 a b c d + = S4a a + | S4b b + | S4c c + | S4d d + deriving (Eq, Ord, Show, Generic) + +instance (Binary a, Binary b, Binary c, Binary d) => Binary (S4 a b c d) + +partitionS3 :: [S3 a b c] -> ([a], [b], [c]) +partitionS3 = foldr f ([], [], []) + where + f i (as, bs, cs) = case i of + S3a a -> (a:as, bs, cs) + S3b b -> (as, b:bs, cs) + S3c c -> (as, bs, c:cs) + +partitionS4 :: [S4 a b c d] -> ([a], [b], [c], [d]) +partitionS4 = foldr f ([], [], [], []) + where + f i (as, bs, cs, ds) = case i of + S4a a -> (a:as, bs, cs, ds) + S4b b -> (as, b:bs, cs, ds) + S4c c -> (as, bs, c:cs, ds) + S4d d -> (as, bs, cs, d:ds) + +caseS3 :: (a -> d) -> (b -> d) -> (c -> d) -> S3 a b c -> d +caseS3 fa fb fc s3 = case s3 of + S3a a -> fa a + S3b b -> fb b + S3c c -> fc c + +caseS4 :: (a -> e) -> (b -> e) -> (c -> e) -> (d -> e) -> S4 a b c d -> e +caseS4 fa fb fc fd s4 = case s4 of + S4a a -> fa a + S4b b -> fb b + S4c c -> fc c + S4d d -> fd d + +mapS3 :: (a -> a1) -> (b -> b1) -> (c -> c1) -> S3 a b c -> S3 a1 b1 c1 +mapS3 fa fb fc = caseS3 (S3a . fa) (S3b . fb) (S3c . fc) + +mapS4 + :: (a -> a1) -> (b -> b1) -> (c -> c1) -> (d -> d1) + -> S4 a b c d + -> S4 a1 b1 c1 d1 +mapS4 a b c d = caseS4 (S4a . a) (S4b . b) (S4c . c) (S4d . d) + +mapS3a + :: Functor f + => (a -> f a1) -> (b -> f b1) -> (c -> f c1) -> S3 a b c -> f (S3 a1 b1 c1) +mapS3a a b c = caseS3 (fmap S3a . a) (fmap S3b . b) (fmap S3c . c) + +mapS4a + :: Functor f + => (a -> f a1) -> (b -> f b1) -> (c -> f c1) -> (d -> f d1) + -> S4 a b c d -> f (S4 a1 b1 c1 d1) + +mapS4a a b c d = caseS4 (fmap S4a . a) (fmap S4b . b) (fmap S4c . c) + (fmap S4d . d) + diff --git a/lib/Penny/Wheat.hs b/lib/Penny/Wheat.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Wheat.hs @@ -0,0 +1,367 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Wheat - Penny ledger tests +-- +-- Wheat helps you build tests to check all the postings in your +-- ledger. Perhaps you want to make sure all the account names are +-- valid, or that your checking account has no unreconciled +-- transactions. With Wheat you can easily build a command line +-- program that will check all the postings in a ledger for you +-- against criteria that you specify. + +module Penny.Wheat + ( -- * Configuration + WheatConf(..) + + -- * Tests + , eachPostingMustBeTrue + , atLeastNPostings + + -- * Convenience functions + , futureFirstsOfTheMonth + + -- * Running tests + , main + ) where + +import Control.Monad (when) +import qualified Control.Monad.Exception.Synchronous as Ex +import Data.Either (partitionEithers) +import Data.Maybe (mapMaybe) +import qualified Penny.Copper as Cop +import qualified Penny.Copper.Parsec as CP +import qualified Penny.Lincoln as L +import qualified Penny.Liberty as Ly +import qualified Data.Text as X +import qualified Data.Time as Time +import qualified Text.Matchers as M +import qualified Text.Parsec as Parsec +import qualified System.Exit as Exit +import qualified System.IO as IO +import qualified Penny.Shield as S +import qualified Penny.Steel.Sums as Su + +import qualified Data.Version as V +import qualified Data.Prednote.TestTree as TT +import qualified Data.Prednote.Pdct as Pe +import qualified System.Console.Rainbow as Rb +import qualified System.Console.MultiArg as MA +import System.Locale (defaultTimeLocale) + +------------------------------------------------------------ +-- Other conveniences +------------------------------------------------------------ + + +-- | A non-terminating list of starting with the first day of the +-- first month following the given day, followed by successive first +-- days of the month. +futureFirstsOfTheMonth :: Time.Day -> [Time.Day] +futureFirstsOfTheMonth d = iterate (Time.addGregorianMonthsClip 1) d1 + where + d1 = Time.fromGregorian yr mo 1 + (yr, mo, _) = Time.toGregorian $ Time.addGregorianMonthsClip 1 d + +------------------------------------------------------------ +-- CLI +------------------------------------------------------------ + +-- | Record holding all data to configure Wheat. +data WheatConf = WheatConf + { briefDescription :: String + -- ^ This is displayed at the beginning of the online help. It + -- should be a one-line description of what this program does--for + -- example, what it checks for. + + , moreHelp :: [String] + -- ^ Displayed at the end of the online help. It should be a list + -- of lines, wich each line not terminated by a newline + -- character. It is displayed at the end of the online help. + + , tests :: [Time.UTCTime -> TT.TestTree L.Posting] + -- ^ The actual tests to run. The UTCTime is the @base time@. Each + -- test may decide what to do with the base time--for example, the + -- test might say that all postings have to have a date on or + -- before that date. Or the test might just ignore the base time. + + , indentAmt :: Pe.IndentAmt + -- ^ How many spaces to indent each level in a tree of tests. + + , passVerbosity :: TT.Verbosity + -- ^ Verbosity for tests that pass + + , failVerbosity :: TT.Verbosity + -- ^ Verbosity for tests that fail + + , groupPred :: TT.Name -> Bool + -- ^ Group names are filtered with this function; a group is only + -- run if this function returns True. + + , testPred :: TT.Name -> Bool + -- ^ Test names are filtered with this function; a test is only + -- run if this function returns True. + + , showSkippedTests :: Bool + -- ^ Some tests might be skipped; see 'testPred'. This controls + -- whether you want to see a notification of tests that were + -- skipped. (Does not affect skipped groups; see 'groupVerbosity' + -- for that.) + + , groupVerbosity :: TT.GroupVerbosity + -- ^ Show group names? Even if you do not show the names of + -- groups, tests within the group will still be indented. + + , stopOnFail :: Bool + -- ^ If True, then tests will stop running immediately after a + -- single test fails. If False, all tests are always run. + + , colorToFile :: Bool + -- ^ Use colors even if stdout is not a file? + + , baseTime :: Time.UTCTime + -- ^ Tests may use this date and time as they wish; see + -- 'tests'. Typically you will set this to the current instant. + + , ledgers :: [String] + -- ^ Ledger files to read in from disk. + } + +data Parsed = Parsed + { p_indentAmt :: Pe.IndentAmt + , p_passVerbosity :: TT.Verbosity + , p_failVerbosity :: TT.Verbosity + , p_groupPred :: TT.Name -> Bool + , p_testPred :: TT.Name -> Bool + , p_showSkippedTests :: Bool + , p_groupVerbosity :: TT.GroupVerbosity + , p_stopOnFail :: Bool + , p_colorToFile :: Bool + , p_baseTime :: Time.UTCTime + , p_help :: Bool + , p_ledgers :: [String] + } + +parseBaseTime :: String -> Ex.Exceptional MA.InputError Time.UTCTime +parseBaseTime s = case Parsec.parse CP.dateTime "" (X.pack s) of + Left e -> Ex.throw (MA.ErrorMsg $ "could not parse date: " ++ show e) + Right g -> return . L.toUTC $ g + +parseRegexp :: String -> Ex.Exceptional MA.InputError (TT.Name -> Bool) +parseRegexp s = case M.pcre M.Sensitive (X.pack s) of + Ex.Exception e -> Ex.throw . MA.ErrorMsg $ + "could not parse regular expression: " ++ X.unpack e + Ex.Success m -> return . M.match $ m + +parseArg :: String -> Parsed -> Parsed +parseArg s p = p { p_ledgers = p_ledgers p ++ [s] } + +allOpts :: [MA.OptSpec (Parsed -> Parsed)] +allOpts = + let allChoices = + [ ("silent", \p -> p { p_failVerbosity = TT.Silent }) + , ("minimal", \p -> p { p_failVerbosity = TT.PassFail }) + , ("false", \p -> p { p_failVerbosity = TT.FalseSubjects }) + , ("true", \p -> p { p_failVerbosity = TT.TrueSubjects }) + , ("all", \p -> p { p_failVerbosity = TT.Discards }) + ] in + [ MA.OptSpec ["indentation"] "i" + (fmap (\i p -> p { p_indentAmt = i }) (MA.OneArgE MA.reader)) + + , MA.OptSpec ["pass-verbosity"] "p" $ MA.ChoiceArg allChoices + + , MA.OptSpec ["fail-verbosity"] "f" $ MA.ChoiceArg allChoices + + , MA.OptSpec ["group-regexp"] "g" + (fmap (\f p -> p { p_groupPred = f }) (MA.OneArgE parseRegexp)) + + , MA.OptSpec ["test-regexp"] "t" + (fmap (\f p -> p { p_testPred = f }) (MA.OneArgE parseRegexp)) + + , MA.OptSpec ["show-skipped-tests"] "" + ( MA.NoArg (\p -> p { p_showSkippedTests + = not (p_showSkippedTests p) })) + + , MA.OptSpec ["group-verbosity"] "G" $ MA.ChoiceArg + [ ("silent", \p -> p { p_groupVerbosity = TT.NoGroups }) + , ("active", \p -> p { p_groupVerbosity = TT.ActiveGroups }) + , ("all", \p -> p { p_groupVerbosity = TT.AllGroups }) + ] + + , MA.OptSpec ["stop-on-failure"] "" + ( MA.NoArg (\p -> p { p_stopOnFail + = not (p_stopOnFail p) })) + + , MA.OptSpec ["color-to-file"] "" + ( MA.NoArg (\p -> p { p_colorToFile + = not (p_colorToFile p) })) + + , MA.OptSpec ["base-date"] "" + (fmap (\d p -> p { p_baseTime = d }) (MA.OneArgE parseBaseTime)) + ] + +getTTOpts :: [a] -> Parsed -> TT.TestOpts a +getTTOpts as o = TT.TestOpts + { TT.tIndentAmt = p_indentAmt o + , TT.tPassVerbosity = p_passVerbosity o + , TT.tFailVerbosity = p_failVerbosity o + , TT.tGroupPred = p_groupPred o + , TT.tTestPred = p_testPred o + , TT.tShowSkippedTests = p_showSkippedTests o + , TT.tGroupVerbosity = p_groupVerbosity o + , TT.tSubjects = as + , TT.tStopOnFail = p_stopOnFail o + } + +-- | Runs Wheat tests. Prints the result to standard output. Exits +-- unsuccessfully if the user gave bad command line options or if at +-- least a single test failed; exits successfully if all tests +-- succeeded. Shows the version number and exits successfully if that +-- was requested. +main + :: V.Version + -- ^ Version of the binary + -> (S.Runtime -> WheatConf) -> IO () +main ver getWc = do + rt <- S.runtime + let wc = getWc rt + parsed <- MA.simpleWithHelp (help wc) MA.Intersperse + (fmap Left (Ly.version ver) : (map (fmap Right) allOpts)) + (return . (fmap Right parseArg)) + let (showVers, fns) = partitionEithers parsed + case showVers of + [] -> return () + x:_ -> x + let fn = foldl (flip (.)) id fns + psd = fn (getParsedFromWheatConf wc) + term <- Rb.smartTermFromEnv (p_colorToFile psd) IO.stdout + pfs <- getItems (p_ledgers psd) + let ttOpts = getTTOpts pfs psd + tts = zipWith ($) (tests wc) (repeat (p_baseTime psd)) + (cks, _, nFail) = TT.runTests ttOpts 0 tts + Rb.printChunks term cks + when (nFail > 0) Exit.exitFailure + +getParsedFromWheatConf :: WheatConf -> Parsed +getParsedFromWheatConf w = Parsed + { p_indentAmt = indentAmt w + , p_passVerbosity = passVerbosity w + , p_failVerbosity = failVerbosity w + , p_groupPred = groupPred w + , p_testPred = testPred w + , p_showSkippedTests = showSkippedTests w + , p_groupVerbosity = groupVerbosity w + , p_stopOnFail = stopOnFail w + , p_colorToFile = colorToFile w + , p_baseTime = baseTime w + , p_help = False + , p_ledgers = ledgers w + } + +getItems :: [String] -> IO [L.Posting] +getItems ss = fmap f $ Cop.open ss + where + f = concatMap L.transactionToPostings + . mapMaybe ( let cn = const Nothing + in Su.caseS4 Just cn cn cn) + +-- +-- Tests +-- + +-- | Passes only if each posting is True. +eachPostingMustBeTrue + :: TT.Name + -> Pe.Pdct L.Posting + -> TT.TestTree L.Posting +eachPostingMustBeTrue n = TT.eachSubjectMustBeTrue n L.display + +-- | Passes if at least a particular number of postings is True. +atLeastNPostings + :: Int + -- ^ The number of postings that must be true for the test to pass + -> TT.Name + -> Pe.Pdct L.Posting + -> TT.TestTree L.Posting +atLeastNPostings i n = TT.nSubjectsMustBeTrue n L.display i + +-- +-- Help +-- + +help + :: WheatConf + -> String + -- ^ Program name + -> String +help wc pn = unlines + [ "usage: " ++ pn ++ " [options] [FILE...]" + , "" + , briefDescription wc + , "" + , "Options:" + , " -i, --indentation AMT" + , " Indent each level by this many spaces" + , " " ++ dflt (show . indentAmt $ wc) + , " -p, --pass-verbosity VERBOSITY" + , " Verbosity for tests that pass. Argument may be:" + , " silent - show nothing at all" + , " minimal - show whether the test passed or failed" + , " false - show subjects that are false" + , " true - show subjects that are true or false" + , " all - show all subjects" + , " " ++ dflt (showVerbosity . passVerbosity $ wc) + , " -f, --fail-verbosity VERBOSITY" + , " Verbosity for tests that fail." + , " (uses same VERBOSITY options as --pass-verbosity)" + , " " ++ dflt (showVerbosity . failVerbosity $ wc) + , " -g, --group-regexp REGEXP" + , " Run only groups whose name matches the given" + , " Perl-compatible regular expression" + , " (overrides the compiled-in default)" + , " -t, --test-regexp REGEXP" + , " Run only tests whose name matches the given" + , " Perl-compatible regular expression" + , " (overrides the compiled-in default)" + , " --show-skipped-tests" + , " Toggle whether to show tests that are skipped" + , " using the --test-regexp option" + , " (does not affect groups that are skipped; see next option)" + , " " ++ dflt (show . showSkippedTests $ wc) + , " --G, group-verbosity ARG" + , " Control which group names are shown. Argument may be:" + , " silent - do not show any group names" + , " active - show group names that were not skipped" + , " all - show all group names, including skipped ones" + , " " ++ dflt (showGroupVerbosity . groupVerbosity $ wc) + , " --stop-on-failure" + , " Stop running tests after a single test fails" + , " " ++ dflt (show . stopOnFail $ wc) + , " --color-to-file" + , " Use color even when standard output is not a terminal" + , " " ++ dflt (show . colorToFile $ wc) + , " --base-date DATE" + , " Use this date as a basis for checks" + , " " ++ dflt ( Time.formatTime defaultTimeLocale "%c" + . baseTime $ wc) + , "" + ] + ++ unlines (moreHelp wc) + +dflt :: String -> String +dflt s = "(default: " ++ s ++ ")" + +showVerbosity :: TT.Verbosity -> String +showVerbosity v = case v of + TT.Silent -> "silent" + TT.PassFail -> "minimal" + TT.FalseSubjects -> "false" + TT.TrueSubjects -> "true" + TT.Discards -> "all" + +showGroupVerbosity :: TT.GroupVerbosity -> String +showGroupVerbosity v = case v of + TT.NoGroups -> "silent" + TT.ActiveGroups -> "active" + TT.AllGroups -> "all" + + diff --git a/lib/Penny/Zinc.hs b/lib/Penny/Zinc.hs new file mode 100644 --- /dev/null +++ b/lib/Penny/Zinc.hs @@ -0,0 +1,746 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Zinc - the Penny command-line interface +module Penny.Zinc + ( Defaults(..) + , ColorToFile(..) + , Matcher(..) + , SortField(..) + , runZinc + ) where + +import qualified Penny.Cabin.Interface as I +import qualified Penny.Cabin.Parsers as P +import qualified Penny.Cabin.Scheme as E +import qualified Penny.Cabin.Scheme.Schemes as Schemes +import qualified Penny.Copper as C +import qualified Penny.Liberty as Ly +import qualified Data.Prednote.Expressions as X +import qualified Data.Prednote.Pdct as Pe +import qualified Penny.Lincoln as L +import qualified Penny.Lincoln.Queries as Q +import qualified Penny.Shield as S +import qualified Penny.Steel.Sums as Su + +import Control.Applicative ((<*>), pure, (<$)) +import Control.Monad (join) +import qualified Control.Monad.Trans.State as St +import qualified Control.Monad.Exception.Synchronous as Ex +import Data.Char (toUpper, toLower) +import Data.Either (partitionEithers) +import Data.List (isPrefixOf) +import Data.Maybe (mapMaybe, catMaybes, fromMaybe) +import Data.Monoid (mappend, mconcat, (<>)) +import Data.Ord (comparing) +import Data.Text (Text, pack) +import Data.Version (Version) +import qualified Data.Text.IO as TIO +import qualified System.Console.MultiArg as MA +import qualified System.Exit as Exit +import qualified System.IO as IO +import qualified Text.Matchers as M +import qualified System.Console.Rainbow as R + +runZinc + :: Version + -- ^ Version of the executable + -> Defaults + -> S.Runtime + -> [I.Report] + -> IO () +runZinc ver df rt rs = do + let ord = sortPairsToFn . sorter $ df + hlp = helpText df rt rs + join $ MA.modesWithHelp hlp (allOpts ver (S.currentTime rt) df) + (processGlobal rt ord df rs) + + +-- | Whether to use color when standard output is not a terminal. +newtype ColorToFile = ColorToFile { unColorToFile :: Bool } + deriving (Eq, Show) + +data Matcher + = Within + | Exact + | TDFA + | PCRE + deriving (Eq, Show) + +data SortField + = Payee + | Date + | Flag + | Number + | Account + | DrCr + | Qty + | Commodity + | PostingMemo + | TransactionMemo + deriving (Eq, Show, Ord) + +data Defaults = Defaults + { sensitive :: M.CaseSensitive + , matcher :: Matcher + , colorToFile :: ColorToFile + , defaultScheme :: Maybe E.Scheme + -- ^ If Nothing, no default scheme. If the user does not pick a + -- scheme, no colors are used. + , moreSchemes :: [E.Scheme] + , sorter :: [(SortField, P.SortOrder)] + -- ^ For example, to sort by date and then by payee if the dates + -- are equal, use + -- + -- > [(Date, Ascending), (Payee, Ascending)] + + , exprDesc :: X.ExprDesc + } + +sortPairToFn :: (SortField, P.SortOrder) -> Orderer +sortPairToFn (s, d) = if d == P.Descending then flipOrder r else r + where + r = case s of + Payee -> comparing Q.payee + Date -> comparing Q.dateTime + Flag -> comparing Q.flag + Number -> comparing Q.number + Account -> comparing Q.account + DrCr -> comparing Q.drCr + Qty -> comparing Q.qty + Commodity -> comparing Q.commodity + PostingMemo -> comparing Q.postingMemo + TransactionMemo -> comparing Q.transactionMemo + +descPair :: (SortField, P.SortOrder) -> String +descPair (i, d) = desc ++ ", " ++ dir + where + dir = case d of + P.Ascending -> "ascending" + P.Descending -> "descending" + desc = case show i of + [] -> [] + x:xs -> toLower x : xs + +descSortList :: [(SortField, P.SortOrder)] -> [String] +descSortList ls = case ls of + [] -> [" No sorting performed by default"] + x:xs -> descFirst x : map descRest xs + +descFirst :: (SortField, P.SortOrder) -> String +descFirst p = " Default sort order: " ++ descPair p + +descRest :: (SortField, P.SortOrder) -> String +descRest p = " then: " ++ descPair p + +sortPairsToFn :: [(SortField, P.SortOrder)] -> Orderer +sortPairsToFn = mconcat . map sortPairToFn + +-- +-- ## Option parsing +-- + +-- +-- ## OptResult, and functions dealing with it +-- +newtype ShowExpression = ShowExpression Bool + deriving (Show, Eq) + +newtype VerboseFilter = VerboseFilter Bool + deriving (Show, Eq) + +type Error = Text + +data OptResult + = ROperand (M.CaseSensitive + -> Ly.MatcherFactory + -> Ex.Exceptional Ly.Error Ly.Operand) + | RPostFilter (Ex.Exceptional Ly.Error Ly.PostFilterFn) + | RMatcherSelect Ly.MatcherFactory + | RCaseSelect M.CaseSensitive + | ROperator (X.Token L.Posting) + | RSortSpec (Ex.Exceptional Error Orderer) + | RColorToFile ColorToFile + | RScheme E.Changers + | RExprDesc X.ExprDesc + | RShowExpression + | RVerboseFilter + | RShowVersion (IO ()) + +getPostFilters + :: [OptResult] + -> Ex.Exceptional Ly.Error [Ly.PostFilterFn] +getPostFilters = + sequence + . mapMaybe f + where + f o = case o of + RPostFilter pf -> Just pf + _ -> Nothing + +getExprDesc + :: Defaults + -> [OptResult] + -> X.ExprDesc +getExprDesc df os = case mapMaybe f os of + [] -> exprDesc df + xs -> last xs + where + f (RExprDesc d) = Just d + f _ = Nothing + +getSortSpec + :: Orderer + -> [OptResult] + -> Ex.Exceptional Error Orderer +getSortSpec i ls = + let getSpec o = case o of + RSortSpec x -> Just x + _ -> Nothing + exSpecs = mapMaybe getSpec ls + in if null exSpecs + then return i + else fmap mconcat . sequence $ exSpecs + +getShowVersion :: [OptResult] -> Maybe (IO ()) +getShowVersion ls = case mapMaybe f ls of + [] -> Nothing + xs -> Just $ last xs + where + f o = case o of { RShowVersion i -> Just i; _ -> Nothing } + +type Factory = M.CaseSensitive + -> Text -> Ex.Exceptional Text M.Matcher + +makeToken + :: OptResult + -> St.State (M.CaseSensitive, Factory) + (Maybe (Ex.Exceptional Ly.Error (X.Token L.Posting))) +makeToken o = case o of + ROperand f -> do + (s, fty) <- St.get + let g = fmap X.operand (f s fty) + return (Just g) + RMatcherSelect f -> do + (c, _) <- St.get + St.put (c, f) + return Nothing + RCaseSelect c -> do + (_, f) <- St.get + St.put (c, f) + return Nothing + ROperator t -> return . Just . return $ t + _ -> return Nothing + + +makeTokens + :: Defaults + -> [OptResult] + -> Ex.Exceptional Ly.Error ( [X.Token L.Posting] + , (M.CaseSensitive, Factory) ) +makeTokens df os = + let initSt = (sensitive df, fty) + fty = case matcher df of + Within -> \c t -> return (M.within c t) + Exact -> \c t -> return (M.exact c t) + TDFA -> M.tdfa + PCRE -> M.pcre + lsSt = mapM makeToken os + (ls, st') = St.runState lsSt initSt + in fmap (\xs -> (xs, st')) . sequence . catMaybes $ ls + + +allOpts :: Version -> L.DateTime -> Defaults -> [MA.OptSpec OptResult] +allOpts ver dt df = + map (fmap ROperand) (Ly.operandSpecs dt) + ++ [fmap RPostFilter . fst $ Ly.postFilterSpecs] + ++ [fmap RPostFilter . snd $ Ly.postFilterSpecs] + ++ map (fmap RMatcherSelect) Ly.matcherSelectSpecs + ++ map (fmap RCaseSelect) Ly.caseSelectSpecs + ++ map (fmap ROperator) Ly.operatorSpecs + ++ [fmap RSortSpec sortSpecs] + ++ [ optColorToFile ] + ++ let ss = moreSchemes df + in (if not . null $ ss then [optScheme ss] else []) + ++ map (fmap RExprDesc) Ly.exprDesc + ++ [ RShowExpression <$ Ly.showExpression + , RVerboseFilter <$ Ly.verboseFilter + , fmap RShowVersion (Ly.version ver) + ] + +optColorToFile :: MA.OptSpec OptResult +optColorToFile = MA.OptSpec ["color-to-file"] "" (MA.ChoiceArg ls) + where + ls = [ ("yes", RColorToFile $ ColorToFile True) + , ("no", RColorToFile $ ColorToFile False) ] + +getColorToFile :: Defaults -> [OptResult] -> ColorToFile +getColorToFile d ls = + case mapMaybe getOpt ls of + [] -> colorToFile d + xs -> last xs + where + getOpt o = case o of + RColorToFile c -> Just c + _ -> Nothing + +optScheme :: [E.Scheme] -> MA.OptSpec OptResult +optScheme ss = MA.OptSpec ["scheme"] "" (MA.ChoiceArg ls) + where + ls = map f ss + f (E.Scheme n _ s) = (n, RScheme s) + +getScheme :: Defaults -> [OptResult] -> Maybe E.Changers +getScheme d ls = + case mapMaybe getOpt ls of + [] -> fmap E.changers $ defaultScheme d + xs -> Just $ last xs + where + getOpt o = case o of + RScheme s -> Just s + _ -> Nothing + +getShowExpression :: [OptResult] -> ShowExpression +getShowExpression ls = case mapMaybe f ls of + [] -> ShowExpression False + _ -> ShowExpression True + where + f o = case o of { RShowExpression -> Just (); _ -> Nothing } + +getVerboseFilter :: [OptResult] -> VerboseFilter +getVerboseFilter ls = case mapMaybe f ls of + [] -> VerboseFilter False + _ -> VerboseFilter True + where + f o = case o of { RVerboseFilter -> Just (); _ -> Nothing } + +-- | Indicates the result of a successful parse of filtering options. +data FilterOpts = FilterOpts + { foResultFactory :: Factory + -- ^ The factory indicated, so that it can be used in + -- subsequent parses of the same command line. + + , foResultSensitive :: M.CaseSensitive + -- ^ Indicated case sensitivity, so that it can be used in + -- subsequent parses of the command line. + + , foSorterFilterer :: [L.Transaction] + -> ([R.Chunk], [(Ly.LibertyMeta, L.Posting)]) + -- ^ Applied to a list of Transaction, will sort and filter + -- the transactions and assign them LibertyMeta. + + , foTextSpecs :: Maybe E.Changers + + , foColorToFile :: ColorToFile + , foExprDesc :: X.ExprDesc + , foPredicate :: Pe.Pdct L.Posting + , foShowExpression :: ShowExpression + , foVerboseFilter :: VerboseFilter + } + +processGlobal + :: S.Runtime + -> Orderer + -> Defaults + -> [I.Report] + -> [OptResult] + -> Either (a -> IO ()) [MA.Mode (IO ())] +processGlobal rt srt df rpts os + = case processFiltOpts srt df os of + Ex.Exception s -> Left $ (const $ handleTextError s) + Ex.Success mayFo -> case mayFo of + Left i -> Left . const $ i + Right fo -> Right $ map (makeMode rt fo) rpts + +processFiltOpts + :: Orderer + -> Defaults + -> [OptResult] + -> Ex.Exceptional Error (Either (IO ()) FilterOpts) + -- ^ Left if the user asked to see the version; Right with the + -- FilterOpts otherwise. +processFiltOpts ord df os = case getShowVersion os of + Just i -> return $ Left i + Nothing -> do + postFilts <- getPostFilters os + sortSpec <- getSortSpec ord os + (toks, (rs, rf)) <- makeTokens df os + let ctf = getColorToFile df os + sch = getScheme df os + expDsc = getExprDesc df os + showExpr = getShowExpression os + verbFilt = getVerboseFilter os + pdct <- Ly.parsePredicate expDsc toks + let sf = Ly.xactionsToFiltered pdct postFilts sortSpec + return . Right $ FilterOpts rf rs sf sch + ctf expDsc pdct showExpr verbFilt + +makeMode + :: S.Runtime + -> FilterOpts + -> I.Report + -> MA.Mode (IO ()) +makeMode rt fo r = fmap makeIO mode + where + mode = snd (r rt) (foResultSensitive fo) (foResultFactory fo) + (fromMaybe Schemes.plainLabels . foTextSpecs $ fo) + (foExprDesc fo) (fmap snd (foSorterFilterer fo)) + makeIO parseResult = do + (posArgs, printRpt) <- + Ex.switch handleTextError return parseResult + (txns, pps) <- fmap splitLedger $ C.open posArgs + let term = if unColorToFile (foColorToFile fo) + then S.termFromEnv rt + else S.autoTerm rt + printer = R.printChunks term + verbFiltChunks = fst . foSorterFilterer fo $ txns + showFilterExpression printer (foShowExpression fo) (foPredicate fo) + showVerboseFilter printer (foVerboseFilter fo) verbFiltChunks + Ex.switch handleTextError (R.printChunks term) + $ printRpt txns pps + + +handleTextError :: Text -> IO a +handleTextError x = do + pn <- MA.getProgName + TIO.hPutStr IO.stderr $ (pack pn) <> ": error: " <> x + Exit.exitFailure + +indentAmt :: Pe.IndentAmt +indentAmt = 4 + +blankLine :: R.Chunk +blankLine = R.plain "\n" + +showFilterExpression + :: ([R.Chunk] -> IO ()) + -> ShowExpression + -> Pe.Pdct L.Posting + -> IO () +showFilterExpression ptr (ShowExpression se) pdct = + if not se + then return () + else ptr $ info : blankLine : + (Pe.showPdct indentAmt 0 pdct ++ [blankLine]) + where + info = R.plain "Posting filter expression:\n" + +showVerboseFilter + :: ([R.Chunk] -> IO ()) + -> VerboseFilter + -> [R.Chunk] + -> IO () +showVerboseFilter ptr (VerboseFilter vb) cks = + if not vb + then return () + else ptr $ info : blankLine : (cks ++ [blankLine]) + where + info = R.plain "Filtering information:\n" + +-- | Splits a Ledger into its Transactions and PricePoints. +splitLedger :: [C.LedgerItem] -> ([L.Transaction], [L.PricePoint]) +splitLedger = partitionEithers . mapMaybe toEither + where + toEither = Su.caseS4 (Just . Left) (Just . Right) + (const Nothing) (const Nothing) + +helpText + :: Defaults + -> S.Runtime + -> [I.Report] + -> String + -> String +helpText df rt pairMakers pn = + mappend (help df pn) . mconcat . map addHdr . fmap fst $ pairs + where + pairs = pairMakers <*> pure rt + addHdr s = hdr ++ s + hdr = unlines [ "", replicate 50 '=' ] + + +------------------------------------------------------------ +-- ## Sorting +------------------------------------------------------------ + +-- The monoid instance of Ordering takes the first non-EQ item. For +-- example: +-- +-- mconcat [EQ, LT, GT] == LT. +-- +-- If b is a monoid, then (a -> b) is also a monoid. Therefore (a -> a +-- -> Ordering) is also a monoid. So for example to compare the first +-- element of a pair and then by the second element only if the first +-- element is equal: +-- +-- mconcat [comparing fst, comparing snd] + +type Orderer = L.Posting -> L.Posting -> Ordering + +flipOrder :: (a -> a -> Ordering) -> (a -> a -> Ordering) +flipOrder f = f' where + f' p1 p2 = case f p1 p2 of + LT -> GT + GT -> LT + EQ -> EQ + +capitalizeFirstLetter :: String -> String +capitalizeFirstLetter s = case s of + [] -> [] + (x:xs) -> toUpper x : xs + +ordPairs :: [(String, Orderer)] +ordPairs = + [ ("payee", comparing Q.payee) + , ("date", comparing Q.dateTime) + , ("flag", comparing Q.flag) + , ("number", comparing Q.number) + , ("account", comparing Q.account) + , ("drCr", comparing Q.drCr) + , ("qty", comparing Q.qty) + , ("commodity", comparing Q.commodity) + , ("postingMemo", comparing Q.postingMemo) + , ("transactionMemo", comparing Q.transactionMemo) ] + +ords :: [(String, Orderer)] +ords = ordPairs ++ uppers ++ [none] where + uppers = map toReversed ordPairs + toReversed (s, f) = + (capitalizeFirstLetter s, flipOrder f) + none = ("none", const . const $ EQ) + + +-- | True if the first argument matches the second argument. The match +-- on the first letter is case sensitive; the match on the other +-- letters is not case sensitive. True if both strings are empty. +argMatch :: String -> String -> Bool +argMatch s1 s2 = case (s1, s2) of + (x:xs, y:ys) -> + (x == y) && ((map toUpper xs) `isPrefixOf` (map toUpper ys)) + _ -> True + +sortSpecs :: MA.OptSpec (Ex.Exceptional Error Orderer) +sortSpecs = MA.OptSpec ["sort"] ['s'] (MA.OneArg f) + where + f a = + let matches = filter (\p -> a `argMatch` (fst p)) ords + in case matches of + x:[] -> return $ snd x + _ -> Ex.throw $ "bad sort specification: " <> pack a <> "\n" + + + +------------------------------------------------------------ +-- ## Help +------------------------------------------------------------ + +help :: Defaults -> String -> String +help d pn = unlines $ + [ "usage: " ++ pn ++ " [posting filters] report [report options] file . . ." + , "" + , "Posting filters" + , "------------------------------------------" + , "" + , "Dates" + , "-----" + , "" + , "-d, --date cmp timespec" + , " Date must be within the time frame given. timespec" + , " is a day or a day and a time. Valid values for cmp:" + , " <, >, <=, >=, ==, /=, !=" + , "--current" + , " Same as \"--date <= (right now) \"" + , "" + , "Serials" + , "----------------" + , "These options take the form --option cmp num; the given" + , "sequence number must fall within the given range. \"rev\"" + , "in the option name indicates numbering is from end to beginning." + , "" + , "--globalTransaction, --revGlobalTransaction" + , " All transactions, after reading the ledger files" + , "--globalPosting, --revGlobalPosting" + , " All postings, after reading the leder files" + , "--fileTransaction, --revFileTransaction" + , " Transactions in each ledger file, after reading the files" + , " (numbering restarts with each file)" + , "--filePosting, --revFilePosting" + , " Postings in each ledger file, after reading the files" + , " (numbering restarts with each file)" + , "" + , "Pattern matching" + , "----------------" + , "" + , "-a pattern, --account pattern" + , " Pattern must match colon-separated account name" + , "--account-level num pat" + , " Pattern must match sub account at given level" + , "--account-any pat" + , " Pattern must match sub account at any level" + , "-p pattern, --payee pattern" + , " Payee must match pattern" + , "-t pattern, --tag pattern" + , " Tag must match pattern" + , "-n, --number pattern" + , " Number must match pattern" + , "-f, --flag pattern" + , " Flag must match pattern" + , "-y, --commodity pattern" + , " Pattern must match commodity name" + , "--posting-memo pattern" + , " Posting memo must match pattern" + , "--transaction-memo pattern" + , " Transaction memo must match pattern" + , "" + , "Other posting characteristics" + , "-----------------------------" + , "--debit" + , " Entry must be a debit" + , "--credit" + , " Entry must be a credit" + , "-q, --qty cmp number" + , " Entry quantity must fall within given range" + , "--filename pattern" + , " Filename of posting must match pattern" + , "" + , "Filtering based upon sibling postings" + , "-------------------------------------" + , "--s-globalPosting" + , "--s-revGlobalPosting" + , "--s-filePosting" + , "--s-revFilePosting" + , "--s-account" + , "--s-account-level" + , "--s-account-any" + , "--s-payee" + , "--s-tag" + , "--s-number" + , "--s-flag" + , "--s-commodity" + , "--s-posting-memo" + , "--s-debit" + , "--s-credit" + , "--s-qty" + , "" + , "Options affecting patterns" + , "--------------------------" + , "" + + , "-i, --case-insensitive" + , " Be case insensitive" + ++ ifDefault (sensitive d == M.Insensitive) + + , "-I, --case-sensitive" + , " Be case sensitive" + ++ ifDefault (sensitive d == M.Sensitive) + + , "" + + , "-w, --within" + , " Use \"within\" matcher" + ++ ifDefault (matcher d == Within) + + , "-r, --pcre" + , " Use \"pcre\" matcher" + ++ ifDefault (matcher d == PCRE) + + , "--posix" + , " Use \"posix\" matcher" + ++ ifDefault (matcher d == TDFA) + + , "-x, --exact" + , " Use \"exact\" matcher" + ++ ifDefault (matcher d == Exact) + , "" + , "Infix or RPN selection" + , "----------------------" + , "--infix - use infix notation" + ++ ifDefault (exprDesc d == X.Infix) + , "--rpn - use reverse polish notation" + ++ ifDefault (exprDesc d == X.RPN) + , "" + , "Infix Operators - from highest to lowest precedence" + , "(all are left associative)" + , "--------------------------" + , "--open expr --close" + , "-( expr -)" + , " Force precedence (as in \"open\" and \"close\" parentheses)" + , "--not, -N expr" + , " True if expr is false" + , "expr1 --and expr2" + , "expr -A expr2" + , " True if expr and expr2 are both true" + , "expr1 --or expr2" + , "expr1 -O expr2" + , " True if either expr1 or expr2 is true" + , "" + , "RPN Operators" + , "-------------" + , "--not, -N" + , "--and, -A" + , "--or, -O" + , " RPN counterparts to the infix operators" + , " are postfix and manipulate the RPN stack accordingly" + , "" + , "Showing expressions" + , "-------------------" + , "--show-expression" + , " Show the parsed filter expression" + , "--verbose-filter" + , " Verbosely show filtering results" + , "" + , "Removing postings after sorting and filtering" + , "---------------------------------------------" + , "--head n" + , " Keep only the first n postings" + , "--tail n" + , " Keep only the last n postings" + , "" + , "Sorting" + , "-------" + , "" + , "-s key, --sort key" + , " Sort postings according to key" + , "" + , "Keys:" + , " payee, date, flag, number, account, drCr," + , " qty, commodity, postingMemo, transactionMemo" + , "" + , " Ascending order by default; for descending order," + , " capitalize the name of the key." + , " (use \"none\" to leave postings in ledger file order)" + , "" + ] ++ descSortList (sorter d) ++ + [ "" + , "Colors" + , "------" + , "default scheme:" + , maybe " (none)" descScheme (defaultScheme d) + , "" + ] + ++ let schs = moreSchemes d + in (if not . null $ schs + then + [ "--scheme SCHEME_NAME" + , " use color scheme for report. Available schemes:" + ] ++ map descScheme schs + else []) + ++ + [ "" + , "--color-to-file no|yes" + , " Whether to use color when standard output is not a" + , " terminal (default: " ++ + if unColorToFile . colorToFile $ d then "yes)" else "no)" + , "" + , "Meta" + , "----" + , "--help, -h - show this help and exit" + , "--version - show version and exit" + ] + + +descScheme :: E.Scheme -> String +descScheme (E.Scheme n d _) = " " ++ n ++ " - " ++ d + +-- | The string @ (default)@ if the condition is True; otherwise, +-- nothing. +ifDefault :: Bool -> String +ifDefault b = if b then " (default)" else "" diff --git a/penny-lib.cabal b/penny-lib.cabal --- a/penny-lib.cabal +++ b/penny-lib.cabal @@ -1,5 +1,5 @@ Name: penny-lib -Version: 0.12.0.0 +Version: 0.14.0.0 Cabal-version: >=1.8 Build-Type: Simple License: BSD3 @@ -39,13 +39,16 @@ Library Build-depends: base ==4.* + , action-permutations ==0.0.0.0 + , binary ==0.7.* , bytestring ==0.10.* , cereal ==0.3.* , containers ==0.5.* , explicit-exception ==0.1.* , matchers ==0.6.* , monad-loops ==0.3.* - , multiarg ==0.14.* + , multiarg ==0.16.* + , ofx ==0.2.* , old-locale ==1.0.* , parsec >= 3.1.2 && < 3.2 , pcre-light ==0.4.* @@ -63,12 +66,12 @@ Exposed-modules: Penny , Penny.Brenner - , Penny.Brenner.Amex - , Penny.Brenner.BofA , Penny.Brenner.Clear , Penny.Brenner.Database , Penny.Brenner.Import + , Penny.Brenner.Info , Penny.Brenner.Merge + , Penny.Brenner.OFX , Penny.Brenner.Print , Penny.Brenner.Types , Penny.Brenner.Util @@ -101,10 +104,10 @@ , Penny.Cabin.Scheme.Schemes , Penny.Cabin.TextFormat , Penny.Copper + , Penny.Copper.Interface , Penny.Copper.Parsec , Penny.Copper.Render , Penny.Copper.Terminals - , Penny.Copper.Types , Penny.Liberty , Penny.Lincoln , Penny.Lincoln.Balance @@ -114,10 +117,8 @@ , Penny.Lincoln.Bits.Price , Penny.Lincoln.Bits.Qty , Penny.Lincoln.Builders - , Penny.Lincoln.Family - , Penny.Lincoln.Family.Child - , Penny.Lincoln.Family.Family - , Penny.Lincoln.Family.Siblings + , Penny.Lincoln.Ents + , Penny.Lincoln.Equivalent , Penny.Lincoln.HasText , Penny.Lincoln.Matchers , Penny.Lincoln.Predicates @@ -126,23 +127,129 @@ , Penny.Lincoln.Queries , Penny.Lincoln.Queries.Siblings , Penny.Lincoln.Serial - , Penny.Lincoln.Transaction - , Penny.Lincoln.Transaction.Unverified , Penny.Shield , Penny.Steel , Penny.Steel.NestedMap + , Penny.Steel.Sums , Penny.Wheat , Penny.Zinc Other-modules: Paths_penny_lib + hs-source-dirs: lib + if flag(incabal) + cpp-options: -Dincabal + ghc-options: -Wall if flag(debug) ghc-options: -auto-all -caf-all + if ! flag (buildlib) + buildable: False + +-- I'm going to not list the exposed-modules for the test, and +-- hope it works :) it seems cabal only uses this information for +-- executables to determine what to bundle into the dist tarball. +-- Since the test modules are all listed above for the library, +-- this should not be a problem. However, if there are extra +-- test modules that are not in the library, list them here. +Executable penny-test + Main-is: penny-test.hs + hs-source-dirs: tests lib + Build-depends: + base ==4.* + , action-permutations ==0.0.0.0 + , binary ==0.7.* + , bytestring ==0.10.* + , cereal ==0.3.* + , containers ==0.5.* + , explicit-exception ==0.1.* + , matchers ==0.6.* + , monad-loops ==0.3.* + , multiarg ==0.16.* + , ofx ==0.2.* + , old-locale ==1.0.* + , parsec >= 3.1.2 && < 3.2 + , pcre-light ==0.4.* + , prednote == 0.8.* + , pretty-show ==1.5.* + , rainbow ==0.2.* + , semigroups ==0.9.* + , split ==0.2.* + , strict ==0.3.* + , terminfo == 0.3.* + , text ==0.11.* + , time ==1.4.* + , transformers == 0.3.* + + + -- Test dependencies. test-framework has issues with newer versions, + -- see + -- https://github.com/batterseapower/test-framework/issues/34 + , QuickCheck ==2.5.* + , random-shuffle ==0.0.4 + + if ! flag(test) + buildable: False + + ghc-options: -Wall + +Executable penny-gibberish + Main-is: penny-gibberish.hs + hs-source-dirs: tests lib + Build-depends: + base ==4.* + , action-permutations ==0.0.0.0 + , binary ==0.7.* + , bytestring ==0.10.* + , cereal ==0.3.* + , containers ==0.5.* + , explicit-exception ==0.1.* + , matchers ==0.6.* + , monad-loops ==0.3.* + , multiarg ==0.16.* + , ofx ==0.2.* + , old-locale ==1.0.* + , parsec >= 3.1.2 && < 3.2 + , pcre-light ==0.4.* + , prednote == 0.8.* + , pretty-show ==1.5.* + , rainbow ==0.2.* + , semigroups ==0.9.* + , split ==0.2.* + , strict ==0.3.* + , terminfo == 0.3.* + , text ==0.11.* + , time ==1.4.* + , transformers == 0.3.* + + + -- Test dependencies. test-framework has issues with newer versions, + -- see + -- https://github.com/batterseapower/test-framework/issues/34 + , QuickCheck ==2.5.* + , random-shuffle ==0.0.4 + , random ==1.0.* + + if ! flag(test) + buildable: False + + ghc-options: -Wall + Flag debug Description: turns on some debugging options Default: False +Flag test + Description: enables QuickCheck tests + Default: False + +Flag incabal + Description: enables imports that only Cabal makes available + Default: True + +Flag buildlib + Description: build library + Default: True diff --git a/tests/penny-gibberish.hs b/tests/penny-gibberish.hs new file mode 100644 --- /dev/null +++ b/tests/penny-gibberish.hs @@ -0,0 +1,98 @@ +module Main where + +import qualified System.Console.MultiArg as MA +import qualified Control.Monad.Exception.Synchronous as Ex +import qualified Test.QuickCheck.Gen as G +import qualified System.Random as Rand +import Control.Monad (replicateM) +import qualified Gibberish.Parsers as P +import qualified Penny.Copper.Render as R +import qualified System.Exit as Exit +import qualified Data.Text.IO as TIO +import qualified System.IO as IO + +help :: String -> String +help pn = unlines + [ "usage: " ++ pn ++ " [options]" + , "Print a nonsensical but valid Penny file to standard output." + , "Uses modified generators that only make printable ASCII." + , "Options:" + , " -s, --size INT" + , " QuickCheck size parameter. Bigger numbers give more" + , " gibberish. (default: 5)" + , " -c, --count INT" + , " Number of items (transactions, comments, prices, and" + , " blank lines, total) to output. (default: 100)" + , " -l, --left GROUP_SPEC" + , " Group left of the decimal point (default: none)" + , " -r, --right GROUP_SPEC" + , " Group right of the decimal point (default: none)" + , " where GROUP_SPEC is:" + , " none - no digit grouping" + , " large - group if greater than 9,999 left of decimal," + , " or more than 4 decimal places right of decimal" + , " all - group whenever there are at least 4 places" + ] + +data Opts = Opts + { optSize :: Int + , optCount :: Int + , optLeft :: R.GroupSpec + , optRight :: R.GroupSpec + } deriving Show + +defaultOpts :: Opts +defaultOpts = Opts 5 100 R.NoGrouping R.NoGrouping + +options :: [MA.OptSpec (Opts -> Opts)] +options = + [ MA.OptSpec ["size"] "s" . MA.OneArgE $ \s -> do + i <- MA.reader s + if i < 1 + then Ex.throw (MA.ErrorMsg "non-positive size parameter") + else return (\os -> os { optSize = i }) + + , MA.OptSpec ["count"] "c" . MA.OneArgE $ \s -> do + i <- MA.reader s + if i < 1 + then Ex.throw (MA.ErrorMsg "non-positive count parameter") + else return (\os -> os { optCount = i }) + + , MA.OptSpec ["left"] "l" . MA.ChoiceArg + . map (\(str, spec) -> (str, \os -> os { optLeft = spec })) + $ groupSpecs + + , MA.OptSpec ["right"] "r" . MA.ChoiceArg + . map (\(str, spec) -> (str, \os -> os { optRight = spec })) + $ groupSpecs + ] + +groupSpecs :: [(String, R.GroupSpec)] +groupSpecs = [ ("none", R.NoGrouping) + , ("large", R.GroupLarge) + , ("all", R.GroupAll ) ] + +posArg :: a -> Ex.Exceptional MA.InputError b +posArg _ = Ex.throw (MA.ErrorMsg "no non-option arguments accepted") + +parse :: [(Opts -> Opts)] -> Opts +parse os = foldl (flip (.)) id os defaultOpts + +main :: IO () +main = do + pn <- MA.getProgName + os <- fmap parse $ MA.simpleWithHelp help MA.Intersperse options + posArg + gen <- Rand.getStdGen + let is = (\g -> G.unGen g gen (optSize os)) + . fmap (map fst) + . replicateM (optCount os) + $ P.item + gs = R.GroupSpecs (optLeft os) (optRight os) + x = mapM (R.item gs) is + case x of + Nothing -> do + IO.hPutStrLn IO.stderr $ pn ++ ": error: could not render ledger." + IO.hPutStrLn IO.stderr $ pn ++ "bad ledger: " ++ show is + Exit.exitFailure + Just strs -> mapM_ TIO.putStr strs >> Exit.exitSuccess diff --git a/tests/penny-test.hs b/tests/penny-test.hs new file mode 100644 --- /dev/null +++ b/tests/penny-test.hs @@ -0,0 +1,50 @@ +module Main where + +import qualified Lincoln as L +import qualified Copper as C +import qualified Control.Monad.Exception.Synchronous as Ex +import qualified System.Console.MultiArg as MA +import qualified System.Exit as Exit +import qualified Test.QuickCheck as Q + +help :: String -> String +help pn = unlines + [ "usage: " ++ pn ++ "[options]" + , "runs all QuickCheck tests for Penny." + , "Returns 0 if all tests succeeded, non-zero otherwise." + , "Options:" + , "--size, -s INT" + , " Limit QuickCheck size parameter to INT" + , "--count, -n INT" + , " Maximum number of successful tests needed" + ] + +options :: [MA.OptSpec (Q.Args -> Q.Args)] +options = + [ MA.OptSpec ["size"] "s" . MA.OneArgE $ \s -> do + i <- MA.reader s + let f a = a { Q.maxSize = i } + return f + + , MA.OptSpec ["count"] "n" . MA.OneArgE $ \s -> do + i <- MA.reader s + let f a = a { Q.maxSuccess = i } + return f + ] + +main :: IO () +main = do + opts <- MA.simpleWithHelp help MA.Intersperse + options + ( const . Ex.Exception . MA.ErrorMsg + $ "this command does not accept positional arguments") + let args = foldl (flip (.)) id opts Q.stdArgs + runner = Q.quickCheckWithResult args + acts = map ($ runner) allTests + bools <- sequence acts + if and bools + then Exit.exitSuccess + else Exit.exitFailure + +allTests :: [(Q.Property -> IO Q.Result) -> IO Bool] +allTests = [ L.runTests ] ++ C.tests