diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2011-2012 Omari Norman. +Copyright (c) 2011-2013 Omari Norman. All rights reserved. Redistribution and use in source and binary forms, with or without @@ -13,9 +13,10 @@ the documentation and/or other materials provided with the distribution. - * Neither the name of Omari Norman nor the names of its - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. + * Neither the name of Omari Norman nor the names of contributors + to this software may be used to endorse or promote products + derived from this software without specific prior written + permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT diff --git a/Penny.hs b/Penny.hs --- a/Penny.hs +++ b/Penny.hs @@ -1,88 +1,442 @@ -{- | Penny - double-entry accounting system +-- | Penny - extensible double-entry accounting system -Penny is organized into a tree of modules, each with a name. Check out -the links for details on each component of Penny. +module Penny + ( -- * Building a custom Penny binary -"Penny.Cabin" - Penny reports. Depends on Lincoln and Liberty. + -- | Everything you need to create a custom Penny program is + -- available by importing only this module. + Defaults(..) + , Z.Matcher(..) -"Penny.Copper" - the Penny parser. Depends on Lincoln. + -- ** Color schemes + , E.Scheme(..) + , E.TextSpecs + , E.Labels(..) + , E.EvenAndOdd(..) + , Sw.switchForeground + , Sw.switchBackground + , module Penny.Cabin.Chunk -"Penny.Liberty" - Penny command line parser helpers. Depends on -Lincoln and Copper. + -- ** Sorting + , Z.SortField(..) + , CabP.SortOrder(..) -"Penny.Lincoln" - the Penny core. Depends on no other Penny components. + -- ** Formatting quantities + , defaultQtyFormat -"Penny.Shield" the Penny runtime environment + -- ** Convert report options + , Target(..) + , CP.SortBy(..) -"Penny.Zinc" - the Penny command-line interface. Depends on Cabin, -Copper, Liberty, and Lincoln. + -- ** Postings report options + , M.Box + , Fields(..) + , Spacers(..) + , widthFromRuntime + , Ps.yearMonthDay + , Ps.qtyAsIs + , Ps.balanceAsIs -The dependencies are represented as a dot file in doc/dependencies.dot -in the Penny git repository. + -- ** Runtime + , S.Runtime + , S.environment -This module exports a few functions that are useful for building a -simple command line program with default options. To make anything -more complicated you may need to import modules from deeper down -within the hierarchy, but for a program based on the defaults only you -should be able to import this module only (and nothing else). + -- ** Text + , X.Text + , X.pack --} -module Penny ( - -- * Default time zone - Copper.DefaultTimeZone (DefaultTimeZone) - , Copper.utcDefault - , minsToDefaultTimeZone - - -- * Radix and grouping characters - , Copper.RadGroup - , Copper.periodComma - , Copper.periodSpace - , Copper.commaPeriod - , Copper.commaSpace - - -- * Reports - , Cabin.allReportsWithDefaults - - -- * Parser defaults - , Z.T(..) - , Z.defaultFromRuntime - - -- * Main function - , defaultPenny - , customPenny - - -- * Other useful stuff - for custom reports + -- ** 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.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 Penny.Cabin as Cabin -import qualified Penny.Copper as Copper +import qualified Data.Text as X +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 Penny.Cabin.Chunk +import qualified Penny.Cabin.Chunk.Switch as Sw +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 Penny.Shield as S import qualified Penny.Zinc as Z +import qualified Penny.Shield as S +import qualified Text.Matchers.Text as Mr --- | Use to make a DefaultTimeZone based on the number of minutes the --- time zone is offset from UTC. Make sure the argument you supply is --- between (-840) and 840; otherwise your program will crash at --- runtime. -minsToDefaultTimeZone :: Int -> Copper.DefaultTimeZone -minsToDefaultTimeZone i = case L.minsToOffset i of - Nothing -> error $ "penny: error: minutes out of range of " - ++ "allowed values for time zone" - Just tzo -> Copper.DefaultTimeZone tzo +-- | 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 -defaultPenny :: Copper.DefaultTimeZone -> Copper.RadGroup -> IO () -defaultPenny dtz rg = do - rt <- S.runtime - let df = Z.defaultFromRuntime dtz rg - rs = Cabin.allReportsWithDefaults dtz rg - Z.runPenny rt dtz rg df rs + , matcher :: Z.Matcher + -- ^ Which matcher to use -customPenny :: - Copper.DefaultTimeZone - -> Copper.RadGroup - -> (S.Runtime -> Z.T) - -> [Cabin.Report] + , colorToFile :: Bool + -- ^ Use colors when standard output is not a terminal? + + , 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 + :: (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 () -customPenny dtz rg gd rs = do +runPenny getDefaults = do rt <- S.runtime - Z.runPenny rt dtz rg gd rs + let df = getDefaults rt + rs = allReports df + Z.runZinc (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 + } + +toBalanceDefaults :: Defaults -> MP.ParseOpts +toBalanceDefaults d = MP.ParseOpts + { MP.showZeroBalances = + CO.ShowZeroBalances . balanceShowZeroBalances $ d + , MP.order = balanceOrder d + , MP.needsHelp = False + } + +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 new file mode 100644 --- /dev/null +++ b/Penny/Brenner.hs @@ -0,0 +1,276 @@ +-- | 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(..) + , brennerMain + ) where + +import qualified Penny.Brenner.Types as Y +import Data.Maybe (mapMaybe) +import qualified Data.Text as X +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 +import System.Exit (exitFailure) +import qualified System.IO as IO + +brennerMain :: Config -> IO () +brennerMain cf = do + as <- MA.getArgs + pr <- MA.getProgName + let cf' = convertConfig cf + r = MA.modes globalOpts (preProcessor cf') whatMode as + processParseResult pr cf' r + +data Arg + = AHelp + | AFitAcct String + deriving (Eq, Show) + +toFitAcctOpt :: Arg -> Maybe String +toFitAcctOpt a = case a of { AFitAcct s -> Just s; _ -> Nothing } + +globalOpts :: [MA.OptSpec Arg] +globalOpts = + [ MA.OptSpec ["help"] "h" (MA.NoArg AHelp) + , MA.OptSpec ["fit-account"] "f" (MA.OneArg AFitAcct) + ] + +data PreProc + = NeedsHelp + | DoIt (Maybe Y.FitAcct) + +preProcessor :: Y.Config -> [Arg] -> Ex.Exceptional String PreProc +preProcessor cf as = + if any (== AHelp) as + then return NeedsHelp + else do + let cardOpt = case mapMaybe toFitAcctOpt as of + [] -> Nothing + xs -> Just . last $ xs + card <- case cardOpt of + Nothing -> return $ Y.defaultFitAcct cf + Just o -> + let pdct (Y.Name n, _) = n == X.pack o + in case filter pdct (Y.moreFitAccts cf) of + [] -> Ex.throw $ "financial institution account " + ++ o ++ " not configured." + (_, c):[] -> return $ Just c + _ -> Ex.throw $ "more than one financial institution account " + ++ "named " ++ o ++ " configured." + return $ DoIt card + +whatMode + :: PreProc + -> Either (String -> String) + [MA.Mode (Ex.Exceptional String (IO ()))] +whatMode pp = case pp of + NeedsHelp -> Left id + DoIt mayCd -> + Right $ [C.mode, I.mode, M.mode, P.mode, D.mode] <*> [mayCd] + + +processParseResult + :: String + -- ^ Program name + -> Y.Config + + -> Ex.Exceptional MA.Error + (a, Either b (Ex.Exceptional String (IO ()))) + -> IO () +processParseResult pr cf ex = + case ex of + Ex.Exception err -> do + IO.hPutStr IO.stderr $ MA.formatError pr err + exitFailure + Ex.Success g -> processResult pr cf g + + +processResult + :: String + -- ^ Program name + + -> Y.Config + -> (a, Either b (Ex.Exceptional String (IO ()))) + -> IO () +processResult pr cf (_, ei) = + case ei of + Left _ -> putStr (help pr cf) + Right ex -> case ex of + Ex.Exception e -> do + putStrLn $ pr ++ ": error: " ++ e + exitFailure + Ex.Success g -> g + +help :: + String + -- ^ Program name + + -> Y.Config + -> String +help n c = 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 card 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. + + + } deriving Show + +convertFitAcct :: FitAcct -> Y.FitAcct +convertFitAcct (FitAcct db ax df cy gs tl sd sb ps) = Y.FitAcct + { Y.dbLocation = Y.DbLocation . X.pack $ db + , Y.pennyAcct = Y.PennyAcct . Bd.account $ ax + , Y.defaultAcct = Y.DefaultAcct . Bd.account $ 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 + } + +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 + } diff --git a/Penny/Brenner/Amex.hs b/Penny/Brenner/Amex.hs new file mode 100644 --- /dev/null +++ b/Penny/Brenner/Amex.hs @@ -0,0 +1,121 @@ +-- | 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 new file mode 100644 --- /dev/null +++ b/Penny/Brenner/BofA.hs @@ -0,0 +1,212 @@ +-- | 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) 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 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 diff --git a/Penny/Brenner/Clear.hs b/Penny/Brenner/Clear.hs new file mode 100644 --- /dev/null +++ b/Penny/Brenner/Clear.hs @@ -0,0 +1,186 @@ +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 System.Exit (exitFailure) +import qualified System.IO as IO +import Text.Show.Pretty (ppShow) +import qualified Penny.Brenner.Types as Y +import qualified Penny.Brenner.Util as U + + +help :: String +help = unlines + [ "usage: penny-fit 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 + = AHelp + | APosArg String + deriving (Eq, Show) + +toPosArg :: Arg -> Maybe String +toPosArg a = case a of { APosArg s -> Just s; _ -> Nothing } + +data Opts = Opts + { csvLocation :: Y.FitFileLocation + , ledgerLocations :: [String] + } deriving Show + + +mode :: Maybe Y.FitAcct -> MA.Mode (Ex.Exceptional String (IO ())) +mode c = MA.Mode + { MA.mName = "clear" + , MA.mIntersperse = MA.Intersperse + , MA.mOpts = [ MA.OptSpec ["help"] "h" (MA.NoArg AHelp) ] + , MA.mPosArgs = APosArg + , MA.mProcess = process c + } + +process :: Maybe Y.FitAcct -> [Arg] -> Ex.Exceptional String (IO ()) +process mayC as = + if any (== AHelp) as + then return $ putStrLn help + else do + c <- case mayC of + Just cd -> return cd + Nothing -> Ex.throw $ "no financial institution account given" + ++ " on command line, and no default financial" + ++ " institution configured." + (csv, ls) <- case mapMaybe toPosArg as of + [] -> Ex.throw $ "clear: you must provide a postings file." + x:xs -> return (Y.FitFileLocation x, xs) + let os = Opts csv ls + return $ runClear c os + +fatal :: String -> IO a +fatal s = do + IO.hPutStrLn IO.stderr $ "penny-fit clear: error: " ++ s + exitFailure + +runClear :: Y.FitAcct -> Opts -> IO () +runClear c os = do + dbList <- U.quitOnError + $ U.loadDb (Y.AllowNew False) (Y.dbLocation c) + let db = M.fromList dbList + (_, prsr) = Y.parser c + txns <- U.quitOnError $ prsr (csvLocation os) + leds <- C.openStdin (ledgerLocations os) + toClear <- case mapM (findUNumber db) txns of + Nothing -> fatal $ "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)) + (fatal $ "some postings were not cleared. " + ++ "Those not cleared:\n" ++ ppShow left) + case R.ledger (Y.groupSpecs c) led' of + Nothing -> + fatal "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 new file mode 100644 --- /dev/null +++ b/Penny/Brenner/Database.hs @@ -0,0 +1,51 @@ +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 +import qualified Control.Monad.Exception.Synchronous as Ex + +help :: String +help = unlines + [ "penny-fit [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 = ArgHelp | ArgPos String deriving (Eq, Show) + +mode + :: Maybe Y.FitAcct + -> MA.Mode (Ex.Exceptional String (IO ())) +mode mayFa = MA.Mode + { MA.mName = "database" + , MA.mIntersperse = MA.Intersperse + , MA.mOpts = [MA.OptSpec ["help"] "h" (MA.NoArg ArgHelp)] + , MA.mPosArgs = ArgPos + , MA.mProcess = processor mayFa + } + +processor + :: Maybe Y.FitAcct + -> [Arg] + -> Ex.Exceptional String (IO ()) +processor mayFa ls + | any (== ArgHelp) ls = return (putStrLn help) + | any isArgPos ls = Ex.throw $ + "penny-fit database: error: this command does" + ++ " not accept non-option arguments." + | otherwise = case mayFa of + Nothing -> Ex.throw $ "no financial institution account" + ++ " selected on command line, and no default" + ++ " financial instititution account configured." + Just fa -> return $ do + let dbLoc = Y.dbLocation fa + db <- U.quitOnError $ U.loadDb (Y.AllowNew False) dbLoc + mapM_ putStr . map U.showDbPair $ db + +isArgPos :: Arg -> Bool +isArgPos (ArgPos _) = True +isArgPos _ = False diff --git a/Penny/Brenner/Import.hs b/Penny/Brenner/Import.hs new file mode 100644 --- /dev/null +++ b/Penny/Brenner/Import.hs @@ -0,0 +1,134 @@ +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 +import qualified System.IO as IO +import qualified System.Exit as E + + +data Arg + = AHelp + | 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 + :: Y.DbLocation + -> ( Y.FitFileLocation + -> IO (Ex.Exceptional String [Y.Posting])) + -> MA.Mode (Ex.Exceptional String (IO ())) +mode dbLoc prsr = MA.Mode + { MA.mName = "import" + , MA.mIntersperse = MA.Intersperse + , MA.mOpts = + [ MA.OptSpec ["help"] "h" (MA.NoArg AHelp) + , MA.OptSpec ["new"] "n" (MA.NoArg AAllowNew) + ] + , MA.mPosArgs = AFitFile + , MA.mProcess = processor dbLoc prsr + } +-} + +mode + :: Maybe Y.FitAcct + -> MA.Mode (Ex.Exceptional String (IO ())) +mode mayFa = MA.Mode + { MA.mName = "import" + , MA.mIntersperse = MA.Intersperse + , MA.mOpts = + [ MA.OptSpec ["help"] "h" (MA.NoArg AHelp) + , MA.OptSpec ["new"] "n" (MA.NoArg AAllowNew) + ] + , MA.mPosArgs = AFitFile + , MA.mProcess = processor mayFa + } + +processor + :: Maybe Y.FitAcct + -> [Arg] + -> Ex.Exceptional String (IO ()) +processor mayFa as = do + let err s = Ex.throw $ "import: " ++ s + if any (== AHelp) as + then return $ putStrLn help + else do + (dbLoc, prsr) <- case mayFa of + Nothing -> err $ "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 + [] -> err "you must provide a postings file to read" + x:[] -> return (Y.FitFileLocation x) + _ -> err "you cannot provide more than one postings file to read" + let aNew = Y.AllowNew $ any (== AAllowNew) as + return $ 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.quitOnError $ U.loadDb (allowNew os) dbLoc + parseResult <- parser os (fitFile os) + ins <- case parseResult of + Ex.Exception e -> do + IO.hPutStrLn IO.stderr $ "penny-fit: error: " ++ e + E.exitFailure + Ex.Success g -> return g + let (new, len) = appendNew txnsOld ins + U.saveDb dbLoc new + putStrLn $ "imported " ++ show len ++ " new transactions." + +help :: String +help = unlines + [ "penny-fit [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 new file mode 100644 --- /dev/null +++ b/Penny/Brenner/Merge.hs @@ -0,0 +1,274 @@ +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) +import qualified Data.Map as M +import Data.Maybe (mapMaybe, isNothing) +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 Control.Monad.Exception.Synchronous as Ex +import qualified System.IO as IO +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 System.Exit (exitFailure) +import qualified Penny.Brenner.Types as Y +import qualified Penny.Brenner.Util as U + +data Arg + = AHelp + | APos String + deriving (Eq, Show) + +toPosArg :: Arg -> Maybe String +toPosArg a = case a of { APos s -> Just s; _ -> Nothing } + +mode :: Maybe Y.FitAcct -> MA.Mode (Ex.Exceptional String (IO ())) +mode maybeC = MA.Mode + { MA.mName = "merge" + , MA.mIntersperse = MA.Intersperse + , MA.mOpts = + [ MA.OptSpec ["help"] "h" (MA.NoArg AHelp) + ] + , MA.mPosArgs = APos + , MA.mProcess = processor maybeC + } + +processor :: Maybe Y.FitAcct -> [Arg] -> Ex.Exceptional a (IO ()) +processor maybeC as = return $ + if any (== AHelp) as + then putStrLn help + else doMerge maybeC (mapMaybe toPosArg as) + +doMerge :: Maybe Y.FitAcct -> [String] -> IO () +doMerge maybeAcct ss = do + acct <- case maybeAcct of + Nothing -> do + IO.hPutStrLn IO.stderr $ "merge: error: no financial" + ++ " institution account provided on command line, and" + ++ " no default account configured." + exitFailure + Just ac -> return ac + dbLs <- U.quitOnError + $ U.loadDb (Y.AllowNew False) (Y.dbLocation acct) + l <- C.openStdin ss + let dbWithEntry = fmap (pairWithEntry acct) . M.fromList $ dbLs + (l', db') = changeItems acct + l (filterDb (Y.pennyAcct acct) dbWithEntry l) + newTxns = createTransactions acct db' + final = C.Ledger (C.unLedger l' ++ newTxns) + case R.ledger (Y.groupSpecs acct) final of + Nothing -> do + IO.hPutStrLn IO.stderr "Could not render final ledger." + exitFailure + Just x -> TIO.putStr x + + +help :: String +help = unlines + [ "penny-fit 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" + ] + +-- | 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 + :: Y.FitAcct + -> (Y.UNumber, (Y.Posting, L.Entry)) + -> L.Transaction +newTransaction acct (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 (L.Payee pa) } + pa = if X.null . Y.unPayee . Y.payee $ a + then Y.unDesc . Y.desc $ a + else Y.unPayee . Y.payee $ a + pennyAcct = Y.unPennyAcct . Y.pennyAcct $ acct + p1 = (U.emptyRPosting pennyAcct (L.qty . L.amount $ e)) + { U.rTags = L.Tags [newLincolnUNumber u] } + p2 = U.emptyIPosting (Y.unDefaultAcct . Y.defaultAcct $ acct) + +-- | Creates new transactions for all the items remaining in the +-- DbMap. Appends a blank line after each one. +createTransactions + :: Y.FitAcct + -> DbWithEntry + -> [C.Item] +createTransactions acct = + concatMap (\i -> [i, C.BlankLine]) + . map C.Transaction + . map (newTransaction acct) + . M.assocs + diff --git a/Penny/Brenner/Print.hs b/Penny/Brenner/Print.hs new file mode 100644 --- /dev/null +++ b/Penny/Brenner/Print.hs @@ -0,0 +1,71 @@ +-- | 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 System.IO as IO +import qualified System.Exit as E +import qualified Control.Monad.Exception.Synchronous as Ex +import Data.Maybe (mapMaybe) + +help :: String +help = unlines + [ "penny-fit [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 + = ArgHelp + | ArgFile String + deriving (Eq, Show) + +mode + :: Maybe Y.FitAcct + -> MA.Mode (Ex.Exceptional String (IO ())) +mode mayFa = MA.Mode + { MA.mName = "print" + , MA.mIntersperse = MA.Intersperse + , MA.mOpts = [MA.OptSpec ["help"] "h" (MA.NoArg ArgHelp)] + , MA.mPosArgs = ArgFile + , MA.mProcess = processor mayFa + } + +processor + :: Maybe Y.FitAcct + -> [Arg] + -> Ex.Exceptional String (IO ()) +processor mayFa ls = + if any (== ArgHelp) ls + then return (putStrLn help) + else case mayFa of + Nothing -> Ex.throw $ + "no financial institution account" + ++ " provided on command line, and no account" + ++ " configured by default." + Just fa -> return $ 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 + IO.hPutStrLn IO.stderr $ "penny-fit print: error: " ++ s + E.exitFailure + Ex.Success ps -> mapM putStr . map U.showPosting $ ps + toFile a = case a of + ArgFile s -> Just (Y.FitFileLocation s) + _ -> Nothing + diff --git a/Penny/Brenner/Types.hs b/Penny/Brenner/Types.hs new file mode 100644 --- /dev/null +++ b/Penny/Brenner/Types.hs @@ -0,0 +1,287 @@ +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. + + } + +-- | 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 new file mode 100644 --- /dev/null +++ b/Penny/Brenner/Util.hs @@ -0,0 +1,97 @@ +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 Control.Monad (join) +import qualified System.IO as IO +import qualified System.Exit as E + +-- | 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 (Ex.Exceptional String 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 (return []) + else IOE.ioError e + Right g -> return . readDbTuple $ g + +-- | 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 + +quitOnError + :: IO (Ex.Exceptional String a) + -> IO a +quitOnError = join . fmap (Ex.switch err return) + where + err s = do + IO.hPutStrLn IO.stderr $ "penny-fit: error: " ++ s + E.exitFailure + +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 --- a/Penny/Cabin.hs +++ b/Penny/Cabin.hs @@ -1,15 +1,7 @@ -- | Cabin - Penny reports -module Penny.Cabin (allReportsWithDefaults, I.Report(..)) where - -import qualified Penny.Cabin.Balance as B -import qualified Penny.Cabin.Posts as P -import qualified Penny.Copper as C -import qualified Penny.Cabin.Interface as I +-- +-- 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 -allReportsWithDefaults :: - C.DefaultTimeZone - -> C.RadGroup - -> [I.Report] -allReportsWithDefaults dtz rg = - [ B.balanceReport (B.defaultOptions dtz) - , P.makeReport (P.defaultOptions dtz rg) ] diff --git a/Penny/Cabin/Allocate.hs b/Penny/Cabin/Allocate.hs deleted file mode 100644 --- a/Penny/Cabin/Allocate.hs +++ /dev/null @@ -1,72 +0,0 @@ -module Penny.Cabin.Allocate ( - Allocation, - allocation, - unAllocation, - allocate) where - -import qualified Control.Monad.Trans.State as St -import qualified Data.Foldable as F -import qualified Data.Traversable as T -import qualified Data.Map as M - -newtype Allocation = Allocation { unAllocation :: Int } - deriving (Show, Eq, Ord) - -allocation :: Int -> Allocation -allocation i = - if i < 1 - then error "Allocations must be at least 1" - else Allocation i - --- | Divide up a whole number proportionally into several parts. The --- sum of the parts is guaranteed to add up to original number. -allocate :: - Ord k - => M.Map k Allocation - -- ^ Maps arbitrary unique values to the allocations, so that you - -- can look up the corresponding allocations. - - -> Int - -- ^ Allocated values will add up to this number. - - -> M.Map k Int - -- ^ The given number, allocated into proportional parts. - -allocate m t = let - tot = F.sum . fmap (toDouble . unAllocation) $ m - ratios = fmap ((/tot) . toDouble . unAllocation) m - rounded = fmap (round . (* (toDouble t))) ratios - toDouble = fromIntegral :: Int -> Double - - in if M.null m - then M.empty - else adjust rounded t - -adjust :: - Ord k - => M.Map k Int - -> Int - -> M.Map k Int -adjust ws w = let - wsInts = fmap fromIntegral ws - diff = (fromIntegral w) - F.sum wsInts in - if M.null ws - then M.empty - else if diff == 0 - then ws - else let - ws' = St.evalState (T.mapM adjustMap ws) diff - in adjust ws' w - --- | The state is the target number minus the current actual total. -adjustMap :: Int -> St.State Int Int -adjustMap w = do - diff <- St.get - case compare diff 0 of - EQ -> return w - GT -> do - St.put (pred diff) - return (succ w) - LT -> do - St.put (succ diff) - return (pred w) diff --git a/Penny/Cabin/Balance.hs b/Penny/Cabin/Balance.hs --- a/Penny/Cabin/Balance.hs +++ b/Penny/Cabin/Balance.hs @@ -1,107 +1,21 @@ --- | The Penny balance report -module Penny.Cabin.Balance ( - -- * Making reports - - -- | Use these functions if you are building a report from your own - -- code and you are not using the Zinc parser. - T.report - , T.nullConvert - , T.converter - - -- * Parsing reports - -- | For use with the Zinc command line parser. - , BalanceOpts(..) - , balanceReport - , defaultOptions - , balanceAsIs - - ) where +-- | 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.Tree as T -import qualified Penny.Cabin.Balance.Parser as P -import qualified Penny.Cabin.Balance.Help as H -import qualified Penny.Cabin.Chunk as Chunk -import qualified Penny.Cabin.Colors as C -import qualified Penny.Cabin.Colors.DarkBackground as Dark +import qualified Penny.Cabin.Balance.MultiCommodity as MC import qualified Penny.Cabin.Interface as I -import qualified Penny.Cabin.Options as CO -import qualified Penny.Copper as Cop -import qualified Penny.Lincoln as L -import qualified Penny.Lincoln.Balance as Bal -import qualified Penny.Shield as S - -import qualified Control.Monad.Exception.Synchronous as Ex -import qualified Data.Text as X -import System.Console.MultiArg.Prim (Parser) - -data BalanceOpts = BalanceOpts { - drCrColors :: C.DrCrColors - , baseColors :: C.BaseColors - , balanceFormat :: L.BottomLine -> X.Text - , colorPref :: Chunk.Colors - , showZeroBalances :: CO.ShowZeroBalances - , defaultTimeZone :: Cop.DefaultTimeZone - , convert :: Maybe (L.Commodity, L.DateTime) - } - -toParseOpts :: BalanceOpts -> P.ParseOpts -toParseOpts b = P.ParseOpts { - P.drCrColors = drCrColors b - , P.baseColors = baseColors b - , P.colorPref = colorPref b - , P.showZeroBalances = showZeroBalances b - , P.convert = convert b - } - -toTreeOpts :: P.ParseOpts -> BalanceOpts -> T.TreeOpts -toTreeOpts p b = T.TreeOpts { - T.drCrColors = P.drCrColors p - , T.baseColors = P.baseColors p - , T.balanceFormat = balanceFormat b - , T.showZeroBalances = P.showZeroBalances p - } - -parser :: (S.Runtime -> BalanceOpts) -> Parser I.ReportFunc -parser frt = do - parsed <- P.parseOptions - let rf rt _ _ ps pps = do - let bo = frt rt - po = toParseOpts bo - po' <- Ex.mapException showParseErr $ - parsed rt (defaultTimeZone bo) po - let to = toTreeOpts po' bo - conv <- case P.convert po' of - Nothing -> return $ T.nullConvert ps - Just co -> T.converter co pps ps - return - . Chunk.chunksToText (P.colorPref po') - . concat - . T.report to - $ conv - return rf - - -showParseErr :: P.Error -> X.Text -showParseErr = X.pack . show - - -balanceReport :: (S.Runtime -> BalanceOpts) -> I.Report -balanceReport f = I.Report H.help "balance" (parser f) - - -defaultOptions :: Cop.DefaultTimeZone -> S.Runtime -> BalanceOpts -defaultOptions dtz rt = BalanceOpts { - drCrColors = Dark.drCrColors - , baseColors = Dark.baseColors - , balanceFormat = balanceAsIs - , colorPref = CO.maxCapableColors rt - , showZeroBalances = CO.ShowZeroBalances False - , defaultTimeZone = dtz - , convert = Nothing - } +import qualified Penny.Cabin.Balance.Convert as C +import qualified Penny.Cabin.Balance.Convert.Options as ConvOpts -balanceAsIs :: L.BottomLine -> X.Text -balanceAsIs n = case n of - L.Zero -> X.pack "--" - L.NonZero c -> X.pack . show . L.unQty . Bal.qty $ c +-- | 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 new file mode 100644 --- /dev/null +++ b/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 + +-- | 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 + } + +-- | 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 [Scheme.PreChunk] +report os@(Opts getFmt _ _ _ _) ps bs = do + fstBl <- sumConvertSort os ps bs + let (rs, L.To cy) = rows fstBl + fmt = getFmt cy + return $ K.rowsToChunks 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 _ _ fsf = MA.Mode + { MA.mName = "convert" + , MA.mIntersperse = MA.Intersperse + , MA.mOpts = map (fmap Right) P.allOptSpecs + , MA.mPosArgs = Left + , MA.mProcess = process rt o fsf } + +process + :: S.Runtime + -> O.DefaultOpts + -> ([L.Transaction] -> [L.Box Ly.LibertyMeta]) + -> [Either String (P.Opts -> Ex.Exceptional String P.Opts)] + -> Ex.Exceptional String (Either I.HelpStr I.ArgsAndReport) +process rt 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 s + Ex.Success g -> return $ + let noDefault = X.pack "no default price found" + in case fromParsedOpts g of + NeedsHelp -> Left $ help defaultOpts + DoReport f -> + let pr ts pps = do + rptOpts <- Ex.fromMaybe noDefault $ + f pps (O.format defaultOpts) + let boxes = fsf ts + report rptOpts pps boxes + in Right (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) + + +data HelpOrOpts + = NeedsHelp + | 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 + :: P.Opts + -> HelpOrOpts +fromParsedOpts (P.Opts szb tgt dt so sb hlp) = + if hlp + then NeedsHelp + else DoReport $ \pps fmt -> case tgt of + P.ManualTarget to -> + Just $ Opts fmt szb (getSorter so sb) to dt + P.AutoTarget -> + case mostFrequent pps of + Nothing -> Nothing + Just to -> + Just $ Opts fmt szb (getSorter so sb) to dt + +-- | 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 new file mode 100644 --- /dev/null +++ b/Penny/Cabin/Balance/Convert/Chunker.hs @@ -0,0 +1,227 @@ +-- | 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.Chunk as Chunk +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 + +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 :: E.PreChunk } + +-- | 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 (E.width . 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 :: + IsEven + -> Columns R.ColumnSpec + -> [E.PreChunk] +colsToBits isEven (Columns a dc q) = let + fillSpec = if isEven + then (E.Other, E.Even) + else (E.Other, E.Odd) + spacer w = R.ColumnSpec j (Chunk.Width w) fillSpec [] + j = R.LeftJustify + cs = a + : spacer widthSpacerAcct + : dc + : spacer widthSpacerDrCr + : q + : [] + in R.row cs + +colsListToBits + :: [Columns R.ColumnSpec] + -> [[E.PreChunk]] +colsListToBits = zipWith f bools where + f b c = colsToBits b c + bools = iterate not True + +preSpecsToBits + :: [Columns PreSpec] + -> [E.PreChunk] +preSpecsToBits = + concat + . colsListToBits + . 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 :: + (L.Qty -> X.Text) + -- ^ How to format a balance to allow for digit grouping + -> [Row] + -> [E.PreChunk] +rowsToChunks fmt = + preSpecsToBits + . rowsToColumns fmt + +rowsToColumns :: + (L.Qty -> X.Text) + -- ^ How to format a balance to allow for digit grouping + + -> [Row] + -> [Columns PreSpec] +rowsToColumns fmt rs = map (mkRow fmt) pairs + where + pairs = Meta.visibleNums (,) rs + + +mkRow :: + (L.Qty -> X.Text) + -> (Meta.VisibleNum, Row) + -> Columns PreSpec +mkRow fmt (vn, r) = case r of + RMain m -> mkMainRow fmt (vn, m) + ROneCol c -> mkOneColRow (vn, c) + +mkOneColRow :: + (Meta.VisibleNum, OneColRow) + -> Columns PreSpec +mkOneColRow (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.PreChunk lbl eo txt) + cd = PreSpec R.LeftJustify (lbl, eo) (E.PreChunk lbl eo X.empty) + cq = cd + +mkMainRow :: + (L.Qty -> X.Text) + -> (Meta.VisibleNum, MainRow) + -> Columns PreSpec +mkMainRow fmt (vn, (MainRow i acctTxt b)) = Columns ca cd cq + where + eo = E.fromVisibleNum vn + lbl = E.Other + ca = PreSpec R.LeftJustify (lbl, eo) (E.PreChunk lbl eo txt) + where + txt = X.append indents acctTxt + indents = X.replicate (indentAmount * max 0 i) + (X.singleton ' ') + cd = PreSpec R.LeftJustify (lbl, eo) cksDrCr + cq = PreSpec R.LeftJustify (lbl, eo) cksQty + (cksDrCr, cksQty) = balanceChunks fmt vn b + + +balanceChunks :: + (L.Qty -> X.Text) + -> Meta.VisibleNum + -> L.BottomLine + -> (E.PreChunk, E.PreChunk) +balanceChunks fmt vn bl = (chkDc, chkQt) + where + eo = E.fromVisibleNum vn + chkDc = E.bottomLineToDrCr bl eo + chkQt = E.PreChunk lbl eo t + where + (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 new file mode 100644 --- /dev/null +++ b/Penny/Cabin/Balance/Convert/Options.hs @@ -0,0 +1,44 @@ +-- | 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 + , P.showHelp = False + } + +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 new file mode 100644 --- /dev/null +++ b/Penny/Cabin/Balance/Convert/Parser.hs @@ -0,0 +1,94 @@ +-- | 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 + , showHelp :: Bool + } + +-- | 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 + , fmap toExc parseHelp ] + 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 } + +parseHelp :: C.OptSpec (Opts -> Opts) +parseHelp = fmap f P.help + where + f _ o = o { showHelp = True } diff --git a/Penny/Cabin/Balance/Help.hs b/Penny/Cabin/Balance/Help.hs deleted file mode 100644 --- a/Penny/Cabin/Balance/Help.hs +++ /dev/null @@ -1,34 +0,0 @@ -module Penny.Cabin.Balance.Help where - -import qualified Data.Text as X - -help :: X.Text -help = X.pack helpStr - -helpStr :: String -helpStr = unlines [ - "balance, bal", - " Show account balances. Accepts ONLY the following options:", - "", - " --color yes|no|auto|256", - " yes: show 8 colors always", - " no: never show colors", - " auto: show 8 or 256 colors, but only if stdout is a terminal", - " 256: show 256 colors always", - " --background light|dark", - " Use appropriate color scheme for terminal background", - "", - " --show-zero-balances", - " Show balances that are zero", - " --hide-zero-balances", - " Hide balances that are zero", - "", - " --convert commodity dateTime", - " Convert all commodities to the given commodity using their", - " price at the given date (and, optionally, time.) Fails if", - " any commodity does not have the necessary price.", - " -c commodity", - " Same as \"--convert commodity [right now]\"", - "" - ] - diff --git a/Penny/Cabin/Balance/MultiCommodity.hs b/Penny/Cabin/Balance/MultiCommodity.hs new file mode 100644 --- /dev/null +++ b/Penny/Cabin/Balance/MultiCommodity.hs @@ -0,0 +1,173 @@ +-- | 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.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 + +-- | 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 + } + +defaultOpts :: Opts +defaultOpts = Opts + { balanceFormat = defaultFormat + , showZeroBalances = CO.ShowZeroBalances True + , order = compare + } + +defaultParseOpts :: P.ParseOpts +defaultParseOpts = P.ParseOpts + { P.showZeroBalances = CO.ShowZeroBalances False + , P.order = CP.Ascending + , P.needsHelp = False + } + +fromParseOpts :: + (L.Commodity -> L.Qty -> X.Text) + -> P.ParseOpts + -> Opts +fromParseOpts fmt (P.ParseOpts szb o _) = Opts fmt szb o' + 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] -> [E.PreChunk] +report (Opts bf szb o) = + K.rowsToChunks 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 _ _ fsf = MA.Mode + { MA.mName = "balance" + , MA.mIntersperse = MA.Intersperse + , MA.mOpts = map (fmap Right) P.allSpecs + , MA.mPosArgs = Left + , MA.mProcess = process fmt o rt fsf + } + +process + :: Applicative f + => (L.Commodity -> L.Qty -> X.Text) + -> P.ParseOpts + -> a + -> ([L.Transaction] -> [L.Box Ly.LibertyMeta]) + -> [Either String (P.ParseOpts -> P.ParseOpts)] + -> f (Either I.HelpStr I.ArgsAndReport) +process fmt o _ fsf ls = + let (posArgs, fns) = Ei.partitionEithers ls + mkParsedOpts = foldl (flip (.)) id fns + os' = mkParsedOpts o + mcOpts = fromParseOpts fmt os' + pr txns _ = return $ report mcOpts (fsf txns) + in pure $ if P.needsHelp os' + then Left $ help o + else Right (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 new file mode 100644 --- /dev/null +++ b/Penny/Cabin/Balance/MultiCommodity/Chunker.hs @@ -0,0 +1,212 @@ +-- | 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.Chunk as Chunk +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 + +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 :: [E.PreChunk] } + +-- | 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 E.width . 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 :: + IsEven + -> Columns R.ColumnSpec + -> [E.PreChunk] +colsToBits 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 (Chunk.Width w) fillSpec [] + j = R.LeftJustify + cs = a + : spacer widthSpacerAcct + : dc + : spacer widthSpacerDrCr + : c + : spacer widthSpacerCommodity + : q + : [] + in R.row cs + +colsListToBits + :: [Columns R.ColumnSpec] + -> [[E.PreChunk]] +colsListToBits = zipWith f bools where + f b c = colsToBits b c + bools = iterate not True + +preSpecsToBits + :: [Columns PreSpec] + -> [E.PreChunk] +preSpecsToBits = + concat + . colsListToBits + . 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 :: + (L.Commodity -> L.Qty -> X.Text) + -- ^ How to format a balance to allow for digit grouping + -> [Row] + -> [E.PreChunk] +rowsToChunks fmt = + preSpecsToBits + . rowsToColumns fmt + +rowsToColumns :: + (L.Commodity -> L.Qty -> X.Text) + -- ^ How to format a balance to allow for digit grouping + + -> [Row] + -> [Columns PreSpec] +rowsToColumns fmt rs = map (mkColumn fmt) pairs + where + pairs = Meta.visibleNums (,) rs + + +mkColumn :: + (L.Commodity -> L.Qty -> X.Text) + -> (Meta.VisibleNum, Row) + -> Columns PreSpec +mkColumn fmt (vn, (Row i acctTxt bs)) = Columns ca cd cc cq + where + lbl = E.Other + eo = E.fromVisibleNum vn + ca = PreSpec R.LeftJustify (lbl, eo) [E.PreChunk lbl eo 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 eo + else + let balChks = map (balanceChunks fmt eo) bs + cDrCr = map (\(a, _, _) -> a) balChks + cCmdty = map (\(_, a, _) -> a) balChks + cQty = map (\(_, _, a) -> a) balChks + in (cDrCr, cCmdty, cQty) + + +balanceChunksEmpty + :: E.EvenOdd + -> ([E.PreChunk], [E.PreChunk], [E.PreChunk]) +balanceChunksEmpty eo = (dash, dash, dash) + where + dash = [E.PreChunk E.Zero eo (X.pack "--")] + +balanceChunks + :: (L.Commodity -> L.Qty -> X.Text) + -> E.EvenOdd + -> (L.Commodity, L.BottomLine) + -> (E.PreChunk, E.PreChunk, E.PreChunk) +balanceChunks fmt eo (cty, bl) = (chkDc, chkCt, chkQt) + where + chkDc = E.bottomLineToDrCr bl eo + chkCt = E.bottomLineToCmdty eo (cty, bl) + chkQt = E.bottomLineToQty fmt eo (cty, bl) + + +indentAmount :: Int +indentAmount = 2 + diff --git a/Penny/Cabin/Balance/MultiCommodity/Parser.hs b/Penny/Cabin/Balance/MultiCommodity/Parser.hs new file mode 100644 --- /dev/null +++ b/Penny/Cabin/Balance/MultiCommodity/Parser.hs @@ -0,0 +1,35 @@ +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 + , needsHelp :: Bool + } + + +parseHelp :: MA.OptSpec (ParseOpts -> ParseOpts) +parseHelp = fmap f P.help + where + f _ o = o { needsHelp = True } + +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 = [parseHelp, zeroBalances, parseOrder] diff --git a/Penny/Cabin/Balance/Parser.hs b/Penny/Cabin/Balance/Parser.hs deleted file mode 100644 --- a/Penny/Cabin/Balance/Parser.hs +++ /dev/null @@ -1,156 +0,0 @@ -module Penny.Cabin.Balance.Parser ( - Error(..) - , ParseOpts(..) - , parseOptions - ) where - -import qualified Data.Text as X -import Control.Applicative ((<|>), many, Applicative, pure) -import Control.Monad ((>=>)) -import qualified Control.Monad.Exception.Synchronous as Ex -import qualified Penny.Cabin.Colors as Col -import qualified Penny.Cabin.Colors.DarkBackground as DB -import qualified Penny.Cabin.Colors.LightBackground as LB -import qualified Penny.Cabin.Chunk as Chk -import qualified Penny.Cabin.Options as CO -import qualified Penny.Copper.Commodity as CC -import qualified Penny.Copper.DateTime as CD -import qualified Penny.Lincoln as L -import qualified Penny.Shield as S -import System.Console.MultiArg.Prim (Parser) -import qualified System.Console.MultiArg.Combinator as C -import qualified Text.Parsec as Parsec - -data ParseOpts = ParseOpts { - drCrColors :: Col.DrCrColors - , baseColors :: Col.BaseColors - , colorPref :: Chk.Colors - , showZeroBalances :: CO.ShowZeroBalances - , convert :: Maybe (L.Commodity, L.DateTime) - } - - -data Error = BadColorName String - | BadBackground String - | BadCommodity String - | BadDate String - deriving Show - - -processColorArg :: - S.Runtime - -> String - -> Maybe Chk.Colors -processColorArg rt x - | x == "yes" = return Chk.Colors8 - | x == "no" = return Chk.Colors0 - | x == "auto" = return (CO.maxCapableColors rt) - | x == "256" = return Chk.Colors256 - | otherwise = Nothing - -parseOpt :: [String] -> [Char] -> C.ArgSpec a -> Parser a -parseOpt ss cs a = C.parseOption [C.OptSpec ss cs a] - -color :: Parser (S.Runtime - -> ParseOpts - -> Ex.Exceptional Error ParseOpts) -color = parseOpt ["color"] "" (C.OneArg f) - where - f a1 rt op = case processColorArg rt a1 of - Nothing -> Ex.throw . BadColorName $ a1 - Just c -> return (op { colorPref = c }) - -processBackgroundArg :: - String - -> Maybe (Col.DrCrColors, Col.BaseColors) -processBackgroundArg x - | x == "light" = return (LB.drCrColors, LB.baseColors) - | x == "dark" = return (DB.drCrColors, DB.baseColors) - | otherwise = Nothing - - -background :: Parser (ParseOpts -> Ex.Exceptional Error ParseOpts) -background = parseOpt ["background"] "" (C.OneArg f) - where - f a1 op = case processBackgroundArg a1 of - Nothing -> Ex.throw . BadBackground $ a1 - Just (dc, base) -> - return op { drCrColors = dc - , baseColors = base } - -parseShowZeroBalances :: Parser (ParseOpts -> ParseOpts) -parseShowZeroBalances = parseOpt opt "" (C.NoArg f) - where - opt = ["show-zero-balances"] - f op = - op {showZeroBalances = CO.ShowZeroBalances True } - -hideZeroBalances :: Parser (ParseOpts -> ParseOpts) -hideZeroBalances = parseOpt ["hide-zero-balances"] "" (C.NoArg f) - where - f op = - op {showZeroBalances = CO.ShowZeroBalances False } - -convertLong :: - Parser (CD.DefaultTimeZone - -> ParseOpts - -> Ex.Exceptional Error ParseOpts) -convertLong = parseOpt ["convert"] "" (C.TwoArg f) - where - f a1 a2 dtz op = do - cty <- case Parsec.parse CC.lvl1Cmdty "" (X.pack a1) of - Left _ -> Ex.throw . BadCommodity $ a1 - Right g -> return g - let parseDate = CD.dateTime dtz - dt <- case Parsec.parse parseDate "" (X.pack a2) of - Left _ -> Ex.throw . BadDate $ a2 - Right g -> return g - let op' = op { convert = Just (cty, dt) } - return op' - -convertShort :: Parser (S.Runtime - -> ParseOpts - -> Ex.Exceptional Error ParseOpts) -convertShort = parseOpt [] ['c'] (C.OneArg f) - where - f a1 rt op = do - cty <- case Parsec.parse CC.lvl1Cmdty "" (X.pack a1) of - Left _ -> Ex.throw . BadCommodity $ a1 - Right g -> return g - let dt = S.currentTime rt - op' = op { convert = Just (cty, dt) } - return op' - - -parseOptions :: Parser (S.Runtime - -> CD.DefaultTimeZone - -> ParseOpts - -> Ex.Exceptional Error ParseOpts) -parseOptions = do - fns <- many parseOption - let f rt dtz o1 = - let fns' = map (\fn -> fn rt dtz) fns - in foldl (>=>) return fns' o1 - return f - -parseOption :: Parser (S.Runtime - -> CD.DefaultTimeZone - -> ParseOpts - -> Ex.Exceptional Error ParseOpts) -parseOption = - (do { f <- color; return (\rt _ o -> f rt o )}) - <|> wrap background - <|> wrap (impurify parseShowZeroBalances) - <|> wrap (impurify hideZeroBalances) - <|> (do { f <- convertLong; return (\_ dtz o -> f dtz o )}) - <|> (do { f <- convertShort; return (\rt _ o -> f rt o )}) - where - wrap p = do - f <- p - return (\_ _ op -> f op) - -impurify :: - (Applicative m, Functor f) - => f (a -> a) - -> f (a -> m a) -impurify = fmap (\f -> pure . f) diff --git a/Penny/Cabin/Balance/Tree.hs b/Penny/Cabin/Balance/Tree.hs deleted file mode 100644 --- a/Penny/Cabin/Balance/Tree.hs +++ /dev/null @@ -1,468 +0,0 @@ --- | Takes postings and places them into a tree for further --- processing. --- --- Steps: --- --- * 1. [LT.PostingInfo] -> [PriceConverted] --- --- * 2. [PriceConverted] -> FlatMap --- --- * 3. FlatMap -> RawBals --- --- * 4. RawBals -> (SummedBals, TotalBal) --- --- * 5. (SummedBals, TotalBal) -> (SummedWithIsEven, TotalBal) --- --- * 6. (SummedWithIsEven, TotalBal) -> (PreSpecMap, TotalBal) --- --- * 7. (PreSpecMap, TotalBal) -> [Columns PreSpec] --- --- * 8. [Columns PreSpec] -> [Columns R.ColumnSpec] (strict) --- --- * 9. [Columns R.ColumnSpec] -> [[Chunk.Bit]] (lazy) -module Penny.Cabin.Balance.Tree ( - report - , TreeOpts(..) - , PriceConverteds - , nullConvert - , converter - ) where - -import Control.Applicative(Applicative(pure, (<*>)), (<$>)) -import qualified Control.Monad.Exception.Synchronous as Ex -import qualified Control.Monad.Trans.State as St -import qualified Penny.Cabin.Row as R -import qualified Data.Foldable as Fdbl -import qualified Data.Functor.Identity as Id -import qualified Data.Map as M -import qualified Data.Monoid as Monoid -import qualified Penny.Lincoln.NestedMap as NM -import qualified Data.Text as X -import qualified Data.Traversable as Tr -import qualified Penny.Cabin.Options as CO -import qualified Penny.Cabin.Chunk as Chunk -import qualified Penny.Cabin.Colors as C -import qualified Penny.Liberty as Ly -import qualified Penny.Lincoln as L -import qualified Penny.Lincoln.Queries as Q -import qualified Penny.Lincoln.Balance as Bal -import qualified Data.Semigroup as S - --- Step 1. Convert prices. - -data PriceConverted = PriceConverted { - pcEntry :: L.Entry - , pcAccount :: L.Account } - -newtype PriceConverteds = - PriceConverteds { unPriceConverteds :: [PriceConverted] } - -convertOne :: - L.PriceDb - -> (L.Commodity, L.DateTime) - -> L.Entry - -> Ex.Exceptional X.Text L.Entry -convertOne db (cty, dt) en@(L.Entry dc am@(L.Amount _ fr)) = - if fr == cty - then return en - else do - let to = L.To cty - am' <- case L.convert db dt to am of - Ex.Exception e -> Ex.throw (convertError cty am e) - Ex.Success g -> return g - return (L.Entry dc am') - -convertError :: - L.Commodity - -> L.Amount - -> L.PriceDbError - -> X.Text -convertError to (L.Amount _ fr) e = - let fromErr = L.text (L.Delimited (X.singleton ':') - (Fdbl.toList . L.unCommodity $ fr)) - toErr = L.text (L.Delimited (X.singleton ':') - (Fdbl.toList . 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") - - -buildDb :: [L.PricePoint] -> L.PriceDb -buildDb = foldl f L.emptyDb where - f db pb = L.addPrice db pb - --- | Makes PriceConverteds where there is no target commodity. -nullConvert :: [L.Box Ly.LibertyMeta] -> PriceConverteds -nullConvert = - let f b = PriceConverted en ac - where - p = L.boxPostFam b - en = Q.entry p - ac = Q.account p - in PriceConverteds . map f - --- | Makes PriceConverteds where commodities will have to be changed --- to a target commodity. This will fail if necessary price data is --- lacking. -converter :: - (L.Commodity, L.DateTime) - -> [L.PricePoint] - -> [L.Box Ly.LibertyMeta] - -> Ex.Exceptional X.Text PriceConverteds -converter conv pbs bs = - let f b = let p = L.boxPostFam b - en = Q.entry p - ac = Q.account p - in do - en' <- convertOne db conv en - return (PriceConverted en' ac) - db = buildDb pbs - in fmap PriceConverteds $ mapM f bs - - --- Step 2. This puts all the PriceConverteds into a flat map, where --- the key is the full account name and the value is the balance. If --- the user desired, zero balances are eliminated from the flat map. -newtype FlatMap = FlatMap { _unFlatMap :: M.Map L.Account Bal.Balance } - -toFlatMap :: TreeOpts -> PriceConverteds -> FlatMap -toFlatMap o = FlatMap . foldr f M.empty . unPriceConverteds where - remove = not . CO.unShowZeroBalances . showZeroBalances $ o - f pc m = - let a = pcAccount pc - bal = Bal.entryToBalance . pcEntry $ pc - in case M.lookup a m of - Nothing -> M.insert a bal m - Just oldBal -> - let added = Bal.addBalances oldBal bal - newBal = if remove - then Bal.removeZeroCommodities added - else Just added - in case newBal of - Nothing -> M.delete a m - Just b' -> M.insert a b' m - --- Step 3 -newtype RawBal = RawBal { unRawBal :: S.Option Bal.Balance } -instance Monoid.Monoid RawBal where - mappend (RawBal b1) (RawBal b2) = RawBal $ b1 `Monoid.mappend` b2 - mempty = RawBal Monoid.mempty - -type RawBals = NM.NestedMap L.SubAccountName RawBal - --- | Inserts a pair from the FlatMap into the Balances NestedMap. -insertBalance :: - L.Account - -> Bal.Balance - -> RawBals - -> RawBals -insertBalance a b rbs = let - rb = RawBal . S.Option . Just $ b - subs = Fdbl.toList . L.unAccount $ a - in NM.insert rbs subs rb - -rawBalances :: FlatMap -> RawBals -rawBalances (FlatMap m) = M.foldrWithKey insertBalance NM.empty m - --- Step 4 -newtype SummedBal = - SummedBal { unSummedBal :: S.Option Bal.Balance } -instance Monoid.Monoid SummedBal where - mappend (SummedBal b1) (SummedBal b2) = - SummedBal $ b1 `Monoid.mappend` b2 - mempty = SummedBal Monoid.mempty -type TotalBal = SummedBal -type SummedBals = NM.NestedMap L.SubAccountName SummedBal - -sumBalances :: RawBals -> (SummedBals, TotalBal) -sumBalances rb = (sb, (SummedBal . unRawBal $ tb)) where - (tb, rawBals) = NM.cumulativeTotal rb - sb = fmap (SummedBal . unRawBal) rawBals - --- Step 5 -type SummedWithIsEven = NM.NestedMap L.SubAccountName (SummedBal, Bool) - -makeSummedWithIsEven :: - (SummedBals, TotalBal) - -> (SummedWithIsEven, TotalBal) -makeSummedWithIsEven (sb, tb) = (swie, tb) where - swie = St.evalState (Tr.mapM f sb) False - f lbl = do - st <- St.get - St.put (not st) - return (lbl, st) - --- Step 6 -data Columns a = Columns { - account :: a - , drCr :: a - , commodity :: a - , quantity :: a - } deriving Show - -instance Functor Columns where - fmap f c = Columns { - account = f (account 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 { - account = (account fn) (account fa) - , drCr = (drCr fn) (drCr fa) - , commodity = (commodity fn) (commodity fa) - , quantity = (quantity fn) (quantity fa) - } - -data PreSpec = PreSpec { - _justification :: R.Justification - , _padSpec :: Chunk.TextSpec - , bits :: [Chunk.Chunk] } - -type PreSpecMap = NM.NestedMap L.SubAccountName (Columns PreSpec) - --- | Takes a list of triples from bottomLineChunks and creates three --- Cells, one each for DrCr, Commodity, and Qty. -bottomLineBalCells :: - Chunk.TextSpec -- ^ Fill colors - -> [(Chunk.Chunk, Chunk.Chunk, Chunk.Chunk)] - -> (PreSpec, PreSpec, PreSpec) -bottomLineBalCells spec ts = (mkSpec dc, mkSpec ct, mkSpec qt) where - mkSpec ls = PreSpec R.LeftJustify spec ls - (dc, ct, qt) = foldr f ([], [], []) ts - f (da, ca, qa) (d, c, q) = (da:d, ca:c, qa:q) - - -type IsEven = Bool - --- | Returns a triple (x, y, z), where x is the DrCr chunk, y is the --- commodity chunk, and z is the qty chunk. -bottomLineBalChunks :: - TreeOpts - -> IsEven - -> (L.Commodity, Bal.BottomLine) - -> (Chunk.Chunk, Chunk.Chunk, Chunk.Chunk) -bottomLineBalChunks os isEven (comm, bl) = (dc, cty, qty) where - dc = Chunk.chunk ts dcTxt - cty = Chunk.chunk ts ctyTxt - qty = Chunk.chunk ts qtyTxt - ctyTxt = L.text (L.Delimited (X.singleton ':') (L.textList comm)) - (ts, dcTxt, qtyTxt) = case bl of - Bal.Zero -> let - getTs = if isEven then C.evenZero else C.oddZero - dcT = X.pack "--" - qtyT = dcT - in (getTs . drCrColors $ os, dcT, qtyT) - Bal.NonZero clm -> let - (getTs, dcT) = case Bal.drCr clm of - L.Debit -> - (if isEven then C.evenDebit else C.oddDebit, - X.pack "Dr") - L.Credit -> - (if isEven then C.evenCredit else C.oddCredit, - X.pack "Cr") - qTxt = (balanceFormat os) bl - in (getTs . drCrColors $ os, dcT, qTxt) - - -fillTextSpec :: - TreeOpts - -> IsEven - -> Chunk.TextSpec -fillTextSpec os isEven = let - getTs = if isEven then C.evenColors else C.oddColors - in getTs . baseColors $ os - - -bottomLineCells :: - TreeOpts - -> IsEven - -> SummedBal - -> (PreSpec, PreSpec, PreSpec) -bottomLineCells os isEven mayBal = let - fill = fillTextSpec os isEven - tsZero = if isEven - then C.evenZero . drCrColors $ os - else C.oddZero . drCrColors $ os - zeroSpec = - PreSpec R.LeftJustify - tsZero [Chunk.chunk tsZero (X.pack "--")] - zeroSpecs = (zeroSpec, zeroSpec, zeroSpec) - in case S.getOption . unSummedBal $ mayBal of - Nothing -> zeroSpecs - Just bal -> bottomLineBalCells fill - . map (bottomLineBalChunks os isEven) - . M.assocs - . Bal.unBalance - $ bal - -padding :: Int -padding = 2 - -accountPreSpec :: - TreeOpts - -> IsEven - -> Int - -> L.SubAccountName - -> PreSpec -accountPreSpec os isEven lvl acct = PreSpec j ts [bit] where - j = R.LeftJustify - ts = if isEven - then C.evenColors . baseColors $ os - else C.oddColors . baseColors $ os - bit = Chunk.chunk ts txt where - txt = pad `X.append` (L.text acct) - pad = X.replicate (padding * lvl) (X.singleton ' ') - - -makePreSpec :: - TreeOpts - -> [(L.SubAccountName, (SummedBal, Bool))] - -> L.SubAccountName - -> (SummedBal, Bool) - -> Columns PreSpec -makePreSpec os ps a (mayBal, isEven) = Columns act dc com qt where - lvl = length ps + 1 - act = accountPreSpec os isEven lvl a - (dc, com, qt) = bottomLineCells os isEven mayBal - -traverser :: - TreeOpts - -> [(L.SubAccountName, (SummedBal, Bool))] - -> L.SubAccountName - -> (SummedBal, Bool) - -> a - -> Id.Identity (Maybe (Columns PreSpec)) -traverser os hist a mayBal _ = - return (Just $ makePreSpec os hist a mayBal) - -makePreSpecMap :: - TreeOpts - -> (SummedWithIsEven, TotalBal) - -> (PreSpecMap, TotalBal) -makePreSpecMap os (sb, tb) = (cim, tb) where - cim = Id.runIdentity (NM.traverseWithTrail (traverser os) sb) - --- Step 7 -makeTotalCells :: - TreeOpts - -> SummedBal - -> Columns PreSpec -makeTotalCells os mayBal = Columns act dc com qt where - act = accountPreSpec os True 0 tot - tot = L.SubAccountName $ L.TextNonEmpty 'T' (X.pack "otal") - (dc, com, qt) = bottomLineCells os True mayBal - -makeColumnList :: TreeOpts -> (PreSpecMap, TotalBal) -> [Columns PreSpec] -makeColumnList os (cim, tb) = totCols : restCols where - totCols = makeTotalCells os tb - restCols = Fdbl.toList cim - - --- Step 8 - --- | 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 (maximum . map Chunk.chunkWidth . 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 - - --- Step 9 -widthSpacerAcct :: Int -widthSpacerAcct = 4 - -widthSpacerDrCr :: Int -widthSpacerDrCr = 1 - -widthSpacerCommodity :: Int -widthSpacerCommodity = 1 - -colsToBits :: - TreeOpts - -> IsEven - -> Columns R.ColumnSpec - -> [Chunk.Chunk] -colsToBits os isEven (Columns a dc c q) = let - fillSpec = if isEven - then C.evenColors . baseColors $ os - else C.oddColors . baseColors $ os - spacer w = R.ColumnSpec j (Chunk.Width w) fillSpec [] - j = R.LeftJustify - cs = a - : spacer widthSpacerAcct - : dc - : spacer widthSpacerDrCr - : c - : spacer widthSpacerCommodity - : q - : [] - in R.row cs - -colsListToBits :: - TreeOpts - -> [Columns R.ColumnSpec] - -> [[Chunk.Chunk]] -colsListToBits os = zipWith f bools where - f b c = colsToBits os b c - bools = iterate not True - - --- Options -data TreeOpts = TreeOpts { - drCrColors :: C.DrCrColors - , baseColors :: C.BaseColors - , balanceFormat :: L.BottomLine -> X.Text - , showZeroBalances :: CO.ShowZeroBalances - } - --- Tie it all together - -report :: - TreeOpts - -> PriceConverteds - -> [[Chunk.Chunk]] -report os = - colsListToBits os - . resizeColumnsInList - . makeColumnList os - . makePreSpecMap os - . makeSummedWithIsEven - . sumBalances - . rawBalances - . toFlatMap os - diff --git a/Penny/Cabin/Balance/Util.hs b/Penny/Cabin/Balance/Util.hs new file mode 100644 --- /dev/null +++ b/Penny/Cabin/Balance/Util.hs @@ -0,0 +1,228 @@ +-- | 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.Lincoln.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/Chunk.hs b/Penny/Cabin/Chunk.hs --- a/Penny/Cabin/Chunk.hs +++ b/Penny/Cabin/Chunk.hs @@ -1,2408 +1,2469 @@ --- | Handles colors and special effects for text. This module was --- written using the control sequences documented for xterm in --- ctlseqs.txt, which is included in the xterm source code (on Debian --- GNU/Linux systems, it is at --- \/usr\/share\/doc\/xterm\/ctlseqs.txt.gz). The code in here should also --- work for any terminal which recognizes ISO 6429 escape sequences --- (also known as ANSI escape sequences), but only for 8 colors. This --- module also generates sequences for 256 color xterms; though this --- works fine with xterm, it might not work on other terminals (I --- believe it works for other terminals commonly found on Linux --- systems, such as gnome-terminal and Konsole, but I have not tested --- these terminals as I do not use them.) Perhaps it also works on --- Windows or Mac OS X systems and their terminals, though I have not --- tested them (in particular, Windows could be problematic as not all --- Windows terminals support ISO 6429.) --- --- In theory there are more portable ways to generate color codes, --- such as through curses (or is it ncurses?) but support for ISO 6429 --- is widespread enough that I am prepared to say that if your --- terminal does not support it, too bad; just use the colorless mode. -module Penny.Cabin.Chunk ( - -- * Colors - Colors(Colors0, Colors8, Colors256), - Background8, - Background256, - Foreground8, - Foreground256, - - -- * Chunks - Chunk, - chunk, - Width(Width, unWidth), - chunkWidth, - chunksToText, - - -- * Effects - Bold(Bold, unBold), - Underline(Underline, unUnderline), - Flash(Flash, unFlash), - Inverse(Inverse, unInverse), - - -- * Style and TextSpec - - -- | A style is a bundle of attributes that describes text - -- attributes, such as its color and whether it is bold. - StyleCommon (StyleCommon, bold, underline, flash, inverse), - Style8 (Style8, foreground8, background8, common8), - Style256 (Style256, foreground256, background256, common256), - defaultStyleCommon, - defaultStyle8, - defaultStyle256, - - TextSpec (TextSpec, style8, style256), - defaultTextSpec, - - -- * Specific colors - -- * 8 color foreground colors - color8_f_default, - color8_f_black, - color8_f_red, - color8_f_green, - color8_f_yellow, - color8_f_blue, - color8_f_magenta, - color8_f_cyan, - color8_f_white, - - -- ** 8 color background colors - color8_b_default, - color8_b_black, - color8_b_red, - color8_b_green, - color8_b_yellow, - color8_b_blue, - color8_b_magenta, - color8_b_cyan, - color8_b_white, - - -- * 256 color foreground colors - color256_f_default, - color256_f_0, - color256_f_1, - color256_f_2, - color256_f_3, - color256_f_4, - color256_f_5, - color256_f_6, - color256_f_7, - color256_f_8, - color256_f_9, - color256_f_10, - color256_f_11, - color256_f_12, - color256_f_13, - color256_f_14, - color256_f_15, - color256_f_16, - color256_f_17, - color256_f_18, - color256_f_19, - color256_f_20, - color256_f_21, - color256_f_22, - color256_f_23, - color256_f_24, - color256_f_25, - color256_f_26, - color256_f_27, - color256_f_28, - color256_f_29, - color256_f_30, - color256_f_31, - color256_f_32, - color256_f_33, - color256_f_34, - color256_f_35, - color256_f_36, - color256_f_37, - color256_f_38, - color256_f_39, - color256_f_40, - color256_f_41, - color256_f_42, - color256_f_43, - color256_f_44, - color256_f_45, - color256_f_46, - color256_f_47, - color256_f_48, - color256_f_49, - color256_f_50, - color256_f_51, - color256_f_52, - color256_f_53, - color256_f_54, - color256_f_55, - color256_f_56, - color256_f_57, - color256_f_58, - color256_f_59, - color256_f_60, - color256_f_61, - color256_f_62, - color256_f_63, - color256_f_64, - color256_f_65, - color256_f_66, - color256_f_67, - color256_f_68, - color256_f_69, - color256_f_70, - color256_f_71, - color256_f_72, - color256_f_73, - color256_f_74, - color256_f_75, - color256_f_76, - color256_f_77, - color256_f_78, - color256_f_79, - color256_f_80, - color256_f_81, - color256_f_82, - color256_f_83, - color256_f_84, - color256_f_85, - color256_f_86, - color256_f_87, - color256_f_88, - color256_f_89, - color256_f_90, - color256_f_91, - color256_f_92, - color256_f_93, - color256_f_94, - color256_f_95, - color256_f_96, - color256_f_97, - color256_f_98, - color256_f_99, - color256_f_100, - color256_f_101, - color256_f_102, - color256_f_103, - color256_f_104, - color256_f_105, - color256_f_106, - color256_f_107, - color256_f_108, - color256_f_109, - color256_f_110, - color256_f_111, - color256_f_112, - color256_f_113, - color256_f_114, - color256_f_115, - color256_f_116, - color256_f_117, - color256_f_118, - color256_f_119, - color256_f_120, - color256_f_121, - color256_f_122, - color256_f_123, - color256_f_124, - color256_f_125, - color256_f_126, - color256_f_127, - color256_f_128, - color256_f_129, - color256_f_130, - color256_f_131, - color256_f_132, - color256_f_133, - color256_f_134, - color256_f_135, - color256_f_136, - color256_f_137, - color256_f_138, - color256_f_139, - color256_f_140, - color256_f_141, - color256_f_142, - color256_f_143, - color256_f_144, - color256_f_145, - color256_f_146, - color256_f_147, - color256_f_148, - color256_f_149, - color256_f_150, - color256_f_151, - color256_f_152, - color256_f_153, - color256_f_154, - color256_f_155, - color256_f_156, - color256_f_157, - color256_f_158, - color256_f_159, - color256_f_160, - color256_f_161, - color256_f_162, - color256_f_163, - color256_f_164, - color256_f_165, - color256_f_166, - color256_f_167, - color256_f_168, - color256_f_169, - color256_f_170, - color256_f_171, - color256_f_172, - color256_f_173, - color256_f_174, - color256_f_175, - color256_f_176, - color256_f_177, - color256_f_178, - color256_f_179, - color256_f_180, - color256_f_181, - color256_f_182, - color256_f_183, - color256_f_184, - color256_f_185, - color256_f_186, - color256_f_187, - color256_f_188, - color256_f_189, - color256_f_190, - color256_f_191, - color256_f_192, - color256_f_193, - color256_f_194, - color256_f_195, - color256_f_196, - color256_f_197, - color256_f_198, - color256_f_199, - color256_f_200, - color256_f_201, - color256_f_202, - color256_f_203, - color256_f_204, - color256_f_205, - color256_f_206, - color256_f_207, - color256_f_208, - color256_f_209, - color256_f_210, - color256_f_211, - color256_f_212, - color256_f_213, - color256_f_214, - color256_f_215, - color256_f_216, - color256_f_217, - color256_f_218, - color256_f_219, - color256_f_220, - color256_f_221, - color256_f_222, - color256_f_223, - color256_f_224, - color256_f_225, - color256_f_226, - color256_f_227, - color256_f_228, - color256_f_229, - color256_f_230, - color256_f_231, - color256_f_232, - color256_f_233, - color256_f_234, - color256_f_235, - color256_f_236, - color256_f_237, - color256_f_238, - color256_f_239, - color256_f_240, - color256_f_241, - color256_f_242, - color256_f_243, - color256_f_244, - color256_f_245, - color256_f_246, - color256_f_247, - color256_f_248, - color256_f_249, - color256_f_250, - color256_f_251, - color256_f_252, - color256_f_253, - color256_f_254, - color256_f_255, - - -- ** 256 color background colors - color256_b_default, - color256_b_0, - color256_b_1, - color256_b_2, - color256_b_3, - color256_b_4, - color256_b_5, - color256_b_6, - color256_b_7, - color256_b_8, - color256_b_9, - color256_b_10, - color256_b_11, - color256_b_12, - color256_b_13, - color256_b_14, - color256_b_15, - color256_b_16, - color256_b_17, - color256_b_18, - color256_b_19, - color256_b_20, - color256_b_21, - color256_b_22, - color256_b_23, - color256_b_24, - color256_b_25, - color256_b_26, - color256_b_27, - color256_b_28, - color256_b_29, - color256_b_30, - color256_b_31, - color256_b_32, - color256_b_33, - color256_b_34, - color256_b_35, - color256_b_36, - color256_b_37, - color256_b_38, - color256_b_39, - color256_b_40, - color256_b_41, - color256_b_42, - color256_b_43, - color256_b_44, - color256_b_45, - color256_b_46, - color256_b_47, - color256_b_48, - color256_b_49, - color256_b_50, - color256_b_51, - color256_b_52, - color256_b_53, - color256_b_54, - color256_b_55, - color256_b_56, - color256_b_57, - color256_b_58, - color256_b_59, - color256_b_60, - color256_b_61, - color256_b_62, - color256_b_63, - color256_b_64, - color256_b_65, - color256_b_66, - color256_b_67, - color256_b_68, - color256_b_69, - color256_b_70, - color256_b_71, - color256_b_72, - color256_b_73, - color256_b_74, - color256_b_75, - color256_b_76, - color256_b_77, - color256_b_78, - color256_b_79, - color256_b_80, - color256_b_81, - color256_b_82, - color256_b_83, - color256_b_84, - color256_b_85, - color256_b_86, - color256_b_87, - color256_b_88, - color256_b_89, - color256_b_90, - color256_b_91, - color256_b_92, - color256_b_93, - color256_b_94, - color256_b_95, - color256_b_96, - color256_b_97, - color256_b_98, - color256_b_99, - color256_b_100, - color256_b_101, - color256_b_102, - color256_b_103, - color256_b_104, - color256_b_105, - color256_b_106, - color256_b_107, - color256_b_108, - color256_b_109, - color256_b_110, - color256_b_111, - color256_b_112, - color256_b_113, - color256_b_114, - color256_b_115, - color256_b_116, - color256_b_117, - color256_b_118, - color256_b_119, - color256_b_120, - color256_b_121, - color256_b_122, - color256_b_123, - color256_b_124, - color256_b_125, - color256_b_126, - color256_b_127, - color256_b_128, - color256_b_129, - color256_b_130, - color256_b_131, - color256_b_132, - color256_b_133, - color256_b_134, - color256_b_135, - color256_b_136, - color256_b_137, - color256_b_138, - color256_b_139, - color256_b_140, - color256_b_141, - color256_b_142, - color256_b_143, - color256_b_144, - color256_b_145, - color256_b_146, - color256_b_147, - color256_b_148, - color256_b_149, - color256_b_150, - color256_b_151, - color256_b_152, - color256_b_153, - color256_b_154, - color256_b_155, - color256_b_156, - color256_b_157, - color256_b_158, - color256_b_159, - color256_b_160, - color256_b_161, - color256_b_162, - color256_b_163, - color256_b_164, - color256_b_165, - color256_b_166, - color256_b_167, - color256_b_168, - color256_b_169, - color256_b_170, - color256_b_171, - color256_b_172, - color256_b_173, - color256_b_174, - color256_b_175, - color256_b_176, - color256_b_177, - color256_b_178, - color256_b_179, - color256_b_180, - color256_b_181, - color256_b_182, - color256_b_183, - color256_b_184, - color256_b_185, - color256_b_186, - color256_b_187, - color256_b_188, - color256_b_189, - color256_b_190, - color256_b_191, - color256_b_192, - color256_b_193, - color256_b_194, - color256_b_195, - color256_b_196, - color256_b_197, - color256_b_198, - color256_b_199, - color256_b_200, - color256_b_201, - color256_b_202, - color256_b_203, - color256_b_204, - color256_b_205, - color256_b_206, - color256_b_207, - color256_b_208, - color256_b_209, - color256_b_210, - color256_b_211, - color256_b_212, - color256_b_213, - color256_b_214, - color256_b_215, - color256_b_216, - color256_b_217, - color256_b_218, - color256_b_219, - color256_b_220, - color256_b_221, - color256_b_222, - color256_b_223, - color256_b_224, - color256_b_225, - color256_b_226, - color256_b_227, - color256_b_228, - color256_b_229, - color256_b_230, - color256_b_231, - color256_b_232, - color256_b_233, - color256_b_234, - color256_b_235, - color256_b_236, - color256_b_237, - color256_b_238, - color256_b_239, - color256_b_240, - color256_b_241, - color256_b_242, - color256_b_243, - color256_b_244, - color256_b_245, - color256_b_246, - color256_b_247, - color256_b_248, - color256_b_249, - color256_b_250, - color256_b_251, - color256_b_252, - color256_b_253, - color256_b_254, - color256_b_255 - - ) where - - -import Data.Monoid (Monoid, mempty, mappend) -import Data.Text (Text) -import qualified Data.Text as X -import qualified Data.Text.Lazy as XL -import qualified Data.Text.Lazy.Builder as TB - --- --- Colors --- - --- | How many colors to actually show. -data Colors = Colors0 | Colors8 | Colors256 - deriving Show - --- | Background color in an 8 color setting. -newtype Background8 = Background8 { unBackground8 :: Code } - --- | Background color in a 256 color setting. -newtype Background256 = Background256 { unBackground256 :: Code } - --- | Foreground color in an 8 color setting. -newtype Foreground8 = Foreground8 { unForeground8 :: Code } - --- | Foreground color in a 256 color setting. -newtype Foreground256 = Foreground256 { unForeground256 :: Code } - - --- --- Chunks --- - --- | A chunk is some textual data coupled with a description of what --- color the text is. The chunk knows what colors to use for both --- foreground color and background color, in both an 8 color terminal --- and a 256 color terminal. The chunk has only one set of color --- descriptions. To change colors, you must use a new chunk. --- --- There is no way to combine chunks. To print large numbers of --- chunks, lazily build a list of them and then print them using --- chunksToText. -data Chunk = Chunk TextSpec Text - -chunk :: TextSpec -> Text -> Chunk -chunk = Chunk - --- | How wide the text of a chunk is. -newtype Width = Width { unWidth :: Int } - deriving (Show, Eq, Ord) - -instance Monoid Width where - mempty = Width 0 - mappend (Width w1) (Width w2) = Width $ w1 + w2 - -chunkWidth :: Chunk -> Width -chunkWidth (Chunk _ t) = Width . X.length $ t - --- | Transforms chunks to a lazy Text. This function runs lazily and --- in constant time and space. -chunksToText :: Colors -> [Chunk] -> XL.Text -chunksToText c = TB.toLazyText . foldr (builder c) (printReset c) - - --- --- Effects --- -newtype Bold = Bold { unBold :: Bool } -newtype Underline = Underline { unUnderline :: Bool } -newtype Flash = Flash { unFlash :: Bool } -newtype Inverse = Inverse { unInverse :: Bool } - --- --- Styles --- - --- | Style elements that apply in both 8 and 256 color --- terminals. However, the elements are described separately for 8 and --- 256 color terminals, so that the text appearance can change --- depending on how many colors a terminal has. -data StyleCommon = StyleCommon { - bold :: Bold - , underline :: Underline - , flash :: Flash - , inverse :: Inverse } - --- | Describes text appearance (foreground and background colors, as --- well as other attributes such as bold) for an 8 color terminal. -data Style8 = Style8 { - foreground8 :: Foreground8 - , background8 :: Background8 - , common8 :: StyleCommon } - --- | Describes text appearance (foreground and background colors, as --- well as other attributes such as bold) for a 256 color terminal. -data Style256 = Style256 { - foreground256 :: Foreground256 - , background256 :: Background256 - , common256 :: StyleCommon } - --- | Has all bold, flash, underline, and inverse turned off. -defaultStyleCommon :: StyleCommon -defaultStyleCommon = StyleCommon { - bold = Bold False - , underline = Underline False - , flash = Flash False - , inverse = Inverse False } - --- | Uses the default terminal colors (which will vary depending on --- the terminal). -defaultStyle8 :: Style8 -defaultStyle8 = Style8 { - foreground8 = color8_f_default - , background8 = color8_b_default - , common8 = defaultStyleCommon } - --- | Uses the default terminal colors (which will vary depending on --- the terminal). -defaultStyle256 :: Style256 -defaultStyle256 = Style256 { - foreground256 = color256_f_default - , background256 = color256_b_default - , common256 = defaultStyleCommon } - --- --- TextSpec --- - --- | The TextSpec bundles together the styles for the 8 and 256 color --- terminals, so that the text can be portrayed on any terminal. -data TextSpec = TextSpec { - style8 :: Style8 - , style256 :: Style256 } - --- | A TextSpec with the default colors on 8 and 256 color terminals, --- with all attributes turned off. -defaultTextSpec :: TextSpec -defaultTextSpec = TextSpec { - style8 = defaultStyle8 - , style256 = defaultStyle256 } - --- --- Internal --- - -(+++) :: TB.Builder -> TB.Builder -> TB.Builder -(+++) = mappend -infixr 5 +++ - -builder :: Colors -> Chunk -> TB.Builder -> TB.Builder -builder c (Chunk ts t) acc = - printReset c - +++ textSpecCodes c ts - +++ TB.fromText t - +++ acc - -textSpecCodes :: Colors -> TextSpec -> TB.Builder -textSpecCodes c s = case c of - Colors0 -> mempty - Colors8 -> style8Colors $ style8 s - Colors256 -> style256Colors $ style256 s - -style8Colors :: Style8 -> TB.Builder -style8Colors s = - (unCode . unForeground8 . foreground8 $ s) - +++ (unCode . unBackground8 . background8 $ s) - +++ (common (common8 s)) - -style256Colors :: Style256 -> TB.Builder -style256Colors s = - (unCode . unForeground256 . foreground256 $ s) - +++ (unCode . unBackground256 . background256 $ s) - +++ (common (common256 s)) - -common :: StyleCommon -> TB.Builder -common s = - (if unBold . bold $ s then unCode boldOn else mempty) - +++ (if unUnderline . underline $ s - then unCode underlineOn else mempty) - +++ (if unFlash . flash $ s - then unCode flashOn else mempty) - +++ (if unInverse . inverse $ s - then unCode inverseOn else mempty) - -newtype Code = Code { unCode :: TB.Builder } - -code :: String -> Code -code s = Code $ - TB.fromString (toEnum 27:'[':[]) - +++ TB.fromString s - +++ TB.singleton 'm' - -boldOn :: Code -boldOn = code "1" - -underlineOn :: Code -underlineOn = code "4" - -flashOn :: Code -flashOn = code "5" - -inverseOn :: Code -inverseOn = code "7" - -resetOn :: Code -resetOn = code "0" - -printReset :: Colors -> TB.Builder -printReset c = case c of - Colors0 -> mempty - _ -> unCode resetOn - --- --- Color basement --- -color8_f_default :: Foreground8 -color8_f_default = Foreground8 . Code $ mempty - -color8_f_black :: Foreground8 -color8_f_black = Foreground8 . code $ "30" - -color8_f_red :: Foreground8 -color8_f_red = Foreground8 . code $ "31" - -color8_f_green :: Foreground8 -color8_f_green = Foreground8 . code $ "32" - -color8_f_yellow :: Foreground8 -color8_f_yellow = Foreground8 . code $ "33" - -color8_f_blue :: Foreground8 -color8_f_blue = Foreground8 . code $ "34" - -color8_f_magenta :: Foreground8 -color8_f_magenta = Foreground8 . code $ "35" - -color8_f_cyan :: Foreground8 -color8_f_cyan = Foreground8 . code $ "36" - -color8_f_white :: Foreground8 -color8_f_white = Foreground8 . code $ "37" - -color8_b_default :: Background8 -color8_b_default = Background8 . Code $ mempty - -color8_b_black :: Background8 -color8_b_black = Background8 . code $ "40" - -color8_b_red :: Background8 -color8_b_red = Background8 . code $ "41" - -color8_b_green :: Background8 -color8_b_green = Background8 . code $ "42" - -color8_b_yellow :: Background8 -color8_b_yellow = Background8 . code $ "43" - -color8_b_blue :: Background8 -color8_b_blue = Background8 . code $ "44" - -color8_b_magenta :: Background8 -color8_b_magenta = Background8 . code $ "45" - -color8_b_cyan :: Background8 -color8_b_cyan = Background8 . code $ "46" - -color8_b_white :: Background8 -color8_b_white = Background8 . code $ "47" - -color256_f_default :: Foreground256 -color256_f_default = Foreground256 . Code $ mempty - -color256_f_0 :: Foreground256 -color256_f_0 = Foreground256 . code $ "38;5;0" - -color256_f_1 :: Foreground256 -color256_f_1 = Foreground256 . code $ "38;5;1" - -color256_f_2 :: Foreground256 -color256_f_2 = Foreground256 . code $ "38;5;2" - -color256_f_3 :: Foreground256 -color256_f_3 = Foreground256 . code $ "38;5;3" - -color256_f_4 :: Foreground256 -color256_f_4 = Foreground256 . code $ "38;5;4" - -color256_f_5 :: Foreground256 -color256_f_5 = Foreground256 . code $ "38;5;5" - -color256_f_6 :: Foreground256 -color256_f_6 = Foreground256 . code $ "38;5;6" - -color256_f_7 :: Foreground256 -color256_f_7 = Foreground256 . code $ "38;5;7" - -color256_f_8 :: Foreground256 -color256_f_8 = Foreground256 . code $ "38;5;8" - -color256_f_9 :: Foreground256 -color256_f_9 = Foreground256 . code $ "38;5;9" - -color256_f_10 :: Foreground256 -color256_f_10 = Foreground256 . code $ "38;5;10" - -color256_f_11 :: Foreground256 -color256_f_11 = Foreground256 . code $ "38;5;11" - -color256_f_12 :: Foreground256 -color256_f_12 = Foreground256 . code $ "38;5;12" - -color256_f_13 :: Foreground256 -color256_f_13 = Foreground256 . code $ "38;5;13" - -color256_f_14 :: Foreground256 -color256_f_14 = Foreground256 . code $ "38;5;14" - -color256_f_15 :: Foreground256 -color256_f_15 = Foreground256 . code $ "38;5;15" - -color256_f_16 :: Foreground256 -color256_f_16 = Foreground256 . code $ "38;5;16" - -color256_f_17 :: Foreground256 -color256_f_17 = Foreground256 . code $ "38;5;17" - -color256_f_18 :: Foreground256 -color256_f_18 = Foreground256 . code $ "38;5;18" - -color256_f_19 :: Foreground256 -color256_f_19 = Foreground256 . code $ "38;5;19" - -color256_f_20 :: Foreground256 -color256_f_20 = Foreground256 . code $ "38;5;20" - -color256_f_21 :: Foreground256 -color256_f_21 = Foreground256 . code $ "38;5;21" - -color256_f_22 :: Foreground256 -color256_f_22 = Foreground256 . code $ "38;5;22" - -color256_f_23 :: Foreground256 -color256_f_23 = Foreground256 . code $ "38;5;23" - -color256_f_24 :: Foreground256 -color256_f_24 = Foreground256 . code $ "38;5;24" - -color256_f_25 :: Foreground256 -color256_f_25 = Foreground256 . code $ "38;5;25" - -color256_f_26 :: Foreground256 -color256_f_26 = Foreground256 . code $ "38;5;26" - -color256_f_27 :: Foreground256 -color256_f_27 = Foreground256 . code $ "38;5;27" - -color256_f_28 :: Foreground256 -color256_f_28 = Foreground256 . code $ "38;5;28" - -color256_f_29 :: Foreground256 -color256_f_29 = Foreground256 . code $ "38;5;29" - -color256_f_30 :: Foreground256 -color256_f_30 = Foreground256 . code $ "38;5;30" - -color256_f_31 :: Foreground256 -color256_f_31 = Foreground256 . code $ "38;5;31" - -color256_f_32 :: Foreground256 -color256_f_32 = Foreground256 . code $ "38;5;32" - -color256_f_33 :: Foreground256 -color256_f_33 = Foreground256 . code $ "38;5;33" - -color256_f_34 :: Foreground256 -color256_f_34 = Foreground256 . code $ "38;5;34" - -color256_f_35 :: Foreground256 -color256_f_35 = Foreground256 . code $ "38;5;35" - -color256_f_36 :: Foreground256 -color256_f_36 = Foreground256 . code $ "38;5;36" - -color256_f_37 :: Foreground256 -color256_f_37 = Foreground256 . code $ "38;5;37" - -color256_f_38 :: Foreground256 -color256_f_38 = Foreground256 . code $ "38;5;38" - -color256_f_39 :: Foreground256 -color256_f_39 = Foreground256 . code $ "38;5;39" - -color256_f_40 :: Foreground256 -color256_f_40 = Foreground256 . code $ "38;5;40" - -color256_f_41 :: Foreground256 -color256_f_41 = Foreground256 . code $ "38;5;41" - -color256_f_42 :: Foreground256 -color256_f_42 = Foreground256 . code $ "38;5;42" - -color256_f_43 :: Foreground256 -color256_f_43 = Foreground256 . code $ "38;5;43" - -color256_f_44 :: Foreground256 -color256_f_44 = Foreground256 . code $ "38;5;44" - -color256_f_45 :: Foreground256 -color256_f_45 = Foreground256 . code $ "38;5;45" - -color256_f_46 :: Foreground256 -color256_f_46 = Foreground256 . code $ "38;5;46" - -color256_f_47 :: Foreground256 -color256_f_47 = Foreground256 . code $ "38;5;47" - -color256_f_48 :: Foreground256 -color256_f_48 = Foreground256 . code $ "38;5;48" - -color256_f_49 :: Foreground256 -color256_f_49 = Foreground256 . code $ "38;5;49" - -color256_f_50 :: Foreground256 -color256_f_50 = Foreground256 . code $ "38;5;50" - -color256_f_51 :: Foreground256 -color256_f_51 = Foreground256 . code $ "38;5;51" - -color256_f_52 :: Foreground256 -color256_f_52 = Foreground256 . code $ "38;5;52" - -color256_f_53 :: Foreground256 -color256_f_53 = Foreground256 . code $ "38;5;53" - -color256_f_54 :: Foreground256 -color256_f_54 = Foreground256 . code $ "38;5;54" - -color256_f_55 :: Foreground256 -color256_f_55 = Foreground256 . code $ "38;5;55" - -color256_f_56 :: Foreground256 -color256_f_56 = Foreground256 . code $ "38;5;56" - -color256_f_57 :: Foreground256 -color256_f_57 = Foreground256 . code $ "38;5;57" - -color256_f_58 :: Foreground256 -color256_f_58 = Foreground256 . code $ "38;5;58" - -color256_f_59 :: Foreground256 -color256_f_59 = Foreground256 . code $ "38;5;59" - -color256_f_60 :: Foreground256 -color256_f_60 = Foreground256 . code $ "38;5;60" - -color256_f_61 :: Foreground256 -color256_f_61 = Foreground256 . code $ "38;5;61" - -color256_f_62 :: Foreground256 -color256_f_62 = Foreground256 . code $ "38;5;62" - -color256_f_63 :: Foreground256 -color256_f_63 = Foreground256 . code $ "38;5;63" - -color256_f_64 :: Foreground256 -color256_f_64 = Foreground256 . code $ "38;5;64" - -color256_f_65 :: Foreground256 -color256_f_65 = Foreground256 . code $ "38;5;65" - -color256_f_66 :: Foreground256 -color256_f_66 = Foreground256 . code $ "38;5;66" - -color256_f_67 :: Foreground256 -color256_f_67 = Foreground256 . code $ "38;5;67" - -color256_f_68 :: Foreground256 -color256_f_68 = Foreground256 . code $ "38;5;68" - -color256_f_69 :: Foreground256 -color256_f_69 = Foreground256 . code $ "38;5;69" - -color256_f_70 :: Foreground256 -color256_f_70 = Foreground256 . code $ "38;5;70" - -color256_f_71 :: Foreground256 -color256_f_71 = Foreground256 . code $ "38;5;71" - -color256_f_72 :: Foreground256 -color256_f_72 = Foreground256 . code $ "38;5;72" - -color256_f_73 :: Foreground256 -color256_f_73 = Foreground256 . code $ "38;5;73" - -color256_f_74 :: Foreground256 -color256_f_74 = Foreground256 . code $ "38;5;74" - -color256_f_75 :: Foreground256 -color256_f_75 = Foreground256 . code $ "38;5;75" - -color256_f_76 :: Foreground256 -color256_f_76 = Foreground256 . code $ "38;5;76" - -color256_f_77 :: Foreground256 -color256_f_77 = Foreground256 . code $ "38;5;77" - -color256_f_78 :: Foreground256 -color256_f_78 = Foreground256 . code $ "38;5;78" - -color256_f_79 :: Foreground256 -color256_f_79 = Foreground256 . code $ "38;5;79" - -color256_f_80 :: Foreground256 -color256_f_80 = Foreground256 . code $ "38;5;80" - -color256_f_81 :: Foreground256 -color256_f_81 = Foreground256 . code $ "38;5;81" - -color256_f_82 :: Foreground256 -color256_f_82 = Foreground256 . code $ "38;5;82" - -color256_f_83 :: Foreground256 -color256_f_83 = Foreground256 . code $ "38;5;83" - -color256_f_84 :: Foreground256 -color256_f_84 = Foreground256 . code $ "38;5;84" - -color256_f_85 :: Foreground256 -color256_f_85 = Foreground256 . code $ "38;5;85" - -color256_f_86 :: Foreground256 -color256_f_86 = Foreground256 . code $ "38;5;86" - -color256_f_87 :: Foreground256 -color256_f_87 = Foreground256 . code $ "38;5;87" - -color256_f_88 :: Foreground256 -color256_f_88 = Foreground256 . code $ "38;5;88" - -color256_f_89 :: Foreground256 -color256_f_89 = Foreground256 . code $ "38;5;89" - -color256_f_90 :: Foreground256 -color256_f_90 = Foreground256 . code $ "38;5;90" - -color256_f_91 :: Foreground256 -color256_f_91 = Foreground256 . code $ "38;5;91" - -color256_f_92 :: Foreground256 -color256_f_92 = Foreground256 . code $ "38;5;92" - -color256_f_93 :: Foreground256 -color256_f_93 = Foreground256 . code $ "38;5;93" - -color256_f_94 :: Foreground256 -color256_f_94 = Foreground256 . code $ "38;5;94" - -color256_f_95 :: Foreground256 -color256_f_95 = Foreground256 . code $ "38;5;95" - -color256_f_96 :: Foreground256 -color256_f_96 = Foreground256 . code $ "38;5;96" - -color256_f_97 :: Foreground256 -color256_f_97 = Foreground256 . code $ "38;5;97" - -color256_f_98 :: Foreground256 -color256_f_98 = Foreground256 . code $ "38;5;98" - -color256_f_99 :: Foreground256 -color256_f_99 = Foreground256 . code $ "38;5;99" - -color256_f_100 :: Foreground256 -color256_f_100 = Foreground256 . code $ "38;5;100" - -color256_f_101 :: Foreground256 -color256_f_101 = Foreground256 . code $ "38;5;101" - -color256_f_102 :: Foreground256 -color256_f_102 = Foreground256 . code $ "38;5;102" - -color256_f_103 :: Foreground256 -color256_f_103 = Foreground256 . code $ "38;5;103" - -color256_f_104 :: Foreground256 -color256_f_104 = Foreground256 . code $ "38;5;104" - -color256_f_105 :: Foreground256 -color256_f_105 = Foreground256 . code $ "38;5;105" - -color256_f_106 :: Foreground256 -color256_f_106 = Foreground256 . code $ "38;5;106" - -color256_f_107 :: Foreground256 -color256_f_107 = Foreground256 . code $ "38;5;107" - -color256_f_108 :: Foreground256 -color256_f_108 = Foreground256 . code $ "38;5;108" - -color256_f_109 :: Foreground256 -color256_f_109 = Foreground256 . code $ "38;5;109" - -color256_f_110 :: Foreground256 -color256_f_110 = Foreground256 . code $ "38;5;110" - -color256_f_111 :: Foreground256 -color256_f_111 = Foreground256 . code $ "38;5;111" - -color256_f_112 :: Foreground256 -color256_f_112 = Foreground256 . code $ "38;5;112" - -color256_f_113 :: Foreground256 -color256_f_113 = Foreground256 . code $ "38;5;113" - -color256_f_114 :: Foreground256 -color256_f_114 = Foreground256 . code $ "38;5;114" - -color256_f_115 :: Foreground256 -color256_f_115 = Foreground256 . code $ "38;5;115" - -color256_f_116 :: Foreground256 -color256_f_116 = Foreground256 . code $ "38;5;116" - -color256_f_117 :: Foreground256 -color256_f_117 = Foreground256 . code $ "38;5;117" - -color256_f_118 :: Foreground256 -color256_f_118 = Foreground256 . code $ "38;5;118" - -color256_f_119 :: Foreground256 -color256_f_119 = Foreground256 . code $ "38;5;119" - -color256_f_120 :: Foreground256 -color256_f_120 = Foreground256 . code $ "38;5;120" - -color256_f_121 :: Foreground256 -color256_f_121 = Foreground256 . code $ "38;5;121" - -color256_f_122 :: Foreground256 -color256_f_122 = Foreground256 . code $ "38;5;122" - -color256_f_123 :: Foreground256 -color256_f_123 = Foreground256 . code $ "38;5;123" - -color256_f_124 :: Foreground256 -color256_f_124 = Foreground256 . code $ "38;5;124" - -color256_f_125 :: Foreground256 -color256_f_125 = Foreground256 . code $ "38;5;125" - -color256_f_126 :: Foreground256 -color256_f_126 = Foreground256 . code $ "38;5;126" - -color256_f_127 :: Foreground256 -color256_f_127 = Foreground256 . code $ "38;5;127" - -color256_f_128 :: Foreground256 -color256_f_128 = Foreground256 . code $ "38;5;128" - -color256_f_129 :: Foreground256 -color256_f_129 = Foreground256 . code $ "38;5;129" - -color256_f_130 :: Foreground256 -color256_f_130 = Foreground256 . code $ "38;5;130" - -color256_f_131 :: Foreground256 -color256_f_131 = Foreground256 . code $ "38;5;131" - -color256_f_132 :: Foreground256 -color256_f_132 = Foreground256 . code $ "38;5;132" - -color256_f_133 :: Foreground256 -color256_f_133 = Foreground256 . code $ "38;5;133" - -color256_f_134 :: Foreground256 -color256_f_134 = Foreground256 . code $ "38;5;134" - -color256_f_135 :: Foreground256 -color256_f_135 = Foreground256 . code $ "38;5;135" - -color256_f_136 :: Foreground256 -color256_f_136 = Foreground256 . code $ "38;5;136" - -color256_f_137 :: Foreground256 -color256_f_137 = Foreground256 . code $ "38;5;137" - -color256_f_138 :: Foreground256 -color256_f_138 = Foreground256 . code $ "38;5;138" - -color256_f_139 :: Foreground256 -color256_f_139 = Foreground256 . code $ "38;5;139" - -color256_f_140 :: Foreground256 -color256_f_140 = Foreground256 . code $ "38;5;140" - -color256_f_141 :: Foreground256 -color256_f_141 = Foreground256 . code $ "38;5;141" - -color256_f_142 :: Foreground256 -color256_f_142 = Foreground256 . code $ "38;5;142" - -color256_f_143 :: Foreground256 -color256_f_143 = Foreground256 . code $ "38;5;143" - -color256_f_144 :: Foreground256 -color256_f_144 = Foreground256 . code $ "38;5;144" - -color256_f_145 :: Foreground256 -color256_f_145 = Foreground256 . code $ "38;5;145" - -color256_f_146 :: Foreground256 -color256_f_146 = Foreground256 . code $ "38;5;146" - -color256_f_147 :: Foreground256 -color256_f_147 = Foreground256 . code $ "38;5;147" - -color256_f_148 :: Foreground256 -color256_f_148 = Foreground256 . code $ "38;5;148" - -color256_f_149 :: Foreground256 -color256_f_149 = Foreground256 . code $ "38;5;149" - -color256_f_150 :: Foreground256 -color256_f_150 = Foreground256 . code $ "38;5;150" - -color256_f_151 :: Foreground256 -color256_f_151 = Foreground256 . code $ "38;5;151" - -color256_f_152 :: Foreground256 -color256_f_152 = Foreground256 . code $ "38;5;152" - -color256_f_153 :: Foreground256 -color256_f_153 = Foreground256 . code $ "38;5;153" - -color256_f_154 :: Foreground256 -color256_f_154 = Foreground256 . code $ "38;5;154" - -color256_f_155 :: Foreground256 -color256_f_155 = Foreground256 . code $ "38;5;155" - -color256_f_156 :: Foreground256 -color256_f_156 = Foreground256 . code $ "38;5;156" - -color256_f_157 :: Foreground256 -color256_f_157 = Foreground256 . code $ "38;5;157" - -color256_f_158 :: Foreground256 -color256_f_158 = Foreground256 . code $ "38;5;158" - -color256_f_159 :: Foreground256 -color256_f_159 = Foreground256 . code $ "38;5;159" - -color256_f_160 :: Foreground256 -color256_f_160 = Foreground256 . code $ "38;5;160" - -color256_f_161 :: Foreground256 -color256_f_161 = Foreground256 . code $ "38;5;161" - -color256_f_162 :: Foreground256 -color256_f_162 = Foreground256 . code $ "38;5;162" - -color256_f_163 :: Foreground256 -color256_f_163 = Foreground256 . code $ "38;5;163" - -color256_f_164 :: Foreground256 -color256_f_164 = Foreground256 . code $ "38;5;164" - -color256_f_165 :: Foreground256 -color256_f_165 = Foreground256 . code $ "38;5;165" - -color256_f_166 :: Foreground256 -color256_f_166 = Foreground256 . code $ "38;5;166" - -color256_f_167 :: Foreground256 -color256_f_167 = Foreground256 . code $ "38;5;167" - -color256_f_168 :: Foreground256 -color256_f_168 = Foreground256 . code $ "38;5;168" - -color256_f_169 :: Foreground256 -color256_f_169 = Foreground256 . code $ "38;5;169" - -color256_f_170 :: Foreground256 -color256_f_170 = Foreground256 . code $ "38;5;170" - -color256_f_171 :: Foreground256 -color256_f_171 = Foreground256 . code $ "38;5;171" - -color256_f_172 :: Foreground256 -color256_f_172 = Foreground256 . code $ "38;5;172" - -color256_f_173 :: Foreground256 -color256_f_173 = Foreground256 . code $ "38;5;173" - -color256_f_174 :: Foreground256 -color256_f_174 = Foreground256 . code $ "38;5;174" - -color256_f_175 :: Foreground256 -color256_f_175 = Foreground256 . code $ "38;5;175" - -color256_f_176 :: Foreground256 -color256_f_176 = Foreground256 . code $ "38;5;176" - -color256_f_177 :: Foreground256 -color256_f_177 = Foreground256 . code $ "38;5;177" - -color256_f_178 :: Foreground256 -color256_f_178 = Foreground256 . code $ "38;5;178" - -color256_f_179 :: Foreground256 -color256_f_179 = Foreground256 . code $ "38;5;179" - -color256_f_180 :: Foreground256 -color256_f_180 = Foreground256 . code $ "38;5;180" - -color256_f_181 :: Foreground256 -color256_f_181 = Foreground256 . code $ "38;5;181" - -color256_f_182 :: Foreground256 -color256_f_182 = Foreground256 . code $ "38;5;182" - -color256_f_183 :: Foreground256 -color256_f_183 = Foreground256 . code $ "38;5;183" - -color256_f_184 :: Foreground256 -color256_f_184 = Foreground256 . code $ "38;5;184" - -color256_f_185 :: Foreground256 -color256_f_185 = Foreground256 . code $ "38;5;185" - -color256_f_186 :: Foreground256 -color256_f_186 = Foreground256 . code $ "38;5;186" - -color256_f_187 :: Foreground256 -color256_f_187 = Foreground256 . code $ "38;5;187" - -color256_f_188 :: Foreground256 -color256_f_188 = Foreground256 . code $ "38;5;188" - -color256_f_189 :: Foreground256 -color256_f_189 = Foreground256 . code $ "38;5;189" - -color256_f_190 :: Foreground256 -color256_f_190 = Foreground256 . code $ "38;5;190" - -color256_f_191 :: Foreground256 -color256_f_191 = Foreground256 . code $ "38;5;191" - -color256_f_192 :: Foreground256 -color256_f_192 = Foreground256 . code $ "38;5;192" - -color256_f_193 :: Foreground256 -color256_f_193 = Foreground256 . code $ "38;5;193" - -color256_f_194 :: Foreground256 -color256_f_194 = Foreground256 . code $ "38;5;194" - -color256_f_195 :: Foreground256 -color256_f_195 = Foreground256 . code $ "38;5;195" - -color256_f_196 :: Foreground256 -color256_f_196 = Foreground256 . code $ "38;5;196" - -color256_f_197 :: Foreground256 -color256_f_197 = Foreground256 . code $ "38;5;197" - -color256_f_198 :: Foreground256 -color256_f_198 = Foreground256 . code $ "38;5;198" - -color256_f_199 :: Foreground256 -color256_f_199 = Foreground256 . code $ "38;5;199" - -color256_f_200 :: Foreground256 -color256_f_200 = Foreground256 . code $ "38;5;200" - -color256_f_201 :: Foreground256 -color256_f_201 = Foreground256 . code $ "38;5;201" - -color256_f_202 :: Foreground256 -color256_f_202 = Foreground256 . code $ "38;5;202" - -color256_f_203 :: Foreground256 -color256_f_203 = Foreground256 . code $ "38;5;203" - -color256_f_204 :: Foreground256 -color256_f_204 = Foreground256 . code $ "38;5;204" - -color256_f_205 :: Foreground256 -color256_f_205 = Foreground256 . code $ "38;5;205" - -color256_f_206 :: Foreground256 -color256_f_206 = Foreground256 . code $ "38;5;206" - -color256_f_207 :: Foreground256 -color256_f_207 = Foreground256 . code $ "38;5;207" - -color256_f_208 :: Foreground256 -color256_f_208 = Foreground256 . code $ "38;5;208" - -color256_f_209 :: Foreground256 -color256_f_209 = Foreground256 . code $ "38;5;209" - -color256_f_210 :: Foreground256 -color256_f_210 = Foreground256 . code $ "38;5;210" - -color256_f_211 :: Foreground256 -color256_f_211 = Foreground256 . code $ "38;5;211" - -color256_f_212 :: Foreground256 -color256_f_212 = Foreground256 . code $ "38;5;212" - -color256_f_213 :: Foreground256 -color256_f_213 = Foreground256 . code $ "38;5;213" - -color256_f_214 :: Foreground256 -color256_f_214 = Foreground256 . code $ "38;5;214" - -color256_f_215 :: Foreground256 -color256_f_215 = Foreground256 . code $ "38;5;215" - -color256_f_216 :: Foreground256 -color256_f_216 = Foreground256 . code $ "38;5;216" - -color256_f_217 :: Foreground256 -color256_f_217 = Foreground256 . code $ "38;5;217" - -color256_f_218 :: Foreground256 -color256_f_218 = Foreground256 . code $ "38;5;218" - -color256_f_219 :: Foreground256 -color256_f_219 = Foreground256 . code $ "38;5;219" - -color256_f_220 :: Foreground256 -color256_f_220 = Foreground256 . code $ "38;5;220" - -color256_f_221 :: Foreground256 -color256_f_221 = Foreground256 . code $ "38;5;221" - -color256_f_222 :: Foreground256 -color256_f_222 = Foreground256 . code $ "38;5;222" - -color256_f_223 :: Foreground256 -color256_f_223 = Foreground256 . code $ "38;5;223" - -color256_f_224 :: Foreground256 -color256_f_224 = Foreground256 . code $ "38;5;224" - -color256_f_225 :: Foreground256 -color256_f_225 = Foreground256 . code $ "38;5;225" - -color256_f_226 :: Foreground256 -color256_f_226 = Foreground256 . code $ "38;5;226" - -color256_f_227 :: Foreground256 -color256_f_227 = Foreground256 . code $ "38;5;227" - -color256_f_228 :: Foreground256 -color256_f_228 = Foreground256 . code $ "38;5;228" - -color256_f_229 :: Foreground256 -color256_f_229 = Foreground256 . code $ "38;5;229" - -color256_f_230 :: Foreground256 -color256_f_230 = Foreground256 . code $ "38;5;230" - -color256_f_231 :: Foreground256 -color256_f_231 = Foreground256 . code $ "38;5;231" - -color256_f_232 :: Foreground256 -color256_f_232 = Foreground256 . code $ "38;5;232" - -color256_f_233 :: Foreground256 -color256_f_233 = Foreground256 . code $ "38;5;233" - -color256_f_234 :: Foreground256 -color256_f_234 = Foreground256 . code $ "38;5;234" - -color256_f_235 :: Foreground256 -color256_f_235 = Foreground256 . code $ "38;5;235" - -color256_f_236 :: Foreground256 -color256_f_236 = Foreground256 . code $ "38;5;236" - -color256_f_237 :: Foreground256 -color256_f_237 = Foreground256 . code $ "38;5;237" - -color256_f_238 :: Foreground256 -color256_f_238 = Foreground256 . code $ "38;5;238" - -color256_f_239 :: Foreground256 -color256_f_239 = Foreground256 . code $ "38;5;239" - -color256_f_240 :: Foreground256 -color256_f_240 = Foreground256 . code $ "38;5;240" - -color256_f_241 :: Foreground256 -color256_f_241 = Foreground256 . code $ "38;5;241" - -color256_f_242 :: Foreground256 -color256_f_242 = Foreground256 . code $ "38;5;242" - -color256_f_243 :: Foreground256 -color256_f_243 = Foreground256 . code $ "38;5;243" - -color256_f_244 :: Foreground256 -color256_f_244 = Foreground256 . code $ "38;5;244" - -color256_f_245 :: Foreground256 -color256_f_245 = Foreground256 . code $ "38;5;245" - -color256_f_246 :: Foreground256 -color256_f_246 = Foreground256 . code $ "38;5;246" - -color256_f_247 :: Foreground256 -color256_f_247 = Foreground256 . code $ "38;5;247" - -color256_f_248 :: Foreground256 -color256_f_248 = Foreground256 . code $ "38;5;248" - -color256_f_249 :: Foreground256 -color256_f_249 = Foreground256 . code $ "38;5;249" - -color256_f_250 :: Foreground256 -color256_f_250 = Foreground256 . code $ "38;5;250" - -color256_f_251 :: Foreground256 -color256_f_251 = Foreground256 . code $ "38;5;251" - -color256_f_252 :: Foreground256 -color256_f_252 = Foreground256 . code $ "38;5;252" - -color256_f_253 :: Foreground256 -color256_f_253 = Foreground256 . code $ "38;5;253" - -color256_f_254 :: Foreground256 -color256_f_254 = Foreground256 . code $ "38;5;254" - -color256_f_255 :: Foreground256 -color256_f_255 = Foreground256 . code $ "38;5;255" - -color256_b_default :: Background256 -color256_b_default = Background256 . Code $ mempty - -color256_b_0 :: Background256 -color256_b_0 = Background256 . code $ "48;5;0" - -color256_b_1 :: Background256 -color256_b_1 = Background256 . code $ "48;5;1" - -color256_b_2 :: Background256 -color256_b_2 = Background256 . code $ "48;5;2" - -color256_b_3 :: Background256 -color256_b_3 = Background256 . code $ "48;5;3" - -color256_b_4 :: Background256 -color256_b_4 = Background256 . code $ "48;5;4" - -color256_b_5 :: Background256 -color256_b_5 = Background256 . code $ "48;5;5" - -color256_b_6 :: Background256 -color256_b_6 = Background256 . code $ "48;5;6" - -color256_b_7 :: Background256 -color256_b_7 = Background256 . code $ "48;5;7" - -color256_b_8 :: Background256 -color256_b_8 = Background256 . code $ "48;5;8" - -color256_b_9 :: Background256 -color256_b_9 = Background256 . code $ "48;5;9" - -color256_b_10 :: Background256 -color256_b_10 = Background256 . code $ "48;5;10" - -color256_b_11 :: Background256 -color256_b_11 = Background256 . code $ "48;5;11" - -color256_b_12 :: Background256 -color256_b_12 = Background256 . code $ "48;5;12" - -color256_b_13 :: Background256 -color256_b_13 = Background256 . code $ "48;5;13" - -color256_b_14 :: Background256 -color256_b_14 = Background256 . code $ "48;5;14" - -color256_b_15 :: Background256 -color256_b_15 = Background256 . code $ "48;5;15" - -color256_b_16 :: Background256 -color256_b_16 = Background256 . code $ "48;5;16" - -color256_b_17 :: Background256 -color256_b_17 = Background256 . code $ "48;5;17" - -color256_b_18 :: Background256 -color256_b_18 = Background256 . code $ "48;5;18" - -color256_b_19 :: Background256 -color256_b_19 = Background256 . code $ "48;5;19" - -color256_b_20 :: Background256 -color256_b_20 = Background256 . code $ "48;5;20" - -color256_b_21 :: Background256 -color256_b_21 = Background256 . code $ "48;5;21" - -color256_b_22 :: Background256 -color256_b_22 = Background256 . code $ "48;5;22" - -color256_b_23 :: Background256 -color256_b_23 = Background256 . code $ "48;5;23" - -color256_b_24 :: Background256 -color256_b_24 = Background256 . code $ "48;5;24" - -color256_b_25 :: Background256 -color256_b_25 = Background256 . code $ "48;5;25" - -color256_b_26 :: Background256 -color256_b_26 = Background256 . code $ "48;5;26" - -color256_b_27 :: Background256 -color256_b_27 = Background256 . code $ "48;5;27" - -color256_b_28 :: Background256 -color256_b_28 = Background256 . code $ "48;5;28" - -color256_b_29 :: Background256 -color256_b_29 = Background256 . code $ "48;5;29" - -color256_b_30 :: Background256 -color256_b_30 = Background256 . code $ "48;5;30" - -color256_b_31 :: Background256 -color256_b_31 = Background256 . code $ "48;5;31" - -color256_b_32 :: Background256 -color256_b_32 = Background256 . code $ "48;5;32" - -color256_b_33 :: Background256 -color256_b_33 = Background256 . code $ "48;5;33" - -color256_b_34 :: Background256 -color256_b_34 = Background256 . code $ "48;5;34" - -color256_b_35 :: Background256 -color256_b_35 = Background256 . code $ "48;5;35" - -color256_b_36 :: Background256 -color256_b_36 = Background256 . code $ "48;5;36" - -color256_b_37 :: Background256 -color256_b_37 = Background256 . code $ "48;5;37" - -color256_b_38 :: Background256 -color256_b_38 = Background256 . code $ "48;5;38" - -color256_b_39 :: Background256 -color256_b_39 = Background256 . code $ "48;5;39" - -color256_b_40 :: Background256 -color256_b_40 = Background256 . code $ "48;5;40" - -color256_b_41 :: Background256 -color256_b_41 = Background256 . code $ "48;5;41" - -color256_b_42 :: Background256 -color256_b_42 = Background256 . code $ "48;5;42" - -color256_b_43 :: Background256 -color256_b_43 = Background256 . code $ "48;5;43" - -color256_b_44 :: Background256 -color256_b_44 = Background256 . code $ "48;5;44" - -color256_b_45 :: Background256 -color256_b_45 = Background256 . code $ "48;5;45" - -color256_b_46 :: Background256 -color256_b_46 = Background256 . code $ "48;5;46" - -color256_b_47 :: Background256 -color256_b_47 = Background256 . code $ "48;5;47" - -color256_b_48 :: Background256 -color256_b_48 = Background256 . code $ "48;5;48" - -color256_b_49 :: Background256 -color256_b_49 = Background256 . code $ "48;5;49" - -color256_b_50 :: Background256 -color256_b_50 = Background256 . code $ "48;5;50" - -color256_b_51 :: Background256 -color256_b_51 = Background256 . code $ "48;5;51" - -color256_b_52 :: Background256 -color256_b_52 = Background256 . code $ "48;5;52" - -color256_b_53 :: Background256 -color256_b_53 = Background256 . code $ "48;5;53" - -color256_b_54 :: Background256 -color256_b_54 = Background256 . code $ "48;5;54" - -color256_b_55 :: Background256 -color256_b_55 = Background256 . code $ "48;5;55" - -color256_b_56 :: Background256 -color256_b_56 = Background256 . code $ "48;5;56" - -color256_b_57 :: Background256 -color256_b_57 = Background256 . code $ "48;5;57" - -color256_b_58 :: Background256 -color256_b_58 = Background256 . code $ "48;5;58" - -color256_b_59 :: Background256 -color256_b_59 = Background256 . code $ "48;5;59" - -color256_b_60 :: Background256 -color256_b_60 = Background256 . code $ "48;5;60" - -color256_b_61 :: Background256 -color256_b_61 = Background256 . code $ "48;5;61" - -color256_b_62 :: Background256 -color256_b_62 = Background256 . code $ "48;5;62" - -color256_b_63 :: Background256 -color256_b_63 = Background256 . code $ "48;5;63" - -color256_b_64 :: Background256 -color256_b_64 = Background256 . code $ "48;5;64" - -color256_b_65 :: Background256 -color256_b_65 = Background256 . code $ "48;5;65" - -color256_b_66 :: Background256 -color256_b_66 = Background256 . code $ "48;5;66" - -color256_b_67 :: Background256 -color256_b_67 = Background256 . code $ "48;5;67" - -color256_b_68 :: Background256 -color256_b_68 = Background256 . code $ "48;5;68" - -color256_b_69 :: Background256 -color256_b_69 = Background256 . code $ "48;5;69" - -color256_b_70 :: Background256 -color256_b_70 = Background256 . code $ "48;5;70" - -color256_b_71 :: Background256 -color256_b_71 = Background256 . code $ "48;5;71" - -color256_b_72 :: Background256 -color256_b_72 = Background256 . code $ "48;5;72" - -color256_b_73 :: Background256 -color256_b_73 = Background256 . code $ "48;5;73" - -color256_b_74 :: Background256 -color256_b_74 = Background256 . code $ "48;5;74" - -color256_b_75 :: Background256 -color256_b_75 = Background256 . code $ "48;5;75" - -color256_b_76 :: Background256 -color256_b_76 = Background256 . code $ "48;5;76" - -color256_b_77 :: Background256 -color256_b_77 = Background256 . code $ "48;5;77" - -color256_b_78 :: Background256 -color256_b_78 = Background256 . code $ "48;5;78" - -color256_b_79 :: Background256 -color256_b_79 = Background256 . code $ "48;5;79" - -color256_b_80 :: Background256 -color256_b_80 = Background256 . code $ "48;5;80" - -color256_b_81 :: Background256 -color256_b_81 = Background256 . code $ "48;5;81" - -color256_b_82 :: Background256 -color256_b_82 = Background256 . code $ "48;5;82" - -color256_b_83 :: Background256 -color256_b_83 = Background256 . code $ "48;5;83" - -color256_b_84 :: Background256 -color256_b_84 = Background256 . code $ "48;5;84" - -color256_b_85 :: Background256 -color256_b_85 = Background256 . code $ "48;5;85" - -color256_b_86 :: Background256 -color256_b_86 = Background256 . code $ "48;5;86" - -color256_b_87 :: Background256 -color256_b_87 = Background256 . code $ "48;5;87" - -color256_b_88 :: Background256 -color256_b_88 = Background256 . code $ "48;5;88" - -color256_b_89 :: Background256 -color256_b_89 = Background256 . code $ "48;5;89" - -color256_b_90 :: Background256 -color256_b_90 = Background256 . code $ "48;5;90" - -color256_b_91 :: Background256 -color256_b_91 = Background256 . code $ "48;5;91" - -color256_b_92 :: Background256 -color256_b_92 = Background256 . code $ "48;5;92" - -color256_b_93 :: Background256 -color256_b_93 = Background256 . code $ "48;5;93" - -color256_b_94 :: Background256 -color256_b_94 = Background256 . code $ "48;5;94" - -color256_b_95 :: Background256 -color256_b_95 = Background256 . code $ "48;5;95" - -color256_b_96 :: Background256 -color256_b_96 = Background256 . code $ "48;5;96" - -color256_b_97 :: Background256 -color256_b_97 = Background256 . code $ "48;5;97" - -color256_b_98 :: Background256 -color256_b_98 = Background256 . code $ "48;5;98" - -color256_b_99 :: Background256 -color256_b_99 = Background256 . code $ "48;5;99" - -color256_b_100 :: Background256 -color256_b_100 = Background256 . code $ "48;5;100" - -color256_b_101 :: Background256 -color256_b_101 = Background256 . code $ "48;5;101" - -color256_b_102 :: Background256 -color256_b_102 = Background256 . code $ "48;5;102" - -color256_b_103 :: Background256 -color256_b_103 = Background256 . code $ "48;5;103" - -color256_b_104 :: Background256 -color256_b_104 = Background256 . code $ "48;5;104" - -color256_b_105 :: Background256 -color256_b_105 = Background256 . code $ "48;5;105" - -color256_b_106 :: Background256 -color256_b_106 = Background256 . code $ "48;5;106" - -color256_b_107 :: Background256 -color256_b_107 = Background256 . code $ "48;5;107" - -color256_b_108 :: Background256 -color256_b_108 = Background256 . code $ "48;5;108" - -color256_b_109 :: Background256 -color256_b_109 = Background256 . code $ "48;5;109" - -color256_b_110 :: Background256 -color256_b_110 = Background256 . code $ "48;5;110" - -color256_b_111 :: Background256 -color256_b_111 = Background256 . code $ "48;5;111" - -color256_b_112 :: Background256 -color256_b_112 = Background256 . code $ "48;5;112" - -color256_b_113 :: Background256 -color256_b_113 = Background256 . code $ "48;5;113" - -color256_b_114 :: Background256 -color256_b_114 = Background256 . code $ "48;5;114" - -color256_b_115 :: Background256 -color256_b_115 = Background256 . code $ "48;5;115" - -color256_b_116 :: Background256 -color256_b_116 = Background256 . code $ "48;5;116" - -color256_b_117 :: Background256 -color256_b_117 = Background256 . code $ "48;5;117" - -color256_b_118 :: Background256 -color256_b_118 = Background256 . code $ "48;5;118" - -color256_b_119 :: Background256 -color256_b_119 = Background256 . code $ "48;5;119" - -color256_b_120 :: Background256 -color256_b_120 = Background256 . code $ "48;5;120" - -color256_b_121 :: Background256 -color256_b_121 = Background256 . code $ "48;5;121" - -color256_b_122 :: Background256 -color256_b_122 = Background256 . code $ "48;5;122" - -color256_b_123 :: Background256 -color256_b_123 = Background256 . code $ "48;5;123" - -color256_b_124 :: Background256 -color256_b_124 = Background256 . code $ "48;5;124" - -color256_b_125 :: Background256 -color256_b_125 = Background256 . code $ "48;5;125" - -color256_b_126 :: Background256 -color256_b_126 = Background256 . code $ "48;5;126" - -color256_b_127 :: Background256 -color256_b_127 = Background256 . code $ "48;5;127" - -color256_b_128 :: Background256 -color256_b_128 = Background256 . code $ "48;5;128" - -color256_b_129 :: Background256 -color256_b_129 = Background256 . code $ "48;5;129" - -color256_b_130 :: Background256 -color256_b_130 = Background256 . code $ "48;5;130" - -color256_b_131 :: Background256 -color256_b_131 = Background256 . code $ "48;5;131" - -color256_b_132 :: Background256 -color256_b_132 = Background256 . code $ "48;5;132" - -color256_b_133 :: Background256 -color256_b_133 = Background256 . code $ "48;5;133" - -color256_b_134 :: Background256 -color256_b_134 = Background256 . code $ "48;5;134" - -color256_b_135 :: Background256 -color256_b_135 = Background256 . code $ "48;5;135" - -color256_b_136 :: Background256 -color256_b_136 = Background256 . code $ "48;5;136" - -color256_b_137 :: Background256 -color256_b_137 = Background256 . code $ "48;5;137" - -color256_b_138 :: Background256 -color256_b_138 = Background256 . code $ "48;5;138" - -color256_b_139 :: Background256 -color256_b_139 = Background256 . code $ "48;5;139" - -color256_b_140 :: Background256 -color256_b_140 = Background256 . code $ "48;5;140" - -color256_b_141 :: Background256 -color256_b_141 = Background256 . code $ "48;5;141" - -color256_b_142 :: Background256 -color256_b_142 = Background256 . code $ "48;5;142" - -color256_b_143 :: Background256 -color256_b_143 = Background256 . code $ "48;5;143" - -color256_b_144 :: Background256 -color256_b_144 = Background256 . code $ "48;5;144" - -color256_b_145 :: Background256 -color256_b_145 = Background256 . code $ "48;5;145" - -color256_b_146 :: Background256 -color256_b_146 = Background256 . code $ "48;5;146" - -color256_b_147 :: Background256 -color256_b_147 = Background256 . code $ "48;5;147" - -color256_b_148 :: Background256 -color256_b_148 = Background256 . code $ "48;5;148" - -color256_b_149 :: Background256 -color256_b_149 = Background256 . code $ "48;5;149" - -color256_b_150 :: Background256 -color256_b_150 = Background256 . code $ "48;5;150" - -color256_b_151 :: Background256 -color256_b_151 = Background256 . code $ "48;5;151" - -color256_b_152 :: Background256 -color256_b_152 = Background256 . code $ "48;5;152" - -color256_b_153 :: Background256 -color256_b_153 = Background256 . code $ "48;5;153" - -color256_b_154 :: Background256 -color256_b_154 = Background256 . code $ "48;5;154" - -color256_b_155 :: Background256 -color256_b_155 = Background256 . code $ "48;5;155" - -color256_b_156 :: Background256 -color256_b_156 = Background256 . code $ "48;5;156" - -color256_b_157 :: Background256 -color256_b_157 = Background256 . code $ "48;5;157" - -color256_b_158 :: Background256 -color256_b_158 = Background256 . code $ "48;5;158" - -color256_b_159 :: Background256 -color256_b_159 = Background256 . code $ "48;5;159" - -color256_b_160 :: Background256 -color256_b_160 = Background256 . code $ "48;5;160" - -color256_b_161 :: Background256 -color256_b_161 = Background256 . code $ "48;5;161" - -color256_b_162 :: Background256 -color256_b_162 = Background256 . code $ "48;5;162" - -color256_b_163 :: Background256 -color256_b_163 = Background256 . code $ "48;5;163" - -color256_b_164 :: Background256 -color256_b_164 = Background256 . code $ "48;5;164" - -color256_b_165 :: Background256 -color256_b_165 = Background256 . code $ "48;5;165" - -color256_b_166 :: Background256 -color256_b_166 = Background256 . code $ "48;5;166" - -color256_b_167 :: Background256 -color256_b_167 = Background256 . code $ "48;5;167" - -color256_b_168 :: Background256 -color256_b_168 = Background256 . code $ "48;5;168" - -color256_b_169 :: Background256 -color256_b_169 = Background256 . code $ "48;5;169" - -color256_b_170 :: Background256 -color256_b_170 = Background256 . code $ "48;5;170" - -color256_b_171 :: Background256 -color256_b_171 = Background256 . code $ "48;5;171" - -color256_b_172 :: Background256 -color256_b_172 = Background256 . code $ "48;5;172" - -color256_b_173 :: Background256 -color256_b_173 = Background256 . code $ "48;5;173" - -color256_b_174 :: Background256 -color256_b_174 = Background256 . code $ "48;5;174" - -color256_b_175 :: Background256 -color256_b_175 = Background256 . code $ "48;5;175" - -color256_b_176 :: Background256 -color256_b_176 = Background256 . code $ "48;5;176" - -color256_b_177 :: Background256 -color256_b_177 = Background256 . code $ "48;5;177" - -color256_b_178 :: Background256 -color256_b_178 = Background256 . code $ "48;5;178" - -color256_b_179 :: Background256 -color256_b_179 = Background256 . code $ "48;5;179" - -color256_b_180 :: Background256 -color256_b_180 = Background256 . code $ "48;5;180" - -color256_b_181 :: Background256 -color256_b_181 = Background256 . code $ "48;5;181" - -color256_b_182 :: Background256 -color256_b_182 = Background256 . code $ "48;5;182" - -color256_b_183 :: Background256 -color256_b_183 = Background256 . code $ "48;5;183" - -color256_b_184 :: Background256 -color256_b_184 = Background256 . code $ "48;5;184" - -color256_b_185 :: Background256 -color256_b_185 = Background256 . code $ "48;5;185" - -color256_b_186 :: Background256 -color256_b_186 = Background256 . code $ "48;5;186" - -color256_b_187 :: Background256 -color256_b_187 = Background256 . code $ "48;5;187" - -color256_b_188 :: Background256 -color256_b_188 = Background256 . code $ "48;5;188" - -color256_b_189 :: Background256 -color256_b_189 = Background256 . code $ "48;5;189" - -color256_b_190 :: Background256 -color256_b_190 = Background256 . code $ "48;5;190" - -color256_b_191 :: Background256 -color256_b_191 = Background256 . code $ "48;5;191" - -color256_b_192 :: Background256 -color256_b_192 = Background256 . code $ "48;5;192" - -color256_b_193 :: Background256 -color256_b_193 = Background256 . code $ "48;5;193" - -color256_b_194 :: Background256 -color256_b_194 = Background256 . code $ "48;5;194" - -color256_b_195 :: Background256 -color256_b_195 = Background256 . code $ "48;5;195" - -color256_b_196 :: Background256 -color256_b_196 = Background256 . code $ "48;5;196" - -color256_b_197 :: Background256 -color256_b_197 = Background256 . code $ "48;5;197" - -color256_b_198 :: Background256 -color256_b_198 = Background256 . code $ "48;5;198" - -color256_b_199 :: Background256 -color256_b_199 = Background256 . code $ "48;5;199" - -color256_b_200 :: Background256 -color256_b_200 = Background256 . code $ "48;5;200" - -color256_b_201 :: Background256 -color256_b_201 = Background256 . code $ "48;5;201" - -color256_b_202 :: Background256 -color256_b_202 = Background256 . code $ "48;5;202" - -color256_b_203 :: Background256 -color256_b_203 = Background256 . code $ "48;5;203" - -color256_b_204 :: Background256 -color256_b_204 = Background256 . code $ "48;5;204" - -color256_b_205 :: Background256 -color256_b_205 = Background256 . code $ "48;5;205" - -color256_b_206 :: Background256 -color256_b_206 = Background256 . code $ "48;5;206" - -color256_b_207 :: Background256 -color256_b_207 = Background256 . code $ "48;5;207" - -color256_b_208 :: Background256 -color256_b_208 = Background256 . code $ "48;5;208" - -color256_b_209 :: Background256 -color256_b_209 = Background256 . code $ "48;5;209" - -color256_b_210 :: Background256 -color256_b_210 = Background256 . code $ "48;5;210" - -color256_b_211 :: Background256 -color256_b_211 = Background256 . code $ "48;5;211" - -color256_b_212 :: Background256 -color256_b_212 = Background256 . code $ "48;5;212" - -color256_b_213 :: Background256 -color256_b_213 = Background256 . code $ "48;5;213" - -color256_b_214 :: Background256 -color256_b_214 = Background256 . code $ "48;5;214" - -color256_b_215 :: Background256 -color256_b_215 = Background256 . code $ "48;5;215" - -color256_b_216 :: Background256 -color256_b_216 = Background256 . code $ "48;5;216" - -color256_b_217 :: Background256 -color256_b_217 = Background256 . code $ "48;5;217" - -color256_b_218 :: Background256 -color256_b_218 = Background256 . code $ "48;5;218" - -color256_b_219 :: Background256 -color256_b_219 = Background256 . code $ "48;5;219" - -color256_b_220 :: Background256 -color256_b_220 = Background256 . code $ "48;5;220" - -color256_b_221 :: Background256 -color256_b_221 = Background256 . code $ "48;5;221" - -color256_b_222 :: Background256 -color256_b_222 = Background256 . code $ "48;5;222" - -color256_b_223 :: Background256 -color256_b_223 = Background256 . code $ "48;5;223" - -color256_b_224 :: Background256 -color256_b_224 = Background256 . code $ "48;5;224" - -color256_b_225 :: Background256 -color256_b_225 = Background256 . code $ "48;5;225" - -color256_b_226 :: Background256 -color256_b_226 = Background256 . code $ "48;5;226" - -color256_b_227 :: Background256 -color256_b_227 = Background256 . code $ "48;5;227" - -color256_b_228 :: Background256 -color256_b_228 = Background256 . code $ "48;5;228" - -color256_b_229 :: Background256 -color256_b_229 = Background256 . code $ "48;5;229" - -color256_b_230 :: Background256 -color256_b_230 = Background256 . code $ "48;5;230" - -color256_b_231 :: Background256 -color256_b_231 = Background256 . code $ "48;5;231" - -color256_b_232 :: Background256 -color256_b_232 = Background256 . code $ "48;5;232" - -color256_b_233 :: Background256 -color256_b_233 = Background256 . code $ "48;5;233" - -color256_b_234 :: Background256 -color256_b_234 = Background256 . code $ "48;5;234" - -color256_b_235 :: Background256 -color256_b_235 = Background256 . code $ "48;5;235" - -color256_b_236 :: Background256 -color256_b_236 = Background256 . code $ "48;5;236" - -color256_b_237 :: Background256 -color256_b_237 = Background256 . code $ "48;5;237" - -color256_b_238 :: Background256 -color256_b_238 = Background256 . code $ "48;5;238" - -color256_b_239 :: Background256 -color256_b_239 = Background256 . code $ "48;5;239" - -color256_b_240 :: Background256 -color256_b_240 = Background256 . code $ "48;5;240" - -color256_b_241 :: Background256 -color256_b_241 = Background256 . code $ "48;5;241" - -color256_b_242 :: Background256 -color256_b_242 = Background256 . code $ "48;5;242" - -color256_b_243 :: Background256 -color256_b_243 = Background256 . code $ "48;5;243" - -color256_b_244 :: Background256 -color256_b_244 = Background256 . code $ "48;5;244" - -color256_b_245 :: Background256 -color256_b_245 = Background256 . code $ "48;5;245" - -color256_b_246 :: Background256 -color256_b_246 = Background256 . code $ "48;5;246" - -color256_b_247 :: Background256 -color256_b_247 = Background256 . code $ "48;5;247" - -color256_b_248 :: Background256 -color256_b_248 = Background256 . code $ "48;5;248" - -color256_b_249 :: Background256 -color256_b_249 = Background256 . code $ "48;5;249" - -color256_b_250 :: Background256 -color256_b_250 = Background256 . code $ "48;5;250" - -color256_b_251 :: Background256 -color256_b_251 = Background256 . code $ "48;5;251" - -color256_b_252 :: Background256 -color256_b_252 = Background256 . code $ "48;5;252" - -color256_b_253 :: Background256 -color256_b_253 = Background256 . code $ "48;5;253" - -color256_b_254 :: Background256 -color256_b_254 = Background256 . code $ "48;5;254" - -color256_b_255 :: Background256 -color256_b_255 = Background256 . code $ "48;5;255" +-- | Handles colors and special effects for text. Internally this +-- module uses the Haskell terminfo library, which links against the +-- UNIX library of the same name, so it should work with a wide +-- variety of UNIX terminals. This module is a layer between terminfo +-- and the rest of Penny, allowing the Chunk internals to be swapped +-- out and replaced. (I know this because this module previously used +-- a home-grown implementation written based on the Xterm +-- configuration; that implementation was swapped out and replaced +-- with terminfo with minimal disruption.) +-- +-- However, terminfo is a UNIX thing, so at this time Penny probably +-- would not work on a Windows based system. +-- +-- There is an ansi-terminal library on Hackage, which does support +-- Windows. One problem with that though is that ansi-terminal does +-- not appear to support more than 8 colors; Chunk supports 256 +-- colors, which is very helpful for Penny. +module Penny.Cabin.Chunk ( + -- * Colors + Term(..), + autoTerm, + termFromEnv, + Background8, + Background256, + Foreground8, + Foreground256, + + -- * Chunks + Chunk, + chunk, + Width(Width, unWidth), + chunkWidth, + printChunks, + + -- * Effects + Bold(Bold, unBold), + Underline(Underline, unUnderline), + Flash(Flash, unFlash), + Inverse(Inverse, unInverse), + + -- * Style and TextSpec + + -- | A style is a bundle of attributes that describes text + -- attributes, such as its color and whether it is bold. + StyleCommon (StyleCommon, bold, underline, flash, inverse), + Style8 (Style8, foreground8, background8, common8), + Style256 (Style256, foreground256, background256, common256), + defaultStyleCommon, + defaultStyle8, + defaultStyle256, + + TextSpec (TextSpec, style8, style256), + defaultTextSpec, + + -- * Specific colors + -- * 8 color foreground colors + color8_f_default, + color8_f_black, + color8_f_red, + color8_f_green, + color8_f_yellow, + color8_f_blue, + color8_f_magenta, + color8_f_cyan, + color8_f_white, + + -- ** 8 color background colors + color8_b_default, + color8_b_black, + color8_b_red, + color8_b_green, + color8_b_yellow, + color8_b_blue, + color8_b_magenta, + color8_b_cyan, + color8_b_white, + + -- * 256 color foreground colors + color256_f_default, + color256_f_0, + color256_f_1, + color256_f_2, + color256_f_3, + color256_f_4, + color256_f_5, + color256_f_6, + color256_f_7, + color256_f_8, + color256_f_9, + color256_f_10, + color256_f_11, + color256_f_12, + color256_f_13, + color256_f_14, + color256_f_15, + color256_f_16, + color256_f_17, + color256_f_18, + color256_f_19, + color256_f_20, + color256_f_21, + color256_f_22, + color256_f_23, + color256_f_24, + color256_f_25, + color256_f_26, + color256_f_27, + color256_f_28, + color256_f_29, + color256_f_30, + color256_f_31, + color256_f_32, + color256_f_33, + color256_f_34, + color256_f_35, + color256_f_36, + color256_f_37, + color256_f_38, + color256_f_39, + color256_f_40, + color256_f_41, + color256_f_42, + color256_f_43, + color256_f_44, + color256_f_45, + color256_f_46, + color256_f_47, + color256_f_48, + color256_f_49, + color256_f_50, + color256_f_51, + color256_f_52, + color256_f_53, + color256_f_54, + color256_f_55, + color256_f_56, + color256_f_57, + color256_f_58, + color256_f_59, + color256_f_60, + color256_f_61, + color256_f_62, + color256_f_63, + color256_f_64, + color256_f_65, + color256_f_66, + color256_f_67, + color256_f_68, + color256_f_69, + color256_f_70, + color256_f_71, + color256_f_72, + color256_f_73, + color256_f_74, + color256_f_75, + color256_f_76, + color256_f_77, + color256_f_78, + color256_f_79, + color256_f_80, + color256_f_81, + color256_f_82, + color256_f_83, + color256_f_84, + color256_f_85, + color256_f_86, + color256_f_87, + color256_f_88, + color256_f_89, + color256_f_90, + color256_f_91, + color256_f_92, + color256_f_93, + color256_f_94, + color256_f_95, + color256_f_96, + color256_f_97, + color256_f_98, + color256_f_99, + color256_f_100, + color256_f_101, + color256_f_102, + color256_f_103, + color256_f_104, + color256_f_105, + color256_f_106, + color256_f_107, + color256_f_108, + color256_f_109, + color256_f_110, + color256_f_111, + color256_f_112, + color256_f_113, + color256_f_114, + color256_f_115, + color256_f_116, + color256_f_117, + color256_f_118, + color256_f_119, + color256_f_120, + color256_f_121, + color256_f_122, + color256_f_123, + color256_f_124, + color256_f_125, + color256_f_126, + color256_f_127, + color256_f_128, + color256_f_129, + color256_f_130, + color256_f_131, + color256_f_132, + color256_f_133, + color256_f_134, + color256_f_135, + color256_f_136, + color256_f_137, + color256_f_138, + color256_f_139, + color256_f_140, + color256_f_141, + color256_f_142, + color256_f_143, + color256_f_144, + color256_f_145, + color256_f_146, + color256_f_147, + color256_f_148, + color256_f_149, + color256_f_150, + color256_f_151, + color256_f_152, + color256_f_153, + color256_f_154, + color256_f_155, + color256_f_156, + color256_f_157, + color256_f_158, + color256_f_159, + color256_f_160, + color256_f_161, + color256_f_162, + color256_f_163, + color256_f_164, + color256_f_165, + color256_f_166, + color256_f_167, + color256_f_168, + color256_f_169, + color256_f_170, + color256_f_171, + color256_f_172, + color256_f_173, + color256_f_174, + color256_f_175, + color256_f_176, + color256_f_177, + color256_f_178, + color256_f_179, + color256_f_180, + color256_f_181, + color256_f_182, + color256_f_183, + color256_f_184, + color256_f_185, + color256_f_186, + color256_f_187, + color256_f_188, + color256_f_189, + color256_f_190, + color256_f_191, + color256_f_192, + color256_f_193, + color256_f_194, + color256_f_195, + color256_f_196, + color256_f_197, + color256_f_198, + color256_f_199, + color256_f_200, + color256_f_201, + color256_f_202, + color256_f_203, + color256_f_204, + color256_f_205, + color256_f_206, + color256_f_207, + color256_f_208, + color256_f_209, + color256_f_210, + color256_f_211, + color256_f_212, + color256_f_213, + color256_f_214, + color256_f_215, + color256_f_216, + color256_f_217, + color256_f_218, + color256_f_219, + color256_f_220, + color256_f_221, + color256_f_222, + color256_f_223, + color256_f_224, + color256_f_225, + color256_f_226, + color256_f_227, + color256_f_228, + color256_f_229, + color256_f_230, + color256_f_231, + color256_f_232, + color256_f_233, + color256_f_234, + color256_f_235, + color256_f_236, + color256_f_237, + color256_f_238, + color256_f_239, + color256_f_240, + color256_f_241, + color256_f_242, + color256_f_243, + color256_f_244, + color256_f_245, + color256_f_246, + color256_f_247, + color256_f_248, + color256_f_249, + color256_f_250, + color256_f_251, + color256_f_252, + color256_f_253, + color256_f_254, + color256_f_255, + + -- ** 256 color background colors + color256_b_default, + color256_b_0, + color256_b_1, + color256_b_2, + color256_b_3, + color256_b_4, + color256_b_5, + color256_b_6, + color256_b_7, + color256_b_8, + color256_b_9, + color256_b_10, + color256_b_11, + color256_b_12, + color256_b_13, + color256_b_14, + color256_b_15, + color256_b_16, + color256_b_17, + color256_b_18, + color256_b_19, + color256_b_20, + color256_b_21, + color256_b_22, + color256_b_23, + color256_b_24, + color256_b_25, + color256_b_26, + color256_b_27, + color256_b_28, + color256_b_29, + color256_b_30, + color256_b_31, + color256_b_32, + color256_b_33, + color256_b_34, + color256_b_35, + color256_b_36, + color256_b_37, + color256_b_38, + color256_b_39, + color256_b_40, + color256_b_41, + color256_b_42, + color256_b_43, + color256_b_44, + color256_b_45, + color256_b_46, + color256_b_47, + color256_b_48, + color256_b_49, + color256_b_50, + color256_b_51, + color256_b_52, + color256_b_53, + color256_b_54, + color256_b_55, + color256_b_56, + color256_b_57, + color256_b_58, + color256_b_59, + color256_b_60, + color256_b_61, + color256_b_62, + color256_b_63, + color256_b_64, + color256_b_65, + color256_b_66, + color256_b_67, + color256_b_68, + color256_b_69, + color256_b_70, + color256_b_71, + color256_b_72, + color256_b_73, + color256_b_74, + color256_b_75, + color256_b_76, + color256_b_77, + color256_b_78, + color256_b_79, + color256_b_80, + color256_b_81, + color256_b_82, + color256_b_83, + color256_b_84, + color256_b_85, + color256_b_86, + color256_b_87, + color256_b_88, + color256_b_89, + color256_b_90, + color256_b_91, + color256_b_92, + color256_b_93, + color256_b_94, + color256_b_95, + color256_b_96, + color256_b_97, + color256_b_98, + color256_b_99, + color256_b_100, + color256_b_101, + color256_b_102, + color256_b_103, + color256_b_104, + color256_b_105, + color256_b_106, + color256_b_107, + color256_b_108, + color256_b_109, + color256_b_110, + color256_b_111, + color256_b_112, + color256_b_113, + color256_b_114, + color256_b_115, + color256_b_116, + color256_b_117, + color256_b_118, + color256_b_119, + color256_b_120, + color256_b_121, + color256_b_122, + color256_b_123, + color256_b_124, + color256_b_125, + color256_b_126, + color256_b_127, + color256_b_128, + color256_b_129, + color256_b_130, + color256_b_131, + color256_b_132, + color256_b_133, + color256_b_134, + color256_b_135, + color256_b_136, + color256_b_137, + color256_b_138, + color256_b_139, + color256_b_140, + color256_b_141, + color256_b_142, + color256_b_143, + color256_b_144, + color256_b_145, + color256_b_146, + color256_b_147, + color256_b_148, + color256_b_149, + color256_b_150, + color256_b_151, + color256_b_152, + color256_b_153, + color256_b_154, + color256_b_155, + color256_b_156, + color256_b_157, + color256_b_158, + color256_b_159, + color256_b_160, + color256_b_161, + color256_b_162, + color256_b_163, + color256_b_164, + color256_b_165, + color256_b_166, + color256_b_167, + color256_b_168, + color256_b_169, + color256_b_170, + color256_b_171, + color256_b_172, + color256_b_173, + color256_b_174, + color256_b_175, + color256_b_176, + color256_b_177, + color256_b_178, + color256_b_179, + color256_b_180, + color256_b_181, + color256_b_182, + color256_b_183, + color256_b_184, + color256_b_185, + color256_b_186, + color256_b_187, + color256_b_188, + color256_b_189, + color256_b_190, + color256_b_191, + color256_b_192, + color256_b_193, + color256_b_194, + color256_b_195, + color256_b_196, + color256_b_197, + color256_b_198, + color256_b_199, + color256_b_200, + color256_b_201, + color256_b_202, + color256_b_203, + color256_b_204, + color256_b_205, + color256_b_206, + color256_b_207, + color256_b_208, + color256_b_209, + color256_b_210, + color256_b_211, + color256_b_212, + color256_b_213, + color256_b_214, + color256_b_215, + color256_b_216, + color256_b_217, + color256_b_218, + color256_b_219, + color256_b_220, + color256_b_221, + color256_b_222, + color256_b_223, + color256_b_224, + color256_b_225, + color256_b_226, + color256_b_227, + color256_b_228, + color256_b_229, + color256_b_230, + color256_b_231, + color256_b_232, + color256_b_233, + color256_b_234, + color256_b_235, + color256_b_236, + color256_b_237, + color256_b_238, + color256_b_239, + color256_b_240, + color256_b_241, + color256_b_242, + color256_b_243, + color256_b_244, + color256_b_245, + color256_b_246, + color256_b_247, + color256_b_248, + color256_b_249, + color256_b_250, + color256_b_251, + color256_b_252, + color256_b_253, + color256_b_254, + color256_b_255 + + ) where + + +import Data.Monoid (Monoid, mempty, mappend, mconcat) +import Data.Text (Text) +import Data.Maybe (fromMaybe) +import qualified Data.Text as X +import qualified System.Console.Terminfo as T +import qualified Penny.Shield as S + +-- +-- Colors +-- + +-- | Which terminal definition to use. +data Term + = Dumb + -- ^ Using this terminal should always succeed. This suppresses all + -- colors. Uesful if output is not going to a TTY, or if you just do + -- not like colors. + + | TermName String + -- ^ Use the terminal with this given name. You might get this from + -- the TERM environment variable, or set it explicitly. A runtime + -- error will result if the terminfo database does not have a + -- definition for this terminal. If this terminal supports 256 + -- colors, then 256 colors are used. If this terminal supports less + -- than 256 colors, but at least 8 colors, then 8 colors are + -- used. Otherwise, no colors are used. + deriving (Eq, Show) + + +-- | Determines which 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 :: S.Runtime -> Term +termFromEnv rt = case S.term rt of + Just t -> TermName . S.unTerm $ t + Nothing -> Dumb + +-- | Determines which 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 :: S.Runtime -> Term +autoTerm rt = case S.output rt of + S.IsTTY -> termFromEnv rt + S.NotTTY -> Dumb + +-- For Background8, Background256, Foreground8, Foreground256: the +-- newtype wraps a Terminfo Color. If Nothing, use the default color. + +-- | Background color in an 8 color setting. +newtype Background8 = Background8 { unBackground8 :: Maybe T.Color } + deriving (Eq, Show, Ord) + +-- | Background color in a 256 color setting. +newtype Background256 = Background256 { unBackground256 :: Maybe T.Color } + deriving (Eq, Show, Ord) + +-- | Foreground color in an 8 color setting. +newtype Foreground8 = Foreground8 { unForeground8 :: Maybe T.Color } + deriving (Eq, Show, Ord) + +-- | Foreground color in a 256 color setting. +newtype Foreground256 = Foreground256 { unForeground256 :: Maybe T.Color } + deriving (Eq, Show, Ord) + + +-- +-- Chunks +-- + +-- | A chunk is some textual data coupled with a description of what +-- color the text is, attributes like whether it is bold or +-- underlined, etc. The chunk knows what foreground and background +-- colors and what attributes to use for both an 8 color terminal and +-- a 256 color terminal. To change these attributes and colors, you +-- must make a new chunk. +-- +-- There is no way to combine chunks. To print large numbers of +-- chunks, lazily build a list of them and then print them using +-- 'printChunks'. + +data Chunk = Chunk TextSpec Text + deriving (Eq, Show, Ord) + +-- | Makes new Chunks. +chunk :: TextSpec -> Text -> Chunk +chunk = Chunk + +-- | How wide the text of a chunk is. +newtype Width = Width { unWidth :: Int } + deriving (Show, Eq, Ord) + +instance Monoid Width where + mempty = Width 0 + mappend (Width w1) (Width w2) = Width $ w1 + w2 + +chunkWidth :: Chunk -> Width +chunkWidth (Chunk _ t) = Width . X.length $ t + +-- | Sends a list of chunks to standard output for printing. Sets up +-- the terminal (this only needs to be done once.) Lazily processes +-- the list of Chunk. +printChunks :: Term -> [Chunk] -> IO () +printChunks t cs = do + let setup = case t of + Dumb -> T.setupTerm "dumb" + TermName s -> T.setupTerm s + term <- setup + mapM_ (printChunk term) cs + T.runTermOutput term (defaultColors term) + T.runTermOutput term + $ case T.getCapability term T.allAttributesOff of + Nothing -> error $ "Penny.Cabin.Chunk.printChunks: error: " + ++ "allAttributesOff failed" + Just s -> s + +printChunk :: T.Terminal -> Chunk -> IO () +printChunk t (Chunk ts x) = + T.runTermOutput t + . mconcat + $ [defaultColors t, codes, txt] + where + codes = getTermCodes t ts + txt = T.termText . X.unpack $ x + +defaultColors :: T.Terminal -> T.TermOutput +defaultColors term = + fromMaybe mempty (T.getCapability term T.restoreDefaultColors) + +-- +-- Effects +-- +newtype Bold = Bold { unBold :: Bool } + deriving (Show, Eq, Ord) + +newtype Underline = Underline { unUnderline :: Bool } + deriving (Show, Eq, Ord) + +newtype Flash = Flash { unFlash :: Bool } + deriving (Show, Eq, Ord) + +newtype Inverse = Inverse { unInverse :: Bool } + deriving (Show, Eq, Ord) + +-- +-- Styles +-- + +-- | Style elements that apply in both 8 and 256 color +-- terminals. However, the elements are described separately for 8 and +-- 256 color terminals, so that the text appearance can change +-- depending on how many colors a terminal has. +data StyleCommon = StyleCommon + { bold :: Bold + , underline :: Underline + , flash :: Flash + , inverse :: Inverse + } deriving (Show, Eq, Ord) + +-- | Describes text appearance (foreground and background colors, as +-- well as other attributes such as bold) for an 8 color terminal. +data Style8 = Style8 + { foreground8 :: Foreground8 + , background8 :: Background8 + , common8 :: StyleCommon + } deriving (Show, Eq, Ord) + +-- | Describes text appearance (foreground and background colors, as +-- well as other attributes such as bold) for a 256 color terminal. +data Style256 = Style256 + { foreground256 :: Foreground256 + , background256 :: Background256 + , common256 :: StyleCommon + } deriving (Show, Eq, Ord) + +-- | Has all bold, flash, underline, and inverse turned off. +defaultStyleCommon :: StyleCommon +defaultStyleCommon = StyleCommon + { bold = Bold False + , underline = Underline False + , flash = Flash False + , inverse = Inverse False + } + +-- | Uses the default terminal colors (which will vary depending on +-- the terminal). +defaultStyle8 :: Style8 +defaultStyle8 = Style8 + { foreground8 = color8_f_default + , background8 = color8_b_default + , common8 = defaultStyleCommon + } + +-- | Uses the default terminal colors (which will vary depending on +-- the terminal). +defaultStyle256 :: Style256 +defaultStyle256 = Style256 + { foreground256 = color256_f_default + , background256 = color256_b_default + , common256 = defaultStyleCommon + } + +-- +-- TextSpec +-- + +-- | The TextSpec bundles together the styles for the 8 and 256 color +-- terminals, so that the text can be portrayed on any terminal. +data TextSpec = TextSpec + { style8 :: Style8 + , style256 :: Style256 + } deriving (Show, Eq, Ord) + +-- | A TextSpec with the default colors on 8 and 256 color terminals, +-- with all attributes turned off. +defaultTextSpec :: TextSpec +defaultTextSpec = TextSpec + { style8 = defaultStyle8 + , style256 = defaultStyle256 + } + +-- +-- Internal +-- + +commonAttrs :: T.Terminal -> StyleCommon -> T.TermOutput +commonAttrs t s = + let a = T.Attributes + { T.standoutAttr = False + , T.underlineAttr = unUnderline . underline $ s + , T.reverseAttr = unInverse . inverse $ s + , T.blinkAttr = unFlash . flash $ s + , T.dimAttr = False + , T.boldAttr = unBold . bold $ s + , T.invisibleAttr = False + , T.protectedAttr = False + } + in case T.getCapability t (T.setAttributes) of + Nothing -> error $ "Penny.Cabin.Chunk: commonAttrs: " + ++ "capability failed; should never happen" + Just f -> f a + + +-- | Gets the right set of terminal codes to apply the desired +-- highlighting, bold, underlining, etc. Be sure to apply the +-- attributes first (bold, underlining, etc) and then the +-- colors. Setting the colors first and then the attributes seems to +-- reset the colors, giving blank output. +getTermCodes + :: T.Terminal + -> TextSpec + -> T.TermOutput +getTermCodes t ts = fromMaybe mempty $ do + cols <- T.getCapability t T.termColors + let TextSpec s8 s256 = ts + Style8 f8 b8 c8 = s8 + Style256 f256 b256 c256 = s256 + setFg <- T.getCapability t T.setForegroundColor + setBg <- T.getCapability t T.setBackgroundColor + (fg, bg, cm) <- case () of + _ | cols >= 256 -> Just $ ( unForeground256 f256 + , unBackground256 b256 + , c256 ) + | cols >= 8 -> Just ( unForeground8 f8 + , unBackground8 b8 + , c8) + | otherwise -> Nothing + let oFg = maybe mempty setFg fg + oBg = maybe mempty setBg bg + oCm = commonAttrs t cm + return $ mconcat [oCm, oFg, oBg] + + +-- +-- Color basement +-- +color8_f_default :: Foreground8 +color8_f_default = Foreground8 Nothing + +color8_f_black :: Foreground8 +color8_f_black = Foreground8 $ Just T.Black + +color8_f_red :: Foreground8 +color8_f_red = Foreground8 $ Just T.Red + +color8_f_green :: Foreground8 +color8_f_green = Foreground8 $ Just T.Green + +color8_f_yellow :: Foreground8 +color8_f_yellow = Foreground8 $ Just T.Yellow + +color8_f_blue :: Foreground8 +color8_f_blue = Foreground8 $ Just T.Blue + +color8_f_magenta :: Foreground8 +color8_f_magenta = Foreground8 $ Just T.Magenta + +color8_f_cyan :: Foreground8 +color8_f_cyan = Foreground8 $ Just T.Cyan + +color8_f_white :: Foreground8 +color8_f_white = Foreground8 $ Just T.White + +color8_b_default :: Background8 +color8_b_default = Background8 Nothing + +color8_b_black :: Background8 +color8_b_black = Background8 $ Just T.Black + +color8_b_red :: Background8 +color8_b_red = Background8 $ Just T.Red + +color8_b_green :: Background8 +color8_b_green = Background8 $ Just T.Green + +color8_b_yellow :: Background8 +color8_b_yellow = Background8 $ Just T.Yellow + +color8_b_blue :: Background8 +color8_b_blue = Background8 $ Just T.Blue + +color8_b_magenta :: Background8 +color8_b_magenta = Background8 $ Just T.Magenta + +color8_b_cyan :: Background8 +color8_b_cyan = Background8 $ Just T.Cyan + +color8_b_white :: Background8 +color8_b_white = Background8 $ Just T.White + +color256_f_default :: Foreground256 +color256_f_default = Foreground256 Nothing + +color256_f_0 :: Foreground256 +color256_f_0 = Foreground256 (Just (T.ColorNumber 0)) + +color256_f_1 :: Foreground256 +color256_f_1 = Foreground256 (Just (T.ColorNumber 1)) + +color256_f_2 :: Foreground256 +color256_f_2 = Foreground256 (Just (T.ColorNumber 2)) + +color256_f_3 :: Foreground256 +color256_f_3 = Foreground256 (Just (T.ColorNumber 3)) + +color256_f_4 :: Foreground256 +color256_f_4 = Foreground256 (Just (T.ColorNumber 4)) + +color256_f_5 :: Foreground256 +color256_f_5 = Foreground256 (Just (T.ColorNumber 5)) + +color256_f_6 :: Foreground256 +color256_f_6 = Foreground256 (Just (T.ColorNumber 6)) + +color256_f_7 :: Foreground256 +color256_f_7 = Foreground256 (Just (T.ColorNumber 7)) + +color256_f_8 :: Foreground256 +color256_f_8 = Foreground256 (Just (T.ColorNumber 8)) + +color256_f_9 :: Foreground256 +color256_f_9 = Foreground256 (Just (T.ColorNumber 9)) + +color256_f_10 :: Foreground256 +color256_f_10 = Foreground256 (Just (T.ColorNumber 10)) + +color256_f_11 :: Foreground256 +color256_f_11 = Foreground256 (Just (T.ColorNumber 11)) + +color256_f_12 :: Foreground256 +color256_f_12 = Foreground256 (Just (T.ColorNumber 12)) + +color256_f_13 :: Foreground256 +color256_f_13 = Foreground256 (Just (T.ColorNumber 13)) + +color256_f_14 :: Foreground256 +color256_f_14 = Foreground256 (Just (T.ColorNumber 14)) + +color256_f_15 :: Foreground256 +color256_f_15 = Foreground256 (Just (T.ColorNumber 15)) + +color256_f_16 :: Foreground256 +color256_f_16 = Foreground256 (Just (T.ColorNumber 16)) + +color256_f_17 :: Foreground256 +color256_f_17 = Foreground256 (Just (T.ColorNumber 17)) + +color256_f_18 :: Foreground256 +color256_f_18 = Foreground256 (Just (T.ColorNumber 18)) + +color256_f_19 :: Foreground256 +color256_f_19 = Foreground256 (Just (T.ColorNumber 19)) + +color256_f_20 :: Foreground256 +color256_f_20 = Foreground256 (Just (T.ColorNumber 20)) + +color256_f_21 :: Foreground256 +color256_f_21 = Foreground256 (Just (T.ColorNumber 21)) + +color256_f_22 :: Foreground256 +color256_f_22 = Foreground256 (Just (T.ColorNumber 22)) + +color256_f_23 :: Foreground256 +color256_f_23 = Foreground256 (Just (T.ColorNumber 23)) + +color256_f_24 :: Foreground256 +color256_f_24 = Foreground256 (Just (T.ColorNumber 24)) + +color256_f_25 :: Foreground256 +color256_f_25 = Foreground256 (Just (T.ColorNumber 25)) + +color256_f_26 :: Foreground256 +color256_f_26 = Foreground256 (Just (T.ColorNumber 26)) + +color256_f_27 :: Foreground256 +color256_f_27 = Foreground256 (Just (T.ColorNumber 27)) + +color256_f_28 :: Foreground256 +color256_f_28 = Foreground256 (Just (T.ColorNumber 28)) + +color256_f_29 :: Foreground256 +color256_f_29 = Foreground256 (Just (T.ColorNumber 29)) + +color256_f_30 :: Foreground256 +color256_f_30 = Foreground256 (Just (T.ColorNumber 30)) + +color256_f_31 :: Foreground256 +color256_f_31 = Foreground256 (Just (T.ColorNumber 31)) + +color256_f_32 :: Foreground256 +color256_f_32 = Foreground256 (Just (T.ColorNumber 32)) + +color256_f_33 :: Foreground256 +color256_f_33 = Foreground256 (Just (T.ColorNumber 33)) + +color256_f_34 :: Foreground256 +color256_f_34 = Foreground256 (Just (T.ColorNumber 34)) + +color256_f_35 :: Foreground256 +color256_f_35 = Foreground256 (Just (T.ColorNumber 35)) + +color256_f_36 :: Foreground256 +color256_f_36 = Foreground256 (Just (T.ColorNumber 36)) + +color256_f_37 :: Foreground256 +color256_f_37 = Foreground256 (Just (T.ColorNumber 37)) + +color256_f_38 :: Foreground256 +color256_f_38 = Foreground256 (Just (T.ColorNumber 38)) + +color256_f_39 :: Foreground256 +color256_f_39 = Foreground256 (Just (T.ColorNumber 39)) + +color256_f_40 :: Foreground256 +color256_f_40 = Foreground256 (Just (T.ColorNumber 40)) + +color256_f_41 :: Foreground256 +color256_f_41 = Foreground256 (Just (T.ColorNumber 41)) + +color256_f_42 :: Foreground256 +color256_f_42 = Foreground256 (Just (T.ColorNumber 42)) + +color256_f_43 :: Foreground256 +color256_f_43 = Foreground256 (Just (T.ColorNumber 43)) + +color256_f_44 :: Foreground256 +color256_f_44 = Foreground256 (Just (T.ColorNumber 44)) + +color256_f_45 :: Foreground256 +color256_f_45 = Foreground256 (Just (T.ColorNumber 45)) + +color256_f_46 :: Foreground256 +color256_f_46 = Foreground256 (Just (T.ColorNumber 46)) + +color256_f_47 :: Foreground256 +color256_f_47 = Foreground256 (Just (T.ColorNumber 47)) + +color256_f_48 :: Foreground256 +color256_f_48 = Foreground256 (Just (T.ColorNumber 48)) + +color256_f_49 :: Foreground256 +color256_f_49 = Foreground256 (Just (T.ColorNumber 49)) + +color256_f_50 :: Foreground256 +color256_f_50 = Foreground256 (Just (T.ColorNumber 50)) + +color256_f_51 :: Foreground256 +color256_f_51 = Foreground256 (Just (T.ColorNumber 51)) + +color256_f_52 :: Foreground256 +color256_f_52 = Foreground256 (Just (T.ColorNumber 52)) + +color256_f_53 :: Foreground256 +color256_f_53 = Foreground256 (Just (T.ColorNumber 53)) + +color256_f_54 :: Foreground256 +color256_f_54 = Foreground256 (Just (T.ColorNumber 54)) + +color256_f_55 :: Foreground256 +color256_f_55 = Foreground256 (Just (T.ColorNumber 55)) + +color256_f_56 :: Foreground256 +color256_f_56 = Foreground256 (Just (T.ColorNumber 56)) + +color256_f_57 :: Foreground256 +color256_f_57 = Foreground256 (Just (T.ColorNumber 57)) + +color256_f_58 :: Foreground256 +color256_f_58 = Foreground256 (Just (T.ColorNumber 58)) + +color256_f_59 :: Foreground256 +color256_f_59 = Foreground256 (Just (T.ColorNumber 59)) + +color256_f_60 :: Foreground256 +color256_f_60 = Foreground256 (Just (T.ColorNumber 60)) + +color256_f_61 :: Foreground256 +color256_f_61 = Foreground256 (Just (T.ColorNumber 61)) + +color256_f_62 :: Foreground256 +color256_f_62 = Foreground256 (Just (T.ColorNumber 62)) + +color256_f_63 :: Foreground256 +color256_f_63 = Foreground256 (Just (T.ColorNumber 63)) + +color256_f_64 :: Foreground256 +color256_f_64 = Foreground256 (Just (T.ColorNumber 64)) + +color256_f_65 :: Foreground256 +color256_f_65 = Foreground256 (Just (T.ColorNumber 65)) + +color256_f_66 :: Foreground256 +color256_f_66 = Foreground256 (Just (T.ColorNumber 66)) + +color256_f_67 :: Foreground256 +color256_f_67 = Foreground256 (Just (T.ColorNumber 67)) + +color256_f_68 :: Foreground256 +color256_f_68 = Foreground256 (Just (T.ColorNumber 68)) + +color256_f_69 :: Foreground256 +color256_f_69 = Foreground256 (Just (T.ColorNumber 69)) + +color256_f_70 :: Foreground256 +color256_f_70 = Foreground256 (Just (T.ColorNumber 70)) + +color256_f_71 :: Foreground256 +color256_f_71 = Foreground256 (Just (T.ColorNumber 71)) + +color256_f_72 :: Foreground256 +color256_f_72 = Foreground256 (Just (T.ColorNumber 72)) + +color256_f_73 :: Foreground256 +color256_f_73 = Foreground256 (Just (T.ColorNumber 73)) + +color256_f_74 :: Foreground256 +color256_f_74 = Foreground256 (Just (T.ColorNumber 74)) + +color256_f_75 :: Foreground256 +color256_f_75 = Foreground256 (Just (T.ColorNumber 75)) + +color256_f_76 :: Foreground256 +color256_f_76 = Foreground256 (Just (T.ColorNumber 76)) + +color256_f_77 :: Foreground256 +color256_f_77 = Foreground256 (Just (T.ColorNumber 77)) + +color256_f_78 :: Foreground256 +color256_f_78 = Foreground256 (Just (T.ColorNumber 78)) + +color256_f_79 :: Foreground256 +color256_f_79 = Foreground256 (Just (T.ColorNumber 79)) + +color256_f_80 :: Foreground256 +color256_f_80 = Foreground256 (Just (T.ColorNumber 80)) + +color256_f_81 :: Foreground256 +color256_f_81 = Foreground256 (Just (T.ColorNumber 81)) + +color256_f_82 :: Foreground256 +color256_f_82 = Foreground256 (Just (T.ColorNumber 82)) + +color256_f_83 :: Foreground256 +color256_f_83 = Foreground256 (Just (T.ColorNumber 83)) + +color256_f_84 :: Foreground256 +color256_f_84 = Foreground256 (Just (T.ColorNumber 84)) + +color256_f_85 :: Foreground256 +color256_f_85 = Foreground256 (Just (T.ColorNumber 85)) + +color256_f_86 :: Foreground256 +color256_f_86 = Foreground256 (Just (T.ColorNumber 86)) + +color256_f_87 :: Foreground256 +color256_f_87 = Foreground256 (Just (T.ColorNumber 87)) + +color256_f_88 :: Foreground256 +color256_f_88 = Foreground256 (Just (T.ColorNumber 88)) + +color256_f_89 :: Foreground256 +color256_f_89 = Foreground256 (Just (T.ColorNumber 89)) + +color256_f_90 :: Foreground256 +color256_f_90 = Foreground256 (Just (T.ColorNumber 90)) + +color256_f_91 :: Foreground256 +color256_f_91 = Foreground256 (Just (T.ColorNumber 91)) + +color256_f_92 :: Foreground256 +color256_f_92 = Foreground256 (Just (T.ColorNumber 92)) + +color256_f_93 :: Foreground256 +color256_f_93 = Foreground256 (Just (T.ColorNumber 93)) + +color256_f_94 :: Foreground256 +color256_f_94 = Foreground256 (Just (T.ColorNumber 94)) + +color256_f_95 :: Foreground256 +color256_f_95 = Foreground256 (Just (T.ColorNumber 95)) + +color256_f_96 :: Foreground256 +color256_f_96 = Foreground256 (Just (T.ColorNumber 96)) + +color256_f_97 :: Foreground256 +color256_f_97 = Foreground256 (Just (T.ColorNumber 97)) + +color256_f_98 :: Foreground256 +color256_f_98 = Foreground256 (Just (T.ColorNumber 98)) + +color256_f_99 :: Foreground256 +color256_f_99 = Foreground256 (Just (T.ColorNumber 99)) + +color256_f_100 :: Foreground256 +color256_f_100 = Foreground256 (Just (T.ColorNumber 100)) + +color256_f_101 :: Foreground256 +color256_f_101 = Foreground256 (Just (T.ColorNumber 101)) + +color256_f_102 :: Foreground256 +color256_f_102 = Foreground256 (Just (T.ColorNumber 102)) + +color256_f_103 :: Foreground256 +color256_f_103 = Foreground256 (Just (T.ColorNumber 103)) + +color256_f_104 :: Foreground256 +color256_f_104 = Foreground256 (Just (T.ColorNumber 104)) + +color256_f_105 :: Foreground256 +color256_f_105 = Foreground256 (Just (T.ColorNumber 105)) + +color256_f_106 :: Foreground256 +color256_f_106 = Foreground256 (Just (T.ColorNumber 106)) + +color256_f_107 :: Foreground256 +color256_f_107 = Foreground256 (Just (T.ColorNumber 107)) + +color256_f_108 :: Foreground256 +color256_f_108 = Foreground256 (Just (T.ColorNumber 108)) + +color256_f_109 :: Foreground256 +color256_f_109 = Foreground256 (Just (T.ColorNumber 109)) + +color256_f_110 :: Foreground256 +color256_f_110 = Foreground256 (Just (T.ColorNumber 110)) + +color256_f_111 :: Foreground256 +color256_f_111 = Foreground256 (Just (T.ColorNumber 111)) + +color256_f_112 :: Foreground256 +color256_f_112 = Foreground256 (Just (T.ColorNumber 112)) + +color256_f_113 :: Foreground256 +color256_f_113 = Foreground256 (Just (T.ColorNumber 113)) + +color256_f_114 :: Foreground256 +color256_f_114 = Foreground256 (Just (T.ColorNumber 114)) + +color256_f_115 :: Foreground256 +color256_f_115 = Foreground256 (Just (T.ColorNumber 115)) + +color256_f_116 :: Foreground256 +color256_f_116 = Foreground256 (Just (T.ColorNumber 116)) + +color256_f_117 :: Foreground256 +color256_f_117 = Foreground256 (Just (T.ColorNumber 117)) + +color256_f_118 :: Foreground256 +color256_f_118 = Foreground256 (Just (T.ColorNumber 118)) + +color256_f_119 :: Foreground256 +color256_f_119 = Foreground256 (Just (T.ColorNumber 119)) + +color256_f_120 :: Foreground256 +color256_f_120 = Foreground256 (Just (T.ColorNumber 120)) + +color256_f_121 :: Foreground256 +color256_f_121 = Foreground256 (Just (T.ColorNumber 121)) + +color256_f_122 :: Foreground256 +color256_f_122 = Foreground256 (Just (T.ColorNumber 122)) + +color256_f_123 :: Foreground256 +color256_f_123 = Foreground256 (Just (T.ColorNumber 123)) + +color256_f_124 :: Foreground256 +color256_f_124 = Foreground256 (Just (T.ColorNumber 124)) + +color256_f_125 :: Foreground256 +color256_f_125 = Foreground256 (Just (T.ColorNumber 125)) + +color256_f_126 :: Foreground256 +color256_f_126 = Foreground256 (Just (T.ColorNumber 126)) + +color256_f_127 :: Foreground256 +color256_f_127 = Foreground256 (Just (T.ColorNumber 127)) + +color256_f_128 :: Foreground256 +color256_f_128 = Foreground256 (Just (T.ColorNumber 128)) + +color256_f_129 :: Foreground256 +color256_f_129 = Foreground256 (Just (T.ColorNumber 129)) + +color256_f_130 :: Foreground256 +color256_f_130 = Foreground256 (Just (T.ColorNumber 130)) + +color256_f_131 :: Foreground256 +color256_f_131 = Foreground256 (Just (T.ColorNumber 131)) + +color256_f_132 :: Foreground256 +color256_f_132 = Foreground256 (Just (T.ColorNumber 132)) + +color256_f_133 :: Foreground256 +color256_f_133 = Foreground256 (Just (T.ColorNumber 133)) + +color256_f_134 :: Foreground256 +color256_f_134 = Foreground256 (Just (T.ColorNumber 134)) + +color256_f_135 :: Foreground256 +color256_f_135 = Foreground256 (Just (T.ColorNumber 135)) + +color256_f_136 :: Foreground256 +color256_f_136 = Foreground256 (Just (T.ColorNumber 136)) + +color256_f_137 :: Foreground256 +color256_f_137 = Foreground256 (Just (T.ColorNumber 137)) + +color256_f_138 :: Foreground256 +color256_f_138 = Foreground256 (Just (T.ColorNumber 138)) + +color256_f_139 :: Foreground256 +color256_f_139 = Foreground256 (Just (T.ColorNumber 139)) + +color256_f_140 :: Foreground256 +color256_f_140 = Foreground256 (Just (T.ColorNumber 140)) + +color256_f_141 :: Foreground256 +color256_f_141 = Foreground256 (Just (T.ColorNumber 141)) + +color256_f_142 :: Foreground256 +color256_f_142 = Foreground256 (Just (T.ColorNumber 142)) + +color256_f_143 :: Foreground256 +color256_f_143 = Foreground256 (Just (T.ColorNumber 143)) + +color256_f_144 :: Foreground256 +color256_f_144 = Foreground256 (Just (T.ColorNumber 144)) + +color256_f_145 :: Foreground256 +color256_f_145 = Foreground256 (Just (T.ColorNumber 145)) + +color256_f_146 :: Foreground256 +color256_f_146 = Foreground256 (Just (T.ColorNumber 146)) + +color256_f_147 :: Foreground256 +color256_f_147 = Foreground256 (Just (T.ColorNumber 147)) + +color256_f_148 :: Foreground256 +color256_f_148 = Foreground256 (Just (T.ColorNumber 148)) + +color256_f_149 :: Foreground256 +color256_f_149 = Foreground256 (Just (T.ColorNumber 149)) + +color256_f_150 :: Foreground256 +color256_f_150 = Foreground256 (Just (T.ColorNumber 150)) + +color256_f_151 :: Foreground256 +color256_f_151 = Foreground256 (Just (T.ColorNumber 151)) + +color256_f_152 :: Foreground256 +color256_f_152 = Foreground256 (Just (T.ColorNumber 152)) + +color256_f_153 :: Foreground256 +color256_f_153 = Foreground256 (Just (T.ColorNumber 153)) + +color256_f_154 :: Foreground256 +color256_f_154 = Foreground256 (Just (T.ColorNumber 154)) + +color256_f_155 :: Foreground256 +color256_f_155 = Foreground256 (Just (T.ColorNumber 155)) + +color256_f_156 :: Foreground256 +color256_f_156 = Foreground256 (Just (T.ColorNumber 156)) + +color256_f_157 :: Foreground256 +color256_f_157 = Foreground256 (Just (T.ColorNumber 157)) + +color256_f_158 :: Foreground256 +color256_f_158 = Foreground256 (Just (T.ColorNumber 158)) + +color256_f_159 :: Foreground256 +color256_f_159 = Foreground256 (Just (T.ColorNumber 159)) + +color256_f_160 :: Foreground256 +color256_f_160 = Foreground256 (Just (T.ColorNumber 160)) + +color256_f_161 :: Foreground256 +color256_f_161 = Foreground256 (Just (T.ColorNumber 161)) + +color256_f_162 :: Foreground256 +color256_f_162 = Foreground256 (Just (T.ColorNumber 162)) + +color256_f_163 :: Foreground256 +color256_f_163 = Foreground256 (Just (T.ColorNumber 163)) + +color256_f_164 :: Foreground256 +color256_f_164 = Foreground256 (Just (T.ColorNumber 164)) + +color256_f_165 :: Foreground256 +color256_f_165 = Foreground256 (Just (T.ColorNumber 165)) + +color256_f_166 :: Foreground256 +color256_f_166 = Foreground256 (Just (T.ColorNumber 166)) + +color256_f_167 :: Foreground256 +color256_f_167 = Foreground256 (Just (T.ColorNumber 167)) + +color256_f_168 :: Foreground256 +color256_f_168 = Foreground256 (Just (T.ColorNumber 168)) + +color256_f_169 :: Foreground256 +color256_f_169 = Foreground256 (Just (T.ColorNumber 169)) + +color256_f_170 :: Foreground256 +color256_f_170 = Foreground256 (Just (T.ColorNumber 170)) + +color256_f_171 :: Foreground256 +color256_f_171 = Foreground256 (Just (T.ColorNumber 171)) + +color256_f_172 :: Foreground256 +color256_f_172 = Foreground256 (Just (T.ColorNumber 172)) + +color256_f_173 :: Foreground256 +color256_f_173 = Foreground256 (Just (T.ColorNumber 173)) + +color256_f_174 :: Foreground256 +color256_f_174 = Foreground256 (Just (T.ColorNumber 174)) + +color256_f_175 :: Foreground256 +color256_f_175 = Foreground256 (Just (T.ColorNumber 175)) + +color256_f_176 :: Foreground256 +color256_f_176 = Foreground256 (Just (T.ColorNumber 176)) + +color256_f_177 :: Foreground256 +color256_f_177 = Foreground256 (Just (T.ColorNumber 177)) + +color256_f_178 :: Foreground256 +color256_f_178 = Foreground256 (Just (T.ColorNumber 178)) + +color256_f_179 :: Foreground256 +color256_f_179 = Foreground256 (Just (T.ColorNumber 179)) + +color256_f_180 :: Foreground256 +color256_f_180 = Foreground256 (Just (T.ColorNumber 180)) + +color256_f_181 :: Foreground256 +color256_f_181 = Foreground256 (Just (T.ColorNumber 181)) + +color256_f_182 :: Foreground256 +color256_f_182 = Foreground256 (Just (T.ColorNumber 182)) + +color256_f_183 :: Foreground256 +color256_f_183 = Foreground256 (Just (T.ColorNumber 183)) + +color256_f_184 :: Foreground256 +color256_f_184 = Foreground256 (Just (T.ColorNumber 184)) + +color256_f_185 :: Foreground256 +color256_f_185 = Foreground256 (Just (T.ColorNumber 185)) + +color256_f_186 :: Foreground256 +color256_f_186 = Foreground256 (Just (T.ColorNumber 186)) + +color256_f_187 :: Foreground256 +color256_f_187 = Foreground256 (Just (T.ColorNumber 187)) + +color256_f_188 :: Foreground256 +color256_f_188 = Foreground256 (Just (T.ColorNumber 188)) + +color256_f_189 :: Foreground256 +color256_f_189 = Foreground256 (Just (T.ColorNumber 189)) + +color256_f_190 :: Foreground256 +color256_f_190 = Foreground256 (Just (T.ColorNumber 190)) + +color256_f_191 :: Foreground256 +color256_f_191 = Foreground256 (Just (T.ColorNumber 191)) + +color256_f_192 :: Foreground256 +color256_f_192 = Foreground256 (Just (T.ColorNumber 192)) + +color256_f_193 :: Foreground256 +color256_f_193 = Foreground256 (Just (T.ColorNumber 193)) + +color256_f_194 :: Foreground256 +color256_f_194 = Foreground256 (Just (T.ColorNumber 194)) + +color256_f_195 :: Foreground256 +color256_f_195 = Foreground256 (Just (T.ColorNumber 195)) + +color256_f_196 :: Foreground256 +color256_f_196 = Foreground256 (Just (T.ColorNumber 196)) + +color256_f_197 :: Foreground256 +color256_f_197 = Foreground256 (Just (T.ColorNumber 197)) + +color256_f_198 :: Foreground256 +color256_f_198 = Foreground256 (Just (T.ColorNumber 198)) + +color256_f_199 :: Foreground256 +color256_f_199 = Foreground256 (Just (T.ColorNumber 199)) + +color256_f_200 :: Foreground256 +color256_f_200 = Foreground256 (Just (T.ColorNumber 200)) + +color256_f_201 :: Foreground256 +color256_f_201 = Foreground256 (Just (T.ColorNumber 201)) + +color256_f_202 :: Foreground256 +color256_f_202 = Foreground256 (Just (T.ColorNumber 202)) + +color256_f_203 :: Foreground256 +color256_f_203 = Foreground256 (Just (T.ColorNumber 203)) + +color256_f_204 :: Foreground256 +color256_f_204 = Foreground256 (Just (T.ColorNumber 204)) + +color256_f_205 :: Foreground256 +color256_f_205 = Foreground256 (Just (T.ColorNumber 205)) + +color256_f_206 :: Foreground256 +color256_f_206 = Foreground256 (Just (T.ColorNumber 206)) + +color256_f_207 :: Foreground256 +color256_f_207 = Foreground256 (Just (T.ColorNumber 207)) + +color256_f_208 :: Foreground256 +color256_f_208 = Foreground256 (Just (T.ColorNumber 208)) + +color256_f_209 :: Foreground256 +color256_f_209 = Foreground256 (Just (T.ColorNumber 209)) + +color256_f_210 :: Foreground256 +color256_f_210 = Foreground256 (Just (T.ColorNumber 210)) + +color256_f_211 :: Foreground256 +color256_f_211 = Foreground256 (Just (T.ColorNumber 211)) + +color256_f_212 :: Foreground256 +color256_f_212 = Foreground256 (Just (T.ColorNumber 212)) + +color256_f_213 :: Foreground256 +color256_f_213 = Foreground256 (Just (T.ColorNumber 213)) + +color256_f_214 :: Foreground256 +color256_f_214 = Foreground256 (Just (T.ColorNumber 214)) + +color256_f_215 :: Foreground256 +color256_f_215 = Foreground256 (Just (T.ColorNumber 215)) + +color256_f_216 :: Foreground256 +color256_f_216 = Foreground256 (Just (T.ColorNumber 216)) + +color256_f_217 :: Foreground256 +color256_f_217 = Foreground256 (Just (T.ColorNumber 217)) + +color256_f_218 :: Foreground256 +color256_f_218 = Foreground256 (Just (T.ColorNumber 218)) + +color256_f_219 :: Foreground256 +color256_f_219 = Foreground256 (Just (T.ColorNumber 219)) + +color256_f_220 :: Foreground256 +color256_f_220 = Foreground256 (Just (T.ColorNumber 220)) + +color256_f_221 :: Foreground256 +color256_f_221 = Foreground256 (Just (T.ColorNumber 221)) + +color256_f_222 :: Foreground256 +color256_f_222 = Foreground256 (Just (T.ColorNumber 222)) + +color256_f_223 :: Foreground256 +color256_f_223 = Foreground256 (Just (T.ColorNumber 223)) + +color256_f_224 :: Foreground256 +color256_f_224 = Foreground256 (Just (T.ColorNumber 224)) + +color256_f_225 :: Foreground256 +color256_f_225 = Foreground256 (Just (T.ColorNumber 225)) + +color256_f_226 :: Foreground256 +color256_f_226 = Foreground256 (Just (T.ColorNumber 226)) + +color256_f_227 :: Foreground256 +color256_f_227 = Foreground256 (Just (T.ColorNumber 227)) + +color256_f_228 :: Foreground256 +color256_f_228 = Foreground256 (Just (T.ColorNumber 228)) + +color256_f_229 :: Foreground256 +color256_f_229 = Foreground256 (Just (T.ColorNumber 229)) + +color256_f_230 :: Foreground256 +color256_f_230 = Foreground256 (Just (T.ColorNumber 230)) + +color256_f_231 :: Foreground256 +color256_f_231 = Foreground256 (Just (T.ColorNumber 231)) + +color256_f_232 :: Foreground256 +color256_f_232 = Foreground256 (Just (T.ColorNumber 232)) + +color256_f_233 :: Foreground256 +color256_f_233 = Foreground256 (Just (T.ColorNumber 233)) + +color256_f_234 :: Foreground256 +color256_f_234 = Foreground256 (Just (T.ColorNumber 234)) + +color256_f_235 :: Foreground256 +color256_f_235 = Foreground256 (Just (T.ColorNumber 235)) + +color256_f_236 :: Foreground256 +color256_f_236 = Foreground256 (Just (T.ColorNumber 236)) + +color256_f_237 :: Foreground256 +color256_f_237 = Foreground256 (Just (T.ColorNumber 237)) + +color256_f_238 :: Foreground256 +color256_f_238 = Foreground256 (Just (T.ColorNumber 238)) + +color256_f_239 :: Foreground256 +color256_f_239 = Foreground256 (Just (T.ColorNumber 239)) + +color256_f_240 :: Foreground256 +color256_f_240 = Foreground256 (Just (T.ColorNumber 240)) + +color256_f_241 :: Foreground256 +color256_f_241 = Foreground256 (Just (T.ColorNumber 241)) + +color256_f_242 :: Foreground256 +color256_f_242 = Foreground256 (Just (T.ColorNumber 242)) + +color256_f_243 :: Foreground256 +color256_f_243 = Foreground256 (Just (T.ColorNumber 243)) + +color256_f_244 :: Foreground256 +color256_f_244 = Foreground256 (Just (T.ColorNumber 244)) + +color256_f_245 :: Foreground256 +color256_f_245 = Foreground256 (Just (T.ColorNumber 245)) + +color256_f_246 :: Foreground256 +color256_f_246 = Foreground256 (Just (T.ColorNumber 246)) + +color256_f_247 :: Foreground256 +color256_f_247 = Foreground256 (Just (T.ColorNumber 247)) + +color256_f_248 :: Foreground256 +color256_f_248 = Foreground256 (Just (T.ColorNumber 248)) + +color256_f_249 :: Foreground256 +color256_f_249 = Foreground256 (Just (T.ColorNumber 249)) + +color256_f_250 :: Foreground256 +color256_f_250 = Foreground256 (Just (T.ColorNumber 250)) + +color256_f_251 :: Foreground256 +color256_f_251 = Foreground256 (Just (T.ColorNumber 251)) + +color256_f_252 :: Foreground256 +color256_f_252 = Foreground256 (Just (T.ColorNumber 252)) + +color256_f_253 :: Foreground256 +color256_f_253 = Foreground256 (Just (T.ColorNumber 253)) + +color256_f_254 :: Foreground256 +color256_f_254 = Foreground256 (Just (T.ColorNumber 254)) + +color256_f_255 :: Foreground256 +color256_f_255 = Foreground256 (Just (T.ColorNumber 255)) + +color256_b_default :: Background256 +color256_b_default = Background256 Nothing + +color256_b_0 :: Background256 +color256_b_0 = Background256 (Just (T.ColorNumber 0)) + +color256_b_1 :: Background256 +color256_b_1 = Background256 (Just (T.ColorNumber 1)) + +color256_b_2 :: Background256 +color256_b_2 = Background256 (Just (T.ColorNumber 2)) + +color256_b_3 :: Background256 +color256_b_3 = Background256 (Just (T.ColorNumber 3)) + +color256_b_4 :: Background256 +color256_b_4 = Background256 (Just (T.ColorNumber 4)) + +color256_b_5 :: Background256 +color256_b_5 = Background256 (Just (T.ColorNumber 5)) + +color256_b_6 :: Background256 +color256_b_6 = Background256 (Just (T.ColorNumber 6)) + +color256_b_7 :: Background256 +color256_b_7 = Background256 (Just (T.ColorNumber 7)) + +color256_b_8 :: Background256 +color256_b_8 = Background256 (Just (T.ColorNumber 8)) + +color256_b_9 :: Background256 +color256_b_9 = Background256 (Just (T.ColorNumber 9)) + +color256_b_10 :: Background256 +color256_b_10 = Background256 (Just (T.ColorNumber 10)) + +color256_b_11 :: Background256 +color256_b_11 = Background256 (Just (T.ColorNumber 11)) + +color256_b_12 :: Background256 +color256_b_12 = Background256 (Just (T.ColorNumber 12)) + +color256_b_13 :: Background256 +color256_b_13 = Background256 (Just (T.ColorNumber 13)) + +color256_b_14 :: Background256 +color256_b_14 = Background256 (Just (T.ColorNumber 14)) + +color256_b_15 :: Background256 +color256_b_15 = Background256 (Just (T.ColorNumber 15)) + +color256_b_16 :: Background256 +color256_b_16 = Background256 (Just (T.ColorNumber 16)) + +color256_b_17 :: Background256 +color256_b_17 = Background256 (Just (T.ColorNumber 17)) + +color256_b_18 :: Background256 +color256_b_18 = Background256 (Just (T.ColorNumber 18)) + +color256_b_19 :: Background256 +color256_b_19 = Background256 (Just (T.ColorNumber 19)) + +color256_b_20 :: Background256 +color256_b_20 = Background256 (Just (T.ColorNumber 20)) + +color256_b_21 :: Background256 +color256_b_21 = Background256 (Just (T.ColorNumber 21)) + +color256_b_22 :: Background256 +color256_b_22 = Background256 (Just (T.ColorNumber 22)) + +color256_b_23 :: Background256 +color256_b_23 = Background256 (Just (T.ColorNumber 23)) + +color256_b_24 :: Background256 +color256_b_24 = Background256 (Just (T.ColorNumber 24)) + +color256_b_25 :: Background256 +color256_b_25 = Background256 (Just (T.ColorNumber 25)) + +color256_b_26 :: Background256 +color256_b_26 = Background256 (Just (T.ColorNumber 26)) + +color256_b_27 :: Background256 +color256_b_27 = Background256 (Just (T.ColorNumber 27)) + +color256_b_28 :: Background256 +color256_b_28 = Background256 (Just (T.ColorNumber 28)) + +color256_b_29 :: Background256 +color256_b_29 = Background256 (Just (T.ColorNumber 29)) + +color256_b_30 :: Background256 +color256_b_30 = Background256 (Just (T.ColorNumber 30)) + +color256_b_31 :: Background256 +color256_b_31 = Background256 (Just (T.ColorNumber 31)) + +color256_b_32 :: Background256 +color256_b_32 = Background256 (Just (T.ColorNumber 32)) + +color256_b_33 :: Background256 +color256_b_33 = Background256 (Just (T.ColorNumber 33)) + +color256_b_34 :: Background256 +color256_b_34 = Background256 (Just (T.ColorNumber 34)) + +color256_b_35 :: Background256 +color256_b_35 = Background256 (Just (T.ColorNumber 35)) + +color256_b_36 :: Background256 +color256_b_36 = Background256 (Just (T.ColorNumber 36)) + +color256_b_37 :: Background256 +color256_b_37 = Background256 (Just (T.ColorNumber 37)) + +color256_b_38 :: Background256 +color256_b_38 = Background256 (Just (T.ColorNumber 38)) + +color256_b_39 :: Background256 +color256_b_39 = Background256 (Just (T.ColorNumber 39)) + +color256_b_40 :: Background256 +color256_b_40 = Background256 (Just (T.ColorNumber 40)) + +color256_b_41 :: Background256 +color256_b_41 = Background256 (Just (T.ColorNumber 41)) + +color256_b_42 :: Background256 +color256_b_42 = Background256 (Just (T.ColorNumber 42)) + +color256_b_43 :: Background256 +color256_b_43 = Background256 (Just (T.ColorNumber 43)) + +color256_b_44 :: Background256 +color256_b_44 = Background256 (Just (T.ColorNumber 44)) + +color256_b_45 :: Background256 +color256_b_45 = Background256 (Just (T.ColorNumber 45)) + +color256_b_46 :: Background256 +color256_b_46 = Background256 (Just (T.ColorNumber 46)) + +color256_b_47 :: Background256 +color256_b_47 = Background256 (Just (T.ColorNumber 47)) + +color256_b_48 :: Background256 +color256_b_48 = Background256 (Just (T.ColorNumber 48)) + +color256_b_49 :: Background256 +color256_b_49 = Background256 (Just (T.ColorNumber 49)) + +color256_b_50 :: Background256 +color256_b_50 = Background256 (Just (T.ColorNumber 50)) + +color256_b_51 :: Background256 +color256_b_51 = Background256 (Just (T.ColorNumber 51)) + +color256_b_52 :: Background256 +color256_b_52 = Background256 (Just (T.ColorNumber 52)) + +color256_b_53 :: Background256 +color256_b_53 = Background256 (Just (T.ColorNumber 53)) + +color256_b_54 :: Background256 +color256_b_54 = Background256 (Just (T.ColorNumber 54)) + +color256_b_55 :: Background256 +color256_b_55 = Background256 (Just (T.ColorNumber 55)) + +color256_b_56 :: Background256 +color256_b_56 = Background256 (Just (T.ColorNumber 56)) + +color256_b_57 :: Background256 +color256_b_57 = Background256 (Just (T.ColorNumber 57)) + +color256_b_58 :: Background256 +color256_b_58 = Background256 (Just (T.ColorNumber 58)) + +color256_b_59 :: Background256 +color256_b_59 = Background256 (Just (T.ColorNumber 59)) + +color256_b_60 :: Background256 +color256_b_60 = Background256 (Just (T.ColorNumber 60)) + +color256_b_61 :: Background256 +color256_b_61 = Background256 (Just (T.ColorNumber 61)) + +color256_b_62 :: Background256 +color256_b_62 = Background256 (Just (T.ColorNumber 62)) + +color256_b_63 :: Background256 +color256_b_63 = Background256 (Just (T.ColorNumber 63)) + +color256_b_64 :: Background256 +color256_b_64 = Background256 (Just (T.ColorNumber 64)) + +color256_b_65 :: Background256 +color256_b_65 = Background256 (Just (T.ColorNumber 65)) + +color256_b_66 :: Background256 +color256_b_66 = Background256 (Just (T.ColorNumber 66)) + +color256_b_67 :: Background256 +color256_b_67 = Background256 (Just (T.ColorNumber 67)) + +color256_b_68 :: Background256 +color256_b_68 = Background256 (Just (T.ColorNumber 68)) + +color256_b_69 :: Background256 +color256_b_69 = Background256 (Just (T.ColorNumber 69)) + +color256_b_70 :: Background256 +color256_b_70 = Background256 (Just (T.ColorNumber 70)) + +color256_b_71 :: Background256 +color256_b_71 = Background256 (Just (T.ColorNumber 71)) + +color256_b_72 :: Background256 +color256_b_72 = Background256 (Just (T.ColorNumber 72)) + +color256_b_73 :: Background256 +color256_b_73 = Background256 (Just (T.ColorNumber 73)) + +color256_b_74 :: Background256 +color256_b_74 = Background256 (Just (T.ColorNumber 74)) + +color256_b_75 :: Background256 +color256_b_75 = Background256 (Just (T.ColorNumber 75)) + +color256_b_76 :: Background256 +color256_b_76 = Background256 (Just (T.ColorNumber 76)) + +color256_b_77 :: Background256 +color256_b_77 = Background256 (Just (T.ColorNumber 77)) + +color256_b_78 :: Background256 +color256_b_78 = Background256 (Just (T.ColorNumber 78)) + +color256_b_79 :: Background256 +color256_b_79 = Background256 (Just (T.ColorNumber 79)) + +color256_b_80 :: Background256 +color256_b_80 = Background256 (Just (T.ColorNumber 80)) + +color256_b_81 :: Background256 +color256_b_81 = Background256 (Just (T.ColorNumber 81)) + +color256_b_82 :: Background256 +color256_b_82 = Background256 (Just (T.ColorNumber 82)) + +color256_b_83 :: Background256 +color256_b_83 = Background256 (Just (T.ColorNumber 83)) + +color256_b_84 :: Background256 +color256_b_84 = Background256 (Just (T.ColorNumber 84)) + +color256_b_85 :: Background256 +color256_b_85 = Background256 (Just (T.ColorNumber 85)) + +color256_b_86 :: Background256 +color256_b_86 = Background256 (Just (T.ColorNumber 86)) + +color256_b_87 :: Background256 +color256_b_87 = Background256 (Just (T.ColorNumber 87)) + +color256_b_88 :: Background256 +color256_b_88 = Background256 (Just (T.ColorNumber 88)) + +color256_b_89 :: Background256 +color256_b_89 = Background256 (Just (T.ColorNumber 89)) + +color256_b_90 :: Background256 +color256_b_90 = Background256 (Just (T.ColorNumber 90)) + +color256_b_91 :: Background256 +color256_b_91 = Background256 (Just (T.ColorNumber 91)) + +color256_b_92 :: Background256 +color256_b_92 = Background256 (Just (T.ColorNumber 92)) + +color256_b_93 :: Background256 +color256_b_93 = Background256 (Just (T.ColorNumber 93)) + +color256_b_94 :: Background256 +color256_b_94 = Background256 (Just (T.ColorNumber 94)) + +color256_b_95 :: Background256 +color256_b_95 = Background256 (Just (T.ColorNumber 95)) + +color256_b_96 :: Background256 +color256_b_96 = Background256 (Just (T.ColorNumber 96)) + +color256_b_97 :: Background256 +color256_b_97 = Background256 (Just (T.ColorNumber 97)) + +color256_b_98 :: Background256 +color256_b_98 = Background256 (Just (T.ColorNumber 98)) + +color256_b_99 :: Background256 +color256_b_99 = Background256 (Just (T.ColorNumber 99)) + +color256_b_100 :: Background256 +color256_b_100 = Background256 (Just (T.ColorNumber 100)) + +color256_b_101 :: Background256 +color256_b_101 = Background256 (Just (T.ColorNumber 101)) + +color256_b_102 :: Background256 +color256_b_102 = Background256 (Just (T.ColorNumber 102)) + +color256_b_103 :: Background256 +color256_b_103 = Background256 (Just (T.ColorNumber 103)) + +color256_b_104 :: Background256 +color256_b_104 = Background256 (Just (T.ColorNumber 104)) + +color256_b_105 :: Background256 +color256_b_105 = Background256 (Just (T.ColorNumber 105)) + +color256_b_106 :: Background256 +color256_b_106 = Background256 (Just (T.ColorNumber 106)) + +color256_b_107 :: Background256 +color256_b_107 = Background256 (Just (T.ColorNumber 107)) + +color256_b_108 :: Background256 +color256_b_108 = Background256 (Just (T.ColorNumber 108)) + +color256_b_109 :: Background256 +color256_b_109 = Background256 (Just (T.ColorNumber 109)) + +color256_b_110 :: Background256 +color256_b_110 = Background256 (Just (T.ColorNumber 110)) + +color256_b_111 :: Background256 +color256_b_111 = Background256 (Just (T.ColorNumber 111)) + +color256_b_112 :: Background256 +color256_b_112 = Background256 (Just (T.ColorNumber 112)) + +color256_b_113 :: Background256 +color256_b_113 = Background256 (Just (T.ColorNumber 113)) + +color256_b_114 :: Background256 +color256_b_114 = Background256 (Just (T.ColorNumber 114)) + +color256_b_115 :: Background256 +color256_b_115 = Background256 (Just (T.ColorNumber 115)) + +color256_b_116 :: Background256 +color256_b_116 = Background256 (Just (T.ColorNumber 116)) + +color256_b_117 :: Background256 +color256_b_117 = Background256 (Just (T.ColorNumber 117)) + +color256_b_118 :: Background256 +color256_b_118 = Background256 (Just (T.ColorNumber 118)) + +color256_b_119 :: Background256 +color256_b_119 = Background256 (Just (T.ColorNumber 119)) + +color256_b_120 :: Background256 +color256_b_120 = Background256 (Just (T.ColorNumber 120)) + +color256_b_121 :: Background256 +color256_b_121 = Background256 (Just (T.ColorNumber 121)) + +color256_b_122 :: Background256 +color256_b_122 = Background256 (Just (T.ColorNumber 122)) + +color256_b_123 :: Background256 +color256_b_123 = Background256 (Just (T.ColorNumber 123)) + +color256_b_124 :: Background256 +color256_b_124 = Background256 (Just (T.ColorNumber 124)) + +color256_b_125 :: Background256 +color256_b_125 = Background256 (Just (T.ColorNumber 125)) + +color256_b_126 :: Background256 +color256_b_126 = Background256 (Just (T.ColorNumber 126)) + +color256_b_127 :: Background256 +color256_b_127 = Background256 (Just (T.ColorNumber 127)) + +color256_b_128 :: Background256 +color256_b_128 = Background256 (Just (T.ColorNumber 128)) + +color256_b_129 :: Background256 +color256_b_129 = Background256 (Just (T.ColorNumber 129)) + +color256_b_130 :: Background256 +color256_b_130 = Background256 (Just (T.ColorNumber 130)) + +color256_b_131 :: Background256 +color256_b_131 = Background256 (Just (T.ColorNumber 131)) + +color256_b_132 :: Background256 +color256_b_132 = Background256 (Just (T.ColorNumber 132)) + +color256_b_133 :: Background256 +color256_b_133 = Background256 (Just (T.ColorNumber 133)) + +color256_b_134 :: Background256 +color256_b_134 = Background256 (Just (T.ColorNumber 134)) + +color256_b_135 :: Background256 +color256_b_135 = Background256 (Just (T.ColorNumber 135)) + +color256_b_136 :: Background256 +color256_b_136 = Background256 (Just (T.ColorNumber 136)) + +color256_b_137 :: Background256 +color256_b_137 = Background256 (Just (T.ColorNumber 137)) + +color256_b_138 :: Background256 +color256_b_138 = Background256 (Just (T.ColorNumber 138)) + +color256_b_139 :: Background256 +color256_b_139 = Background256 (Just (T.ColorNumber 139)) + +color256_b_140 :: Background256 +color256_b_140 = Background256 (Just (T.ColorNumber 140)) + +color256_b_141 :: Background256 +color256_b_141 = Background256 (Just (T.ColorNumber 141)) + +color256_b_142 :: Background256 +color256_b_142 = Background256 (Just (T.ColorNumber 142)) + +color256_b_143 :: Background256 +color256_b_143 = Background256 (Just (T.ColorNumber 143)) + +color256_b_144 :: Background256 +color256_b_144 = Background256 (Just (T.ColorNumber 144)) + +color256_b_145 :: Background256 +color256_b_145 = Background256 (Just (T.ColorNumber 145)) + +color256_b_146 :: Background256 +color256_b_146 = Background256 (Just (T.ColorNumber 146)) + +color256_b_147 :: Background256 +color256_b_147 = Background256 (Just (T.ColorNumber 147)) + +color256_b_148 :: Background256 +color256_b_148 = Background256 (Just (T.ColorNumber 148)) + +color256_b_149 :: Background256 +color256_b_149 = Background256 (Just (T.ColorNumber 149)) + +color256_b_150 :: Background256 +color256_b_150 = Background256 (Just (T.ColorNumber 150)) + +color256_b_151 :: Background256 +color256_b_151 = Background256 (Just (T.ColorNumber 151)) + +color256_b_152 :: Background256 +color256_b_152 = Background256 (Just (T.ColorNumber 152)) + +color256_b_153 :: Background256 +color256_b_153 = Background256 (Just (T.ColorNumber 153)) + +color256_b_154 :: Background256 +color256_b_154 = Background256 (Just (T.ColorNumber 154)) + +color256_b_155 :: Background256 +color256_b_155 = Background256 (Just (T.ColorNumber 155)) + +color256_b_156 :: Background256 +color256_b_156 = Background256 (Just (T.ColorNumber 156)) + +color256_b_157 :: Background256 +color256_b_157 = Background256 (Just (T.ColorNumber 157)) + +color256_b_158 :: Background256 +color256_b_158 = Background256 (Just (T.ColorNumber 158)) + +color256_b_159 :: Background256 +color256_b_159 = Background256 (Just (T.ColorNumber 159)) + +color256_b_160 :: Background256 +color256_b_160 = Background256 (Just (T.ColorNumber 160)) + +color256_b_161 :: Background256 +color256_b_161 = Background256 (Just (T.ColorNumber 161)) + +color256_b_162 :: Background256 +color256_b_162 = Background256 (Just (T.ColorNumber 162)) + +color256_b_163 :: Background256 +color256_b_163 = Background256 (Just (T.ColorNumber 163)) + +color256_b_164 :: Background256 +color256_b_164 = Background256 (Just (T.ColorNumber 164)) + +color256_b_165 :: Background256 +color256_b_165 = Background256 (Just (T.ColorNumber 165)) + +color256_b_166 :: Background256 +color256_b_166 = Background256 (Just (T.ColorNumber 166)) + +color256_b_167 :: Background256 +color256_b_167 = Background256 (Just (T.ColorNumber 167)) + +color256_b_168 :: Background256 +color256_b_168 = Background256 (Just (T.ColorNumber 168)) + +color256_b_169 :: Background256 +color256_b_169 = Background256 (Just (T.ColorNumber 169)) + +color256_b_170 :: Background256 +color256_b_170 = Background256 (Just (T.ColorNumber 170)) + +color256_b_171 :: Background256 +color256_b_171 = Background256 (Just (T.ColorNumber 171)) + +color256_b_172 :: Background256 +color256_b_172 = Background256 (Just (T.ColorNumber 172)) + +color256_b_173 :: Background256 +color256_b_173 = Background256 (Just (T.ColorNumber 173)) + +color256_b_174 :: Background256 +color256_b_174 = Background256 (Just (T.ColorNumber 174)) + +color256_b_175 :: Background256 +color256_b_175 = Background256 (Just (T.ColorNumber 175)) + +color256_b_176 :: Background256 +color256_b_176 = Background256 (Just (T.ColorNumber 176)) + +color256_b_177 :: Background256 +color256_b_177 = Background256 (Just (T.ColorNumber 177)) + +color256_b_178 :: Background256 +color256_b_178 = Background256 (Just (T.ColorNumber 178)) + +color256_b_179 :: Background256 +color256_b_179 = Background256 (Just (T.ColorNumber 179)) + +color256_b_180 :: Background256 +color256_b_180 = Background256 (Just (T.ColorNumber 180)) + +color256_b_181 :: Background256 +color256_b_181 = Background256 (Just (T.ColorNumber 181)) + +color256_b_182 :: Background256 +color256_b_182 = Background256 (Just (T.ColorNumber 182)) + +color256_b_183 :: Background256 +color256_b_183 = Background256 (Just (T.ColorNumber 183)) + +color256_b_184 :: Background256 +color256_b_184 = Background256 (Just (T.ColorNumber 184)) + +color256_b_185 :: Background256 +color256_b_185 = Background256 (Just (T.ColorNumber 185)) + +color256_b_186 :: Background256 +color256_b_186 = Background256 (Just (T.ColorNumber 186)) + +color256_b_187 :: Background256 +color256_b_187 = Background256 (Just (T.ColorNumber 187)) + +color256_b_188 :: Background256 +color256_b_188 = Background256 (Just (T.ColorNumber 188)) + +color256_b_189 :: Background256 +color256_b_189 = Background256 (Just (T.ColorNumber 189)) + +color256_b_190 :: Background256 +color256_b_190 = Background256 (Just (T.ColorNumber 190)) + +color256_b_191 :: Background256 +color256_b_191 = Background256 (Just (T.ColorNumber 191)) + +color256_b_192 :: Background256 +color256_b_192 = Background256 (Just (T.ColorNumber 192)) + +color256_b_193 :: Background256 +color256_b_193 = Background256 (Just (T.ColorNumber 193)) + +color256_b_194 :: Background256 +color256_b_194 = Background256 (Just (T.ColorNumber 194)) + +color256_b_195 :: Background256 +color256_b_195 = Background256 (Just (T.ColorNumber 195)) + +color256_b_196 :: Background256 +color256_b_196 = Background256 (Just (T.ColorNumber 196)) + +color256_b_197 :: Background256 +color256_b_197 = Background256 (Just (T.ColorNumber 197)) + +color256_b_198 :: Background256 +color256_b_198 = Background256 (Just (T.ColorNumber 198)) + +color256_b_199 :: Background256 +color256_b_199 = Background256 (Just (T.ColorNumber 199)) + +color256_b_200 :: Background256 +color256_b_200 = Background256 (Just (T.ColorNumber 200)) + +color256_b_201 :: Background256 +color256_b_201 = Background256 (Just (T.ColorNumber 201)) + +color256_b_202 :: Background256 +color256_b_202 = Background256 (Just (T.ColorNumber 202)) + +color256_b_203 :: Background256 +color256_b_203 = Background256 (Just (T.ColorNumber 203)) + +color256_b_204 :: Background256 +color256_b_204 = Background256 (Just (T.ColorNumber 204)) + +color256_b_205 :: Background256 +color256_b_205 = Background256 (Just (T.ColorNumber 205)) + +color256_b_206 :: Background256 +color256_b_206 = Background256 (Just (T.ColorNumber 206)) + +color256_b_207 :: Background256 +color256_b_207 = Background256 (Just (T.ColorNumber 207)) + +color256_b_208 :: Background256 +color256_b_208 = Background256 (Just (T.ColorNumber 208)) + +color256_b_209 :: Background256 +color256_b_209 = Background256 (Just (T.ColorNumber 209)) + +color256_b_210 :: Background256 +color256_b_210 = Background256 (Just (T.ColorNumber 210)) + +color256_b_211 :: Background256 +color256_b_211 = Background256 (Just (T.ColorNumber 211)) + +color256_b_212 :: Background256 +color256_b_212 = Background256 (Just (T.ColorNumber 212)) + +color256_b_213 :: Background256 +color256_b_213 = Background256 (Just (T.ColorNumber 213)) + +color256_b_214 :: Background256 +color256_b_214 = Background256 (Just (T.ColorNumber 214)) + +color256_b_215 :: Background256 +color256_b_215 = Background256 (Just (T.ColorNumber 215)) + +color256_b_216 :: Background256 +color256_b_216 = Background256 (Just (T.ColorNumber 216)) + +color256_b_217 :: Background256 +color256_b_217 = Background256 (Just (T.ColorNumber 217)) + +color256_b_218 :: Background256 +color256_b_218 = Background256 (Just (T.ColorNumber 218)) + +color256_b_219 :: Background256 +color256_b_219 = Background256 (Just (T.ColorNumber 219)) + +color256_b_220 :: Background256 +color256_b_220 = Background256 (Just (T.ColorNumber 220)) + +color256_b_221 :: Background256 +color256_b_221 = Background256 (Just (T.ColorNumber 221)) + +color256_b_222 :: Background256 +color256_b_222 = Background256 (Just (T.ColorNumber 222)) + +color256_b_223 :: Background256 +color256_b_223 = Background256 (Just (T.ColorNumber 223)) + +color256_b_224 :: Background256 +color256_b_224 = Background256 (Just (T.ColorNumber 224)) + +color256_b_225 :: Background256 +color256_b_225 = Background256 (Just (T.ColorNumber 225)) + +color256_b_226 :: Background256 +color256_b_226 = Background256 (Just (T.ColorNumber 226)) + +color256_b_227 :: Background256 +color256_b_227 = Background256 (Just (T.ColorNumber 227)) + +color256_b_228 :: Background256 +color256_b_228 = Background256 (Just (T.ColorNumber 228)) + +color256_b_229 :: Background256 +color256_b_229 = Background256 (Just (T.ColorNumber 229)) + +color256_b_230 :: Background256 +color256_b_230 = Background256 (Just (T.ColorNumber 230)) + +color256_b_231 :: Background256 +color256_b_231 = Background256 (Just (T.ColorNumber 231)) + +color256_b_232 :: Background256 +color256_b_232 = Background256 (Just (T.ColorNumber 232)) + +color256_b_233 :: Background256 +color256_b_233 = Background256 (Just (T.ColorNumber 233)) + +color256_b_234 :: Background256 +color256_b_234 = Background256 (Just (T.ColorNumber 234)) + +color256_b_235 :: Background256 +color256_b_235 = Background256 (Just (T.ColorNumber 235)) + +color256_b_236 :: Background256 +color256_b_236 = Background256 (Just (T.ColorNumber 236)) + +color256_b_237 :: Background256 +color256_b_237 = Background256 (Just (T.ColorNumber 237)) + +color256_b_238 :: Background256 +color256_b_238 = Background256 (Just (T.ColorNumber 238)) + +color256_b_239 :: Background256 +color256_b_239 = Background256 (Just (T.ColorNumber 239)) + +color256_b_240 :: Background256 +color256_b_240 = Background256 (Just (T.ColorNumber 240)) + +color256_b_241 :: Background256 +color256_b_241 = Background256 (Just (T.ColorNumber 241)) + +color256_b_242 :: Background256 +color256_b_242 = Background256 (Just (T.ColorNumber 242)) + +color256_b_243 :: Background256 +color256_b_243 = Background256 (Just (T.ColorNumber 243)) + +color256_b_244 :: Background256 +color256_b_244 = Background256 (Just (T.ColorNumber 244)) + +color256_b_245 :: Background256 +color256_b_245 = Background256 (Just (T.ColorNumber 245)) + +color256_b_246 :: Background256 +color256_b_246 = Background256 (Just (T.ColorNumber 246)) + +color256_b_247 :: Background256 +color256_b_247 = Background256 (Just (T.ColorNumber 247)) + +color256_b_248 :: Background256 +color256_b_248 = Background256 (Just (T.ColorNumber 248)) + +color256_b_249 :: Background256 +color256_b_249 = Background256 (Just (T.ColorNumber 249)) + +color256_b_250 :: Background256 +color256_b_250 = Background256 (Just (T.ColorNumber 250)) + +color256_b_251 :: Background256 +color256_b_251 = Background256 (Just (T.ColorNumber 251)) + +color256_b_252 :: Background256 +color256_b_252 = Background256 (Just (T.ColorNumber 252)) + +color256_b_253 :: Background256 +color256_b_253 = Background256 (Just (T.ColorNumber 253)) + +color256_b_254 :: Background256 +color256_b_254 = Background256 (Just (T.ColorNumber 254)) + +color256_b_255 :: Background256 +color256_b_255 = Background256 (Just (T.ColorNumber 255)) diff --git a/Penny/Cabin/Colors.hs b/Penny/Cabin/Colors.hs deleted file mode 100644 --- a/Penny/Cabin/Colors.hs +++ /dev/null @@ -1,50 +0,0 @@ -module Penny.Cabin.Colors where - -import qualified Penny.Lincoln as L -import qualified Penny.Lincoln.Balance as Bal -import qualified Penny.Lincoln.Bits as Bits -import qualified Penny.Cabin.Chunk as C -import qualified Penny.Cabin.Meta as M - --- | The colors for debits and credits. These are used for the entry's --- amount and for the total amounts that accompany each entry. Here, --- @even@ and @odd@ refer to the the posting's visible number. @Zero@ --- is for the balance entries whose balance is zero. -data DrCrColors = - DrCrColors { evenDebit :: !C.TextSpec - , evenCredit :: !C.TextSpec - , oddDebit :: !C.TextSpec - , oddCredit :: !C.TextSpec - , evenZero :: !C.TextSpec - , oddZero :: !C.TextSpec } - --- | The colors for all fields other than entries and totals. -data BaseColors = - BaseColors { evenColors :: !C.TextSpec - , oddColors :: !C.TextSpec } - --- | Change a BaseColors to a TextSpec. -colors :: M.VisibleNum -> BaseColors -> C.TextSpec -colors vn b = let n = L.forward . M.unVisibleNum $ vn in - if odd n then oddColors b else evenColors b - --- | Change a DrCrColors to a BaseColors; you can then use 'colors' to --- change that to a TextSpec. -drCrToBaseColors :: Bits.DrCr -> DrCrColors -> BaseColors -drCrToBaseColors dc col = case dc of - Bits.Debit -> BaseColors (evenDebit col) (oddDebit col) - Bits.Credit -> BaseColors (evenCredit col) (oddCredit col) - --- | Change a DrCrColors to a BaseColors, based on a balance (unlike --- entries, balances might be zero.) -bottomLineToBaseColors :: DrCrColors -> Bal.BottomLine -> BaseColors -bottomLineToBaseColors col no = case no of - Bal.Zero -> BaseColors (evenZero col) (oddZero col) - Bal.NonZero column -> drCrToBaseColors (Bal.drCr column) col - --- | TextSpec to use when showing the lack of a balance. -noBalanceColors :: M.VisibleNum -> DrCrColors -> C.TextSpec -noBalanceColors vn dc = - if odd . L.forward . M.unVisibleNum $ vn - then oddZero dc - else evenZero dc diff --git a/Penny/Cabin/Colors/DarkBackground.hs b/Penny/Cabin/Colors/DarkBackground.hs deleted file mode 100644 --- a/Penny/Cabin/Colors/DarkBackground.hs +++ /dev/null @@ -1,38 +0,0 @@ --- | The default colors; the user may override. -module Penny.Cabin.Colors.DarkBackground where - -import qualified Penny.Cabin.Colors as PC -import qualified Penny.Cabin.Chunk as CC -import qualified Penny.Cabin.Chunk.Switch as S - -baseColors :: PC.BaseColors -baseColors = PC.BaseColors evenTextSpec oddTextSpec - -drCrColors :: PC.DrCrColors -drCrColors = PC.DrCrColors { PC.evenDebit = debit evenTextSpec - , PC.evenCredit = credit evenTextSpec - , PC.oddDebit = debit oddTextSpec - , PC.oddCredit = credit oddTextSpec - , PC.evenZero = zero evenTextSpec - , PC.oddZero = zero oddTextSpec } - -evenTextSpec :: CC.TextSpec -evenTextSpec = CC.defaultTextSpec - -oddTextSpec :: CC.TextSpec -oddTextSpec = S.switchBackground CC.color8_b_default - CC.color256_b_235 evenTextSpec - --- | Debits in 256 colors are orange; in 8 colors, magenta -debit :: CC.TextSpec -> CC.TextSpec -debit = S.switchForeground CC.color8_f_magenta CC.color256_f_208 - --- | Credits in 256 colors are cyan; in 8 colors, cyan -credit :: CC.TextSpec -> CC.TextSpec -credit = S.switchForeground CC.color8_f_cyan (CC.color256_f_45) - --- | Zero values are white -zero :: CC.TextSpec -> CC.TextSpec -zero = S.switchForeground CC.color8_f_white (CC.color256_f_15) - - diff --git a/Penny/Cabin/Colors/LightBackground.hs b/Penny/Cabin/Colors/LightBackground.hs deleted file mode 100644 --- a/Penny/Cabin/Colors/LightBackground.hs +++ /dev/null @@ -1,35 +0,0 @@ --- | The default colors; the user may override. -module Penny.Cabin.Colors.LightBackground where - -import qualified Penny.Cabin.Colors as PC -import qualified Penny.Cabin.Chunk as CC -import qualified Penny.Cabin.Chunk.Switch as S - -baseColors :: PC.BaseColors -baseColors = PC.BaseColors evenTextSpec oddTextSpec - -drCrColors :: PC.DrCrColors -drCrColors = PC.DrCrColors { PC.evenDebit = debit evenTextSpec - , PC.evenCredit = credit evenTextSpec - , PC.oddDebit = debit oddTextSpec - , PC.oddCredit = credit oddTextSpec - , PC.evenZero = zero evenTextSpec - , PC.oddZero = zero oddTextSpec } - -evenTextSpec :: CC.TextSpec -evenTextSpec = CC.defaultTextSpec - -oddTextSpec :: CC.TextSpec -oddTextSpec = S.switchBackground CC.color8_b_default - (CC.color256_b_247) evenTextSpec - -debit :: CC.TextSpec -> CC.TextSpec -debit = S.switchForeground CC.color8_f_magenta (CC.color256_f_13) - -credit :: CC.TextSpec -> CC.TextSpec -credit = S.switchForeground CC.color8_f_cyan (CC.color256_f_14) - -zero :: CC.TextSpec -> CC.TextSpec -zero = S.switchForeground CC.color8_f_white (CC.color256_f_15) - - diff --git a/Penny/Cabin/Interface.hs b/Penny/Cabin/Interface.hs --- a/Penny/Cabin/Interface.hs +++ b/Penny/Cabin/Interface.hs @@ -2,54 +2,57 @@ -- anything that is a 'Report'. module Penny.Cabin.Interface where +import qualified Penny.Cabin.Scheme as S import Control.Monad.Exception.Synchronous (Exceptional) import qualified Data.Text as X -import qualified Data.Text.Lazy as XL import Text.Matchers.Text (CaseSensitive) -import System.Console.MultiArg.Prim (Parser) +import qualified System.Console.MultiArg as MA import qualified Penny.Lincoln as L import qualified Penny.Liberty as Ly import Penny.Shield (Runtime) -type ReportFunc = - Runtime - -- ^ Information only known at runtime, such as the - -- environment. Does not include any information that is derived - -- from parsing the command line. +-- | 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. - -> CaseSensitive +-- | 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) +type ParseResult = Exceptional String (Either HelpStr 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 [S.PreChunk] + -- ^ The exception type is a strict Text, containing the error + -- message. The success type is a list of PreChunks containing the + -- resulting report. This allows for errors after the list of + -- transactions has been seen. + + +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 (X.Text -> Bool)) -- ^ Result from previous parsers indicating the matcher factory the -- user wishes to use - - -> [L.Box Ly.LibertyMeta] - -- ^ Postings that will be included in the report - - -> [L.PricePoint] - -- ^ PricePoints to be included in the report - - - -> Exceptional X.Text XL.Text - -- ^ The exception type is a strict Text, containing the error - -- message. The success type is a lazy Text, containing the - -- resulting report. + -> ([L.Transaction] -> [L.Box Ly.LibertyMeta]) + -- ^ Result from previous parsers that will sort and filter incoming + -- transactions -data Report = - Report { help :: X.Text - -- ^ A strict Text containing a help message. - - , name :: String - -- ^ The name of the report - - , parseReport :: Parser ReportFunc - -- ^ The parser must parse everything beginning with the - -- first word after the name of the report (the parser does - -- not parse the name of the report) up until, but not - -- including, the first non-option word. - } + -> MA.Mode ParseResult diff --git a/Penny/Cabin/Meta.hs b/Penny/Cabin/Meta.hs --- a/Penny/Cabin/Meta.hs +++ b/Penny/Cabin/Meta.hs @@ -1,15 +1,38 @@ +-- | Metadata that is specific to Cabin. module Penny.Cabin.Meta (VisibleNum, unVisibleNum, - visibleNums ) where + 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) -visibleNums :: +-- | Assigns VisibleNum to a list of boxes. +visibleNumBoxes :: (VisibleNum -> a -> b) -> [L.Box a] -> [L.Box b] -visibleNums f = L.serialItems s' where - s' ser (L.Box m pf) = L.Box (f (VisibleNum ser) m) pf +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 --- a/Penny/Cabin/Options.hs +++ b/Penny/Cabin/Options.hs @@ -2,32 +2,15 @@ module Penny.Cabin.Options where -import qualified Penny.Cabin.Chunk as C -import qualified Penny.Shield as S - --- | The user's color preference. -data ColorPref = Pref0 | Pref8 | Pref256 | PrefAuto - deriving Show - -maxCapableColors :: S.Runtime -> C.Colors -maxCapableColors r = case S.output r of - S.NotTTY -> C.Colors0 - S.IsTTY -> - case lookup "TERM" (S.environment r) of - Nothing -> C.Colors8 - (Just t) -> if t == "xterm-256color" - then C.Colors256 - else C.Colors8 - -autoColors :: ColorPref -> S.Runtime -> C.Colors -autoColors c r = case c of - Pref0 -> C.Colors0 - Pref8 -> C.Colors8 - Pref256 -> C.Colors256 - PrefAuto -> maxCapableColors r - -- | 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 new file mode 100644 --- /dev/null +++ b/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/Penny/Cabin/Posts.hs b/Penny/Cabin/Posts.hs --- a/Penny/Cabin/Posts.hs +++ b/Penny/Cabin/Posts.hs @@ -33,13 +33,15 @@ -- show various fields. However, the order of the fields is not -- configurable without editing the source code (sorry). -module Penny.Cabin.Posts ( - postsReport - , parseReport - , makeReport +module Penny.Cabin.Posts + ( postsReport + , zincReport , defaultOptions , ZincOpts(..) - , ymd + , A.Alloc + , A.SubAccountLength(..) + , A.alloc + , yearMonthDay , qtyAsIs , balanceAsIs , defaultWidth @@ -47,120 +49,121 @@ , widthFromRuntime , defaultFields , defaultSpacerWidth + , T.ReportWidth(..) ) where +import Control.Applicative ((<$>), (<*>)) import qualified Control.Monad.Exception.Synchronous as Ex +import qualified Data.Either as Ei import qualified Data.Text as X -import qualified Data.Text.Lazy as XL -import qualified Penny.Cabin.Chunk as CC -import qualified Penny.Cabin.Colors as PC -import qualified Penny.Cabin.Colors.DarkBackground as Dark 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.Allocate as Alc import qualified Penny.Cabin.Posts.Chunk as C import qualified Penny.Cabin.Posts.Fields as F -import qualified Penny.Cabin.Posts.Help as H 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.Copper as Cop import qualified Penny.Lincoln as L -import qualified Penny.Lincoln.Balance as Bal import qualified Penny.Lincoln.Queries as Q import qualified Penny.Liberty as Ly import qualified Penny.Shield as Sh +import Data.List (intersperse) +import Data.Maybe (catMaybes) +import qualified Data.Foldable as Fdbl import Data.Time as Time -import System.Console.MultiArg.Prim (Parser) +import qualified System.Console.MultiArg as MA import System.Locale (defaultTimeLocale) import Text.Matchers.Text (CaseSensitive) -- | All information needed to make a Posts report. This function -- never fails. postsReport :: - CC.Colors - -- ^ How many colors to show. - -> CO.ShowZeroBalances + CO.ShowZeroBalances -> (L.Box Ly.LibertyMeta -> Bool) -- ^ 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] - -> XL.Text + -> [E.PreChunk] -postsReport col szb pdct pff co = - CC.chunksToText col - . C.makeChunk co +postsReport szb pdct pff co = + C.makeChunk co . M.toBoxList szb pdct pff -parseReport :: - (Sh.Runtime -> ZincOpts) - -> Parser I.ReportFunc -parseReport frt = do - getState <- P.parseOptions - let rf rt cs fty ps _ = do - let zo = frt rt - maySt' = getState rt dtz rg st - where - dtz = defaultTimeZone zo - rg = radGroup zo - st = newParseState cs fty zo - st' <- Ex.mapException showParserError maySt' - pdct <- getPredicate . P.tokens $ st' - return $ postsReport (P.colorPref st') - (P.showZeroBalances st') pdct - (P.postFilter st') (chunkOpts st' zo) ps - return rf - - -makeReport :: - (Sh.Runtime -> ZincOpts) - -> I.Report -makeReport frt = I.Report { - I.help = H.help - , I.name = "postings" - , I.parseReport = parseReport frt } +zincReport :: ZincOpts -> I.Report +zincReport opts rt = (helpStr opts, md) + where + md cs fty fsf = MA.Mode + { MA.mName = "postings" + , MA.mIntersperse = MA.Intersperse + , MA.mOpts = map (fmap Right) (P.allSpecs rt) + , MA.mPosArgs = Left + , MA.mProcess = process opts cs fty fsf + } +process + :: ZincOpts + -> CaseSensitive + -> L.Factory + -> ([L.Transaction] -> [L.Box Ly.LibertyMeta]) + -> [Either String (P.State -> Ex.Exceptional String P.State)] + -> Ex.Exceptional String (Either I.HelpStr I.ArgsAndReport) +process os cs fty fsf ls = + let (posArgs, clOpts) = Ei.partitionEithers ls + pState = newParseState cs fty os + exState' = foldl (>>=) (return pState) clOpts + in fmap (mkPrintReport posArgs os fsf) exState' -defaultOptions :: - Cop.DefaultTimeZone - -> Cop.RadGroup - -> Sh.Runtime +mkPrintReport + :: [String] -> ZincOpts -defaultOptions dtz rg rt = ZincOpts { - defaultTimeZone = dtz - , radGroup = rg - , fields = defaultFields - , colorPref = CO.maxCapableColors rt - , drCrColors = Dark.drCrColors - , baseColors = Dark.baseColors + -> ([L.Transaction] -> [L.Box Ly.LibertyMeta]) + -> P.State + -> Either I.HelpStr I.ArgsAndReport +mkPrintReport posArgs zo fsf st = r + where + r = if P.showHelp st then Left $ helpStr zo else Right pr + pr = (posArgs, f) + f txns _ = fmap mkChunks exPdct + where + exPdct = getPredicate (P.tokens st) + mkChunks pdct = chks + where + chks = postsReport (P.showZeroBalances st) pdct + (P.postFilter st) (chunkOpts st zo) boxes + boxes = fsf txns + + +defaultOptions + :: Sh.Runtime + -> ZincOpts +defaultOptions rt = ZincOpts + { fields = defaultFields , width = widthFromRuntime rt , showZeroBalances = CO.ShowZeroBalances False - , dateFormat = ymd + , dateFormat = yearMonthDay , qtyFormat = qtyAsIs , balanceFormat = balanceAsIs , subAccountLength = A.SubAccountLength 2 - , payeeAllocation = Alc.allocation 60 - , accountAllocation = Alc.allocation 40 + , payeeAllocation = A.alloc 60 + , accountAllocation = A.alloc 40 , spacers = defaultSpacerWidth } -showParserError :: P.Error -> X.Text -showParserError = X.pack . show - getPredicate :: [Ly.Token (L.Box Ly.LibertyMeta -> Bool)] -> Ex.Exceptional X.Text (L.Box Ly.LibertyMeta -> Bool) @@ -175,34 +178,10 @@ -- | All the information to configure the postings report if the -- options will be parsed in from the command line. -data ZincOpts = ZincOpts { - defaultTimeZone :: Cop.DefaultTimeZone - -- ^ The postings report takes options to determine which posts will - -- be visible. This determines the time zone to use when parsing - -- these options. Does not affect how the resulting report is - -- formatted. For that, see the dateFormat field. - - , radGroup :: Cop.RadGroup - -- ^ The postings report takes options to determine which posts - -- will be visible. This determines the radix point and grouping - -- character to use when parsing these options. Does not affect - -- how the resulting report is formatted. For that, see the - -- qtyFormat field. - - , fields :: F.Fields Bool +data ZincOpts = ZincOpts + { fields :: F.Fields Bool -- ^ Default fields to show in the report. - - , colorPref :: CC.Colors - -- ^ How many colors you want to see, or do it - -- automatically. - , drCrColors :: PC.DrCrColors - -- ^ Colors to use when displaying debits, credits, and - -- when displaying balance totals - - , baseColors :: PC.BaseColors - -- ^ Colors to use when displaying everything else - , width :: T.ReportWidth -- ^ Gives the default report width. This can be -- overridden on the command line. You can use the @@ -225,7 +204,7 @@ -- the quantity. Allows you to format digit grouping, -- radix points, perform rounding, etc. - , balanceFormat :: L.Commodity -> L.BottomLine -> X.Text + , balanceFormat :: L.Commodity -> L.Qty -> X.Text -- ^ How to display balance totals. Similar to -- balanceFormat. @@ -233,7 +212,7 @@ -- ^ When shortening the names of sub accounts to make -- them fit, they will be this long. - , payeeAllocation :: Alc.Allocation + , 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 @@ -241,24 +220,22 @@ -- is 40, the payee takes about 60 percent of the -- remaining space and the account takes about 40 percent. - , accountAllocation :: Alc.Allocation + , 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 + P.State -> ZincOpts -> C.ChunkOpts -chunkOpts s z = C.ChunkOpts { - C.baseColors = P.baseColors s - , C.drCrColors = P.drCrColors s - , C.dateFormat = dateFormat z +chunkOpts s z = C.ChunkOpts + { C.dateFormat = dateFormat z , C.qtyFormat = qtyFormat z , C.balanceFormat = balanceFormat z , C.fields = P.fields s @@ -275,40 +252,36 @@ -> L.Factory -> ZincOpts -> P.State -newParseState cs fty o = P.State { - P.sensitive = cs +newParseState cs fty o = P.State + { P.sensitive = cs , P.factory = fty , P.tokens = [] , P.postFilter = [] , P.fields = fields o - , P.colorPref = colorPref o - , P.drCrColors = drCrColors o - , P.baseColors = baseColors o , P.width = width o , P.showZeroBalances = showZeroBalances o + , P.showHelp = False } -- | Shows the date of a posting in YYYY-MM-DD format. -ymd :: Box -> X.Text -ymd p = X.pack (Time.formatTime defaultTimeLocale fmt d) where - d = Time.localDay - . L.localTime - . Q.dateTime - . L.boxPostFam - $ p - fmt = "%Y-%m-%d" +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 . L.unQty . Q.qty . L.boxPostFam $ p +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.BottomLine -> X.Text -balanceAsIs _ n = case n of - L.Zero -> X.pack "--" - L.NonZero c -> X.pack . show . L.unQty . Bal.qty $ c +balanceAsIs :: a -> L.Qty -> X.Text +balanceAsIs _ = X.pack . show -- | The default width for the report. defaultWidth :: T.ReportWidth @@ -394,3 +367,186 @@ , S.postingQty = 1 , S.totalDrCr = 1 , S.totalCmdty = 1 } + +------------------------------------------------------------ +-- ## Help +------------------------------------------------------------ + +ifDefault :: Bool -> String +ifDefault b = if b then " (default)" else "" + +bundles :: Int -> [a] -> [[a]] +bundles c ls + | c < 1 = error "bundles: argument must be positive" + | otherwise = case splitAt c ls of + (r, []) -> [r] + (r, rs) -> r : bundles c rs + +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" + , "" + , "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" + , "" + , "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 ", ") + . bundles 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/Allocate.hs b/Penny/Cabin/Posts/Allocate.hs deleted file mode 100644 --- a/Penny/Cabin/Posts/Allocate.hs +++ /dev/null @@ -1,65 +0,0 @@ -module Penny.Cabin.Posts.Allocate ( - Allocation, - allocation, - unAllocation, - allocate) where - -import qualified Control.Monad.Trans.State as St -import qualified Data.Foldable as F -import qualified Data.Traversable as T - --- | Allocations are integers. The absolute value of the integer is --- used, so for practical purposes @-4@ is the same allocation as @4@. -newtype Allocation = Allocation { unAllocation :: Int } - deriving (Show, Eq, Ord) - -allocation :: Int -> Allocation -allocation = Allocation - --- | Properties of the allocated result: --- --- * If the sum of the absolute values of the allocations is zero, --- then each of the elements in the result will also be zero. --- --- * Otherwise, if any allocation is zero, then the corresponding --- amount in the result will also be zero. The sum of the results will --- equal the total requested. -allocate :: - (Functor f, F.Foldable f, T.Traversable f) - => f Allocation - -> Int - -> f Int -allocate m t = let - tot = F.sum . fmap (toDouble . abs . unAllocation) $ m - ratios = fmap ((/tot) . toDouble . abs . unAllocation) m - rounded = fmap (round . (* (toDouble t))) ratios - toDouble = fromIntegral :: Int -> Double - in if tot == 0 - then fmap (const 0) m - else adjust rounded t - -adjust :: (Functor f, F.Foldable f, T.Traversable f) - => f Int - -> Int - -> f Int -adjust ws w = let - wsInts = fmap fromIntegral ws - diff = (fromIntegral w) - F.sum wsInts in - if diff == 0 - then ws - else let - ws' = St.evalState (T.mapM adjustMap ws) diff - in adjust ws' w - --- | The state is the target number minus the current actual total. -adjustMap :: Int -> St.State Int Int -adjustMap w = if w == 0 then return 0 else do - diff <- St.get - case compare diff 0 of - EQ -> return w - GT -> do - St.put (pred diff) - return (succ w) - LT -> do - St.put (succ diff) - return (pred w) diff --git a/Penny/Cabin/Posts/Allocated.hs b/Penny/Cabin/Posts/Allocated.hs --- a/Penny/Cabin/Posts/Allocated.hs +++ b/Penny/Cabin/Posts/Allocated.hs @@ -14,29 +14,49 @@ -- c. If the rightmost growing field is to the right of Account but is -- not TotalQty, omit its spacer. -- --- 2. Subtract from this sum the width of the Payee and Account --- spacers: +-- 2. Obtain the width of the Payee and Account spacers. Include each +-- spacer if its corresponding field appears in the report. -- --- a. Subtract the width of Payee spacer if it appears. +-- 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. -- --- b. Subtract the width of the Account spacer if it appears. +-- 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". -- --- 3. If the remaining width is 0 or less, do nothing. Return, but --- indicate in return value that neither Payee nor Account is showing. +-- 5. Split up the available width for the Payee and Account fields +-- depending on which fields appear: -- --- 4. Allocate the remaining width. If only Payee or Account appears, --- it gets all the width; otherwise, allocate the widths. No special --- arrangements are made if either field gets an allocation of 0. +-- 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. -- --- 5. Fill cell contents. Return filled cells. +-- 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 @@ -45,15 +65,15 @@ import qualified Data.Text as X import qualified Penny.Cabin.Chunk as C import qualified Penny.Cabin.Row as R -import qualified Penny.Cabin.Posts.Allocate as A -import qualified Penny.Cabin.Colors as PC 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 @@ -66,13 +86,22 @@ 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 +data AllocatedOpts = AllocatedOpts + { fields :: Fields Bool , subAccountLength :: SubAccountLength - , baseColors :: PC.BaseColors - , payeeAllocation :: A.Allocation - , accountAllocation :: A.Allocation + , allocations :: Fields Alloc , spacers :: S.Spacers Int , growerWidths :: G.Fields (Maybe Int) , reportWidth :: Ty.ReportWidth @@ -85,79 +114,54 @@ -- 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 :: - AllocatedOpts +payeeAndAcct + :: AllocatedOpts -> [Box] -> Fields (Maybe ([R.ColumnSpec], Int)) -payeeAndAcct as = allocateCells sl bc ws - where - sl = subAccountLength as - bc = baseColors as - ws = fieldWidth (fields as) (payeeAllocation as) - (accountAllocation as) (spacers as) - (growerWidths as) (reportWidth as) +payeeAndAcct ao bs = + let allBuilders = + T.traverse (builders (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 --- | Allocates cells. Returns a pair, with the first element being the --- list of allocated cells, and the second indicating the width of the --- cells, which will be greater than zero. -allocateCells :: - SubAccountLength - -> PC.BaseColors - -> Fields UnShrunkWidth - -> [Box] - -> Fields (Maybe ([R.ColumnSpec], Int)) -allocateCells sl bc fs bs = - let mkPayees i b = allocPayee i bc b - mkAccts i b = allocAcct i sl bc b - cellMakers = Fields mkPayees mkAccts - mkCells (UnShrunkWidth width) maker = - if width > 0 - then Just (map (maker width) bs) - else Nothing - unShrunkCells = mkCells <$> fs <*> cellMakers - in fmap (fmap removeExtraSpace) unShrunkCells - +safeMaximum :: Ord a => a -> [a] -> a +safeMaximum d ls = case ls of + [] -> d + xs -> maximum xs --- | After first being allocated by allocPayee and allocAcct, cells --- are as wide as the total space allocated. This function removes the --- extra space, making all the cells as wide as the widest --- cell. Returns the resized cells and the new width. -removeExtraSpace :: [R.ColumnSpec] -> ([R.ColumnSpec], Int) -removeExtraSpace cs = (trimmed, len) where - len = Fdbl.foldl' f 0 cs where - f acc c = max acc (Fdbl.foldl' g 0 (R.bits c)) where - g inAcc chk = max inAcc (C.unWidth . C.chunkWidth $ chk) - trimmed = map f cs where - f c = c { R.width = C.Width len } +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 --- | The width of an on-screen field, after accounting for the width --- of the entire report and the allocations but before shrinking. -newtype UnShrunkWidth = UnShrunkWidth Int - deriving Show +newtype AvailableWidth = AvailableWidth Int + deriving (Eq, Ord, Show) --- | Gets the width of the two allocated fields. -fieldWidth :: - Fields Bool - -> A.Allocation -- ^ Payee allocation - -> A.Allocation -- ^ Accout allocation +availableWidthForAllocs + :: G.Fields (Maybe Int) -> S.Spacers Int - -> G.Fields (Maybe Int) + -> Fields Bool -> Ty.ReportWidth - -> Fields UnShrunkWidth -fieldWidth flds pa aa ss fs (Ty.ReportWidth rw) = - let grownWidth = sumGrowersAndSpacers fs ss - widthForCells = rw - grownWidth - allocSpacerWidth - payeeSpacerWidth = if payee flds then abs (S.payee ss) else 0 - acctSpacerWidth = if account flds then abs (S.account ss) else 0 - allocSpacerWidth = payeeSpacerWidth + acctSpacerWidth - allocs = (\bool alloc -> if bool then alloc else A.allocation 0) - <$> flds - <*> Fields pa aa - in if widthForCells < 1 - then pure (UnShrunkWidth 0) - else fmap UnShrunkWidth $ A.allocate allocs widthForCells - + -> 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 @@ -179,8 +183,8 @@ . Fdbl.toList . fmap toWidth . pairedWithSpacers fs - + -- | Takes a triple: -- -- * The first element is Just _ if the field appears in the report; @@ -230,7 +234,7 @@ <$> G.pairWithSpacer f s <*> G.eFields --- | Sums the contents of growing cells and their accompanying +-- | Sums the widths of growing cells and their accompanying -- spacers; makes the adjustments described in sumSpacers. sumGrowersAndSpacers :: G.Fields (Maybe Int) @@ -243,59 +247,132 @@ Nothing -> acc Just i -> acc + i +newtype Request = Request { unRequest :: Int } + deriving (Eq, Ord, Show) -allocPayee :: - Int - -- ^ Width that is permitted for this column - -> PC.BaseColors +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 + :: SubAccountLength -> Box - -> R.ColumnSpec -allocPayee w bc i = - let pb = L.boxPostFam i - ts = PC.colors (M.visibleNum . L.boxMeta $ i) bc - c = R.ColumnSpec j (C.Width w) ts sq - j = R.LeftJustify - sq = case Q.payee pb of - Nothing -> [] - Just pye -> - let wrapped = - Fdbl.toList - . TF.unLines - . TF.wordWrap w - . TF.txtWords - . HT.text - $ pye - toBit (TF.Words seqTxts) = - C.chunk ts - . X.unwords - . Fdbl.toList - $ seqTxts - in fmap toBit wrapped - in c + -> Fields (Request, Final -> R.ColumnSpec) +builders sl b = Fields (buildPayee b) (buildAcct sl b) +buildPayee + :: 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. -allocAcct :: - Int - -- ^ Width that is permitted for this column - -> SubAccountLength - -> PC.BaseColors +buildPayee i = (maxW, mkSpec) + where + pb = L.boxPostFam i + eo = E.fromVisibleNum . M.visibleNum . L.boxMeta $ i + j = R.LeftJustify + ps = (E.Other, eo) + mayPye = Q.payee pb + maxW = Request $ maybe 0 (X.length . HT.text) mayPye + mkSpec (Final w) = R.ColumnSpec j (C.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) = + E.PreChunk E.Other eo + . X.unwords + . Fdbl.toList + $ seqTxts + in fmap toBit wrapped + + +buildAcct :: + SubAccountLength -> Box - -> R.ColumnSpec -allocAcct aw sl bc i = - let pb = L.boxPostFam i - ts = PC.colors (M.visibleNum . L.boxMeta $ i) bc - in R.ColumnSpec R.LeftJustify (C.Width aw) ts $ - let target = TF.Target aw - shortest = TF.Shortest . unSubAccountLength $ sl - a = Q.account pb - ws = TF.Words . Seq.fromList . HT.textList $ a - (TF.Words shortened) = TF.shorten shortest target ws - in [C.chunk ts - . X.concat - . intersperse (X.singleton ':') - . Fdbl.toList - $ shortened] + -> (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 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) + mkSpec (Final aw) = R.ColumnSpec R.LeftJustify (C.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 = [ E.PreChunk E.Other eo + . X.concat + . intersperse (X.singleton ':') + . Fdbl.toList + $ shortened ] + instance Functor Fields where fmap f i = Fields { payee = f (payee i) @@ -314,4 +391,4 @@ 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 --- a/Penny/Cabin/Posts/BottomRows.hs +++ b/Penny/Cabin/Posts/BottomRows.hs @@ -32,10 +32,10 @@ import qualified Data.Text as X import qualified Data.Traversable as T import qualified Penny.Cabin.Chunk as C +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.Colors as PC import qualified Penny.Cabin.Posts.Fields as F import qualified Penny.Cabin.Posts.Growers as G import qualified Penny.Cabin.Posts.Meta as M @@ -46,11 +46,10 @@ import qualified Penny.Lincoln.HasText as HT import qualified Penny.Lincoln.Queries as Q -data BottomOpts = BottomOpts { - growingWidths :: G.Fields (Maybe Int) +data BottomOpts = BottomOpts + { growingWidths :: G.Fields (Maybe Int) , allocatedWidths :: A.Fields (Maybe Int) , fields :: F.Fields Bool - , baseColors :: PC.BaseColors , reportWidth :: Ty.ReportWidth , spacers :: S.Spacers Int } @@ -58,10 +57,10 @@ bottomRows :: BottomOpts -> [Box] - -> Fields (Maybe [[C.Chunk]]) + -> Fields (Maybe [[E.PreChunk]]) bottomRows os bs = makeRows bs pcs where pcs = infoProcessors topSpecs (reportWidth os) wanted - wanted = requestedMakers (fields os) (baseColors os) + wanted = requestedMakers (fields os) topSpecs = topCellSpecs (growingWidths os) (allocatedWidths os) (spacers os) @@ -110,16 +109,16 @@ hanging :: [TopCellSpec] - -> Maybe ((Box -> Int -> (C.TextSpec, R.ColumnSpec)) - -> Box -> [C.Chunk]) + -> Maybe ((Box -> Int -> ((E.Label, E.EvenOdd), R.ColumnSpec)) + -> Box -> [E.PreChunk]) hanging specs = hangingWidths specs >>= return . hangingInfoProcessor hangingInfoProcessor :: Hanging Int - -> (Box -> Int -> (C.TextSpec, R.ColumnSpec)) + -> (Box -> Int -> ((E.Label, E.EvenOdd), R.ColumnSpec)) -> Box - -> [C.Chunk] + -> [E.PreChunk] hangingInfoProcessor widths mkr info = row where row = R.row [left, mid, right] (ts, mid) = mkr info (mainCell widths) @@ -129,8 +128,8 @@ widthOfTopColumns :: [TopCellSpec] - -> Maybe ((Box -> Int -> (C.TextSpec, R.ColumnSpec)) - -> Box -> [C.Chunk]) + -> Maybe ((Box -> Int -> ((E.Label, E.EvenOdd), R.ColumnSpec)) + -> Box -> [E.PreChunk]) widthOfTopColumns ts = if null ts then Nothing @@ -142,18 +141,18 @@ widthOfReport :: Ty.ReportWidth - -> (Box -> Int -> (C.TextSpec, R.ColumnSpec)) + -> (Box -> Int -> ((E.Label, E.EvenOdd), R.ColumnSpec)) -> Box - -> [C.Chunk] + -> [E.PreChunk] widthOfReport (Ty.ReportWidth rw) fn info = makeSpecificWidth rw fn info chooseProcessor :: [TopCellSpec] -> Ty.ReportWidth - -> (Box -> Int -> (C.TextSpec, R.ColumnSpec)) + -> (Box -> Int -> ((E.Label, E.EvenOdd), R.ColumnSpec)) -> Box - -> [C.Chunk] + -> [E.PreChunk] chooseProcessor specs rw fn = let firstTwo = First (hanging specs) `mappend` First (widthOfTopColumns specs) @@ -164,8 +163,8 @@ infoProcessors :: [TopCellSpec] -> Ty.ReportWidth - -> Fields (Maybe (Box -> Int -> (C.TextSpec, R.ColumnSpec))) - -> Fields (Maybe (Box -> [C.Chunk])) + -> Fields (Maybe (Box -> Int -> ((E.Label, E.EvenOdd), R.ColumnSpec))) + -> Fields (Maybe (Box -> [E.PreChunk])) infoProcessors specs rw flds = let chooser = chooseProcessor specs rw mkProcessor mayFn = case mayFn of @@ -176,8 +175,8 @@ makeRows :: [Box] - -> Fields (Maybe (Box -> [C.Chunk])) - -> Fields (Maybe [[C.Chunk]]) + -> Fields (Maybe (Box -> [E.PreChunk])) + -> Fields (Maybe [[E.PreChunk]]) makeRows is flds = let mkRow fn = map fn is in fmap (fmap mkRow) flds @@ -234,8 +233,8 @@ 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 :: @@ -274,12 +273,15 @@ -- | 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 :: Int -> (Box -> Int -> (a, R.ColumnSpec)) - -> Box -> [C.Chunk] + -> Box -> [E.PreChunk] makeSpecificWidth w f i = R.row [c] where (_, c) = f i w -type Maker = PC.BaseColors -> Box -> Int -> (C.TextSpec, R.ColumnSpec) +type Maker + = Box + -> Int + -> ((E.Label, E.EvenOdd), R.ColumnSpec) makers :: Fields Maker makers = Fields tagsCell memoCell filenameCell @@ -289,18 +291,21 @@ -- field that the user wants to see. requestedMakers :: F.Fields Bool - -> PC.BaseColors - -> Fields (Maybe (Box -> Int -> (C.TextSpec, R.ColumnSpec))) -requestedMakers allFlds bc = + -> Fields (Maybe (Box -> Int -> ((E.Label, E.EvenOdd), R.ColumnSpec))) +requestedMakers allFlds = let flds = bottomRowsFields allFlds - filler b mkr = if b then Just $ mkr bc else Nothing + filler b mkr = if b then Just $ mkr else Nothing in filler <$> flds <*> makers -tagsCell :: PC.BaseColors -> Box -> Int -> (C.TextSpec, R.ColumnSpec) -tagsCell bc info w = (ts, cell) where +tagsCell + :: Box + -> Int + -> ((E.Label, E.EvenOdd), R.ColumnSpec) +tagsCell info w = (ts, cell) where vn = M.visibleNum . L.boxMeta $ info cell = R.ColumnSpec R.LeftJustify (C.Width w) ts cs - ts = PC.colors vn bc + eo = E.fromVisibleNum vn + ts = (E.Other, eo) cs = Fdbl.toList . fmap toBit @@ -313,12 +318,12 @@ . Q.tags . L.boxPostFam $ info - toBit (TF.Words ws) = C.chunk ts t where + toBit (TF.Words ws) = E.PreChunk E.Other eo t where t = X.concat . intersperse (X.singleton ' ') . Fdbl.toList $ ws -memoBits :: C.TextSpec -> L.Memo -> C.Width -> [C.Chunk] -memoBits ts m (C.Width w) = cs where +memoBits :: (E.Label, E.EvenOdd) -> L.Memo -> C.Width -> [E.PreChunk] +memoBits (lbl, eo) m (C.Width w) = cs where cs = Fdbl.toList . fmap toBit . TF.unLines @@ -326,45 +331,44 @@ . TF.Words . Seq.fromList . X.words - . HT.text - . HT.Delimited (X.singleton ' ') - . HT.textList + . X.intercalate (X.singleton ' ') + . L.unMemo $ m - toBit (TF.Words ws) = C.chunk ts (X.unwords . Fdbl.toList $ ws) + toBit (TF.Words ws) = E.PreChunk lbl eo (X.unwords . Fdbl.toList $ ws) -memoCell :: PC.BaseColors -> Box -> Int -> (C.TextSpec, R.ColumnSpec) -memoCell bc info width = (ts, cell) where +memoCell :: Box -> Int -> ((E.Label, E.EvenOdd), R.ColumnSpec) +memoCell info width = (ts, cell) where w = C.Width width vn = M.visibleNum . L.boxMeta $ info + eo = E.fromVisibleNum vn + ts = (E.Other, eo) cell = R.ColumnSpec R.LeftJustify w ts cs - ts = PC.colors vn bc - pm = Q.postingMemo . L.boxPostFam $ info - tm = Q.transactionMemo . L.boxPostFam $ info - nullMemo (L.Memo m) = null m - cs = case (nullMemo pm, nullMemo tm) of - (True, True) -> mempty - (False, True) -> memoBits ts pm w - (True, False) -> memoBits ts tm w - (False, False) -> memoBits ts pm w `mappend` memoBits ts tm w - + mayPm = Q.postingMemo . L.boxPostFam $ info + mayTm = Q.transactionMemo . L.boxPostFam $ info + cs = case (mayPm, mayTm) of + (Nothing, Nothing) -> mempty + (Nothing, Just tm) -> memoBits ts tm w + (Just pm, Nothing) -> memoBits ts pm w + (Just pm, Just tm) -> memoBits ts pm w `mappend` memoBits ts tm w -filenameCell :: PC.BaseColors -> Box -> Int -> (C.TextSpec, R.ColumnSpec) -filenameCell bc info width = (ts, cell) where + +filenameCell :: Box -> Int -> ((E.Label, E.EvenOdd), R.ColumnSpec) +filenameCell info width = (ts, cell) where w = C.Width width vn = M.visibleNum . L.boxMeta $ info + eo = E.fromVisibleNum vn + ts = (E.Other, eo) cell = R.ColumnSpec R.LeftJustify w ts cs - toBit n = C.chunk ts + toBit n = (E.PreChunk E.Other eo) . X.drop (max 0 (X.length n - width)) $ n cs = case Q.filename . L.boxPostFam $ info of Nothing -> [] Just fn -> [toBit . L.unFilename $ fn] - ts = PC.colors vn bc - -data TopRowCells a = TopRowCells { - globalTransaction :: a +data TopRowCells a = TopRowCells + { globalTransaction :: a , revGlobalTransaction :: a , globalPosting :: a , revGlobalPosting :: a @@ -394,8 +398,8 @@ deriving (Show, Eq) topRowCells :: G.Fields a -> A.Fields a -> TopRowCells a -topRowCells g a = TopRowCells { - globalTransaction = G.globalTransaction g +topRowCells g a = TopRowCells + { globalTransaction = G.globalTransaction g , revGlobalTransaction = G.revGlobalTransaction g , globalPosting = G.globalPosting g , revGlobalPosting = G.revGlobalPosting g @@ -453,8 +457,8 @@ deriving (Show, Eq, Enum) eTopRowCells :: TopRowCells ETopRowCells -eTopRowCells = TopRowCells { - globalTransaction = EGlobalTransaction +eTopRowCells = TopRowCells + { globalTransaction = EGlobalTransaction , revGlobalTransaction = ERevGlobalTransaction , globalPosting = EGlobalPosting , revGlobalPosting = ERevGlobalPosting @@ -482,8 +486,8 @@ , totalQty = ETotalQty } instance Functor TopRowCells where - fmap f t = TopRowCells { - globalTransaction = f (globalTransaction t) + fmap f t = TopRowCells + { globalTransaction = f (globalTransaction t) , revGlobalTransaction = f (revGlobalTransaction t) , globalPosting = f (globalPosting t) , revGlobalPosting = f (revGlobalPosting t) @@ -511,8 +515,8 @@ , totalQty = f (totalQty t) } instance Applicative TopRowCells where - pure a = TopRowCells { - globalTransaction = a + pure a = TopRowCells + { globalTransaction = a , revGlobalTransaction = a , globalPosting = a , revGlobalPosting = a @@ -539,8 +543,8 @@ , totalCmdty = a , totalQty = a } - ff <*> fa = TopRowCells { - globalTransaction = globalTransaction ff (globalTransaction fa) + ff <*> fa = TopRowCells + { globalTransaction = globalTransaction ff (globalTransaction fa) , revGlobalTransaction = revGlobalTransaction ff (revGlobalTransaction fa) , globalPosting = globalPosting ff (globalPosting fa) , revGlobalPosting = revGlobalPosting ff (revGlobalPosting fa) diff --git a/Penny/Cabin/Posts/Chunk.hs b/Penny/Cabin/Posts/Chunk.hs --- a/Penny/Cabin/Posts/Chunk.hs +++ b/Penny/Cabin/Posts/Chunk.hs @@ -6,50 +6,44 @@ 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.Allocate as Alc 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 Penny.Cabin.Chunk as C -import qualified Penny.Cabin.Colors as PC 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 { - baseColors :: PC.BaseColors - , drCrColors :: PC.DrCrColors - , dateFormat :: Box -> X.Text +data ChunkOpts = ChunkOpts + { dateFormat :: Box -> X.Text , qtyFormat :: Box -> X.Text - , balanceFormat :: L.Commodity -> L.BottomLine -> X.Text + , balanceFormat :: L.Commodity -> L.Qty -> X.Text , fields :: F.Fields Bool , subAccountLength :: A.SubAccountLength - , payeeAllocation :: Alc.Allocation - , accountAllocation :: Alc.Allocation + , payeeAllocation :: A.Alloc + , accountAllocation :: A.Alloc , spacers :: S.Spacers Int , reportWidth :: Ty.ReportWidth } growOpts :: ChunkOpts -> G.GrowOpts -growOpts c = G.GrowOpts { - G.baseColors = baseColors c - , G.drCrColors = drCrColors c - , G.dateFormat = dateFormat c +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 } +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.baseColors = baseColors c - , A.payeeAllocation = payeeAllocation c - , A.accountAllocation = accountAllocation c + , A.allocations = A.Fields { A.payee = payeeAllocation c + , A.account = accountAllocation c } , A.spacers = spacers c , A.growerWidths = g , A.reportWidth = reportWidth c @@ -64,7 +58,6 @@ B.growingWidths = g , B.allocatedWidths = a , B.fields = fields c - , B.baseColors = baseColors c , B.reportWidth = reportWidth c , B.spacers = spacers c } @@ -72,7 +65,7 @@ makeChunk :: ChunkOpts -> [Box] - -> [C.Chunk] + -> [E.PreChunk] makeChunk c bs = let fmapSnd = fmap (fmap snd) fmapFst = fmap (fmap fst) @@ -83,74 +76,70 @@ bFlds = B.bottomRows (bottomOpts c gFldW aFldW) bs topCells = B.topRowCells (fmapFst gFlds) (fmap (fmap fst) aFlds) withSpacers = B.mergeWithSpacers topCells (spacers c) - topRows = makeTopRows (baseColors c) withSpacers + topRows = makeTopRows withSpacers bottomRows = makeBottomRows bFlds in makeAllRows topRows bottomRows -topRowsCells :: - PC.BaseColors - -> B.TopRowCells (Maybe [R.ColumnSpec], Maybe Int) +topRowsCells + :: B.TopRowCells (Maybe [R.ColumnSpec], Maybe Int) -> [[(R.ColumnSpec, Maybe R.ColumnSpec)]] -topRowsCells bc t = let +topRowsCells t = let toWithSpc (mayCs, maySp) = case mayCs of Nothing -> Nothing - Just cs -> Just (makeSpacers bc cs maySp) + 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 :: [(R.ColumnSpec, Maybe R.ColumnSpec)] -> [C.Chunk] +makeRow :: [(R.ColumnSpec, Maybe R.ColumnSpec)] -> [E.PreChunk] makeRow = R.row . foldr f [] where f (c, mayC) acc = case mayC of Nothing -> c:acc Just spcr -> c:spcr:acc -makeSpacers :: - PC.BaseColors - -> [R.ColumnSpec] +makeSpacers + :: [R.ColumnSpec] -> Maybe Int -> [(R.ColumnSpec, Maybe R.ColumnSpec)] -makeSpacers bc cs mayI = case mayI of +makeSpacers cs mayI = case mayI of Nothing -> map (\c -> (c, Nothing)) cs - Just i -> makeEvenOddSpacers bc cs i + Just i -> makeEvenOddSpacers cs i -makeEvenOddSpacers :: - PC.BaseColors - -> [R.ColumnSpec] +makeEvenOddSpacers + :: [R.ColumnSpec] -> Int -> [(R.ColumnSpec, Maybe R.ColumnSpec)] -makeEvenOddSpacers bc cs i = let absI = abs i in +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 (C.Width absI) ts [] - evenTs = PC.evenColors bc - oddTs = PC.oddColors bc + evenTs = (E.Other, E.Even) + oddTs = (E.Other, E.Odd) in zip cs spcrs -makeTopRows :: - PC.BaseColors - -> B.TopRowCells (Maybe [R.ColumnSpec], Maybe Int) - -> Maybe [[C.Chunk]] -makeTopRows bc trc = +makeTopRows + :: B.TopRowCells (Maybe [R.ColumnSpec], Maybe Int) + -> Maybe [[E.PreChunk]] +makeTopRows trc = if Fdbl.all (isNothing . fst) trc then Nothing - else Just $ map makeRow . topRowsCells bc $ trc + else Just $ map makeRow . topRowsCells $ trc makeBottomRows :: - B.Fields (Maybe [[C.Chunk]]) - -> Maybe [[[C.Chunk]]] + B.Fields (Maybe [[E.PreChunk]]) + -> Maybe [[[E.PreChunk]]] makeBottomRows flds = if Fdbl.all isNothing flds then Nothing else Just . transpose . catMaybes . Fdbl.toList $ flds -makeAllRows :: Maybe [[C.Chunk]] -> Maybe [[[C.Chunk]]] -> [C.Chunk] +makeAllRows :: Maybe [[E.PreChunk]] -> Maybe [[[E.PreChunk]]] -> [E.PreChunk] makeAllRows mayrs mayrrs = case (mayrs, mayrrs) of (Nothing, Nothing) -> [] (Just rs, Nothing) -> concat rs diff --git a/Penny/Cabin/Posts/Fields.hs b/Penny/Cabin/Posts/Fields.hs --- a/Penny/Cabin/Posts/Fields.hs +++ b/Penny/Cabin/Posts/Fields.hs @@ -4,8 +4,8 @@ import Control.Applicative(Applicative(pure, (<*>))) import qualified Data.Foldable as F -data Fields a = Fields { - globalTransaction :: a +data Fields a = Fields + { globalTransaction :: a , revGlobalTransaction :: a , globalPosting :: a , revGlobalPosting :: a @@ -20,7 +20,6 @@ , visible :: a , revVisible :: a , lineNum :: a - -- ^ The line number from the posting's metadata , date :: a , flag :: a , number :: a @@ -34,8 +33,8 @@ , totalQty :: a , tags :: a , memo :: a - , filename :: a } - deriving (Show, Eq) + , filename :: a + } deriving (Show, Eq) instance Functor Fields where fmap f fa = Fields { @@ -164,3 +163,37 @@ (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 --- a/Penny/Cabin/Posts/Growers.hs +++ b/Penny/Cabin/Posts/Growers.hs @@ -8,30 +8,28 @@ import Control.Applicative((<$>), Applicative(pure, (<*>))) import qualified Data.Foldable as Fdbl -import Data.Map (elems, assocs) +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.Chunk as C -import qualified Penny.Cabin.Colors as CC 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 -- | All the options needed to grow the cells. -data GrowOpts = GrowOpts { - baseColors :: CC.BaseColors - , drCrColors :: CC.DrCrColors - , dateFormat :: Box -> X.Text +data GrowOpts = GrowOpts + { dateFormat :: Box -> X.Text , qtyFormat :: Box -> X.Text - , balanceFormat :: L.Commodity -> L.BottomLine -> X.Text + , balanceFormat :: L.Commodity -> L.Qty -> X.Text , fields :: F.Fields Bool } @@ -62,12 +60,14 @@ widestLine :: PreSpec -> Int widestLine (PreSpec _ _ bs) = - maximum . map (R.unWidth . C.chunkWidth) $ bs + case bs of + [] -> 0 + xs -> maximum . map (R.unWidth . E.width) $ xs data PreSpec = PreSpec { _justification :: R.Justification - , _padSpec :: C.TextSpec - , _bits :: [C.Chunk] } + , _padSpec :: (E.Label, E.EvenOdd) + , _bits :: [E.PreChunk] } -- | Given a PreSpec and a width, create a ColumnSpec of the right @@ -77,74 +77,52 @@ -- | Makes a left justified cell that is only one line long. The width -- is unset. -oneLine :: Text -> CC.BaseColors -> Box -> PreSpec -oneLine t bc b = - let ts = CC.colors (M.visibleNum . L.boxMeta $ b) bc +oneLine :: Text -> E.Label -> Box -> PreSpec +oneLine t lbl b = + let eo = E.fromVisibleNum . M.visibleNum . L.boxMeta $ b j = R.LeftJustify - bit = C.chunk ts t - in PreSpec j ts [bit] - --- | Converts a function that accepts a BaseColors to one that accepts --- a GrowOpts. -bcToGrowOpts :: - (CC.BaseColors -> Box -> PreSpec) - -> GrowOpts -> Box -> PreSpec -bcToGrowOpts f g = f (baseColors g) - --- | Converts a function that accepts a DrCrColors to one that accepts --- a GrowOpts. -dcToGrowOpts :: - (CC.DrCrColors -> Box -> PreSpec) - -> GrowOpts -> Box -> PreSpec -dcToGrowOpts f g = f (drCrColors g) + pcs = E.PreChunk lbl eo t + in PreSpec j (lbl, eo) [pcs] -- | Gets a Fields with each field filled with the function that fills -- the cells for that field. growers :: Fields (GrowOpts -> Box -> PreSpec) -growers = Fields { - globalTransaction = bcToGrowOpts getGlobalTransaction - , revGlobalTransaction = bcToGrowOpts getRevGlobalTransaction - , globalPosting = bcToGrowOpts getGlobalPosting - , revGlobalPosting = bcToGrowOpts getRevGlobalPosting - , fileTransaction = bcToGrowOpts getFileTransaction - , revFileTransaction = bcToGrowOpts getRevFileTransaction - , filePosting = bcToGrowOpts getFilePosting - , revFilePosting = bcToGrowOpts getRevFilePosting - , filtered = bcToGrowOpts getFiltered - , revFiltered = bcToGrowOpts getRevFiltered - , sorted = bcToGrowOpts getSorted - , revSorted = bcToGrowOpts getRevSorted - , visible = bcToGrowOpts getVisible - , revVisible = bcToGrowOpts getRevVisible - , lineNum = bcToGrowOpts getLineNum - , date = \o -> getDate (baseColors o) (dateFormat o) - , flag = bcToGrowOpts getFlag - , number = bcToGrowOpts getNumber - , postingDrCr = dcToGrowOpts getPostingDrCr - , postingCmdty = dcToGrowOpts getPostingCmdty - , postingQty = let fn o = - let fmt = qtyFormat o - dc = drCrColors o - in getPostingQty fmt dc - in fn - , totalDrCr = dcToGrowOpts getTotalDrCr - , totalCmdty = dcToGrowOpts getTotalCmdty - , totalQty = let fn o = - let fmt = balanceFormat o - dc = drCrColors o - in getTotalQty fmt dc - in fn } - +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 -> getDate (dateFormat o) + , flag = const getFlag + , number = const getNumber + , postingDrCr = const getPostingDrCr + , postingCmdty = const getPostingCmdty + , postingQty = \o -> getPostingQty (qtyFormat o) + , totalDrCr = const getTotalDrCr + , totalCmdty = const getTotalCmdty + , totalQty = \o -> getTotalQty (balanceFormat o) + } -- | Make a left justified cell one line long that shows a serial. serialCellMaybe :: (L.PostFam -> Maybe Int) -- ^ When applied to a Box, this function returns Just Int if the -- box has a serial, or Nothing if not. - - -> CC.BaseColors -> Box -> PreSpec -serialCellMaybe f bc b = oneLine t bc b + + -> Box -> PreSpec +serialCellMaybe f b = oneLine t E.Other b where t = case f (L.boxPostFam b) of Nothing -> X.empty @@ -152,200 +130,163 @@ serialCell :: (M.PostMeta -> Int) - -> CC.BaseColors -> Box -> PreSpec -serialCell f bc b = oneLine t bc b + -> Box -> PreSpec +serialCell f b = oneLine t E.Other b where t = pack . show . f . L.boxMeta $ b -getGlobalTransaction :: CC.BaseColors -> Box -> PreSpec +getGlobalTransaction :: Box -> PreSpec getGlobalTransaction = serialCellMaybe (fmap (L.forward . L.unGlobalTransaction) . Q.globalTransaction) -getRevGlobalTransaction :: CC.BaseColors -> Box -> PreSpec +getRevGlobalTransaction :: Box -> PreSpec getRevGlobalTransaction = serialCellMaybe (fmap (L.backward . L.unGlobalTransaction) . Q.globalTransaction) -getGlobalPosting :: CC.BaseColors -> Box -> PreSpec +getGlobalPosting :: Box -> PreSpec getGlobalPosting = serialCellMaybe (fmap (L.forward . L.unGlobalPosting) . Q.globalPosting) -getRevGlobalPosting :: CC.BaseColors -> Box -> PreSpec +getRevGlobalPosting :: Box -> PreSpec getRevGlobalPosting = serialCellMaybe (fmap (L.backward . L.unGlobalPosting) . Q.globalPosting) -getFileTransaction :: CC.BaseColors -> Box -> PreSpec +getFileTransaction :: Box -> PreSpec getFileTransaction = serialCellMaybe (fmap (L.forward . L.unFileTransaction) . Q.fileTransaction) -getRevFileTransaction :: CC.BaseColors -> Box -> PreSpec +getRevFileTransaction :: Box -> PreSpec getRevFileTransaction = serialCellMaybe (fmap (L.backward . L.unFileTransaction) . Q.fileTransaction) -getFilePosting :: CC.BaseColors -> Box -> PreSpec +getFilePosting :: Box -> PreSpec getFilePosting = serialCellMaybe (fmap (L.forward . L.unFilePosting) . Q.filePosting) -getRevFilePosting :: CC.BaseColors -> Box -> PreSpec +getRevFilePosting :: Box -> PreSpec getRevFilePosting = serialCellMaybe (fmap (L.backward . L.unFilePosting) . Q.filePosting) -getSorted :: CC.BaseColors -> Box -> PreSpec +getSorted :: Box -> PreSpec getSorted = serialCell (L.forward . Ly.unSortedNum . M.sortedNum) -getRevSorted :: CC.BaseColors -> Box -> PreSpec +getRevSorted :: Box -> PreSpec getRevSorted = serialCell (L.backward . Ly.unSortedNum . M.sortedNum) -getFiltered :: CC.BaseColors -> Box -> PreSpec +getFiltered :: Box -> PreSpec getFiltered = serialCell (L.forward . Ly.unFilteredNum . M.filteredNum) -getRevFiltered :: CC.BaseColors -> Box -> PreSpec +getRevFiltered :: Box -> PreSpec getRevFiltered = serialCell (L.backward . Ly.unFilteredNum . M.filteredNum) -getVisible :: CC.BaseColors -> Box -> PreSpec +getVisible :: Box -> PreSpec getVisible = serialCell (L.forward . M.unVisibleNum . M.visibleNum) -getRevVisible :: CC.BaseColors -> Box -> PreSpec +getRevVisible :: Box -> PreSpec getRevVisible = serialCell (L.backward . M.unVisibleNum . M.visibleNum) -getLineNum :: CC.BaseColors -> Box -> PreSpec -getLineNum bc b = oneLine t bc b where +getLineNum :: Box -> PreSpec +getLineNum b = oneLine t E.Other b where lineTxt = pack . show . L.unPostingLine t = maybe empty lineTxt (Q.postingLine . L.boxPostFam $ b) -getDate :: CC.BaseColors -> (Box -> X.Text) -> Box -> PreSpec -getDate bc gd b = oneLine (gd b) bc b +getDate :: (Box -> X.Text) -> Box -> PreSpec +getDate gd b = oneLine (gd b) E.Other b -getFlag :: CC.BaseColors -> Box -> PreSpec -getFlag bc i = oneLine t bc i where +getFlag :: Box -> PreSpec +getFlag i = oneLine t E.Other i where t = maybe empty L.text (Q.flag . L.boxPostFam $ i) -getNumber :: CC.BaseColors -> Box -> PreSpec -getNumber bc i = oneLine t bc i where +getNumber :: Box -> PreSpec +getNumber i = oneLine t E.Other i where t = maybe empty L.text (Q.number . L.boxPostFam $ i) dcTxt :: L.DrCr -> Text -dcTxt L.Debit = pack "Dr" -dcTxt L.Credit = pack "Cr" +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 :: Text -> CC.DrCrColors -> Box -> PreSpec -coloredPostingCell t dccol i = PreSpec j ts [bit] where +coloredPostingCell :: Text -> Box -> PreSpec +coloredPostingCell t i = PreSpec j (lbl, eo) [bit] where j = R.LeftJustify - bit = C.chunk ts t - dc = Q.drCr . L.boxPostFam $ i - ts = CC.colors (M.visibleNum . L.boxMeta $ i) - . CC.drCrToBaseColors dc - $ dccol + lbl = case Q.drCr . L.boxPostFam $ i of + L.Debit -> E.Debit + L.Credit -> E.Credit + eo = E.fromVisibleNum . M.visibleNum . L.boxMeta $ i + bit = E.PreChunk lbl eo t -getPostingDrCr :: CC.DrCrColors -> Box -> PreSpec -getPostingDrCr dc i = coloredPostingCell t dc i where +getPostingDrCr :: Box -> PreSpec +getPostingDrCr i = coloredPostingCell t i where t = dcTxt . Q.drCr . L.boxPostFam $ i -getPostingCmdty :: CC.DrCrColors -> Box -> PreSpec -getPostingCmdty dc i = coloredPostingCell t dc i where - t = L.text . L.Delimited (X.singleton ':') - . L.textList . Q.commodity . L.boxPostFam $ i +getPostingCmdty :: Box -> PreSpec +getPostingCmdty i = coloredPostingCell t i where + t = L.unCommodity . Q.commodity . L.boxPostFam $ i -getPostingQty :: (Box -> X.Text) -> CC.DrCrColors -> Box -> PreSpec -getPostingQty qf dc i = coloredPostingCell (qf i) dc i +getPostingQty :: (Box -> X.Text) -> Box -> PreSpec +getPostingQty qf i = coloredPostingCell (qf i) i -getTotalDrCr :: CC.DrCrColors -> Box -> PreSpec -getTotalDrCr dccol i = +getTotalDrCr :: Box -> PreSpec +getTotalDrCr i = let vn = M.visibleNum . L.boxMeta $ i - ts = CC.colors vn bc - bc = CC.drCrToBaseColors dc dccol + ps = (lbl, eo) dc = Q.drCr . L.boxPostFam $ i - bits = case M.balance . L.boxMeta $ i of - Nothing -> - let spec = CC.noBalanceColors vn dccol - in [C.chunk spec (pack "--")] - Just bal -> - let toBit bl = - let spec = - CC.colors vn - . CC.bottomLineToBaseColors dccol - $ bl - txt = case bl of - L.Zero -> pack "--" - L.NonZero (L.Column clmDrCr _) -> - dcTxt clmDrCr - in C.chunk spec txt - in fmap toBit . elems . L.unBalance $ bal + lbl = E.dcToLbl dc + eo = E.fromVisibleNum vn + bal = L.unBalance . M.balance . L.boxMeta $ i + bits = + if Map.null bal + then [E.PreChunk E.Zero eo (pack "--")] + else fmap (flip E.bottomLineToDrCr eo) . elems $ bal j = R.LeftJustify - in PreSpec j ts bits + in PreSpec j ps bits -getTotalCmdty :: CC.DrCrColors -> Box -> PreSpec -getTotalCmdty dccol i = +getTotalCmdty :: Box -> PreSpec +getTotalCmdty i = let vn = M.visibleNum . L.boxMeta $ i j = R.RightJustify - ts = CC.colors vn bc - bc = CC.drCrToBaseColors dc dccol + ps = (lbl, eo) dc = Q.drCr . L.boxPostFam $ i - bits = case M.balance . L.boxMeta $ i of - Nothing -> - let spec = CC.noBalanceColors vn dccol - in [C.chunk spec (pack "--")] - Just bal -> - let toBit (com, nou) = - let spec = - CC.colors vn - . CC.bottomLineToBaseColors dccol - $ nou - txt = L.text - . L.Delimited (X.singleton ':') - . L.textList - $ com - in C.chunk spec txt - in fmap toBit . assocs . L.unBalance $ bal - in PreSpec j ts bits + eo = E.fromVisibleNum vn + lbl = E.dcToLbl dc + bal = Map.toList . L.unBalance . M.balance . L.boxMeta $ i + preChunks = E.balancesToCmdtys eo bal + in PreSpec j ps preChunks getTotalQty :: - (L.Commodity -> L.BottomLine -> X.Text) - -> CC.DrCrColors + (L.Commodity -> L.Qty -> X.Text) -> Box -> PreSpec -getTotalQty balFmt dccol i = +getTotalQty balFmt i = let vn = M.visibleNum . L.boxMeta $ i j = R.LeftJustify - ts = CC.colors vn bc - bc = CC.drCrToBaseColors dc dccol dc = Q.drCr . L.boxPostFam $ i - bits = case M.balance . L.boxMeta $ i of - Nothing -> - let spec = CC.noBalanceColors vn dccol - in [C.chunk spec (pack "--")] - Just bal -> - fmap toChunk . assocs . L.unBalance $ bal - where - toChunk (com, nou) = - let spec = - CC.colors vn - . CC.bottomLineToBaseColors dccol - $ nou - txt = balFmt com nou - in C.chunk spec txt - in PreSpec j ts bits + ps = (E.dcToLbl dc, eo) + eo = E.fromVisibleNum vn + bal = Map.toList . L.unBalance . M.balance . L.boxMeta $ i + preChunks = E.balanceToQtys balFmt eo bal + in PreSpec j ps preChunks growingFields :: F.Fields Bool -> Fields Bool -growingFields f = Fields { - globalTransaction = F.globalTransaction f +growingFields f = Fields + { globalTransaction = F.globalTransaction f , revGlobalTransaction = F.revGlobalTransaction f , globalPosting = F.globalPosting f , revGlobalPosting = F.revGlobalPosting f @@ -400,8 +341,8 @@ -- | Returns a Fields where each record has its corresponding EField. eFields :: Fields EFields -eFields = Fields { - globalTransaction = EGlobalTransaction +eFields = Fields + { globalTransaction = EGlobalTransaction , revGlobalTransaction = ERevGlobalTransaction , globalPosting = EGlobalPosting , revGlobalPosting = ERevGlobalPosting @@ -427,8 +368,8 @@ , totalQty = ETotalQty } -- | All growing fields. -data Fields a = Fields { - globalTransaction :: a +data Fields a = Fields + { globalTransaction :: a , revGlobalTransaction :: a , globalPosting :: a , revGlobalPosting :: a @@ -483,8 +424,8 @@ (f (totalQty i) z))))))))))))))))))))))) instance Functor Fields where - fmap f i = Fields { - globalTransaction = f (globalTransaction i) + fmap f i = Fields + { globalTransaction = f (globalTransaction i) , revGlobalTransaction = f (revGlobalTransaction i) , globalPosting = f (globalPosting i) , revGlobalPosting = f (revGlobalPosting i) @@ -510,8 +451,8 @@ , totalQty = f (totalQty i) } instance Applicative Fields where - pure a = Fields { - globalTransaction = a + pure a = Fields + { globalTransaction = a , revGlobalTransaction = a , globalPosting = a , revGlobalPosting = a @@ -536,8 +477,8 @@ , totalCmdty = a , totalQty = a } - fl <*> fa = Fields { - globalTransaction = globalTransaction fl (globalTransaction fa) + fl <*> fa = Fields + { globalTransaction = globalTransaction fl (globalTransaction fa) , revGlobalTransaction = revGlobalTransaction fl (revGlobalTransaction fa) , globalPosting = globalPosting fl (globalPosting fa) , revGlobalPosting = revGlobalPosting fl (revGlobalPosting fa) diff --git a/Penny/Cabin/Posts/Help.hs b/Penny/Cabin/Posts/Help.hs deleted file mode 100644 --- a/Penny/Cabin/Posts/Help.hs +++ /dev/null @@ -1,66 +0,0 @@ -module Penny.Cabin.Posts.Help where - -import qualified Data.Text as X - -help :: X.Text -help = X.pack helpStr - -helpStr :: String -helpStr = unlines [ - "postings, pos", - " Show postings in order with a running balance.", - " The postings report takes the same options shown", - " from above in the categories \"Posting filters\" to", - " \"Removing postings after sorting and filtering\",", - " with the options affecting which postings are shown on screen.", - " Postings not shown still affect the running balance.", - "", - " Additional sequence number filtering options", - " Like the \"Sequence numbers\" options above, these", - " options take the form --option cmp num.", - "", - " --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", - "", - " Other additional options:", - "", - " --color yes|no|auto|256", - " yes: show 8 colors always", - " no: never show colors", - " auto: show 8 or 256 colors, but only if stdout is a terminal", - " 256: show 256 colors always", - " --background light|dark", - " Use appropriate color scheme for terminal background", - "", - " --width num", - " Hint for roughly how wide the report should be in columns", - " --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", - "", - " --show-zero-balances", - " Show balances that are zero", - " --hide-zero-balances", - " Hide balances that are zero", - "" - ] diff --git a/Penny/Cabin/Posts/Meta.hs b/Penny/Cabin/Posts/Meta.hs --- a/Penny/Cabin/Posts/Meta.hs +++ b/Penny/Cabin/Posts/Meta.hs @@ -11,6 +11,7 @@ import qualified Penny.Liberty as Ly import qualified Penny.Cabin.Meta as M import qualified Penny.Cabin.Options as CO +import Data.Monoid (mempty, mappend) -- | The Box type that is used throughout the Posts modules. type Box = L.Box PostMeta @@ -19,16 +20,16 @@ PostMeta { filteredNum :: Ly.FilteredNum , sortedNum :: Ly.SortedNum , visibleNum :: M.VisibleNum - , balance :: Maybe L.Balance } + , balance :: L.Balance } deriving Show addMetadata :: - [(L.Box (Ly.LibertyMeta, Maybe L.Balance))] + [(L.Box (Ly.LibertyMeta, L.Balance))] -> [Box] -addMetadata = M.visibleNums f where - f vn (lm, mb) = - PostMeta (Ly.filteredNum lm) (Ly.sortedNum lm) vn mb +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 @@ -59,21 +60,19 @@ addBalances :: CO.ShowZeroBalances -> [L.Box Ly.LibertyMeta] - -> [(L.Box (Ly.LibertyMeta, Maybe L.Balance))] -addBalances szb = snd . mapAccumL (balanceAccum szb) Nothing + -> [(L.Box (Ly.LibertyMeta, L.Balance))] +addBalances szb = snd . mapAccumL (balanceAccum szb) mempty balanceAccum :: CO.ShowZeroBalances - -> Maybe L.Balance + -> L.Balance -> L.Box Ly.LibertyMeta - -> (Maybe L.Balance, (L.Box (Ly.LibertyMeta, Maybe L.Balance))) -balanceAccum (CO.ShowZeroBalances szb) mb po = + -> (L.Balance, (L.Box (Ly.LibertyMeta, L.Balance))) +balanceAccum (CO.ShowZeroBalances szb) balOld po = let balThis = L.entryToBalance . Q.entry . L.boxPostFam $ po - balNew = case mb of - Nothing -> balThis - Just balOld -> L.addBalances balOld balThis + balNew = mappend balOld balThis balNoZeroes = L.removeZeroCommodities balNew - bal' = if szb then Just balNew else balNoZeroes + 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 --- a/Penny/Cabin/Posts/Parser.hs +++ b/Penny/Cabin/Posts/Parser.hs @@ -1,278 +1,166 @@ -module Penny.Cabin.Posts.Parser (State(..), parseOptions, - Error(..)) where +module Penny.Cabin.Posts.Parser (State(..), + allSpecs) where -import Control.Applicative ((<|>), (<$>), pure, many, (<*>), +import Control.Applicative ((<$>), pure, (<*>), Applicative) -import Control.Monad ((>=>)) import qualified Control.Monad.Exception.Synchronous as Ex import Data.Char (toLower) import qualified Data.Foldable as Fdbl import qualified System.Console.MultiArg.Combinator as C -import System.Console.MultiArg.Prim (Parser) +import qualified System.Console.MultiArg as MA -import qualified Penny.Cabin.Chunk as CC -import qualified Penny.Cabin.Colors as PC +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.Colors.DarkBackground as DB -import qualified Penny.Cabin.Colors.LightBackground as LB import qualified Penny.Cabin.Options as CO -import qualified Penny.Copper as Cop import qualified Penny.Liberty as Ly import qualified Penny.Liberty.Expressions as Exp import qualified Penny.Lincoln as L import qualified Penny.Shield as S import qualified Text.Matchers.Text as M -data Error = BadColorName String - | BadBackgroundArg String - | BadWidthArg String - | NoMatchingFieldName - | MultipleMatchingFieldNames [String] - | LibertyError Ly.Error - | BadNumber String - | BadComparator String - deriving Show - -data State = State { - sensitive :: M.CaseSensitive +data State = State + { sensitive :: M.CaseSensitive , factory :: L.Factory , tokens :: [Ly.Token (L.Box Ly.LibertyMeta -> Bool)] , postFilter :: [Ly.PostFilterFn] , fields :: F.Fields Bool - , colorPref :: CC.Colors - , drCrColors :: PC.DrCrColors - , baseColors :: PC.BaseColors , width :: Ty.ReportWidth , showZeroBalances :: CO.ShowZeroBalances + , showHelp :: Bool } --- | Parses the command line from the first word remaining up until, --- but not including, the first non-option argment. -parseOptions :: - Parser (S.Runtime - -> Cop.DefaultTimeZone - -> Cop.RadGroup - -> State - -> Ex.Exceptional Error State) -parseOptions = f <$> many parseOption where - f ls = - let g rt dtz rg st = - let ls' = map (\fn -> fn rt dtz rg) ls - in (foldl (>=>) return ls') st - in g +allSpecs + :: S.Runtime -> [MA.OptSpec (State -> Ex.Exceptional String State)] +allSpecs rt = + operand rt + ++ boxFilters + ++ parsePostFilter + ++ matcherSelect + ++ caseSelect + ++ operator + ++ [ parseWidth + , showField + , hideField + , showAllFields + , hideAllFields + , parseZeroBalances + , optHelp + ] -parseOption :: - Parser (S.Runtime - -> Cop.DefaultTimeZone - -> Cop.RadGroup - -> State - -> Ex.Exceptional Error State) -parseOption = - operand - <|> wrap boxFilters - <|> wrap parsePostFilter - <|> wrap (impurify matcherSelect) - <|> wrap (impurify caseSelect) - <|> wrap (impurify operator) - <|> (do { f <- color; return (\rt _ _ st -> f rt st)}) - <|> wrap background - <|> wrap parseWidth - <|> wrap showField - <|> wrap hideField - <|> wrap (impurify showAllFields) - <|> wrap (impurify hideAllFields) - <|> wrap (impurify parseShowZeroBalances) - <|> wrap (impurify hideZeroBalances) - where - wrap p = do - f <- p - return (\_ _ _ st -> f st) - -impurify :: - (Functor f, Applicative m) - => f (a -> b) - -> f (a -> m b) -impurify = fmap (\g -> pure . g) - -operand :: Parser (S.Runtime - -> Cop.DefaultTimeZone - -> Cop.RadGroup - -> State - -> Ex.Exceptional Error State) -operand = f <$> Ly.parseOperand +operand + :: S.Runtime + -> [MA.OptSpec (State -> Ex.Exceptional String State)] +operand rt = map (fmap f) (Ly.operandSpecs (S.currentTime rt)) where - f lyFn rt dtz rg st = - let dt = S.currentTime rt - cs = sensitive st + f lyFn st = do + let cs = sensitive st fty = factory st - in case lyFn dt dtz rg cs fty of - Ex.Exception e -> Ex.throw . LibertyError $ e - Ex.Success (Exp.Operand g) -> - let g' = g . L.boxPostFam - ts' = tokens st ++ [Exp.TokOperand g'] - in return st { tokens = ts' } + (Exp.Operand g) <- lyFn cs fty + let g' = g . L.boxPostFam + ts' = tokens st ++ [Exp.TokOperand g'] + return $ st { tokens = ts' } + -- | Processes a option for box-level serials. optBoxSerial :: [String] -- ^ Long options - + -> [Char] -- ^ Short options - + -> (Ly.LibertyMeta -> Int) -- ^ Pulls the serial from the PostMeta - - -> Parser (State -> Ex.Exceptional Error State) -optBoxSerial ls ss f = parseOpt ls ss (C.TwoArg g) + -> C.OptSpec (State -> Ex.Exceptional String State) + +optBoxSerial ls ss f = C.OptSpec ls ss (C.TwoArg g) where g a1 a2 st = do - cmp <- Ex.fromMaybe (BadComparator a1) (Ly.parseComparer a1) - i <- parseInt a2 + cmp <- Ly.parseComparer a1 + i <- Ly.parseInt a2 let h box = let ser = f . L.boxMeta $ box in ser `cmp` i tok = Exp.TokOperand h - return st { tokens = tokens st ++ [tok] } + return $ st { tokens = tokens st ++ [tok] } -optFilteredNum :: Parser (State -> Ex.Exceptional Error State) +optFilteredNum :: C.OptSpec (State -> Ex.Exceptional String State) optFilteredNum = optBoxSerial ["filtered"] "" f where f = L.forward . Ly.unFilteredNum . Ly.filteredNum -optRevFilteredNum :: Parser (State -> Ex.Exceptional Error State) +optRevFilteredNum :: C.OptSpec (State -> Ex.Exceptional String State) optRevFilteredNum = optBoxSerial ["revFiltered"] "" f where f = L.backward . Ly.unFilteredNum . Ly.filteredNum -optSortedNum :: Parser (State -> Ex.Exceptional Error State) +optSortedNum :: C.OptSpec (State -> Ex.Exceptional String State) optSortedNum = optBoxSerial ["sorted"] "" f where f = L.forward . Ly.unSortedNum . Ly.sortedNum -optRevSortedNum :: Parser (State -> Ex.Exceptional Error State) +optRevSortedNum :: C.OptSpec (State -> Ex.Exceptional String State) optRevSortedNum = optBoxSerial ["revSorted"] "" f where f = L.backward . Ly.unSortedNum . Ly.sortedNum -parseInt :: String -> Ex.Exceptional Error Int -parseInt s = case reads s of - (i, ""):[] -> return i - _ -> Ex.throw . BadNumber $ s - -boxFilters :: Parser (State -> Ex.Exceptional Error State) +boxFilters :: [C.OptSpec (State -> Ex.Exceptional String State)] boxFilters = - optFilteredNum - <|> optRevFilteredNum - <|> optSortedNum - <|> optRevSortedNum + [ optFilteredNum + , optRevFilteredNum + , optSortedNum + , optRevSortedNum + ] -parsePostFilter :: Parser (State -> Ex.Exceptional Error State) -parsePostFilter = f <$> Ly.parsePostFilter +parsePostFilter :: [C.OptSpec (State -> Ex.Exceptional String State)] +parsePostFilter = [fmap f optH, fmap f optT] where - f ex st = - case ex of - Ex.Exception e -> Ex.throw . LibertyError $ e - Ex.Success pf -> - return st { postFilter = postFilter st ++ [pf] } + (optH, optT) = Ly.postFilterSpecs + f exc = case exc of + Ex.Exception s -> const $ Ex.throw s + Ex.Success pf -> + let g st = return $ st { postFilter = postFilter st ++ [pf] } + in g -matcherSelect :: Parser (State -> State) -matcherSelect = f <$> Ly.parseMatcherSelect - where - f mf st = st { factory = mf } -caseSelect :: Parser (State -> State) -caseSelect = f <$> Ly.parseCaseSelect - where - f cs st = st { sensitive = cs } - -operator :: Parser (State -> State) -operator = f <$> Ly.parseOperator - where - f oo st = st { tokens = tokens st ++ [oo] } - -parseOpt :: [String] -> [Char] -> C.ArgSpec a -> Parser a -parseOpt ss cs a = C.parseOption [C.OptSpec ss cs a] - -color :: Parser (S.Runtime -> State -> Ex.Exceptional Error State) -color = parseOpt ["color"] "" (C.OneArg f) +matcherSelect :: Applicative f => [C.OptSpec (State -> f State)] +matcherSelect = map (fmap f) Ly.matcherSelectSpecs where - f a1 rt st = case pickColorArg rt a1 of - Nothing -> Ex.throw . BadColorName $ a1 - Just c -> return (st { colorPref = c }) - -pickColorArg :: S.Runtime -> String -> Maybe CC.Colors -pickColorArg rt t - | t == "yes" = Just CC.Colors8 - | t == "no" = Just CC.Colors0 - | t == "256" = Just CC.Colors256 - | t == "auto" = Just . CO.maxCapableColors $ rt - | otherwise = Nothing - -pickBackgroundArg :: String -> Maybe (PC.DrCrColors, PC.BaseColors) -pickBackgroundArg t - | t == "light" = Just (LB.drCrColors, LB.baseColors) - | t == "dark" = Just (DB.drCrColors, DB.baseColors) - | otherwise = Nothing + f mf st = pure $ st { factory = mf } -background :: Parser (State -> Ex.Exceptional Error State) -background = parseOpt ["background"] "" (C.OneArg f) +caseSelect :: Applicative f => [C.OptSpec (State -> f State)] +caseSelect = map (fmap f) Ly.caseSelectSpecs where - f a1 st = case pickBackgroundArg a1 of - Nothing -> Ex.throw . BadBackgroundArg $ a1 - Just (dc, bc) -> return (st { drCrColors = dc - , baseColors = bc } ) - + f cs st = pure $ st { sensitive = cs } -parseWidth :: Parser (State -> Ex.Exceptional Error State) -parseWidth = parseOpt ["width"] "" (C.OneArg f) +operator :: Applicative f => [C.OptSpec (State -> f State)] +operator = map (fmap f) Ly.operatorSpecs where - f a1 st = case reads a1 of - (i, ""):[] -> return (st { width = Ty.ReportWidth i }) - _ -> Ex.throw . BadWidthArg $ a1 + f oo st = pure $ st { tokens = tokens st ++ [oo] } -showField :: Parser (State -> Ex.Exceptional Error State) -showField = parseOpt ["show"] "" (C.OneArg f) +parseWidth :: C.OptSpec (State -> Ex.Exceptional String State) +parseWidth = C.OptSpec ["width"] "" (C.OneArg f) where f a1 st = do - fl <- parseField a1 - let newFl = fieldOn (fields st) fl - return st { fields = newFl } + i <- Ly.parseInt a1 + return $ st { width = Ty.ReportWidth i } -hideField :: Parser (State -> Ex.Exceptional Error State) -hideField = parseOpt ["hide"] "" (C.OneArg f) - where - f a1 st = do - fl <- parseField a1 - let newFl = fieldOff (fields st) fl - return st { fields = newFl } +parseField :: String -> Ex.Exceptional String (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 checkFields flds -showAllFields :: Parser (State -> State) -showAllFields = parseOpt ["show-all"] "" (C.NoArg f) - where - f st = st {fields = pure True} -hideAllFields :: Parser (State -> State) -hideAllFields = parseOpt ["hide-all"] "" (C.NoArg f) - where - f st = st {fields = pure False} - -parseShowZeroBalances :: Parser (State -> State) -parseShowZeroBalances = parseOpt opt "" (C.NoArg f) - where - opt = ["show-zero-balances"] - f st = st {showZeroBalances = CO.ShowZeroBalances True } - -hideZeroBalances :: Parser (State -> State) -hideZeroBalances = parseOpt ["hide-zero-balances"] "" (C.NoArg f) - where - f st = st {showZeroBalances = CO.ShowZeroBalances False } - -- | Turns a field on if it is True. fieldOn :: F.Fields Bool @@ -281,7 +169,7 @@ -> 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 @@ -291,11 +179,11 @@ 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 @@ -304,55 +192,51 @@ f o False = o f _ True = False -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 <$> fieldNames - in checkFields flds +showField :: C.OptSpec (State -> Ex.Exceptional String 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 String 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 :: Applicative f => C.OptSpec (State -> f State) +showAllFields = C.OptSpec ["show-all"] "" (C.NoArg f) + where + f st = pure $ st {fields = pure True} + +hideAllFields :: Applicative f => C.OptSpec (State -> f State) +hideAllFields = C.OptSpec ["hide-all"] "" (C.NoArg f) + where + f st = pure $ st {fields = pure False} + +optHelp :: Applicative f => C.OptSpec (State -> f State) +optHelp = fmap f P.help + where + f _ st = pure $ st { showHelp = True } + +parseZeroBalances :: Applicative f => C.OptSpec (State -> f State) +parseZeroBalances = fmap f P.zeroBalances + where + f szb st = pure $ st { showZeroBalances = szb } + -- | Checks the fields with the True value to ensure there is only one. -checkFields :: F.Fields (String, Bool) -> Ex.Exceptional Error (F.Fields Bool) +checkFields :: + F.Fields (String, Bool) + -> Ex.Exceptional String (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 NoMatchingFieldName + [] -> Ex.throw "no matching field names" _:[] -> return (snd <$> fs) - ls -> Ex.throw . MultipleMatchingFieldNames $ ls - + _ -> Ex.throw "multiple matching field names" -fieldNames :: F.Fields String -fieldNames = F.Fields { - F.globalTransaction = "globalTransaction" - , F.revGlobalTransaction = "revGlobalTransaction" - , F.globalPosting = "globalPosting" - , F.revGlobalPosting = "revGlobalPosting" - , F.fileTransaction = "fileTransaction" - , F.revFileTransaction = "revFileTransaction" - , F.filePosting = "filePosting" - , F.revFilePosting = "revFilePosting" - , F.filtered = "filtered" - , F.revFiltered = "revFiltered" - , F.sorted = "sorted" - , F.revSorted = "revSorted" - , F.visible = "visible" - , F.revVisible = "revVisible" - , F.lineNum = "lineNum" - , F.date = "date" - , F.flag = "flag" - , F.number = "number" - , F.payee = "payee" - , F.account = "account" - , F.postingDrCr = "postingDrCr" - , F.postingCmdty = "postingCmdty" - , F.postingQty = "postingQty" - , F.totalDrCr = "totalDrCr" - , F.totalCmdty = "totalCmdty" - , F.totalQty = "totalQty" - , F.tags = "tags" - , F.memo = "memo" - , F.filename = "filename" } diff --git a/Penny/Cabin/Posts/Spacers.hs b/Penny/Cabin/Posts/Spacers.hs --- a/Penny/Cabin/Posts/Spacers.hs +++ b/Penny/Cabin/Posts/Spacers.hs @@ -3,8 +3,8 @@ -- field. module Penny.Cabin.Posts.Spacers where -data Spacers a = Spacers { - globalTransaction :: a +data Spacers a = Spacers + { globalTransaction :: a , revGlobalTransaction :: a , globalPosting :: a , revGlobalPosting :: a @@ -19,7 +19,6 @@ , visible :: a , revVisible :: a , lineNum :: a - -- ^ The line number from the posting's metadata , date :: a , flag :: a , number :: a @@ -29,5 +28,5 @@ , postingCmdty :: a , postingQty :: a , totalDrCr :: a - , totalCmdty :: a } - deriving (Show, Eq) + , totalCmdty :: a + } deriving (Show, Eq) diff --git a/Penny/Cabin/Row.hs b/Penny/Cabin/Row.hs --- a/Penny/Cabin/Row.hs +++ b/Penny/Cabin/Row.hs @@ -1,3 +1,27 @@ +-- | 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), @@ -7,6 +31,7 @@ import Data.List (transpose) import qualified Data.Text as X import qualified Penny.Cabin.Chunk as C +import qualified Penny.Cabin.Scheme as E -- | How to justify cells. LeftJustify leaves the right side -- ragged. RightJustify leaves the left side ragged. @@ -24,44 +49,48 @@ data ColumnSpec = ColumnSpec { justification :: Justification , width :: C.Width - , padSpec :: C.TextSpec - , bits :: [C.Chunk] } + , padSpec :: (E.Label, E.EvenOdd) + , bits :: [E.PreChunk] } -newtype JustifiedCell = JustifiedCell (Either (C.Chunk, C.Chunk) C.Chunk) +newtype JustifiedCell = JustifiedCell (Either (E.PreChunk, E.PreChunk) + E.PreChunk) data JustifiedColumn = JustifiedColumn { justifiedCells :: [JustifiedCell] , _justifiedWidth :: C.Width - , _justifiedPadSpec :: C.TextSpec } + , _justifiedPadSpec :: (E.Label, E.EvenOdd) } newtype PaddedColumns = PaddedColumns [[JustifiedCell]] newtype CellsByRow = CellsByRow [[JustifiedCell]] newtype CellRowsWithNewlines = CellRowsWithNewlines [[JustifiedCell]] -justify :: - C.TextSpec - -> C.Width +justify + :: C.Width -> Justification - -> C.Chunk + -> E.PreChunk -> JustifiedCell -justify ts (C.Width w) j b +justify (C.Width w) j pc | origWidth < w = JustifiedCell . Left $ pair - | otherwise = JustifiedCell . Right $ b + | otherwise = JustifiedCell . Right $ pc where - origWidth = C.unWidth . C.chunkWidth $ b - pad = C.chunk ts t + origWidth = C.unWidth . E.width $ pc + lbl = E.label pc + eo = E.evenOdd pc + pad = E.PreChunk lbl eo t t = X.replicate (w - origWidth) (X.singleton ' ') pair = case j of - LeftJustify -> (b, pad) - RightJustify -> (pad, b) + LeftJustify -> (pc, pad) + RightJustify -> (pad, pc) newtype Height = Height { _unHeight :: Int } deriving (Show, Eq, Ord) height :: [[a]] -> Height -height = Height . maximum . map length +height xs = case xs of + [] -> Height 0 + ls -> Height . maximum . map length $ ls -row :: [ColumnSpec] -> [C.Chunk] +row :: [ColumnSpec] -> [E.PreChunk] row = concat . concat @@ -73,17 +102,17 @@ justifiedColumn :: ColumnSpec -> JustifiedColumn justifiedColumn (ColumnSpec j w ts bs) = JustifiedColumn cs w ts where - cs = map (justify ts w j) $ bs + cs = map (justify w j) $ bs bottomPad :: [JustifiedColumn] -> PaddedColumns bottomPad jcs = PaddedColumns pcs where justCells = map justifiedCells jcs (Height h) = height justCells pcs = map toPaddedColumn jcs - toPaddedColumn (JustifiedColumn cs (C.Width w) ts) = let + toPaddedColumn (JustifiedColumn cs (C.Width w) (lbl, eo)) = let l = length cs nPads = h - l - pad = C.chunk ts t + pad = E.PreChunk lbl eo t t = X.replicate w (X.singleton ' ') pads = replicate nPads . JustifiedCell . Right $ pad cs' @@ -101,11 +130,11 @@ CellRowsWithNewlines bs' where bs' = foldr f [] bs newline = JustifiedCell . Right - $ C.chunk C.defaultTextSpec (X.singleton '\n') + $ E.PreChunk E.Other E.Even (X.singleton '\n') f cells acc = (cells ++ [newline]) : acc - -toBits :: CellRowsWithNewlines -> [[[C.Chunk]]] + +toBits :: CellRowsWithNewlines -> [[[E.PreChunk]]] toBits (CellRowsWithNewlines cs) = map (map toB) cs where toB (JustifiedCell c) = case c of Left (lb, rb) -> [lb, rb] diff --git a/Penny/Cabin/Scheme.hs b/Penny/Cabin/Scheme.hs new file mode 100644 --- /dev/null +++ b/Penny/Cabin/Scheme.hs @@ -0,0 +1,145 @@ +-- | 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.Chunk as C +import qualified Penny.Cabin.Meta as M +import qualified Penny.Lincoln as L +import qualified Data.Text as X + +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 TextSpecs = Labels (EvenAndOdd C.TextSpec) + +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@ + + , textSpecs :: TextSpecs + } 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) + +data PreChunk = PreChunk + { label :: Label + , evenOdd :: EvenOdd + , text :: X.Text + } deriving (Eq, Show) + +width :: PreChunk -> C.Width +width = C.Width . X.length . text + +makeChunk :: TextSpecs -> PreChunk -> C.Chunk +makeChunk s p = + C.chunk (getEvenOddLabelValue (label p) (evenOdd p) s) + (text p) + +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 -> PreChunk +bottomLineToDrCr bl eo = PreChunk lbl eo t + where + (lbl, t) = case bl of + L.Zero -> (Zero, X.pack "--") + L.NonZero (L.Column clmDrCr _) -> case clmDrCr of + L.Debit -> (Debit, X.singleton '<') + L.Credit -> (Credit, X.singleton '>') + +balancesToCmdtys + :: EvenOdd + -> [(L.Commodity, L.BottomLine)] + -> [PreChunk] +balancesToCmdtys eo ls = + if null ls + then [PreChunk Zero eo (X.pack "--")] + else map (bottomLineToCmdty eo) ls + +bottomLineToCmdty + :: EvenOdd + -> (L.Commodity, L.BottomLine) + -> PreChunk +bottomLineToCmdty eo (cy, bl) = PreChunk lbl eo t + where + t = L.unCommodity cy + lbl = case bl of + L.Zero -> Zero + L.NonZero (L.Column clmDrCr _) -> dcToLbl clmDrCr + +balanceToQtys + :: (L.Commodity -> L.Qty -> X.Text) + -> EvenOdd + -> [(L.Commodity, L.BottomLine)] + -> [PreChunk] +balanceToQtys getTxt eo ls = + if null ls + then [PreChunk Zero eo (X.pack "--")] + else map (bottomLineToQty getTxt eo) ls + + +bottomLineToQty + :: (L.Commodity -> L.Qty -> X.Text) + -> EvenOdd + -> (L.Commodity, L.BottomLine) + -> PreChunk +bottomLineToQty getTxt eo (cy, bl) = PreChunk lbl eo t + where + (lbl, t) = case bl of + L.Zero -> (Zero, X.pack "--") + L.NonZero (L.Column clmDrCr qt) -> (dcToLbl clmDrCr, getTxt cy qt) + diff --git a/Penny/Cabin/Scheme/Schemes.hs b/Penny/Cabin/Scheme/Schemes.hs new file mode 100644 --- /dev/null +++ b/Penny/Cabin/Scheme/Schemes.hs @@ -0,0 +1,89 @@ +-- | Some schemes you can use. + +module Penny.Cabin.Scheme.Schemes where + +import qualified Penny.Cabin.Scheme as E +import qualified Penny.Cabin.Chunk as C +import qualified Penny.Cabin.Chunk.Switch as Sw + +-- | 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 C.TextSpec) +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 :: C.TextSpec +lightEvenTextSpec = C.defaultTextSpec + +lightOddTextSpec :: C.TextSpec +lightOddTextSpec = Sw.switchBackground C.color8_b_default + C.color256_b_255 lightEvenTextSpec + +lightDebit :: C.TextSpec -> C.TextSpec +lightDebit = Sw.switchForeground C.color8_f_magenta C.color256_f_52 + +lightCredit :: C.TextSpec -> C.TextSpec +lightCredit = Sw.switchForeground C.color8_f_cyan C.color256_f_21 + +lightZero :: C.TextSpec -> C.TextSpec +lightZero = Sw.switchForeground C.color8_f_black C.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 C.TextSpec) +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 :: C.TextSpec +darkEvenTextSpec = C.defaultTextSpec + +darkOddTextSpec :: C.TextSpec +darkOddTextSpec = Sw.switchBackground C.color8_b_default + C.color256_b_235 darkEvenTextSpec + +darkDebit :: C.TextSpec -> C.TextSpec +darkDebit = Sw.switchForeground C.color8_f_magenta C.color256_f_208 + +darkCredit :: C.TextSpec -> C.TextSpec +darkCredit = Sw.switchForeground C.color8_f_cyan C.color256_f_45 + +darkZero :: C.TextSpec -> C.TextSpec +darkZero = Sw.switchForeground C.color8_f_white C.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 C.TextSpec) +plainLabels = E.Labels + { E.debit = E.EvenAndOdd C.defaultTextSpec C.defaultTextSpec + , E.credit = E.EvenAndOdd C.defaultTextSpec C.defaultTextSpec + , E.zero = E.EvenAndOdd C.defaultTextSpec C.defaultTextSpec + , E.other = E.EvenAndOdd C.defaultTextSpec C.defaultTextSpec + } + diff --git a/Penny/Copper.hs b/Penny/Copper.hs --- a/Penny/Copper.hs +++ b/Penny/Copper.hs @@ -1,51 +1,51 @@ --- | Copper - the Penny parser -module Penny.Copper ( - -- * Comments - C.Comment(Comment), - - -- * Radix and grouping - Q.RadGroup, - Q.periodComma, Q.periodSpace, Q.commaPeriod, Q.commaSpace, - Q.GroupingSpec(..), - - -- * Default time zone - DT.DefaultTimeZone(DefaultTimeZone), - DT.utcDefault, - - -- * FileContents - FileContents(FileContents, unFileContents), - - -- * Errors - ErrorMsg (ErrorMsg, unErrorMsg), +-- | 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 + , openStdin - -- * Items - I.Item(Transaction, Price, CommentItem, BlankLine), - I.Line(unLine), + -- * 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) - -- * Parsing - Ledger(Ledger, unLedger), - parse, - -- * Rendering - I.render - ) where + , R.GroupSpec(..) + , R.GroupSpecs(..) + , R.ledger + ) where -import Control.Applicative ((<$>)) +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 Text.Parsec ( manyTill, eof ) -import qualified Text.Parsec as P +import qualified Data.Text.IO as TIO +import qualified Text.Parsec as Parsec +import qualified Penny.Copper.Parsec as CP -import qualified Penny.Copper.Comments as C -import qualified Penny.Copper.Qty as Q -import qualified Penny.Copper.DateTime as DT -import qualified Penny.Copper.Item as I import qualified Penny.Lincoln as L - -data Ledger = - Ledger { unLedger :: [(I.Line, I.Item)] } - deriving Show +import qualified Penny.Copper.Render as R +import qualified Penny.Copper.Types as Y +import qualified System.IO.Error as E +import qualified System.IO as IO newtype FileContents = FileContents { unFileContents :: X.Text } deriving (Eq, Show) @@ -54,79 +54,164 @@ deriving (Eq, Show) parseFile :: - DT.DefaultTimeZone - -> Q.RadGroup - -> (L.Filename, FileContents) - -> Ex.Exceptional ErrorMsg - [(I.Line, I.Item)] -parseFile dtz rg (fn, (FileContents c)) = - let p = addFileMetadata fn - <$> manyTill (I.itemWithLineNumber dtz rg) eof + (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 P.parse p fnStr c of + in case Parsec.parse p fnStr c of Left err -> Ex.throw (ErrorMsg . X.pack . show $ err) Right g -> return g -addFileMetadata :: - L.Filename - -> [(I.Line, I.Item)] - -> [(I.Line, I.Item)] -addFileMetadata fn ls = - let (lns, is) = (map fst ls, map snd ls) - eis = map toEiItem is - procTop s m = - m { L.fileTransaction = Just (L.FileTransaction s) - , L.filename = Just fn } - procPstg s m = - m { L.filePosting = Just (L.FilePosting s) } - eis' = L.addSerialsToEithers procTop procPstg eis - is' = map fromEiItem eis' - in zip lns is' +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)) } -addGlobalMetadata :: - [[(I.Line, I.Item)]] - -> [(I.Line, I.Item)] -addGlobalMetadata lss = - let ls = concat lss - procTop s m = - m { L.globalTransaction = Just (L.GlobalTransaction s) } - procPstg s m = - m { L.globalPosting = Just (L.GlobalPosting s) } - (lns, is) = (map fst ls, map snd ls) - eis = map toEiItem is - eis' = L.addSerialsToEithers procTop procPstg eis - is' = map fromEiItem eis' - in zip lns is' +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 :: - DT.DefaultTimeZone - -> Q.RadGroup - -> [(L.Filename, FileContents)] - -> Ex.Exceptional ErrorMsg Ledger -parse dtz rg ps = - mapM (parseFile dtz rg) ps - >>= (return . Ledger . addGlobalMetadata) + [(L.Filename, FileContents)] + -> Ex.Exceptional ErrorMsg Y.Ledger +parse ps = fmap addGlobalMetadata $ mapM parseFile ps -data Other = OPrice L.PricePoint - | OCommentItem C.Comment - | OBlankLine - deriving Show +-- | Reads and parses the given filename. Does not do anything to +-- handle @-@ arguments; for that, see openStdin. Errors are indicated +-- by throwing an exception. +open :: [String] -> IO Y.Ledger +open = fmap addGlobalMetadata + . mapM (\s -> getFileContents s >>= parseAndResolve) -type EiItem = Either Other L.Transaction -toEiItem :: I.Item -> EiItem -toEiItem i = case i of - I.Transaction t -> Right t - I.Price p -> Left (OPrice p) - I.CommentItem c -> Left (OCommentItem c) - I.BlankLine -> Left OBlankLine +getFileContents :: String -> IO (L.Filename, FileContents) +getFileContents s = fmap f (TIO.readFile s) + where f c = (L.Filename . X.pack $ s, FileContents c) -fromEiItem :: EiItem -> I.Item -fromEiItem i = case i of - Left l -> case l of - OPrice p -> I.Price p - OCommentItem c -> I.CommentItem c - OBlankLine -> I.BlankLine - Right t -> I.Transaction t +parseAndResolve :: (L.Filename, FileContents) -> IO Y.Ledger +parseAndResolve p@(L.Filename fn, _) = + Ex.switch err return $ parseFile p + where + err (ErrorMsg x) = + E.ioError $ E.mkIOError E.userErrorType + ("could not parse file: " ++ X.unpack x) + Nothing (Just . X.unpack $ fn) + +-- | 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. Errors are indicated by throwing an exception. +openStdin :: [String] -> IO Y.Ledger +openStdin ss = + let ls = if null ss + then fmap (\x -> [x]) (getFileContentsStdin "-") + else mapM getFileContentsStdin ss + in fmap addGlobalMetadata (ls >>= mapM parseAndResolve) + +getFileContentsStdin :: String -> IO (L.Filename, FileContents) +getFileContentsStdin s = do + txt <- if s == "-" + then do + isTerm <- IO.hIsTerminalDevice IO.stdin + when isTerm + (IO.hPutStrLn IO.stderr $ + "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/Account.hs b/Penny/Copper/Account.hs deleted file mode 100644 --- a/Penny/Copper/Account.hs +++ /dev/null @@ -1,131 +0,0 @@ --- | Account parsers. Account names fall into one of three groups: --- --- * Level 1 account. Can have nearly any character, including --- spaces. However, when in a Ledger file they must be quoted. --- --- * Level 2 account. The first sub-account begins with a letter. All --- other characters may be nearly any character, except for a space. -module Penny.Copper.Account ( - lvl1Account - , lvl1AccountQuoted - , lvl2Account - , render - , lvl1Char - , lvl2FirstChar - , lvl2RemainingChar - ) where - -import Control.Applicative((<$>), (<*>), (*>)) -import qualified Data.Foldable as F -import Data.Text ( snoc, cons, pack, Text ) -import qualified Data.Traversable as T -import Text.Parsec ( - char, satisfy, many, (), - many1, between, sepBy1, option ) -import Text.Parsec.Text ( Parser ) - -import Data.List.NonEmpty (NonEmpty((:|))) -import qualified Data.List.NonEmpty as NE -import qualified Penny.Lincoln.Bits as B -import Penny.Lincoln.TextNonEmpty ( TextNonEmpty ( TextNonEmpty ), - unsafeTextNonEmpty ) -import qualified Penny.Lincoln.HasText as HT -import qualified Penny.Copper.Util as U - --- | Characters allowed in a Level 1 account. (Check the source code --- to see what these are). -lvl1Char :: Char -> Bool -lvl1Char c = allowed && notBanned where - allowed = U.rangeLettersToSymbols c || c == ' ' - notBanned = not $ c `elem` "}:" - -lvl1Sub :: Parser B.SubAccountName -lvl1Sub = f <$> p e where - f = B.SubAccountName . unsafeTextNonEmpty - p = many1 (satisfy lvl1Char) - e = "sub account name" - -lvl1Account :: Parser B.Account -lvl1Account = B.Account . NE.fromList <$> p e where - e = "account name" - p = sepBy1 lvl1Sub (char ':') - -lvl1AccountQuoted :: Parser B.Account -lvl1AccountQuoted = between (char '{') (char '}') lvl1Account - --- | Characters allowed for the first character of a Level 2 account. -lvl2FirstChar :: Char -> Bool -lvl2FirstChar = U.rangeLetters - --- | Characters allowed for the remaining characters of a Level 2 --- account. -lvl2RemainingChar :: Char -> Bool -lvl2RemainingChar c = allowed && notBanned where - allowed = U.rangeLettersToSymbols c - notBanned = not $ c `elem` "}:" - -lvl2SubAccountFirst :: Parser B.SubAccountName -lvl2SubAccountFirst = f <$> c1 <*> cs e where - c1 = satisfy lvl2FirstChar - cs = many (satisfy lvl2RemainingChar) - f l1 lr = B.SubAccountName (TextNonEmpty l1 (pack lr)) - e = "sub account name beginning with a letter" - -lvl2SubAccountRest :: Parser B.SubAccountName -lvl2SubAccountRest = f <$> cs e where - cs = many1 (satisfy p) - p c = allowed && notBanned where - allowed = U.rangeLettersToSymbols c - notBanned = not $ c `elem` "}:" - f = B.SubAccountName . unsafeTextNonEmpty - e = "sub account name" - -lvl2Account :: Parser B.Account -lvl2Account = f <$> p1 <*> p2 e where - f x y = B.Account (x :| y) - p1 = lvl2SubAccountFirst - p2 = option [] $ - char ':' *> sepBy1 lvl2SubAccountRest (char ':') - e = "account name" - -data Level = L1 | L2 - deriving (Eq, Ord, Show) - --- | Checks an account to see what level to render it at. -checkAccount :: B.Account -> Maybe Level -checkAccount (B.Account subs) = let - checkFirst = checkFirstSubAccount (NE.head subs) - checkRest = map checkFirstSubAccount (NE.tail subs) - in F.minimum <$> T.sequenceA (checkFirst : checkRest) - --- | Checks the first sub account to see if it qualifies as a Level 1 --- or Level 2 sub account. -checkFirstSubAccount :: - B.SubAccountName - -> Maybe Level -checkFirstSubAccount s = do - l <- checkOtherSubAccount s - return $ case l of - L1 -> L1 - L2 -> let (B.SubAccountName (TextNonEmpty c _)) = s - in if lvl2FirstChar c then L2 else L1 - --- | Checks a sub account other than the first one to see if it --- qualifies as a Level 1 or Level 2 sub account. -checkOtherSubAccount :: - B.SubAccountName - -> Maybe Level -checkOtherSubAccount = U.checkText ls where - ls = (lvl2RemainingChar, L2) :| [(lvl1Char, L1)] - --- | 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. -render :: B.Account -> Maybe Text -render a = do - l <- checkAccount a - let t = HT.text . HT.Delimited (pack ":") . HT.textList $ a - return $ case l of - L1 -> cons '{' t `snoc` '}' - L2 -> t diff --git a/Penny/Copper/Amount.hs b/Penny/Copper/Amount.hs deleted file mode 100644 --- a/Penny/Copper/Amount.hs +++ /dev/null @@ -1,96 +0,0 @@ --- | Amount parsers. An amount is a commodity and a quantity. (An --- entry is an amount and a debit or credit). --- --- Possible combinations: --- --- * quoted Level 1 commodity, optional whitespace, quantity --- --- * Level 3 commodity, optional whitespace, quantity --- --- * Quantity, optional whitespace, quoted Level 1 commodity --- --- * Quantity, optional whitespace, Level 2 commodity --- --- Each quantity may be quoted or unquoted. -module Penny.Copper.Amount ( - amount - , render - ) where - -import Control.Applicative ((<$>), (<*>), (<|>)) -import qualified Data.Text as X -import Text.Parsec ( char, many, () ) -import Text.Parsec.Text ( Parser ) - -import qualified Penny.Copper.Commodity as C -import qualified Penny.Copper.Qty as Q -import qualified Penny.Lincoln as L - --- | Parse optional spaces, returns appropriate metadata. -spaces :: Parser L.SpaceBetween -spaces = f <$> many (char ' ') where - f l = if null l then L.NoSpaceBetween else L.SpaceBetween - -cmdtyQty :: Parser L.Commodity - -> Q.RadGroup - -> Parser (L.Amount, L.Format) -cmdtyQty p rg = let - f c s q = (a, fmt) where - a = L.Amount q c - fmt = L.Format L.CommodityOnLeft s - e = "amount, commodity on left" - in f <$> p <*> spaces <*> Q.qty rg e - -lvl1CmdtyQty :: Q.RadGroup -> Parser (L.Amount, L.Format) -lvl1CmdtyQty = cmdtyQty C.quotedLvl1Cmdty - -lvl3CmdtyQty :: Q.RadGroup -> Parser (L.Amount, L.Format) -lvl3CmdtyQty = cmdtyQty C.lvl3Cmdty - -cmdtyOnRight :: Q.RadGroup -> Parser (L.Amount, L.Format) -cmdtyOnRight rg = let - f q s c = (a, fmt) where - a = L.Amount q c - fmt = L.Format L.CommodityOnRight s - e = "amount, commodity on right" - in f - <$> Q.qty rg - <*> spaces - <*> (C.quotedLvl1Cmdty <|> C.lvl2Cmdty) - e - --- | Parses an amount with its metadata. Handles all combinations of --- commodities and quantities. -amount :: Q.RadGroup -> Parser (L.Amount, L.Format) -amount rg = lvl1CmdtyQty rg - <|> lvl3CmdtyQty rg - <|> cmdtyOnRight rg - "amount" - --- | Render an Amount. The Format is required so that the commodity --- can be displayed in the right place. -render :: - (Q.GroupingSpec, Q.GroupingSpec) - -- ^ Grouping - -> Q.RadGroup - -> L.Format - -> L.Amount - -> Maybe X.Text -render gs rg f a = let - (q, c) = (L.qty a, L.commodity a) - qty = Q.quote $ Q.renderUnquoted rg gs q - ws = case L.between f of - L.SpaceBetween -> X.singleton ' ' - L.NoSpaceBetween -> X.empty - mayLvl3 = C.renderLvl3 c - mayLvl2 = C.renderLvl2 c - in do - quotedLvl1 <- C.renderQuotedLvl1 c - let (l, r) = case L.side f of - L.CommodityOnLeft -> case mayLvl3 of - Nothing -> (quotedLvl1, qty) - Just l3 -> (l3, qty) - L.CommodityOnRight -> case mayLvl2 of - Nothing -> (qty, quotedLvl1) - Just l2 -> (qty, l2) - return $ X.concat [l, ws, r] diff --git a/Penny/Copper/Comments.hs b/Penny/Copper/Comments.hs deleted file mode 100644 --- a/Penny/Copper/Comments.hs +++ /dev/null @@ -1,35 +0,0 @@ -module Penny.Copper.Comments ( - Comment(Comment) - , comment - , isCommentChar - , render - ) where - -import Control.Applicative ((<*>), (<*), (<$)) -import Data.Text ( Text, pack, cons, snoc ) -import qualified Data.Text as X -import Text.Parsec (many, char, satisfy, ()) -import Text.Parsec.Text ( Parser ) - -import Penny.Copper.Util (eol) -import qualified Penny.Copper.Util as U - -data Comment = Comment Text - deriving (Eq, Show) - -isCommentChar :: Char -> Bool -isCommentChar c = inCategory || allowed where - allowed = c `elem` " " - inCategory = U.rangeLettersToSymbols c - -comment :: Parser Comment -comment = Comment . pack - <$ char '#' - <*> many (satisfy isCommentChar) - <* eol - "single line comment" - -render :: Comment -> Maybe Text -render (Comment t) = case X.find (not . isCommentChar) t of - Nothing -> return $ '#' `cons` t `snoc` '\n' - Just _ -> Nothing diff --git a/Penny/Copper/Commodity.hs b/Penny/Copper/Commodity.hs deleted file mode 100644 --- a/Penny/Copper/Commodity.hs +++ /dev/null @@ -1,187 +0,0 @@ --- | Commodity parsers. Commodity names fall into three groups: --- --- * Level 1 commodities. These can have a broad selection of --- characters, including spaces. The downside is that they need to be --- quoted when they appear in a file. (They don't have to be quoted --- from the command line, presuming that a single command line --- argument captures the entire commodity name and nothing else.) --- --- * Level 2 commodities. The first sub-commodity begins with a letter --- or a symbol. All other characters may be nearly any other --- character. Spaces however are not permitted. --- --- * Level 3 commodities. All charcters must be letters or symbols. In --- addition, the first character cannot be a @+@ or a @-@. -module Penny.Copper.Commodity ( - -- * Level 1 commodities - lvl1Char, - lvl1Cmdty, - quotedLvl1Cmdty, - commandLineCmdty, - - -- * Level 2 commodities - lvl2FirstChar, - lvl2OtherChars, - lvl2Cmdty, - - -- * Level 3 commodities - lvl3FirstChar, - lvl3OtherChars, - lvl3Cmdty, - - -- * Helpers when parsing from a file - leftSideCmdty, - rightSideCmdty, - - -- * Rendering - renderQuotedLvl1, - renderLvl2, - renderLvl3 - ) where - -import Control.Applicative ((<*>), (<$>), (*>), (<|>)) -import Control.Monad (guard) -import Data.Text ( pack, Text, cons, snoc, singleton ) -import Text.Parsec ( satisfy, many, char, sepBy1, many1, (), - between, option, sepBy ) -import Text.Parsec.Text ( Parser ) - -import qualified Penny.Lincoln.Bits as B -import Data.List.NonEmpty (NonEmpty((:|)), fromList) -import Penny.Copper.Util (listIsOK, firstCharOfListIsOK) -import qualified Penny.Copper.Util as U -import qualified Penny.Lincoln.HasText as HT -import Penny.Lincoln.TextNonEmpty ( TextNonEmpty ( TextNonEmpty ), - unsafeTextNonEmpty ) - --- | Most liberal set of letters allowed in a commodity. -lvl1Char :: Char -> Bool -lvl1Char c = (category || specific) && notBanned where - category = U.rangeLettersToSymbols c - specific = c == ' ' - notBanned = not $ c `elem` ['"', ':'] - --- | A sub commodity comprised of the most liberal characters. -lvl1SubCmdty :: Parser B.SubCommodity -lvl1SubCmdty = f <$> m "sub commodity" where - m = many1 (satisfy lvl1Char) - f cs = B.SubCommodity (TextNonEmpty (head cs) (pack $ tail cs)) - --- | A commodity that might have spaces inside of the name. To parse --- this when it is in a ledger file, it must be quoted; use --- quotedLvl1Cmdty for that. This parser can be used directly for values --- entered from the command line. -lvl1Cmdty :: Parser B.Commodity -lvl1Cmdty = (B.Commodity . fromList) - <$> sepBy1 lvl1SubCmdty (char ':') - "commodity with spaces" - - --- | A commodity that may have spaces in the name; is wrapped inside --- of double quotes. -quotedLvl1Cmdty :: Parser B.Commodity -quotedLvl1Cmdty = between q q lvl1Cmdty - "quoted commodity" where - q = char '"' - --- | Allows only letters and symbols. -lvl2FirstChar :: Char -> Bool -lvl2FirstChar c = U.rangeLetters c || U.rangeMathCurrency c - -lvl2OtherChars :: Char -> Bool -lvl2OtherChars c = category && notBanned where - category = U.rangeLettersToSymbols c - notBanned = not $ c `elem` ['"', ':'] - -lvl2FirstSubCmdty :: Parser B.SubCommodity -lvl2FirstSubCmdty = f <$> firstLet <*> restLet e where - e = "sub commodity, first character is letter or symbol" - firstLet = satisfy lvl2FirstChar - restLet = many (satisfy lvl2OtherChars) - f l1 lr = B.SubCommodity (TextNonEmpty l1 (pack lr)) - -lvl2OtherSubCmdty :: Parser B.SubCommodity -lvl2OtherSubCmdty = f <$> ls e where - e = "sub commodity" - ls = many1 (satisfy lvl2OtherChars) - f = B.SubCommodity . unsafeTextNonEmpty - -lvl2Cmdty :: Parser B.Commodity -lvl2Cmdty = f <$> firstSub <*> restSubs e where - e = "commodity, first character is letter or symbol" - firstSub = lvl2FirstSubCmdty - restSubs = option [] - $ char ':' - *> sepBy1 lvl2OtherSubCmdty (char ':') - f s1 sr = B.Commodity (s1 :| sr) - -lvl3OtherChars :: Char -> Bool -lvl3OtherChars c = U.rangeLetters c || U.rangeMathCurrency c - -lvl3FirstChar :: Char -> Bool -lvl3FirstChar c = lvl3OtherChars c && (not $ c `elem` "+-") - -lvl3FirstSubCmdty :: Parser B.SubCommodity -lvl3FirstSubCmdty = f <$> c <*> cs e where - e = "first sub commodity, letters and symbols only, " - ++ "first character not a + or -" - f c1 cr = B.SubCommodity (TextNonEmpty c1 (pack cr)) - c = satisfy lvl3FirstChar - cs = many (satisfy lvl3OtherChars) - -lvl3OtherSubCmdty :: Parser B.SubCommodity -lvl3OtherSubCmdty = f <$> ls e where - e = "sub commodity, letters and symbols only" - f = B.SubCommodity . unsafeTextNonEmpty - ls = many1 (satisfy lvl3OtherChars) - -lvl3Cmdty :: Parser B.Commodity -lvl3Cmdty = f <$> p1 <*> pr e where - f cf cs = B.Commodity (cf :| cs) - p1 = lvl3FirstSubCmdty - pr = option [] $ char ':' *> sepBy lvl3OtherSubCmdty (char ':') - e = "commodity, letters and symbols only" - --- | A commodity being read in from the command line, where the --- commodity is guaranteed to be the only thing to parse. -commandLineCmdty :: Parser B.Commodity -commandLineCmdty = lvl1Cmdty - --- | A commodity on the left side of a quantity in a ledger file. -leftSideCmdty :: Parser B.Commodity -leftSideCmdty = - quotedLvl1Cmdty - <|> lvl3Cmdty - "commodity to the left of the quantity" - --- | A commodity on the right side of a quantity in a ledger file. -rightSideCmdty :: Parser B.Commodity -rightSideCmdty = - quotedLvl1Cmdty - <|> lvl2Cmdty - "commodity to the right of the quantity" - --- | Render a quoted Level 1 commodity. Fails if any character does --- not satisfy lvl1Char. -renderQuotedLvl1 :: B.Commodity -> Maybe Text -renderQuotedLvl1 ca@(B.Commodity c) = do - guard $ listIsOK lvl1Char ca - return $ '"' - `cons` HT.text (HT.Delimited (singleton ':') (HT.textList c)) - `snoc` '"' - --- | 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. -renderLvl2 :: B.Commodity -> Maybe Text -renderLvl2 (B.Commodity c) = do - guard $ firstCharOfListIsOK lvl2FirstChar c - guard $ listIsOK lvl2OtherChars c - return $ HT.text (HT.Delimited (singleton ':') (HT.textList c)) - --- | Render a Level 3 commodity. Fails if any character is not a --- letter or a symbol. -renderLvl3 :: B.Commodity -> Maybe Text -renderLvl3 (B.Commodity c) = do - guard $ listIsOK lvl3OtherChars c - guard $ firstCharOfListIsOK lvl3FirstChar c - return $ HT.text (HT.Delimited (singleton ':') (HT.textList c)) diff --git a/Penny/Copper/DateTime.hs b/Penny/Copper/DateTime.hs deleted file mode 100644 --- a/Penny/Copper/DateTime.hs +++ /dev/null @@ -1,138 +0,0 @@ -module Penny.Copper.DateTime ( - DefaultTimeZone(DefaultTimeZone, unDefaultTimeZone) - , dateTime - , utcDefault - , render - ) where - -import Control.Applicative ((<$>), optional, (<*>)) -import qualified Data.Text as X -import Data.Time (fromGregorianValid) -import Data.Maybe (fromMaybe) -import qualified Data.Time as T -import Text.Parsec (char, digit, (<|>), ()) -import Text.Parsec.Text ( Parser ) -import Control.Monad ( void, when ) -import Data.Fixed ( Pico ) -import System.Locale (defaultTimeLocale) - -import Penny.Copper.Util (spaces) -import qualified Penny.Lincoln.Bits as B - -newtype DefaultTimeZone = - DefaultTimeZone { unDefaultTimeZone :: B.TimeZoneOffset } - deriving (Eq, Show) - -utcDefault :: DefaultTimeZone -utcDefault = DefaultTimeZone B.noOffset - -charToDigit :: Char -> Int -charToDigit c = case c of - '0' -> 0 - '1' -> 1 - '2' -> 2 - '3' -> 3 - '4' -> 4 - '5' -> 5 - '6' -> 6 - '7' -> 7 - '8' -> 8 - '9' -> 9 - _ -> error "unrecognized digit" - -read2digits :: Parser Int -read2digits = f <$> digit <*> digit where - f d1 d2 = charToDigit d1 * 10 + charToDigit d2 - -read4digits :: Parser Integer -read4digits = f <$> digit <*> digit <*> digit <*> digit where - f d1 d2 d3 d4 = fromIntegral $ - charToDigit d1 * 1000 - + charToDigit d2 * 100 - + charToDigit d3 * 10 - + charToDigit d4 - -date :: Parser T.Day -date = do - let slash = void $ char '/' <|> char '-' - y <- read4digits - slash - m <- read2digits - slash - d <- read2digits - case fromGregorianValid y m d of - Nothing -> fail "invalid date" - Just dt -> return dt - -colon :: Parser () -colon = void $ char ':' - -hrs :: Parser Int -hrs = do - h <- read2digits - when (h > 23) $ fail "invalid hour" - return h - -mins :: Parser Int -mins = do - m <- read2digits - when (m > 59) $ fail "invalid minute" - return m - -secs :: Parser Pico -secs = do - s <- fromIntegral <$> read2digits - when (s > 59) $ fail "invalid seconds" - return s - -timeOfDay :: Parser T.TimeOfDay -timeOfDay = do - h <- hrs - colon - m <- mins - maybeS <- optional (colon >> secs) - let s = fromMaybe (fromIntegral (0 :: Int)) maybeS - return $ T.TimeOfDay h m s - -timeZoneOffset :: Parser B.TimeZoneOffset -timeZoneOffset = do - changeSign <- - (char '+' >> return id) - <|> (char '-' >> return (negate :: Int -> Int)) - "time zone sign" - h <- read2digits - m <- read2digits - let mi = h * 60 + m - maybe (fail "invalid time zone offset") return - $ B.minsToOffset (changeSign mi) - -dateTime :: DefaultTimeZone -> Parser B.DateTime -dateTime (DefaultTimeZone dtz) = do - d <- date - spaces - mayTod <- optional timeOfDay - spaces - mayTz <- optional timeZoneOffset - let tod = fromMaybe T.midnight mayTod - tz = fromMaybe dtz mayTz - return (B.dateTime (T.LocalTime d tod) tz) - --- | Render a DateTime. If the DateTime is in the given --- DefaultTimeZone, and the DateTime is midnight, then the time and --- time zone will not be printed. Otherwise, the time and time zone --- will both be printed. The test for time zone equality depends only --- upon the time zone's offset from UTC. -render :: DefaultTimeZone -> B.DateTime -> X.Text -render (DefaultTimeZone dtz) dt = let - lt = B.localTime dt - off = B.timeZone dt - fmtLong = "%F %T %z" - fmtShort = "%F" - sameZone = dtz == off - local = T.localTimeOfDay lt - isMidnight = local == T.midnight - fmt = if sameZone && isMidnight - then fmtShort - else fmtLong - zt = T.ZonedTime lt (T.minutesToTimeZone (B.offsetToMins off)) - in X.pack $ T.formatTime defaultTimeLocale fmt zt diff --git a/Penny/Copper/Entry.hs b/Penny/Copper/Entry.hs deleted file mode 100644 --- a/Penny/Copper/Entry.hs +++ /dev/null @@ -1,43 +0,0 @@ -module Penny.Copper.Entry (entry, render) where - -import Control.Applicative ((<$>), (<*>)) -import Control.Monad ( void ) -import qualified Data.Text as X -import Text.Parsec ( char, string, optional, (<|>), () ) -import Text.Parsec.Text ( Parser ) - -import Penny.Copper.Amount (amount) -import qualified Penny.Copper.Amount as A -import qualified Penny.Copper.Qty as Q -import Penny.Copper.Util (lexeme) -import qualified Penny.Lincoln as L - -drCr :: Parser L.DrCr -drCr = let - dr = do - void (char 'D' <|> char 'd') - void (char 'r') <|> void (string "ebit") - return L.Debit - cr = do - void (char 'C' <|> char 'c') - void (optional (char 'r' >> optional (string "edit"))) - return L.Credit - in dr <|> cr - -entry :: Q.RadGroup -> Parser (L.Entry, L.Format) -entry rg = f <$> lexeme drCr <*> amount rg e where - f dc (am, fmt) = (L.Entry dc am, fmt) - e = "entry" - -render :: - (Q.GroupingSpec, Q.GroupingSpec) - -> Q.RadGroup - -> L.Format - -> L.Entry - -> Maybe X.Text -render gs rg f (L.Entry dc a) = do - amt <- A.render gs rg f a - let dcTxt = X.pack $ case dc of - L.Debit -> "Dr" - L.Credit -> "Cr" - return $ X.append (X.snoc dcTxt ' ') amt diff --git a/Penny/Copper/Flag.hs b/Penny/Copper/Flag.hs deleted file mode 100644 --- a/Penny/Copper/Flag.hs +++ /dev/null @@ -1,30 +0,0 @@ -module Penny.Copper.Flag (flag, isFlagChar, render) where - -import Control.Applicative ((<$>), (<*>)) -import Data.Text ( pack, cons, snoc ) -import qualified Data.Text as X -import Text.Parsec ( char, satisfy, many, between, ()) -import Text.Parsec.Text ( Parser ) - -import qualified Penny.Copper.Util as U -import qualified Penny.Lincoln.Bits as B -import Penny.Lincoln.TextNonEmpty ( TextNonEmpty ( TextNonEmpty ) ) -import qualified Penny.Lincoln.TextNonEmpty as TNE - -isFlagChar :: Char -> Bool -isFlagChar c = allowed && not banned where - allowed = U.rangeLettersToSymbols c || - c == ' ' - banned = c == ']' - -flag :: Parser B.Flag -flag = between (char '[') (char ']') p "flag" where - p = (\c cs -> B.Flag (TextNonEmpty c (pack cs))) - <$> satisfy isFlagChar - <*> many (satisfy isFlagChar) - -render :: B.Flag -> Maybe X.Text -render (B.Flag fl) = - if TNE.all isFlagChar fl - then Just $ '[' `cons` (TNE.toText fl) `snoc` ']' - else Nothing diff --git a/Penny/Copper/Item.hs b/Penny/Copper/Item.hs deleted file mode 100644 --- a/Penny/Copper/Item.hs +++ /dev/null @@ -1,68 +0,0 @@ -module Penny.Copper.Item ( - itemWithLineNumber, - Item(Transaction, Price, CommentItem, BlankLine), - Line(unLine), - render - ) where - -import Control.Applicative ((<$>), (<*>), (<$)) -import qualified Data.Text as X -import Text.Parsec (getPosition, sourceLine, (<|>), - ()) -import Text.Parsec.Text ( Parser ) - -import qualified Penny.Copper.Comments as C -import qualified Penny.Copper.DateTime as DT -import qualified Penny.Lincoln as L -import qualified Penny.Copper.Qty as Q -import Penny.Copper.Price ( price ) -import qualified Penny.Copper.Price as P -import qualified Penny.Copper.Transaction as T -import Penny.Copper.Transaction ( transaction ) -import Penny.Copper.Util (eol) - - --- | An Item is used both to hold the result of parsing an item from a --- file and for rendering. It is parameterized on two types: the --- metadata type for the TopLine, and the metadata type for the --- Posting. -data Item = Transaction L.Transaction - | Price L.PricePoint - | CommentItem C.Comment - | BlankLine - deriving Show - -newtype Line = Line { unLine :: Int } - deriving (Eq, Show) - -itemWithLineNumber :: - DT.DefaultTimeZone - -> Q.RadGroup - -> Parser (Line, Item) -itemWithLineNumber dtz rg = (,) - <$> ((Line . sourceLine) <$> getPosition) - <*> parseItem dtz rg - -parseItem :: - DT.DefaultTimeZone - -> Q.RadGroup - -> Parser Item -parseItem dtz rg = let - bl = BlankLine <$ eol "blank line" - t = Transaction <$> transaction dtz rg - p = Price <$> price dtz rg - c = CommentItem <$> C.comment - in (bl <|> t <|> p <|> c) - -render :: - DT.DefaultTimeZone - -> (Q.GroupingSpec, Q.GroupingSpec) - -> Q.RadGroup - -> Item - -> Maybe X.Text -render dtz gs rg i = case i of - Transaction t -> T.render dtz gs rg t - Price pp -> P.render dtz gs rg pp - CommentItem c -> C.render c - BlankLine -> Just $ X.singleton '\n' - diff --git a/Penny/Copper/Memos/Posting.hs b/Penny/Copper/Memos/Posting.hs deleted file mode 100644 --- a/Penny/Copper/Memos/Posting.hs +++ /dev/null @@ -1,39 +0,0 @@ -module Penny.Copper.Memos.Posting ( - memo, render, isCommentChar) where - -import Control.Applicative ((<*>), (<*), (<$), (<$>)) -import qualified Data.Text as X -import Text.Parsec (char, satisfy, many, ()) -import Text.Parsec.Text ( Parser ) - -import Penny.Copper.Util (eol, rangeLettersToSymbols) -import qualified Penny.Lincoln.Bits as B -import qualified Penny.Lincoln.TextNonEmpty as TNE - -isCommentChar :: Char -> Bool -isCommentChar c = rangeLettersToSymbols c - || c == ' ' - -memo :: Parser B.Memo -memo = B.Memo <$> many memoLine - -memoLine :: Parser B.MemoLine -memoLine = (\c cs -> B.MemoLine $ TNE.TextNonEmpty c (X.pack cs)) - <$ char '\'' - <*> satisfy isCommentChar - <*> many (satisfy isCommentChar) - <* eol - "posting memo" - -render :: B.Memo -> Maybe X.Text -render (B.Memo ls) = X.concat <$> mapM renderLine ls - -renderLine :: B.MemoLine -> Maybe X.Text -renderLine (B.MemoLine l) = - if TNE.all isCommentChar l - then Just $ - X.pack (replicate 8 ' ') - `X.snoc` '\'' - `X.append` TNE.toText l - `X.snoc` '\n' - else Nothing diff --git a/Penny/Copper/Memos/Transaction.hs b/Penny/Copper/Memos/Transaction.hs deleted file mode 100644 --- a/Penny/Copper/Memos/Transaction.hs +++ /dev/null @@ -1,45 +0,0 @@ -module Penny.Copper.Memos.Transaction ( - memo, render, isCommentChar - ) where - -import Control.Applicative ((<*>), (<$>), (<*), (<$)) -import qualified Data.Text as X -import Text.Parsec ( - char, satisfy, sourceLine, getPosition, (), - many) -import Text.Parsec.Text ( Parser ) - -import Penny.Copper.Util (rangeLettersToSymbols, eol) -import qualified Penny.Lincoln as L -import qualified Penny.Lincoln.TextNonEmpty as TNE - -isCommentChar :: Char -> Bool -isCommentChar c = rangeLettersToSymbols c - || c == ' ' - -memoLine :: Parser L.MemoLine -memoLine = L.MemoLine <$> ( - TNE.TextNonEmpty - <$ char ';' - <*> satisfy isCommentChar - <*> (X.pack <$> many (satisfy isCommentChar)) - <* eol ) - "posting memo line" - --- | Parses a transaction memo and associated whitespace afterward. -memo :: Parser (L.Memo, L.TopMemoLine) -memo = - flip (,) - <$> ((L.TopMemoLine . sourceLine) <$> getPosition) - <*> (L.Memo <$> many memoLine) - "transaction memo" - --- | Renders a transaction memo. Fails if the memo is not renderable. -render :: L.Memo -> Maybe X.Text -render (L.Memo m) = X.concat <$> mapM renderLine m - -renderLine :: L.MemoLine -> Maybe X.Text -renderLine (L.MemoLine l) = - if TNE.all isCommentChar l - then Just $ X.singleton ';' `X.append` TNE.toText l `X.snoc` '\n' - else Nothing diff --git a/Penny/Copper/Number.hs b/Penny/Copper/Number.hs deleted file mode 100644 --- a/Penny/Copper/Number.hs +++ /dev/null @@ -1,29 +0,0 @@ -module Penny.Copper.Number (isNumChar, number, render) where - -import Control.Applicative ((<$>), (<*>)) -import Data.Text ( pack, cons, snoc, Text ) -import Text.Parsec ( char, satisfy, many, between, ()) -import Text.Parsec.Text ( Parser ) - -import Penny.Copper.Util (rangeLettersToSymbols) -import qualified Penny.Lincoln.Bits as B -import Penny.Lincoln.TextNonEmpty ( TextNonEmpty ( TextNonEmpty ) ) -import qualified Penny.Lincoln.TextNonEmpty as TNE - -isNumChar :: Char -> Bool -isNumChar c = allowed && not banned where - allowed = rangeLettersToSymbols c || - c == ' ' - banned = c == ')' - -number :: Parser B.Number -number = between (char '(') (char ')') p "number" where - p = (\c cs -> B.Number (TextNonEmpty c (pack cs))) - <$> satisfy isNumChar - <*> many (satisfy isNumChar) - -render :: B.Number -> Maybe Text -render (B.Number tne) = - if TNE.all isNumChar tne - then Just $ '(' `cons` TNE.toText tne `snoc` ')' - else Nothing diff --git a/Penny/Copper/Parsec.hs b/Penny/Copper/Parsec.hs new file mode 100644 --- /dev/null +++ b/Penny/Copper/Parsec.hs @@ -0,0 +1,418 @@ +-- | 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/Payees.hs b/Penny/Copper/Payees.hs deleted file mode 100644 --- a/Penny/Copper/Payees.hs +++ /dev/null @@ -1,87 +0,0 @@ --- | Payee parsers. There are two types of payee parsers: --- --- Quoted payees. These allow the most latitude in the characters --- allowed. They are surrounded by @<@ and @>@. --- --- Unquoted payees. These are not surrounded by @<@ and @>@. Their --- first character must be a letter or number. - -module Penny.Copper.Payees ( - -- * Parse any payee - payee - - -- * Quoted payees - , quotedChar - , quotedPayee - - -- * Unquoted payees - , unquotedFirstChar - , unquotedRestChars - , unquotedPayee - - -- * Rendering - , smartRender - , quoteRender - ) where - -import Control.Applicative ((<$>), (<*>), (<|>)) -import Data.Text (pack, Text, snoc, cons) -import qualified Data.Text as X -import Text.Parsec (char, satisfy, many, between, ()) -import Text.Parsec.Text ( Parser ) - -import Penny.Copper.Util (rangeLettersToSymbols, rangeLetters) -import qualified Penny.Lincoln.Bits as B -import Penny.Lincoln.TextNonEmpty as TNE - -quotedChar :: Char -> Bool -quotedChar c = allowed && not banned where - allowed = rangeLettersToSymbols c || c == ' ' - banned = c == '>' - -payee :: Parser B.Payee -payee = quotedPayee <|> unquotedPayee - -quotedPayee :: Parser B.Payee -quotedPayee = between (char '<') (char '>') p "quoted payee" where - p = (\c cs -> B.Payee (TextNonEmpty c (pack cs))) - <$> satisfy quotedChar - <*> many (satisfy quotedChar) - -unquotedFirstChar :: Char -> Bool -unquotedFirstChar = rangeLetters - -unquotedRestChars :: Char -> Bool -unquotedRestChars = quotedChar - -unquotedPayee :: Parser B.Payee -unquotedPayee = let - p c cs = B.Payee (TextNonEmpty c (pack cs)) - in p - <$> satisfy unquotedFirstChar - <*> many (satisfy unquotedRestChars) - "unquoted payee" - --- | Render a payee with a minimum of quoting. Fails if cannot be --- rendered at all. -smartRender :: B.Payee -> Maybe Text -smartRender (B.Payee p) = let - TextNonEmpty f r = p - noQuoteNeeded = unquotedFirstChar f - && X.all unquotedRestChars r - renderable = TNE.all quotedChar p - quoted = '<' `cons` TNE.toText p `snoc` '>' - makeText - | noQuoteNeeded = Just $ TNE.toText p - | renderable = Just quoted - | otherwise = Nothing - in makeText - --- | Renders with quotes, whether the payee needs it or not. -quoteRender :: B.Payee -> Maybe Text -quoteRender (B.Payee p) = let - renderable = TNE.all quotedChar p - quoted = '<' `cons` TNE.toText p `snoc` '>' - in if renderable - then Just quoted - else Nothing diff --git a/Penny/Copper/Posting.hs b/Penny/Copper/Posting.hs deleted file mode 100644 --- a/Penny/Copper/Posting.hs +++ /dev/null @@ -1,126 +0,0 @@ -module Penny.Copper.Posting ( - posting, render - ) where - -import Control.Applicative ((<$>), (<*>), (<*), (<|>)) -import qualified Data.Text as X -import Text.Parsec ( - getParserState, - statePos, optionMaybe, sourceLine, (), - State) -import Text.Parsec.Text ( Parser ) - -import qualified Penny.Lincoln as L -import qualified Penny.Lincoln.Bits as B -import qualified Penny.Copper.Account as Ac -import qualified Penny.Copper.Entry as En -import qualified Penny.Copper.Flag as Fl -import qualified Penny.Copper.Memos.Posting as Me -import qualified Penny.Copper.Number as Nu -import qualified Penny.Copper.Payees as Pa -import qualified Penny.Copper.Qty as Qt -import qualified Penny.Copper.Tags as Ta -import Penny.Copper.Util (lexeme, eol, renMaybe, txtWords) -import qualified Penny.Lincoln.Transaction as T -import qualified Penny.Lincoln.Transaction.Unverified as U - -posting :: Qt.RadGroup - -> Parser U.Posting -posting rg = - makeUnverified - <$> (L.PostingLine . sourceLine . statePos - <$> getParserState) - <*> (UnverifiedWithMeta - <$> optionMaybe (lexeme Fl.flag) - <*> optionMaybe (lexeme Nu.number) - <*> optionMaybe (lexeme Pa.quotedPayee) - <*> lexeme (Ac.lvl1AccountQuoted <|> Ac.lvl2Account) - <*> lexeme Ta.tags - <*> optionMaybe (lexeme (En.entry rg)) - <* eol - <*> Me.memo) - "posting" - -data UnverifiedWithMeta = UnverifiedWithMeta { - flag :: Maybe B.Flag - , number :: Maybe B.Number - , payee :: Maybe B.Payee - , account :: B.Account - , tags :: B.Tags - , entry :: Maybe (B.Entry, L.Format) - , memo :: B.Memo - } deriving (Eq, Show) - -makeUnverified :: - L.PostingLine - -> UnverifiedWithMeta - -> U.Posting -makeUnverified pl u = upo where - upo = U.Posting (payee u) (number u) (flag u) (account u) - (tags u) en (memo u) meta - (en, fmt) = case entry u of - Nothing -> (Nothing, Nothing) - Just (e, f) -> (Just e, Just f) - meta = L.PostingMeta (Just pl) fmt Nothing Nothing - - --- | 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). -render :: - (Qt.GroupingSpec, Qt.GroupingSpec) - -> Qt.RadGroup - -> T.Posting - -> Maybe X.Text -render gs rg p = do - fl <- renMaybe (T.pFlag p) Fl.render - nu <- renMaybe (T.pNumber p) Nu.render - pa <- renMaybe (T.pPayee p) Pa.quoteRender - ac <- Ac.render (T.pAccount p) - ta <- Ta.render (T.pTags p) - me <- Me.render (T.pMemo p) - maybePair <- case (T.pInferred p, L.postingFormat . T.pMeta $ p) of - (T.Inferred, Nothing) -> return Nothing - (T.NotInferred, Just f) -> return (Just (T.pEntry p, f)) - _ -> Nothing - let renderEn (e, f) = En.render gs rg f e - en <- renMaybe maybePair renderEn - return $ formatter fl nu pa ac ta en me - -formatter :: - X.Text -- ^ Flag - -> X.Text -- ^ Number - -> X.Text -- ^ Payee - -> X.Text -- ^ Account - -> X.Text -- ^ Tags - -> X.Text -- ^ Entry - -> X.Text -- ^ Memo - -> X.Text -formatter fl nu pa ac ta en me = let - colA = X.pack (replicate 4 ' ') - 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 = X.singleton '\n' - in X.concat [colA, colB, colC, colD, rtn, me] diff --git a/Penny/Copper/Price.hs b/Penny/Copper/Price.hs deleted file mode 100644 --- a/Penny/Copper/Price.hs +++ /dev/null @@ -1,97 +0,0 @@ -module Penny.Copper.Price (price, render) where - -import Text.Parsec ( char, getPosition, sourceLine, (), - SourcePos ) -import Text.Parsec.Text ( Parser ) - -import Control.Applicative ((<*>), (<*), (<|>), (<$)) -import Data.Text (singleton, snoc, intercalate) -import qualified Data.Text as X - -import qualified Penny.Lincoln as L -import qualified Penny.Lincoln.Bits.PricePoint as PP -import qualified Penny.Copper.Amount as A -import qualified Penny.Copper.Commodity as C -import qualified Penny.Copper.DateTime as DT -import qualified Penny.Copper.Qty as Q -import Penny.Copper.Util (lexeme, eol) - -{- -BNF-style specification for prices: - - ::= "dateTime" - ::= "quotedLvl1Cmdty" | "lvl2Cmdty" - ::= "amount" --} - -mkPrice :: SourcePos - -> L.DateTime - -> L.Commodity - -> (L.Amount, L.Format) - -> Maybe L.PricePoint -mkPrice pos dt from (am, fmt) = let - to = L.commodity am - q = L.qty am - pm = L.PriceMeta (Just pl) (Just fmt) - pl = L.PriceLine . sourceLine $ pos - in do - p <- L.newPrice (L.From from) (L.To to) (L.CountPerUnit q) - return $ L.PricePoint dt p pm - -maybePrice :: - DT.DefaultTimeZone - -> Q.RadGroup - -> Parser (Maybe L.PricePoint) -maybePrice dtz rg = - mkPrice - <$ lexeme (char '@') - <*> getPosition - <*> lexeme (DT.dateTime dtz) - <*> lexeme (C.quotedLvl1Cmdty <|> C.lvl2Cmdty) - <*> A.amount rg - <* eol - "price" - --- | A price with an EOL and whitespace after the EOL. @price d r@ --- will parse a PriceBox, where @d@ is the DefaultTimeZone for the --- DateTime in the PricePoint, and @r@ is the radix point and grouping --- character to parse the Amount. Fails if the price is not valid --- (e.g. the from and to commodities are the same). -price :: - DT.DefaultTimeZone - -> Q.RadGroup - -> Parser L.PricePoint -price dtz rg = do - b <- maybePrice dtz rg - case b of - Nothing -> fail "invalid price given" - Just p -> return p - --- | @render dtz rg f pp@ renders a price point @pp@. @dtz@ is the --- DefaultTimeZone for rendering of the DateTime in the Price --- Point. @rg@ is the radix point and grouping character for the --- amount. @f@ is the Format for how the price will be --- formatted. Fails if either the From or the To commodity cannot be --- rendered. -render :: - DT.DefaultTimeZone - -> (Q.GroupingSpec, Q.GroupingSpec) - -> Q.RadGroup - -> L.PricePoint - -> Maybe X.Text -render dtz gs rg pp = let - dateTxt = DT.render dtz (PP.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 = C.renderLvl3 from <|> C.renderQuotedLvl1 from - amt = L.Amount q to - in do - fmt <- L.priceFormat . L.ppMeta $ pp - let mayAmtTxt = A.render gs rg fmt amt - amtTxt <- mayAmtTxt - fromTxt <- mayFromTxt - return $ - (intercalate (singleton ' ') - [singleton '@', dateTxt, fromTxt, amtTxt]) - `snoc` '\n' diff --git a/Penny/Copper/Qty.hs b/Penny/Copper/Qty.hs deleted file mode 100644 --- a/Penny/Copper/Qty.hs +++ /dev/null @@ -1,283 +0,0 @@ -module Penny.Copper.Qty ( - -- * Setting the radix and separator characters - RadGroup, periodComma, periodSpace, commaPeriod, - commaSpace, - - -- * Rendering - GroupingSpec(NoGrouping, GroupLarge, GroupAll), - renderUnquoted, - quote, - - -- * Parsing quantities - qtyUnquoted, - qtyQuoted, - qty) where - -import Control.Applicative ((<$>), (<*>), (<$), (*>), optional) -import qualified Data.Decimal as D -import Data.List (intercalate) -import Data.List.Split (splitEvery, splitOn) -import qualified Data.Text as X -import Data.Text (snoc, cons) -import Text.Parsec ( char, (<|>), many1, (), - sepBy1, digit, between) -import qualified Text.Parsec as P -import Text.Parsec.Text ( Parser ) - -import Penny.Lincoln.Bits.Qty ( Qty, partialNewQty, unQty ) - -data Radix = RComma | RPeriod deriving (Eq, Show) -data Grouper = GComma | GPeriod | GSpace deriving (Eq, Show) - -data RadGroup = RadGroup Radix Grouper deriving (Eq, Show) - --- | Radix is period, grouping is comma -periodComma :: RadGroup -periodComma = RadGroup RPeriod GComma - --- | Radix is period, grouping is space -periodSpace :: RadGroup -periodSpace = RadGroup RPeriod GSpace - --- | Radix is comma, grouping is period -commaPeriod :: RadGroup -commaPeriod = RadGroup RComma GPeriod - --- | Radix is comma, grouping is space -commaSpace :: RadGroup -commaSpace = RadGroup RComma GSpace - -parseRadix :: Radix -> Parser () -parseRadix r = () <$ char c "radix point" where - c = case r of RComma -> ','; RPeriod -> '.' - -parseGrouper :: Grouper -> Parser () -parseGrouper g = () <$ char c "grouping character" where - c = case g of - GComma -> ',' - GPeriod -> '.' - GSpace -> ' ' - -{- a BNF style specification for numbers. - - ::= (as specified) - ::= (as specified) - ::= "1" | "2" | "3" | "4" | "5" | "6" | "7" | "8" | "9" | "0" - ::= | - ::= - ::= - ::= | - ::= | - ::= | - ::= - ::= - | - | - | --} - -wholeGrouped :: Grouper -> Parser String -wholeGrouped g = p <$> group1 <*> optional groupRest e where - e = "whole number" - group1 = many1 digit - groupRest = parseGrouper g *> sepBy1 (many1 digit) (parseGrouper g) - p g1 gr = case gr of - Nothing -> g1 - Just groups -> g1 ++ concat groups - -fractionalGrouped :: Grouper -> Parser String -fractionalGrouped g = - p <$> group1 <*> optional groupRest e where - e = "fractional number" - group1 = many1 digit - groupRest = parseGrouper g *> sepBy1 (many1 digit) (parseGrouper g) - p g1 gr = case gr of - Nothing -> g1 - Just groups -> g1 ++ concat groups - -wholeNonGrouped :: Parser String -wholeNonGrouped = many1 digit - -fractionalOnly :: Radix -> Parser String -fractionalOnly r = parseRadix r *> many1 P.digit - -numberStrGrouped :: Radix -> Grouper -> Parser NumberStr -numberStrGrouped r g = startsWhole <|> fracOnly e where - e = "quantity, with optional grouping" - startsWhole = p "whole number" where - p = do - wholeStr <- wholeGrouped g - mayRad <- optional (parseRadix r) - case mayRad of - Nothing -> return $ Whole wholeStr - Just _ -> do - mayFrac <- optional $ fractionalGrouped g - case mayFrac of - Nothing -> return $ WholeRad wholeStr - Just frac -> return $ WholeRadFrac wholeStr frac - fracOnly = RadFrac <$> fractionalOnly r - -numberStrNonGrouped :: Radix -> Parser NumberStr -numberStrNonGrouped r = startsWhole <|> fracOnly e where - e = "quantity, no grouping" - startsWhole = p "whole number" where - p = do - wholeStr <- wholeNonGrouped - mayRad <- optional (parseRadix r) - case mayRad of - Nothing -> return $ Whole wholeStr - Just _ -> do - mayFrac <- optional $ many1 P.digit - case mayFrac of - Nothing -> return $ WholeRad wholeStr - Just frac -> return $ WholeRadFrac wholeStr frac - fracOnly = RadFrac <$> fractionalOnly r - - --- | A number string after radix and grouping characters have been --- stripped out. -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 - --- | Do not use Prelude.read or Prelude.reads on whole decimal strings --- like @232.72@. Sometimes it will fail, though sometimes it will --- succeed; why is not clear to me. Hopefully reading integers won't --- fail! However, in case it does, use read', whose error message will --- at least tell you what number was being read. --- --- Data.Decimal cannot handle decimals whose exponent would exceed --- 255, which is the maximum that a Word8 can hold. A Word8 is used to --- hold the exponent. If the exponent would exceed 255, this function --- fails. -toDecimal :: NumberStr -> Maybe D.Decimal -toDecimal ns = case ns of - Whole s -> Just $ D.Decimal 0 (readWithErr s) - WholeRad s -> Just $ D.Decimal 0 (readWithErr s) - WholeRadFrac w f -> fromWholeRadFrac w f - RadFrac f -> fromWholeRadFrac "0" f - where - fromWholeRadFrac w f = let - len = length f - in if len > 255 - then Nothing - else Just $ D.Decimal (fromIntegral len) (readWithErr (w ++ f)) - -readWithErr :: String -> Integer -readWithErr s = let - readSresult = reads s - in case readSresult of - (i, ""):[] -> i - _ -> error $ "readWithErr failed. String being read: " ++ s - ++ " Result of reads: " ++ show readSresult - --- | Unquoted quantity. These include no spaces, regardless of what --- the grouping character is. -qtyUnquoted :: RadGroup -> Parser Qty -qtyUnquoted (RadGroup r g) = do - nStr <- case g of - GSpace -> numberStrNonGrouped r - _ -> numberStrGrouped r g - d <- case toDecimal nStr of - Nothing -> fail $ "fractional part too big: " ++ show nStr - Just dec -> return dec - return $ partialNewQty d - --- | Parse quoted quantity. It can include spaces, if the grouping --- character is a space. However these must be quoted when in a Ledger --- file (from the command line they need not be quoted). The quote --- character is a caret, @^@. -qtyQuoted :: RadGroup -> Parser Qty -qtyQuoted (RadGroup r g) = between (char '^') (char '^') p where - p = do - nStr <- numberStrGrouped r g - d <- case toDecimal nStr of - Nothing -> fail $ "fractional part too big: " ++ show nStr - Just dec -> return dec - return $ partialNewQty d - --- | Parse a quoted quantity or, if that fails, an unquoted --- quantity. -qty :: RadGroup -> Parser Qty -qty r = qtyQuoted r <|> qtyUnquoted r "quantity" - --- | Specifies how to perform digit grouping when rendering a --- quantity. All grouping groups into groups of 3 digits. -data GroupingSpec = - 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) - --- | Quotes a rendered Qty, but only if necessary; otherwise, simply --- leaves it unquoted. -quote :: X.Text -> X.Text -quote t = case X.find (== ' ') t of - Nothing -> t - Just _ -> '^' `cons` t `snoc` '^' - --- | Renders an unquoted Qty. Performs digit grouping as requested. -renderUnquoted :: - RadGroup - -> (GroupingSpec, GroupingSpec) - -- ^ Group for the portion to the left and right of the radix point? - - -> Qty - -> X.Text -renderUnquoted (RadGroup r g) (gl, gr) q = let - qs = show . unQty $ q - in X.pack $ case splitOn "." qs of - w:[] -> groupWhole g gl w - w:d:[] -> - groupWhole g gl w ++ renderRadix r ++ groupDecimal g gr d - _ -> error "Qty.hs: rendering error" - -renderGrouper :: Grouper -> String -renderGrouper g = case g of - GComma -> "," - GPeriod -> "." - GSpace -> " " - -renderRadix :: Radix -> String -renderRadix r = case r of - RComma -> "," - RPeriod -> "." - --- | Performs grouping for amounts to the left of the radix point. -groupWhole :: Grouper -> GroupingSpec -> String -> String -groupWhole g gs o = let - grouped = intercalate (renderGrouper g) - . reverse - . map reverse - . splitEvery 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 :: Grouper -> GroupingSpec -> String -> String -groupDecimal g gs o = let - grouped = intercalate (renderGrouper g) - . splitEvery 3 - $ o - in case gs of - NoGrouping -> o - GroupLarge -> if length o > 4 then grouped else o - GroupAll -> grouped diff --git a/Penny/Copper/Render.hs b/Penny/Copper/Render.hs new file mode 100644 --- /dev/null +++ b/Penny/Copper/Render.hs @@ -0,0 +1,523 @@ +-- | 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/Tags.hs b/Penny/Copper/Tags.hs deleted file mode 100644 --- a/Penny/Copper/Tags.hs +++ /dev/null @@ -1,37 +0,0 @@ -module Penny.Copper.Tags ( - isTagChar, tags, render - )where - -import Control.Applicative ((<$>), (*>), (<*>)) -import qualified Data.Text as X -import Text.Parsec (char, satisfy, many, ()) -import Text.Parsec.Text ( Parser ) - -import Penny.Copper.Util (lexeme, rangeLettersNumbers) -import qualified Penny.Lincoln.Bits as B -import qualified Penny.Lincoln.TextNonEmpty as TNE - -isTagChar :: Char -> Bool -isTagChar = rangeLettersNumbers - -tagChar :: Parser Char -tagChar = satisfy isTagChar - -tag :: Parser B.Tag -tag = (char '*' *> (f <$> tagChar <*> many tagChar)) e where - f t ts = B.Tag $ TNE.TextNonEmpty t (X.pack ts) - e = "tag" - -tags :: Parser B.Tags -tags = B.Tags <$> many (lexeme tag) - -renderTag :: B.Tag -> Maybe X.Text -renderTag (B.Tag t) = - if TNE.all isTagChar t - then Just $ X.cons '*' (TNE.toText t) - else Nothing - -render :: B.Tags -> Maybe X.Text -render (B.Tags ts) = - X.intercalate (X.singleton ' ') - <$> mapM renderTag ts diff --git a/Penny/Copper/Terminals.hs b/Penny/Copper/Terminals.hs new file mode 100644 --- /dev/null +++ b/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/Penny/Copper/TopLine.hs b/Penny/Copper/TopLine.hs deleted file mode 100644 --- a/Penny/Copper/TopLine.hs +++ /dev/null @@ -1,59 +0,0 @@ -module Penny.Copper.TopLine ( - topLine - , render - ) where - -import Control.Applicative ((<$>), (<*>), (<*), (<|>), pure) -import qualified Data.Text as X -import Text.Parsec ( optionMaybe, getPosition, - sourceLine, optionMaybe ) -import Text.Parsec.Text ( Parser ) - -import qualified Penny.Copper.DateTime as DT -import qualified Penny.Copper.Memos.Transaction as M -import qualified Penny.Copper.Flag as F -import qualified Penny.Copper.Number as N -import qualified Penny.Copper.Payees as P -import qualified Penny.Lincoln as L -import qualified Penny.Lincoln.Transaction as T -import Penny.Copper.Util (lexeme, eol, renMaybe, txtWords) -import qualified Penny.Lincoln.Transaction.Unverified as U - -topLine :: - DT.DefaultTimeZone - -- -> Parser (U.TopLine (Meta.TopMemoLine, Meta.TopLineLine)) - -> Parser U.TopLine -topLine dtz = - f - <$> M.memo - <*> getPosition - <*> lexeme (DT.dateTime dtz) - <*> optionMaybe (lexeme F.flag) - <*> optionMaybe (lexeme N.number) - <*> optionMaybe (P.quotedPayee <|> P.unquotedPayee) - <* eol - where - f (me, tml) pos dt fl nu pa = tl where - tl = U.TopLine dt fl nu pa me meta - meta = L.emptyTopLineMeta { L.topMemoLine = Just tml - , L.topLineLine = Just tll } - tll = L.TopLineLine . sourceLine $ pos - - - -render :: - DT.DefaultTimeZone - -> T.TopLine - -> Maybe X.Text -render dtz tl = - f - <$> M.render (T.tMemo tl) - <*> pure (DT.render dtz (T.tDateTime tl)) - <*> renMaybe (T.tFlag tl) F.render - <*> renMaybe (T.tNumber tl) N.render - <*> renMaybe (T.tPayee tl) P.smartRender - where - f meX dtX flX nuX paX = - meX - `X.append` (txtWords [dtX, flX, nuX, paX]) - `X.snoc` '\n' diff --git a/Penny/Copper/Transaction.hs b/Penny/Copper/Transaction.hs deleted file mode 100644 --- a/Penny/Copper/Transaction.hs +++ /dev/null @@ -1,75 +0,0 @@ -module Penny.Copper.Transaction (transaction, render) where - -import Control.Applicative ((<$>), (<*>)) -import qualified Control.Monad.Exception.Synchronous as Ex -import Data.Foldable (toList) -import qualified Data.Traversable as Tr -import qualified Data.Text as X -import Text.Parsec (many) -import Text.Parsec.Text ( Parser ) - -import qualified Penny.Copper.DateTime as DT -import qualified Penny.Copper.TopLine as TL -import Penny.Copper.TopLine ( topLine ) -import qualified Penny.Copper.Posting as Po -import qualified Penny.Copper.Qty as Qt -import qualified Penny.Lincoln as L -import Penny.Lincoln.Family (orphans) -import qualified Penny.Lincoln.Family.Family as F -import Penny.Lincoln.Family.Family ( Family ( Family ) ) -import qualified Penny.Lincoln.Transaction as T -import qualified Penny.Lincoln.Transaction.Unverified as U - -errorStr :: T.Error -> String -errorStr e = case e of - T.UnbalancedError -> "postings are not balanced" - T.CouldNotInferError -> "could not infer entry for posting" - -mkTransaction :: - U.TopLine - -> U.Posting - -> U.Posting - -> [U.Posting] - -> Ex.Exceptional String L.Transaction -mkTransaction top p1 p2 ps = let - famTrans = Family top p1 p2 ps - errXact = T.transaction famTrans - in case errXact of - Ex.Exception err -> Ex.Exception . errorStr $ err - Ex.Success x -> return x - -maybeTransaction :: - DT.DefaultTimeZone - -> Qt.RadGroup - -> Parser (Ex.Exceptional String L.Transaction) -maybeTransaction dtz rg = - mkTransaction - <$> topLine dtz - <*> Po.posting rg - <*> Po.posting rg - <*> many (Po.posting rg) - -transaction :: - DT.DefaultTimeZone - -> Qt.RadGroup - -> Parser L.Transaction -transaction dtz rg = do - ex <- maybeTransaction dtz rg - case ex of - Ex.Exception s -> fail s - Ex.Success b -> return b - -render :: - DT.DefaultTimeZone - -> (Qt.GroupingSpec, Qt.GroupingSpec) - -> Qt.RadGroup - -> T.Transaction - -> Maybe X.Text -render dtz gs rg txn = do - let txnFam = T.unTransaction txn - tlX <- TL.render dtz (F.parent txnFam) - pstgsX <- Tr.traverse (Po.render gs rg) (orphans txnFam) - return $ tlX `X.append` (X.concat (toList pstgsX)) - - - diff --git a/Penny/Copper/Types.hs b/Penny/Copper/Types.hs new file mode 100644 --- /dev/null +++ b/Penny/Copper/Types.hs @@ -0,0 +1,59 @@ +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/Copper/Util.hs b/Penny/Copper/Util.hs deleted file mode 100644 --- a/Penny/Copper/Util.hs +++ /dev/null @@ -1,150 +0,0 @@ -module Penny.Copper.Util where - -import Control.Applicative ((<*), pure, (<$)) -import qualified Data.Char as C -import qualified Data.Foldable as F -import qualified Data.List.NonEmpty as NE -import qualified Data.Text as X -import qualified Penny.Lincoln.HasText as HT -import qualified Penny.Lincoln.TextNonEmpty as TNE -import Text.Parsec (char, many, skipMany) -import Text.Parsec.Text (Parser) - -rangeLettersToSymbols :: Char -> Bool -rangeLettersToSymbols c = case C.generalCategory c of - C.UppercaseLetter -> True - C.LowercaseLetter -> True - C.TitlecaseLetter -> True - C.ModifierLetter -> True - C.OtherLetter -> True - C.DecimalNumber -> True - C.LetterNumber -> True - C.OtherNumber -> True - C.ConnectorPunctuation -> True - C.DashPunctuation -> True - C.OpenPunctuation -> True - C.ClosePunctuation -> True - C.InitialQuote -> True - C.FinalQuote -> True - C.OtherPunctuation -> True - C.MathSymbol -> True - C.CurrencySymbol -> True - C.ModifierSymbol -> True - C.OtherSymbol -> True - _ -> False - -rangeLetters :: Char -> Bool -rangeLetters c = case C.generalCategory c of - C.UppercaseLetter -> True - C.LowercaseLetter -> True - C.TitlecaseLetter -> True - C.ModifierLetter -> True - C.OtherLetter -> True - _ -> False - -rangeMathCurrency :: Char -> Bool -rangeMathCurrency c = case C.generalCategory c of - C.MathSymbol -> True - C.CurrencySymbol -> True - _ -> False - -rangeSymbols :: Char -> Bool -rangeSymbols c = case C.generalCategory c of - C.MathSymbol -> True - C.CurrencySymbol -> True - C.ModifierSymbol -> True - C.OtherSymbol -> True - _ -> False - -rangeLettersNumbers :: Char -> Bool -rangeLettersNumbers c = case C.generalCategory c of - C.UppercaseLetter -> True - C.LowercaseLetter -> True - C.TitlecaseLetter -> True - C.ModifierLetter -> True - C.OtherLetter -> True - C.DecimalNumber -> True - C.LetterNumber -> True - C.OtherNumber -> True - _ -> False - --- | Creates a new parser that behaves like the old one, but also --- parses any whitespace remaining afterward. -lexeme :: Parser a -> Parser a -lexeme p = p <* skipMany (char ' ') - --- | Parses any trailing whitespace followed by a newline followed by --- additional whitespace. -eol :: Parser () -eol = pure () - <* skipMany (char ' ') - <* char '\n' - <* skipMany (char ' ') - --- | Parses a run of spaces. -spaces :: Parser () -spaces = () <$ many (char ' ') - --- | Applied to a non-empty list of pairs, with the first element of --- the pair being a predicate that returns True if a character is OK --- and the second element being something of an arbitrary type, and to --- something that has a Text. The pairs must be ordered from most --- restrictive to least restrictive predicates. If at least one of the --- predicates indicates that the Text is valid, returns the leftmost b --- associated with that predicate. If none of the predicates indicates --- that the Text is valid, returns the rightmost error. --- --- Here, most restrictive means the predicate that indicates True for --- the narrowest range of characters, while least restrictive means --- the predicate that indicates True for the widest range of --- characters. -checkText :: - HT.HasText a - => NE.NonEmpty ((Char -> Bool), b) - -> a - -> Maybe b -checkText ps a = let - t = HT.text a - results = fmap (g . f) ps where - f (p, b) = (X.find (not . p) t, b) - g (p, b) = case p of - Nothing -> Right b - Just c -> Left c - folder x y = case x of - Right b -> Right b - Left _ -> y - in case F.foldr1 folder results of - Left _ -> Nothing - Right b -> return b - -listIsOK :: - HT.HasTextNonEmptyList a - => (Char -> Bool) -- ^ Returns True for characters that are allowed - -> a - -> Bool -listIsOK p = F.all (TNE.all p) . HT.textNonEmptyList - -firstCharOfListIsOK :: - HT.HasTextNonEmptyList a - => (Char -> Bool) -- ^ Returns True if the first character is allowed - -> a - -> Bool -firstCharOfListIsOK p ls = let - firstText = NE.head . HT.textNonEmptyList $ ls - in p (TNE.first firstText) - --- | 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 - --- | 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 diff --git a/Penny/Liberty.hs b/Penny/Liberty.hs --- a/Penny/Liberty.hs +++ b/Penny/Liberty.hs @@ -8,10 +8,9 @@ -- Cabin will also find useful are relocated here, to Liberty. module Penny.Liberty ( - Error(..), MatcherFactory, X.evaluate, - X.Token, + X.Token(..), FilteredNum(FilteredNum, unFilteredNum), SortedNum(SortedNum, unSortedNum), LibertyMeta(filteredNum, sortedNum), @@ -23,37 +22,33 @@ processPostFilters, parseTokenList, parsePredicate, - + parseInt, + -- * Parsers Operand, - parseOperand, - parsePostFilter, - parseMatcherSelect, - parseCaseSelect, - parseOperator, - Orderer, - parseSort + operandSpecs, + postFilterSpecs, + matcherSelectSpecs, + caseSelectSpecs, + operatorSpecs + ) where -import Control.Applicative ((<|>)) +import Control.Applicative ((<*>), (<$>)) import qualified Control.Monad.Exception.Synchronous as Ex -import Control.Monad.Exception.Synchronous ( - Exceptional(Exception)) import Data.Char (toUpper) -import Data.List (isPrefixOf, sortBy) -import Data.Text (Text, pack) +import Data.List (sortBy) +import Data.Text (Text, pack, unpack) import qualified Data.Text as Text import qualified System.Console.MultiArg.Combinator as C -import System.Console.MultiArg.Prim (Parser) +import System.Console.MultiArg.Combinator (OptSpec) import Text.Parsec (parse) - -import Penny.Copper.DateTime (DefaultTimeZone, dateTime) -import Penny.Copper.Qty (RadGroup, qty) +import qualified Penny.Copper.Parsec as Pc + import Penny.Lincoln.Family.Child (child, parent) import qualified Penny.Lincoln.Predicates as P import qualified Penny.Lincoln as L -import qualified Penny.Lincoln.Queries as Q import qualified Penny.Liberty.Expressions as X import Text.Matchers.CaseSensitive ( @@ -99,7 +94,7 @@ -- instances, filters them, post-filters them, sorts them, and places -- them in Box instances with Filtered serials. xactionsToFiltered :: - + (L.PostFam -> Bool) -- ^ The predicate to filter the transactions @@ -111,7 +106,7 @@ -> [L.Transaction] -- ^ The transactions to work on (probably parsed in from Copper) - + -> [L.Box LibertyMeta] -- ^ Sorted, filtered postings @@ -175,24 +170,8 @@ len = ListLength $ length as fn' (_, idx) = fn len (ItemIndex idx) zipped = zip as [0..] - -data Error = MakeMatcherFactoryError Text - | DateParseError - | BadPatternError Text - | BadNumberError Text - | BadQtyError Text - | BadSortKeyError Text - | BadComparator Text - | BadExpression - | BadColorName Text - | BadFieldName Text - | BadBackgroundArg Text - | UnexpectedWord Text Text - | BadCommodityError Text - deriving Show - ------------------------------------------------------------ -- Operands ------------------------------------------------------------ @@ -204,49 +183,49 @@ String -> CaseSensitive -> MatcherFactory - -> Ex.Exceptional Error (Text -> Bool) + -> Ex.Exceptional String (Text -> Bool) -getMatcher s cs f = case f cs (pack s) of - Ex.Exception e -> Ex.Exception $ BadPatternError e - Ex.Success m -> return m +getMatcher s cs f = Ex.mapException e (f cs (pack s)) + where + e err = "bad pattern: " ++ s ++ " error message: " + ++ unpack err --- | Parses comparers given on command line to a function. +-- | Parses comparers given on command line to a function. Aborts if +-- the string given is invalid. parseComparer :: (Eq a, Ord a) => String - -> Maybe (a -> a -> Bool) + -> Ex.Exceptional String (a -> a -> Bool) parseComparer t - | t == "<" = Just (<) - | t == "<=" = Just (<=) - | t == "==" = Just (==) - | t == "=" = Just (==) - | t == ">" = Just (>) - | t == ">=" = Just (>=) - | t == "/=" = Just (/=) - | t == "!=" = Just (/=) - | otherwise = Nothing + | t == "<" = return (<) + | t == "<=" = return (<=) + | t == "==" = return (==) + | t == "=" = return (==) + | t == ">" = return (>) + | t == ">=" = return (>=) + | t == "/=" = return (/=) + | t == "!=" = return (/=) + | otherwise = Ex.throw $ "invalid comparer: " ++ t -parseDate :: DefaultTimeZone -> Text -> Exceptional Error L.DateTime -parseDate dtz t = case parse (dateTime dtz) "" t of - Left _ -> Exception DateParseError - Right d -> return d +parseDate :: String -> Ex.Exceptional String L.DateTime +parseDate = + Ex.mapException f . Ex.fromEither . parse Pc.dateTime "" . pack + where + f msg = "invalid date: " ++ show msg -date :: Parser (DefaultTimeZone -> Ex.Exceptional Error Operand) -date = - let os = C.OptSpec ["date"] ['d'] (C.TwoArg f) - f a1 a2 dtz = do - cmp <- Ex.fromMaybe (BadComparator (pack a1)) - (parseComparer a1) - dt <- parseDate dtz (pack a2) - return $ X.Operand (P.date (`cmp` dt)) - in C.parseOption [os] +date :: OptSpec (Ex.Exceptional String Operand) +date = C.OptSpec ["date"] ['d'] (C.TwoArg f) + where + f a1 a2 = g <$> parseComparer a1 <*> parseDate a2 + g cmp dt = X.Operand (P.date (`cmp` dt)) -current :: Parser (L.DateTime -> Operand) -current = - let os = C.OptSpec ["current"] [] (C.NoArg f) - f dt = X.Operand (P.date (<= dt)) - in C.parseOption [os] +current :: L.DateTime -> OptSpec Operand +current dt = C.OptSpec ["current"] [] (C.NoArg f) + where + f = X.Operand (P.date (<= dt)) + + -- | Creates options that match against fields that are -- colon-separated. The operand added will return True if the -- posting's colon-separated option matches the pattern given, or @@ -254,7 +233,7 @@ sepOption :: String -- ^ Long option name - + -> Maybe Char -- ^ Short option name, if there is one @@ -262,32 +241,27 @@ -- ^ When applied to a text that separates the different segments of -- the field, a matcher, and a posting, this function returns True -- if the posting matches the matcher or False if it does not. - - -> Parser (CaseSensitive - -> MatcherFactory - -> Ex.Exceptional Error Operand) -sepOption str mc f = - let so = case mc of - Nothing -> [] - Just c -> [c] - os = C.OptSpec [str] so (C.OneArg g) - g a cs fty = do - m <- getMatcher a cs fty - return $ X.Operand (f sep m) - in C.parseOption [os] + -> OptSpec ( CaseSensitive + -> MatcherFactory + -> Ex.Exceptional String Operand ) +sepOption str mc f = C.OptSpec [str] so (C.OneArg g) + where + so = maybe [] return mc + g a cs fty = h <$> getMatcher a cs fty + where + h mtr = X.Operand (f sep mtr) + + sep :: Text sep = Text.singleton ':' -- | Parses exactly one integer; fails if it cannot read exactly one. -parseInt :: String -> Exceptional Error Int -parseInt t = let ps = reads t in - case ps of - [] -> Exception $ BadNumberError (pack t) - ((i, s):[]) -> if length s /= 0 - then Exception $ BadNumberError (pack t) - else return i - _ -> Exception $ BadNumberError (pack t) +parseInt :: String -> Ex.Exceptional String Int +parseInt t = + case reads t of + ((i, ""):[]) -> return i + _ -> Ex.throw ("invalid number: " ++ t) -- | Creates options that take two arguments, with the first argument -- being the level to match, and the second being the pattern that @@ -296,125 +270,121 @@ levelOption :: String -- ^ Long option name - + -> (Int -> (Text -> Bool) -> L.PostFam -> Bool) -- ^ Applied to an integer, a matcher, and a PostingBox, this -- function returns True if a particular field in the posting -- matches the matcher given at the given level, or False otherwise. - - -> Parser (CaseSensitive - -> MatcherFactory -> Exceptional Error Operand) - -levelOption str f = - let os = C.OptSpec [str] [] (C.TwoArg g) - g a1 a2 cs fty = do - n <- parseInt a1 - m <- getMatcher a2 cs fty - return $ X.Operand (f n m) - in C.parseOption [os] + -> OptSpec ( CaseSensitive + -> MatcherFactory + -> Ex.Exceptional String Operand) + +levelOption str f = C.OptSpec [str] [] (C.TwoArg g) + where + g a1 a2 cs fty = h <$> parseInt a1 <*> getMatcher a2 cs fty + h i m = X.Operand (f i m) + + -- | 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 -> ((Text -> Bool) -> L.PostFam -> Bool) -- ^ When applied to a matcher and a PostingBox, this function -- returns True if the posting matches, or False if it does not. - - -> Parser (CaseSensitive - -> MatcherFactory -> Exceptional Error Operand) -patternOption str mc f = - let so = maybe [] (\c -> [c]) mc - os = C.OptSpec [str] so (C.OneArg g) - g a1 cs fty = do - m <- getMatcher a1 cs fty - return $ X.Operand (f m) - in C.parseOption [os] + -> OptSpec ( CaseSensitive + -> MatcherFactory + -> Ex.Exceptional String Operand ) +patternOption str mc f = C.OptSpec [str] so (C.OneArg g) + where + so = maybe [] (\c -> [c]) mc + g a1 cs fty = h <$> getMatcher a1 cs fty + h m = X.Operand (f m) + + + -- | The account option; matches if the pattern given matches the -- colon-separated account name. -account :: Parser (CaseSensitive - -> MatcherFactory -> Exceptional Error Operand) +account :: OptSpec ( CaseSensitive + -> MatcherFactory + -> Ex.Exceptional String Operand ) account = sepOption "account" (Just 'a') P.account -- | The account-level option; matches if the account at the given -- level matches. -accountLevel :: Parser (CaseSensitive - -> MatcherFactory -> Exceptional Error Operand) +accountLevel :: OptSpec ( CaseSensitive + -> MatcherFactory + -> Ex.Exceptional String Operand) accountLevel = levelOption "account-level" P.accountLevel -- | The accountAny option; returns True if the matcher given matches -- a single sub-account name at any level. -accountAny :: Parser (CaseSensitive - -> MatcherFactory -> Exceptional Error Operand) +accountAny :: OptSpec ( CaseSensitive + -> MatcherFactory + -> Ex.Exceptional String Operand ) accountAny = patternOption "account-any" Nothing P.accountAny -- | The payee option; returns True if the matcher matches the payee -- name. -payee :: Parser (CaseSensitive - -> MatcherFactory -> Exceptional Error Operand) +payee :: OptSpec ( CaseSensitive + -> MatcherFactory + -> Ex.Exceptional String Operand ) payee = patternOption "payee" (Just 'p') P.payee -tag :: Parser (CaseSensitive - -> MatcherFactory -> Exceptional Error Operand) +tag :: OptSpec ( CaseSensitive + -> MatcherFactory + -> Ex.Exceptional String Operand) tag = patternOption "tag" (Just 't') P.tag -number :: Parser (CaseSensitive - -> MatcherFactory -> Exceptional Error Operand) +number :: OptSpec ( CaseSensitive + -> MatcherFactory + -> Ex.Exceptional String Operand ) number = patternOption "number" Nothing P.number -flag :: Parser (CaseSensitive - -> MatcherFactory -> Exceptional Error Operand) +flag :: OptSpec ( CaseSensitive + -> MatcherFactory + -> Ex.Exceptional String Operand) flag = patternOption "flag" Nothing P.flag -commodity :: Parser (CaseSensitive - -> MatcherFactory -> Exceptional Error Operand) -commodity = sepOption "commodity" Nothing P.commodity - -commodityLevel :: Parser (CaseSensitive - -> MatcherFactory -> Exceptional Error Operand) -commodityLevel = levelOption "commodity-level" P.commodityLevel - -commodityAny :: Parser (CaseSensitive - -> MatcherFactory -> Exceptional Error Operand) -commodityAny = patternOption "commodity" Nothing P.commodityAny +commodity :: OptSpec ( CaseSensitive + -> MatcherFactory + -> Ex.Exceptional String Operand) +commodity = patternOption "commodity" Nothing P.commodity -postingMemo :: Parser (CaseSensitive - -> MatcherFactory -> Exceptional Error Operand) +postingMemo :: OptSpec ( CaseSensitive + -> MatcherFactory + -> Ex.Exceptional String Operand) postingMemo = patternOption "posting-memo" Nothing P.postingMemo -transactionMemo :: Parser (CaseSensitive - -> MatcherFactory -> Exceptional Error Operand) +transactionMemo :: OptSpec ( CaseSensitive + -> MatcherFactory + -> Ex.Exceptional String Operand) transactionMemo = patternOption "transaction-memo" Nothing P.transactionMemo -debit :: Parser Operand -debit = - let os = C.OptSpec ["debit"] [] (C.NoArg (X.Operand P.debit)) - in C.parseOption [os] +debit :: OptSpec Operand +debit = C.OptSpec ["debit"] [] (C.NoArg (X.Operand P.debit)) -credit :: Parser Operand -credit = - let os = C.OptSpec ["credit"] [] (C.NoArg (X.Operand P.credit)) - in C.parseOption [os] +credit :: OptSpec Operand +credit = C.OptSpec ["credit"] [] (C.NoArg (X.Operand P.credit)) -qtyOption :: Parser (RadGroup -> Exceptional Error Operand) -qtyOption = - let os = C.OptSpec ["qty"] [] (C.TwoArg f) - f a1 a2 rg = do - q <- case parse (qty rg) "" (pack a2) of - Left _ -> Ex.throw $ BadQtyError (pack a2) - Right g -> return g - cmp <- Ex.fromMaybe (BadComparator (pack a1)) - (parseComparer a1) - return $ X.Operand (P.qty (`cmp` q)) - in C.parseOption [os] +qtyOption :: OptSpec (Ex.Exceptional String Operand) +qtyOption = C.OptSpec ["qty"] [] (C.TwoArg f) + where + f a1 a2 = g <$> parseComparer a1 <*> parseQty a2 + parseQty = Ex.mapException err . Ex.fromEither + . parse Pc.quantity "" . pack + err msg = "invalid quantity: " ++ show msg + g cmp qty = X.Operand (P.qty (`cmp` qty)) + -- | Creates two options suitable for comparison of serial numbers, -- one for ascending, one for descending. serialOption :: @@ -426,24 +396,25 @@ -> String -- ^ Name of the command line option, such as @global-transaction@ - -> Parser (Exceptional Error Operand) + -> ( OptSpec (Ex.Exceptional String Operand) + , OptSpec (Ex.Exceptional String Operand) ) -- ^ Parses both descending and ascending serial options. -serialOption getSerial n = - let osA = C.OptSpec [n] [] - (C.TwoArg (f L.forward)) - osD = C.OptSpec [addPrefix "rev" n] [] - (C.TwoArg (f L.backward)) - f getInt a1 a2 = do - cmp <- Ex.fromMaybe (BadComparator (pack a1)) - (parseComparer a1) - i <- parseInt a2 - let op pf = case getSerial pf of - Nothing -> False - Just ser -> getInt ser `cmp` i - return $ X.Operand op - in C.parseOption [osA, osD] +serialOption getSerial n = (osA, osD) + where + osA = C.OptSpec [n] [] + (C.TwoArg (f L.forward)) + osD = C.OptSpec [addPrefix "rev" n] [] + (C.TwoArg (f L.backward)) + f getInt a1 a2 = g <$> parseComparer a1 <*> parseInt a2 + where + g cmp i = + let op pf = case getSerial pf of + Nothing -> False + Just ser -> getInt ser `cmp` i + in X.Operand op + -- | Takes a string, adds a prefix and capitalizes the first letter of -- the old string. e.g. applied to "rev" and "globalTransaction", -- returns "revGlobalTransaction". @@ -453,240 +424,166 @@ "" -> "" x:xs -> toUpper x : xs -globalTransaction :: Parser (Exceptional Error Operand) +globalTransaction :: ( OptSpec (Ex.Exceptional String Operand) + , OptSpec (Ex.Exceptional String Operand) ) globalTransaction = let f = fmap L.unGlobalTransaction - . L.globalTransaction - . L.tMeta + . L.tGlobalTransaction . parent . L.unPostFam in serialOption f "globalTransaction" -globalPosting :: Parser (Exceptional Error Operand) +globalPosting :: ( OptSpec (Ex.Exceptional String Operand) + , OptSpec (Ex.Exceptional String Operand) ) globalPosting = let f = fmap L.unGlobalPosting - . L.globalPosting - . L.pMeta + . L.pGlobalPosting . child . L.unPostFam in serialOption f "globalPosting" -filePosting :: Parser (Exceptional Error Operand) +filePosting :: ( OptSpec (Ex.Exceptional String Operand) + , OptSpec (Ex.Exceptional String Operand) ) filePosting = let f = fmap L.unFilePosting - . L.filePosting - . L.pMeta + . L.pFilePosting . child . L.unPostFam in serialOption f "filePosting" -fileTransaction :: Parser (Exceptional Error Operand) +fileTransaction :: ( OptSpec (Ex.Exceptional String Operand) + , OptSpec (Ex.Exceptional String Operand) ) fileTransaction = let f = fmap L.unFileTransaction - . L.fileTransaction - . L.tMeta + . L.tFileTransaction . parent . L.unPostFam in serialOption f "fileTransaction" --- | Parses operands. -parseOperand :: - Parser (L.DateTime - -> DefaultTimeZone - -> RadGroup - -> CaseSensitive - -> MatcherFactory - -> Ex.Exceptional Error Operand) - -parseOperand = - (do { f <- date; return (\_ dtz _ _ _ -> f dtz)}) - <|> (do { f <- current; return (\dt _ _ _ _ -> return (f dt)) }) - <|> wrapFactArg account - <|> wrapFactArg accountLevel - <|> wrapFactArg accountAny - <|> wrapFactArg payee - <|> wrapFactArg tag - <|> wrapFactArg number - <|> wrapFactArg flag - <|> wrapFactArg commodity - <|> wrapFactArg commodityLevel - <|> wrapFactArg commodityAny - <|> wrapFactArg postingMemo - <|> wrapFactArg transactionMemo - <|> (do { o <- debit; return (\_ _ _ _ _ -> return o) }) - <|> (do { o <- credit; return (\_ _ _ _ _ -> return o) }) - <|> (do { f <- qtyOption; return (\ _ _ rg _ _ -> f rg)}) - <|> wrapNoArg globalTransaction - <|> wrapNoArg globalPosting - <|> wrapNoArg filePosting - <|> wrapNoArg fileTransaction +unDouble + :: ( OptSpec (Ex.Exceptional String Operand) + , OptSpec (Ex.Exceptional String Operand) ) + -> [ OptSpec (a -> b -> Ex.Exceptional String Operand) ] +unDouble (o1, o2) = [fmap f o1, fmap f o2] + where + f = (\g _ _ -> g) -wrapNoArg :: - Parser (Ex.Exceptional Error Operand) - -> Parser (L.DateTime - -> DefaultTimeZone - -> RadGroup - -> CaseSensitive - -> MatcherFactory - -> Ex.Exceptional Error Operand) -wrapNoArg p = do - o <- p - return (\_ _ _ _ _ -> o) +-- | All operand OptSpec. +operandSpecs + :: L.DateTime + -> [OptSpec (CaseSensitive + -> MatcherFactory + -> Ex.Exceptional String Operand)] -wrapFactArg :: - Parser (CaseSensitive -> MatcherFactory -> Exceptional Error Operand) - -> Parser (L.DateTime - -> DefaultTimeZone - -> RadGroup - -> CaseSensitive - -> MatcherFactory - -> Ex.Exceptional Error Operand) -wrapFactArg p = do - f <- p - return (\_ _ _ cs fact -> f cs fact) +operandSpecs dt = + [ fmap (\f _ _ -> f) date + , fmap (\o _ _ -> return o) (current dt) + , wrapFactArg account + , wrapFactArg accountLevel + , wrapFactArg accountAny + , wrapFactArg payee + , wrapFactArg tag + , wrapFactArg number + , wrapFactArg flag + , wrapFactArg commodity + , wrapFactArg postingMemo + , wrapFactArg transactionMemo + , fmap (\f _ _ -> return f) debit + , fmap (\f _ _ -> return f) credit + , fmap (\f _ _ -> f) qtyOption + ] + ++ unDouble globalTransaction + ++ unDouble globalPosting + ++ unDouble filePosting + ++ unDouble fileTransaction + where + wrapFactArg = fmap (\f cs fty -> f cs fty) ------------------------------------------------------------ -- Post filters ------------------------------------------------------------ -optHead :: Parser (Exceptional Error PostFilterFn) -optHead = - let os = C.OptSpec ["head"] [] (C.OneArg f) - f a = do - i <- fmap ItemIndex (parseInt a) - return (\_ idx -> idx < i) - in C.parseOption [os] +optHead :: OptSpec (Ex.Exceptional String PostFilterFn) +optHead = C.OptSpec ["head"] [] (C.OneArg f) + where + f a = g <$> parseInt a + where + g i _ ii = ii < (ItemIndex i) -optTail :: Parser (Exceptional Error PostFilterFn) -optTail = - let os = C.OptSpec ["tail"] [] (C.OneArg f) - f a = do - i <- parseInt a - let g (ListLength len) (ItemIndex idx) = idx >= len - i - return g - in C.parseOption [os] +optTail :: OptSpec (Ex.Exceptional String PostFilterFn) +optTail = C.OptSpec ["tail"] [] (C.OneArg f) + where + f a = g <$> parseInt a + where + g i (ListLength len) (ItemIndex ii) = ii >= len - i -parsePostFilter :: Parser (Exceptional Error PostFilterFn) -parsePostFilter = optHead <|> optTail + +postFilterSpecs :: ( OptSpec (Ex.Exceptional String PostFilterFn) + , OptSpec (Ex.Exceptional String PostFilterFn) ) +postFilterSpecs = (optHead, optTail) + ------------------------------------------------------------ -- Matcher control ------------------------------------------------------------ -noArg :: a -> String -> Parser a -noArg a s = let os = C.OptSpec [s] "" (C.NoArg a) - in C.parseOption [os] +noArg :: a -> String -> OptSpec a +noArg a s = C.OptSpec [s] "" (C.NoArg a) -parseInsensitive :: Parser CaseSensitive +parseInsensitive :: OptSpec CaseSensitive parseInsensitive = - let os = C.OptSpec ["case-insensitive"] ['i'] (C.NoArg Insensitive) - in C.parseOption [os] + C.OptSpec ["case-insensitive"] ['i'] (C.NoArg Insensitive) -parseSensitive :: Parser CaseSensitive + +parseSensitive :: OptSpec CaseSensitive parseSensitive = - let os = C.OptSpec ["case-sensitive"] ['I'] (C.NoArg Sensitive) - in C.parseOption [os] + C.OptSpec ["case-sensitive"] ['I'] (C.NoArg Sensitive) -within :: Parser MatcherFactory +within :: OptSpec MatcherFactory within = noArg (\c t -> return (TM.within c t)) "within" -pcre :: Parser MatcherFactory +pcre :: OptSpec MatcherFactory pcre = noArg TM.pcre "pcre" -posix :: Parser MatcherFactory +posix :: OptSpec MatcherFactory posix = noArg TM.tdfa "posix" -exact :: Parser MatcherFactory +exact :: OptSpec MatcherFactory exact = noArg (\c t -> return (TM.exact c t)) "exact" -parseMatcherSelect :: Parser MatcherFactory -parseMatcherSelect = within <|> pcre <|> posix <|> exact +matcherSelectSpecs :: [OptSpec MatcherFactory] +matcherSelectSpecs = [within, pcre, posix, exact] -parseCaseSelect :: Parser CaseSensitive -parseCaseSelect = parseInsensitive <|> parseSensitive +caseSelectSpecs :: [OptSpec CaseSensitive] +caseSelectSpecs = [parseInsensitive, parseSensitive] ------------------------------------------------------------ -- Operators ------------------------------------------------------------ -- | Open parentheses -open :: Parser (X.Token a) +open :: OptSpec (X.Token a) open = noArg X.TokOpenParen "open" -- | Close parentheses -close :: Parser (X.Token a) +close :: OptSpec (X.Token a) close = noArg X.TokCloseParen "close" -- | and operator -parseAnd :: Parser (X.Token (a -> Bool)) +parseAnd :: OptSpec (X.Token (a -> Bool)) parseAnd = noArg X.tokAnd "and" -- | or operator -parseOr :: Parser (X.Token (a -> Bool)) +parseOr :: OptSpec (X.Token (a -> Bool)) parseOr = noArg X.tokOr "or" -- | not operator -parseNot :: Parser (X.Token (a -> Bool)) +parseNot :: OptSpec (X.Token (a -> Bool)) parseNot = noArg X.tokNot "not" where -parseOperator :: Parser (X.Token (a -> Bool)) -parseOperator = - open <|> close <|> parseAnd <|> parseOr <|> parseNot - ------------------------------------------------------------- --- Sorting ------------------------------------------------------------- -type Orderer = L.PostFam -> L.PostFam -> Ordering - -ordering :: - (Ord b) - => (a -> b) - -> (a -> a -> Ordering) -ordering q = f where - f p1 p2 = compare (q p1) (q p2) - - -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", ordering Q.payee) - , ("date", ordering Q.dateTime) - , ("flag", ordering Q.flag) - , ("number", ordering Q.number) - , ("account", ordering Q.account) - , ("drCr", ordering Q.drCr) - , ("qty", ordering Q.qty) - , ("commodity", ordering Q.commodity) - , ("postingMemo", ordering Q.postingMemo) - , ("transactionMemo", ordering Q.transactionMemo) ] - -ords :: [(String, Orderer)] -ords = ordPairs ++ uppers where - uppers = map toReversed ordPairs - toReversed (s, f) = - (capitalizeFirstLetter s, flipOrder f) - +operatorSpecs :: [OptSpec (X.Token (a -> Bool))] +operatorSpecs = + [open, close, parseAnd, parseOr, parseNot] -parseSort :: Parser (Exceptional Error Orderer) -parseSort = - let os = C.OptSpec ["sort"] ['s'] (C.OneArg f) - f a = - let matches = filter (\p -> a `isPrefixOf` (fst p)) ords - in case matches of - [] -> Ex.throw $ BadSortKeyError (pack a) - x:[] -> return $ snd x - _ -> Ex.throw $ BadSortKeyError (pack a) - in C.parseOption [os] diff --git a/Penny/Liberty/Expressions.hs b/Penny/Liberty/Expressions.hs --- a/Penny/Liberty/Expressions.hs +++ b/Penny/Liberty/Expressions.hs @@ -1,8 +1,8 @@ module Penny.Liberty.Expressions ( I.Precedence(Precedence), - + I.Associativity(ALeft, ARight), - + I.Token(TokOperand, TokUnaryPostfix, TokUnaryPrefix, @@ -10,7 +10,7 @@ TokOpenParen, TokCloseParen), - R.Operand(Operand), + R.Operand(..), tokAnd, tokOr, tokNot, diff --git a/Penny/Liberty/Expressions/Infix.hs b/Penny/Liberty/Expressions/Infix.hs --- a/Penny/Liberty/Expressions/Infix.hs +++ b/Penny/Liberty/Expressions/Infix.hs @@ -10,17 +10,17 @@ module Penny.Liberty.Expressions.Infix ( Precedence(Precedence), - + Associativity(ALeft, ARight), - + Token(TokOperand, TokUnaryPostfix, TokUnaryPrefix, TokBinary, TokOpenParen, TokCloseParen), - + infixToRPN ) where diff --git a/Penny/Liberty/Expressions/RPN.hs b/Penny/Liberty/Expressions/RPN.hs --- a/Penny/Liberty/Expressions/RPN.hs +++ b/Penny/Liberty/Expressions/RPN.hs @@ -6,7 +6,7 @@ -- 4 +@, the @5@ and the @4@ are operands; the @+@ is an operator; -- each of these three is a token. module Penny.Liberty.Expressions.RPN ( - Operand(Operand), + Operand(..), Operator(Unary, Binary), Token(TokOperand, TokOperator), process) where @@ -15,7 +15,7 @@ -- | An operand; for example, in the expression @5 4 +@, @5@ and @4@ -- are operands. -newtype Operand a = Operand a deriving Show +newtype Operand a = Operand { unOperand :: a } deriving Show -- | Operators; for example, in the expression @5 4 +@, @+@ is an -- operator. Because this is RPN, there is no operator precedence. diff --git a/Penny/Lincoln.hs b/Penny/Lincoln.hs --- a/Penny/Lincoln.hs +++ b/Penny/Lincoln.hs @@ -17,85 +17,94 @@ , B.removeZeroCommodities , B.BottomLine (Zero, NonZero) , B.Column (Column) - + -- * Bits -- ** Accounts - , I.SubAccountName (SubAccountName, unSubAccountName) + , I.SubAccount (SubAccount, unSubAccount) , I.Account(Account, unAccount) - + -- ** Amounts - , I.Amount (Amount, qty, commodity) - + , I.Amount (Amount, qty, commodity, side, spaceBetween) + -- ** Commodities , I.Commodity (Commodity, unCommodity) - , I.SubCommodity (SubCommodity, unSubCommodity) - , I.charCommodity - + -- ** DateTime - , I.DateTime - , I.dateTime - , I.localTime - , I.timeZone - , I.TimeZoneOffset + , I.TimeZoneOffset ( offsetToMins ) , I.minsToOffset - , I.offsetToMins , 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 + -- ** Debits and credits , I.DrCr(Debit, Credit) , I.opposite - + -- ** Entries , I.Entry (Entry, drCr, amount) - + -- ** Flag , I.Flag (Flag, unFlag) - + -- ** Memos - , I.MemoLine (MemoLine, unMemoLine) , 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, price, ppMeta) + , I.PricePoint ( PricePoint, dateTime, price, ppSide, + ppSpaceBetween, priceLine) - -- ** Quantities + -- ** Quantities , I.Qty - , I.unQty - , I.partialNewQty - , I.newQty + , I.NumberStr(..) + , I.toQty + , I.mantissa + , I.places , I.add - , I.subt , I.mult - , I.zero , I.difference - , I.Difference(LeftBiggerBy, RightBiggerBy, Equal) - + , I.equivalent + , I.newQty + , I.Mantissa, I.Places + , I.Difference(..) + , I.allocate + -- ** Tags , I.Tag(Tag, unTag) , I.Tags(Tags, unTags) - - + + -- * Builders - , Bd.crashy , Bd.account - + -- * Families -- ** Family types , F.Family(Family) , F.Child(Child) , F.Siblings(Siblings) - + -- ** Manipulating families , F.children , F.orphans @@ -104,27 +113,30 @@ , F.marry , F.divorceWith , F.divorce - + , F.filterChildren + , F.find + , F.mapChildren + , F.mapChildrenA + , F.mapParent + , F.mapParentA + -- * HasText , HT.HasText(text) - , HT.Delimited(Delimited) , HT.HasTextList(textList) - , HT.HasTextNonEmpty(textNonEmpty) - , HT.HasTextNonEmptyList(textNonEmptyList) - -- * TextNonEmpty - , TNE.TextNonEmpty(TextNonEmpty) - -- * Transactions -- ** Postings and transactions , T.Posting , T.Transaction , T.PostFam - -- ** Making transactions + -- ** Making and deconstructing transactions , T.transaction + , T.RTransaction(..) + , T.rTransaction , T.Error ( UnbalancedError, CouldNotInferError) - + , T.toUnverified + -- ** Querying postings , T.Inferred(Inferred, NotInferred) , T.pPayee @@ -135,8 +147,9 @@ , T.pEntry , T.pMemo , T.pInferred - , T.pMeta - , T.changePostingMeta + , T.pPostingLine + , T.pGlobalPosting + , T.pFilePosting -- ** Querying transactions , T.TopLine @@ -145,42 +158,40 @@ , T.tNumber , T.tPayee , T.tMemo - , T.tMeta - , T.changeTransactionMeta + , T.tTopLineLine + , T.tTopMemoLine + , T.tFilename + , T.tGlobalTransaction + , T.tFileTransaction , T.postFam - - -- ** Adding serials to transactions - , T.addSerialsToList - , T.addSerialsToEithers - + -- ** 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 - , M.TopLineLine(TopLineLine, unTopLineLine) - , M.TopMemoLine(TopMemoLine, unTopMemoLine) - , M.Side(CommodityOnLeft, CommodityOnRight) - , M.SpaceBetween(SpaceBetween, NoSpaceBetween) - , M.Format(Format, side, between) - , M.Filename(Filename, unFilename) - , M.PriceLine(PriceLine, unPriceLine) - , M.PostingLine(PostingLine, unPostingLine) - , M.PriceMeta(PriceMeta, priceLine, priceFormat) - , M.GlobalPosting(GlobalPosting, unGlobalPosting) - , M.FilePosting(FilePosting, unFilePosting) - , M.GlobalTransaction(GlobalTransaction, unGlobalTransaction) - , M.FileTransaction(FileTransaction, unFileTransaction) - , M.PostingMeta(PostingMeta, postingLine, postingFormat, - globalPosting, filePosting) - , M.emptyPostingMeta - , M.TopLineMeta(TopLineMeta, topMemoLine, topLineLine, filename, - globalTransaction, fileTransaction) - , M.emptyTopLineMeta - + , 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 @@ -188,14 +199,18 @@ , DB.getPrice , DB.PriceDbError(FromNotFound, ToNotFound, CpuNotFound) , DB.convert - + -- * Serials , S.Serial , S.forward , S.backward - , S.serials + , S.GenSerial + , S.incrementBack + , S.getSerial + , S.makeSerials , S.serialItems - + , S.nSerials + -- * Matchers , Matchers.Matcher , Matchers.Factory @@ -208,8 +223,6 @@ 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.Meta as M import qualified Penny.Lincoln.PriceDb as DB import qualified Penny.Lincoln.Serial as S -import qualified Penny.Lincoln.TextNonEmpty as TNE import qualified Penny.Lincoln.Transaction as T diff --git a/Penny/Lincoln/Balance.hs b/Penny/Lincoln/Balance.hs --- a/Penny/Lincoln/Balance.hs +++ b/Penny/Lincoln/Balance.hs @@ -1,4 +1,4 @@ -module Penny.Lincoln.Balance ( +module Penny.Lincoln.Balance ( Balance, unBalance, Balanced(Balanced, Inferable, NotInferable), @@ -20,13 +20,13 @@ import qualified Penny.Lincoln.Bits as B -- | A balance summarizes several entries. You do not create a Balance --- directly. Instead, use 'entryToBalance'. Balance used to be a --- monoid, but there is nothing appropriate for mempty. Instead, --- Balance is really a semigroup, but not a monoid. +-- directly. Instead, use 'entryToBalance'. newtype Balance = Balance (Map B.Commodity BottomLine) deriving (Show, Eq) --- | The map returned by unBalance is never empty. +-- | 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 @@ -48,7 +48,7 @@ B.Debit -> B.Credit B.Credit -> B.Debit q = qty col - a = B.Amount q c + a = B.Amount q c Nothing Nothing in Inferable e _ -> NotInferable @@ -89,19 +89,21 @@ -- 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) = +addBalances (Balance t1) (Balance t2) = Balance $ M.unionWith mappend t1 t2 instance Semi.Semigroup Balance where (<>) = addBalances --- | Removes zero balances from a Balance. Will not return a Balance --- with no commodities; instead, returns Nothing if there would be a --- balance with no commodities. -removeZeroCommodities :: Balance -> Maybe Balance +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 if M.null m' then Nothing else Just (Balance m') + in Balance m' diff --git a/Penny/Lincoln/Bits.hs b/Penny/Lincoln/Bits.hs --- a/Penny/Lincoln/Bits.hs +++ b/Penny/Lincoln/Bits.hs @@ -1,74 +1,96 @@ -- | Essential data types used to make Transactions and Postings. module Penny.Lincoln.Bits ( -- * Accounts - Ac.SubAccountName(SubAccountName, unSubAccountName), - Ac.Account(Account, unAccount), + O.SubAccount(SubAccount, unSubAccount), + O.Account(Account, unAccount), -- * Amounts - Am.Amount(Amount, qty, commodity), + O.Amount(Amount, qty, commodity, side, spaceBetween), -- * Commodities - C.Commodity(Commodity, unCommodity), - C.SubCommodity(SubCommodity, unSubCommodity), - C.charCommodity, + O.Commodity(Commodity, unCommodity), -- * DateTime - DT.DateTime, - DT.dateTime, - DT.localTime, - DT.timeZone, - DT.TimeZoneOffset, - DT.minsToOffset, DT.offsetToMins, DT.noOffset, + 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, -- * Debits and Credits - DC.DrCr(Debit, Credit), - DC.opposite, - + O.DrCr(Debit, Credit), + O.opposite, + -- * Entries - E.Entry(Entry, drCr, amount), + O.Entry(Entry, drCr, amount), -- * Flag - F.Flag(Flag, unFlag), + O.Flag(Flag, unFlag), -- * Memos - M.MemoLine(MemoLine, unMemoLine), - M.Memo(Memo, unMemo), + O.Memo(Memo, unMemo), -- * Number - N.Number(Number, unNumber), + O.Number(Number, unNumber), -- * Payee - Pa.Payee(Payee, unPayee), + 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, - PP.PricePoint(PricePoint, price, ppMeta), + PricePoint ( .. ), -- * Quantities - Q.Qty, Q.unQty, Q.partialNewQty, - Q.newQty, Q.add, Q.subt, Q.mult, Q.zero, - Q.difference, + 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 - T.Tag(Tag, unTag), - T.Tags(Tags, unTags)) where + 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.Account as Ac -import qualified Penny.Lincoln.Bits.Amount as Am -import qualified Penny.Lincoln.Bits.Commodity as C + +import qualified Penny.Lincoln.Bits.Open as O import qualified Penny.Lincoln.Bits.DateTime as DT -import qualified Penny.Lincoln.Bits.DrCr as DC -import qualified Penny.Lincoln.Bits.Entry as E -import qualified Penny.Lincoln.Bits.Flag as F -import qualified Penny.Lincoln.Bits.Memo as M -import qualified Penny.Lincoln.Bits.Number as N -import qualified Penny.Lincoln.Bits.Payee as Pa import qualified Penny.Lincoln.Bits.Price as Pr -import qualified Penny.Lincoln.Bits.PricePoint as PP import qualified Penny.Lincoln.Bits.Qty as Q -import qualified Penny.Lincoln.Bits.Tags as T + +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/Account.hs b/Penny/Lincoln/Bits/Account.hs deleted file mode 100644 --- a/Penny/Lincoln/Bits/Account.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Penny.Lincoln.Bits.Account where - -import Penny.Lincoln.TextNonEmpty (TextNonEmpty) -import Data.List.NonEmpty (NonEmpty) - -newtype SubAccountName = - SubAccountName { unSubAccountName :: TextNonEmpty } - deriving (Eq, Ord, Show) - -newtype Account = Account { unAccount :: NonEmpty SubAccountName } - deriving (Eq, Show, Ord) - diff --git a/Penny/Lincoln/Bits/Amount.hs b/Penny/Lincoln/Bits/Amount.hs deleted file mode 100644 --- a/Penny/Lincoln/Bits/Amount.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Penny.Lincoln.Bits.Amount where - -import Penny.Lincoln.Bits.Qty ( Qty ) -import Penny.Lincoln.Bits.Commodity ( Commodity ) - -data Amount = Amount { qty :: Qty - , commodity :: Commodity } - deriving (Eq, Show, Ord) diff --git a/Penny/Lincoln/Bits/Commodity.hs b/Penny/Lincoln/Bits/Commodity.hs deleted file mode 100644 --- a/Penny/Lincoln/Bits/Commodity.hs +++ /dev/null @@ -1,19 +0,0 @@ -module Penny.Lincoln.Bits.Commodity where - -import Penny.Lincoln.TextNonEmpty ( - TextNonEmpty ( TextNonEmpty ) ) -import Data.List.NonEmpty (NonEmpty((:|))) -import Data.Text ( empty ) - -newtype Commodity = - Commodity { unCommodity :: NonEmpty SubCommodity } - deriving (Eq, Ord, Show) - -newtype SubCommodity = - SubCommodity { unSubCommodity :: TextNonEmpty } - deriving (Eq, Ord, Show) - --- | Creates a Commodity whose name is only a single character. -charCommodity :: Char -> Commodity -charCommodity c = - Commodity ((SubCommodity (TextNonEmpty c empty)) :| []) diff --git a/Penny/Lincoln/Bits/DateTime.hs b/Penny/Lincoln/Bits/DateTime.hs --- a/Penny/Lincoln/Bits/DateTime.hs +++ b/Penny/Lincoln/Bits/DateTime.hs @@ -1,17 +1,23 @@ --- | Perhaps this could be called @moment@, as it aims to identify a --- moment in time. A DateTime is a combination of a LocalTime from --- Data.Time and a TimeZoneOffset. Previously a DateTime was simply a --- ZonedTime from Data.Time but ZonedTime has data that Penny does not --- need. -module Penny.Lincoln.Bits.DateTime ( - DateTime - , dateTime - , localTime - , timeZone - , TimeZoneOffset - , offsetToMins +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 ) where import qualified Data.Time as T @@ -35,23 +41,95 @@ noOffset :: TimeZoneOffset noOffset = TimeZoneOffset 0 --- | A DateTime is a UTC time that also remembers the local time from --- which it was set. The Eq and Ord instances will compare two --- DateTimes based on their equivalent UTC times. -data DateTime = DateTime { localTime :: T.LocalTime - , timeZone :: TimeZoneOffset } - deriving Show +newtype Hours = Hours { unHours :: Int } + deriving (Eq, Ord, Show) --- | Construct a DateTime. -dateTime :: T.LocalTime -> TimeZoneOffset -> DateTime -dateTime = DateTime +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 (DateTime lt (TimeZoneOffset tzo)) = T.localTimeToUTC tz lt where - tz = T.minutesToTimeZone tzo +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 -instance Eq DateTime where - l == r = toUTC l == toUTC r +-- | Are these DateTimes the same instant in time, after adjusting for +-- local timezones? -instance Ord DateTime where - compare l r = compare (toUTC l) (toUTC r) +sameInstant :: DateTime -> DateTime -> Bool +sameInstant t1 t2 = toUTC t1 == toUTC t2 + diff --git a/Penny/Lincoln/Bits/DrCr.hs b/Penny/Lincoln/Bits/DrCr.hs deleted file mode 100644 --- a/Penny/Lincoln/Bits/DrCr.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Penny.Lincoln.Bits.DrCr where - -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 diff --git a/Penny/Lincoln/Bits/Entry.hs b/Penny/Lincoln/Bits/Entry.hs deleted file mode 100644 --- a/Penny/Lincoln/Bits/Entry.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Penny.Lincoln.Bits.Entry where - -import Penny.Lincoln.Bits.Amount (Amount) -import Penny.Lincoln.Bits.DrCr (DrCr) - -data Entry = Entry { drCr :: DrCr - , amount :: Amount } - deriving (Eq, Show, Ord) - diff --git a/Penny/Lincoln/Bits/Flag.hs b/Penny/Lincoln/Bits/Flag.hs deleted file mode 100644 --- a/Penny/Lincoln/Bits/Flag.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Penny.Lincoln.Bits.Flag where - -import Penny.Lincoln.TextNonEmpty (TextNonEmpty) - -newtype Flag = Flag { unFlag :: TextNonEmpty } - deriving (Eq, Show, Ord) - diff --git a/Penny/Lincoln/Bits/Memo.hs b/Penny/Lincoln/Bits/Memo.hs deleted file mode 100644 --- a/Penny/Lincoln/Bits/Memo.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Penny.Lincoln.Bits.Memo where - -import Penny.Lincoln.TextNonEmpty (TextNonEmpty) - -newtype MemoLine = MemoLine { unMemoLine :: TextNonEmpty } - deriving (Eq, Ord, Show) - -newtype Memo = Memo { unMemo :: [MemoLine] } - deriving (Eq, Show, Ord) diff --git a/Penny/Lincoln/Bits/Number.hs b/Penny/Lincoln/Bits/Number.hs deleted file mode 100644 --- a/Penny/Lincoln/Bits/Number.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Penny.Lincoln.Bits.Number where - -import Penny.Lincoln.TextNonEmpty (TextNonEmpty) - -newtype Number = Number { unNumber :: TextNonEmpty } - deriving (Eq, Show, Ord) diff --git a/Penny/Lincoln/Bits/Open.hs b/Penny/Lincoln/Bits/Open.hs new file mode 100644 --- /dev/null +++ b/Penny/Lincoln/Bits/Open.hs @@ -0,0 +1,124 @@ +-- | 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/Payee.hs b/Penny/Lincoln/Bits/Payee.hs deleted file mode 100644 --- a/Penny/Lincoln/Bits/Payee.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Penny.Lincoln.Bits.Payee where - -import Penny.Lincoln.TextNonEmpty ( TextNonEmpty ) - -newtype Payee = Payee { unPayee :: TextNonEmpty } - deriving (Eq, Show, Ord) - diff --git a/Penny/Lincoln/Bits/Price.hs b/Penny/Lincoln/Bits/Price.hs --- a/Penny/Lincoln/Bits/Price.hs +++ b/Penny/Lincoln/Bits/Price.hs @@ -6,14 +6,13 @@ convert, newPrice) where -import Penny.Lincoln.Bits.Amount (Amount(Amount)) -import Penny.Lincoln.Bits.Commodity (Commodity) +import qualified Penny.Lincoln.Bits.Open as O import Penny.Lincoln.Bits.Qty (Qty, mult) -newtype From = From { unFrom :: Commodity } +newtype From = From { unFrom :: O.Commodity } deriving (Eq, Ord, Show) -newtype To = To { unTo :: Commodity } +newtype To = To { unTo :: O.Commodity } deriving (Eq, Ord, Show) newtype CountPerUnit = CountPerUnit { unCountPerUnit :: Qty } @@ -27,12 +26,12 @@ -- | 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 -> Amount -> Maybe Amount -convert p (Amount q c) = +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 (Amount q' (unTo . to $ 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 diff --git a/Penny/Lincoln/Bits/PricePoint.hs b/Penny/Lincoln/Bits/PricePoint.hs deleted file mode 100644 --- a/Penny/Lincoln/Bits/PricePoint.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Penny.Lincoln.Bits.PricePoint where - -import Penny.Lincoln.Bits.Price (Price) -import Penny.Lincoln.Bits.DateTime (DateTime) -import qualified Penny.Lincoln.Meta as M - -data PricePoint = PricePoint { dateTime :: DateTime - , price :: Price - , ppMeta :: M.PriceMeta } - deriving Show diff --git a/Penny/Lincoln/Bits/Qty.hs b/Penny/Lincoln/Bits/Qty.hs --- a/Penny/Lincoln/Bits/Qty.hs +++ b/Penny/Lincoln/Bits/Qty.hs @@ -2,13 +2,51 @@ -- fractional) of something. It does not have a commodity or a -- Debit/Credit. module Penny.Lincoln.Bits.Qty ( - Qty, unQty, partialNewQty, - newQty, add, subt, mult, - zero, Difference(LeftBiggerBy, RightBiggerBy, Equal), - difference) where + Qty, NumberStr(..), toQty, mantissa, places, newQty, + Mantissa, Places, + add, mult, Difference(LeftBiggerBy, RightBiggerBy, Equal), + equivalent, difference, allocate, + TotSeats, PartyVotes, SeatsWon, largestRemainderMethod) where -import Data.Decimal ( DecimalRaw ( Decimal ), Decimal ) +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 @@ -22,49 +60,238 @@ -- 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. -newtype Qty = Qty Decimal - deriving (Eq, Ord, Show) +-- +-- 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 + + +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. +-- | Subtract the second Qty from the first, after equalizing their +-- exponents. difference :: Qty -> Qty -> Difference -difference (Qty q1) (Qty q2) = case compare q1 q2 of - GT -> LeftBiggerBy (Qty $ q1 - q2) - LT -> RightBiggerBy (Qty $ q2 - q1) - EQ -> Equal +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 --- | Unwrap a Qty to get the underlying Decimal. This Decimal will --- always be greater than zero. -unQty :: Qty -> Decimal -unQty (Qty d) = d +add :: Qty -> Qty -> Qty +add x y = + let ((Qty xm e), (Qty ym _)) = equalizeExponents x y + in Qty (xm + ym) e --- | Make a new Qty. This function is partial. It will call error if --- its argument is less than or equal to zero. -partialNewQty :: Decimal -> Qty -partialNewQty d = - if d <= 0 - then error - $ "partialNewQty: argument less than or equal to zero: " - ++ show d - else Qty d +mult :: Qty -> Qty -> Qty +mult (Qty xm xe) (Qty ym ye) = Qty (xm * ym) (xe + ye) --- | Make a new Qty. Returns Nothing if its argument is less than --- zero. -newQty :: Decimal -> Maybe Qty -newQty d = if d <= 0 then Nothing else Just (Qty d) -add :: Qty -> Qty -> Qty -add (Qty q1) (Qty q2) = Qty $ q1 + q2 +-- | 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. -subt :: Qty -> Qty -> Maybe Qty -subt (Qty q1) (Qty q2) = if q2 > q1 then Nothing else Just $ Qty (q1 - q2) + -> NonEmpty Qty + -- ^ Allocate using this list of Qty. -mult :: Qty -> Qty -> Qty -mult (Qty q1) (Qty q2) = Qty $ q1 * q2 + -> 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. -zero :: Qty -zero = Qty $ Decimal 0 0 +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/Bits/Tags.hs b/Penny/Lincoln/Bits/Tags.hs deleted file mode 100644 --- a/Penny/Lincoln/Bits/Tags.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Penny.Lincoln.Bits.Tags where - -import Penny.Lincoln.TextNonEmpty (TextNonEmpty) - -newtype Tag = Tag { unTag :: TextNonEmpty } - deriving (Eq, Show, Ord) - -newtype Tags = Tags { unTags :: [Tag] } - deriving (Eq, Show, Ord) - diff --git a/Penny/Lincoln/Builders.hs b/Penny/Lincoln/Builders.hs --- a/Penny/Lincoln/Builders.hs +++ b/Penny/Lincoln/Builders.hs @@ -11,52 +11,19 @@ -- 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 ( - crashy - , account - , commodity +module Penny.Lincoln.Builders + ( account ) where -import Control.Monad.Exception.Synchronous as Ex import qualified Data.List.Split as S -import Data.List.NonEmpty (NonEmpty((:|))) import qualified Penny.Lincoln.Bits as B -import Penny.Lincoln.TextNonEmpty (TextNonEmpty(TextNonEmpty)) import Data.Text (pack) -import qualified Data.Traversable as T --- | Makes a function partial. Use if you don't want to bother dealing --- with the Exceptional type. -crashy :: Show e => Ex.Exceptional e a -> a -crashy = Ex.resolve (error . show) - -- | Create an Account. You supply a single String, with colons to -- separate the different sub-accounts. -account :: String -> Ex.Exceptional String B.Account -account input = do - subStrs <- case S.splitOn ":" input of - [] -> error "splitOn returned an empty list; should never happen" - []:[] -> Ex.throw "account name is null" - (s:ss) -> return $ s :| ss - let makeSub s = case s of - [] -> Ex.throw $ - "sub account name is null from account: " ++ input - (c:cs) -> return $ B.SubAccountName (TextNonEmpty c (pack cs)) - subs <- T.traverse makeSub subStrs - return $ B.Account subs - --- | Create a Commodity. You supply a single String, with colons to --- separate the different sub-commodities. -commodity :: String -> Ex.Exceptional String B.Commodity -commodity input = do - subStrs <- case S.splitOn ":" input of - [] -> error "splitOn returned an empty list; should never happen" - []:[] -> Ex.throw "account name is null" - (s:ss) -> return $ s :| ss - let makeSub s = case s of - [] -> Ex.throw $ - "sub account name is null from account: " ++ input - (c:cs) -> return $ B.SubCommodity (TextNonEmpty c (pack cs)) - subs <- T.traverse makeSub subStrs - return $ B.Commodity subs - +account :: String -> B.Account +account s = + if null s + then B.Account [] + else B.Account . map B.SubAccount . map pack . S.splitOn ":" $ s + diff --git a/Penny/Lincoln/Family.hs b/Penny/Lincoln/Family.hs --- a/Penny/Lincoln/Family.hs +++ b/Penny/Lincoln/Family.hs @@ -11,11 +11,11 @@ F.Family(Family), C.Child(Child), S.Siblings(Siblings), - + -- * Mapping families - F.mapChildrenM, + F.mapChildrenA, F.mapChildren, - F.mapParentM, + F.mapParentA, F.mapParent, -- * Functions to manipulate families @@ -26,6 +26,8 @@ marry, divorceWith, divorce, + F.filterChildren, + F.find, S.collapse ) where import qualified Penny.Lincoln.Family.Family as F @@ -69,7 +71,7 @@ -> F.Family p2 c2 -> F.Family (p1, p2) (c1, c2) marry = marryWith (,) (,) - + -- | Splits up a family. divorceWith :: (p1 -> (p2, p3)) -> (c1 -> (c2, c3)) diff --git a/Penny/Lincoln/Family/Family.hs b/Penny/Lincoln/Family/Family.hs --- a/Penny/Lincoln/Family/Family.hs +++ b/Penny/Lincoln/Family/Family.hs @@ -1,6 +1,8 @@ module Penny.Lincoln.Family.Family where -import qualified Data.Functor.Identity as I +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. @@ -11,40 +13,64 @@ , children :: [c] } deriving (Eq, Show) --- | Maps over all children in a monad, in order starting with child +-- | Maps over all children, in order starting with child -- 1, then child 2, then the children in the list from left to right. -mapChildrenM :: - Monad m +mapChildrenA :: + Applicative m => (a -> m b) -> Family p a -> m (Family p b) -mapChildrenM f (Family p c1 c2 cs) = do - c1' <- f c1 - c2' <- f c2 - cs' <- mapM f cs - return $ Family p c1' c2' cs' +mapChildrenA f (Family p c1 c2 cs) = + Family p <$> f c1 <*> f c2 <*> traverse f cs --- | Maps over all children, in order starting with child --- 1, then child 2, then the children in the list from left to right. +-- | Maps over all children. mapChildren :: (a -> b) -> Family p a -> Family p b -mapChildren f fam = I.runIdentity (mapChildrenM f' fam) where - f' = return . f +mapChildren f (Family p c1 c2 cs) = + Family p (f c1) (f c2) (map f cs) --- | Maps over the parent in a monad. -mapParentM :: - Monad m + +-- | Maps over the parent in an Applicative. +mapParentA :: + Applicative m => (a -> m b) -> Family a c -> m (Family b c) -mapParentM f (Family p c1 c2 cs) = do - p' <- f p - return $ Family p' c1 c2 cs +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 fam = I.runIdentity (mapParentM f' fam) where - f' = return . f +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/HasText.hs b/Penny/Lincoln/HasText.hs --- a/Penny/Lincoln/HasText.hs +++ b/Penny/Lincoln/HasText.hs @@ -1,13 +1,8 @@ module Penny.Lincoln.HasText where -import Data.Foldable (toList) -import Data.List (intersperse) -import Data.List.NonEmpty (NonEmpty) -import Data.Text (Text, cons) -import qualified Data.Text as X +import Data.Text (Text) import qualified Penny.Lincoln.Bits as B -import Penny.Lincoln.TextNonEmpty (TextNonEmpty(TextNonEmpty)) class HasText a where text :: a -> Text @@ -15,91 +10,32 @@ instance HasText Text where text = id -instance HasText TextNonEmpty where - text (TextNonEmpty f r) = f `cons` r - -instance HasText B.SubAccountName where - text = text . B.unSubAccountName - -instance HasText B.SubCommodity where - text = text . B.unSubCommodity +instance HasText B.SubAccount where + text = B.unSubAccount instance HasText B.Flag where - text = text . B.unFlag + text = B.unFlag -instance HasText B.MemoLine where - text = text . B.unMemoLine +instance HasText B.Commodity where + text = B.unCommodity instance HasText B.Number where - text = text . B.unNumber + text = B.unNumber instance HasText B.Payee where - text = text . B.unPayee + text = B.unPayee instance HasText B.Tag where - text = text . B.unTag - --- | Applying 'text' to a Delimited type will give you a single Text --- with the delimiter interspersed between the values of the list. -data Delimited a = Delimited Text [a] - deriving Show - -instance HasText a => HasText (Delimited a) where - text (Delimited sep ts) = X.concat . intersperse sep . map text $ ts + text = B.unTag class HasTextList a where textList :: a -> [Text] -instance HasText a => HasTextList (NonEmpty a) where - textList = map text . toList - instance HasTextList B.Account where - textList = textList . B.unAccount - -instance HasTextList B.Commodity where - textList = textList . B.unCommodity + textList = map text . B.unAccount instance HasTextList B.Tags where textList = map text . B.unTags instance HasTextList B.Memo where - textList = map text . B.unMemo - -instance HasText a => HasTextList [a] where - textList = map text - -class HasTextNonEmpty a where - textNonEmpty :: a -> TextNonEmpty - -instance HasTextNonEmpty TextNonEmpty where - textNonEmpty = id - -instance HasTextNonEmpty B.SubAccountName where - textNonEmpty = B.unSubAccountName - -instance HasTextNonEmpty B.SubCommodity where - textNonEmpty = B.unSubCommodity - -instance HasTextNonEmpty B.Flag where - textNonEmpty = B.unFlag - -instance HasTextNonEmpty B.Number where - textNonEmpty = B.unNumber - -instance HasTextNonEmpty B.Payee where - textNonEmpty = B.unPayee - -instance HasTextNonEmpty B.Tag where - textNonEmpty = B.unTag - -class HasTextNonEmptyList a where - textNonEmptyList :: a -> NonEmpty TextNonEmpty - -instance HasTextNonEmpty a => HasTextNonEmptyList (NonEmpty a) where - textNonEmptyList = fmap textNonEmpty - -instance HasTextNonEmptyList B.Account where - textNonEmptyList = fmap textNonEmpty . B.unAccount - -instance HasTextNonEmptyList B.Commodity where - textNonEmptyList = fmap textNonEmpty . B.unCommodity + textList = B.unMemo diff --git a/Penny/Lincoln/Matchers.hs b/Penny/Lincoln/Matchers.hs --- a/Penny/Lincoln/Matchers.hs +++ b/Penny/Lincoln/Matchers.hs @@ -9,10 +9,10 @@ type Matcher = X.Text -> Bool -- | A function that makes Matchers. -type Factory = - MT.CaseSensitive +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. diff --git a/Penny/Lincoln/Meta.hs b/Penny/Lincoln/Meta.hs deleted file mode 100644 --- a/Penny/Lincoln/Meta.hs +++ /dev/null @@ -1,71 +0,0 @@ -module Penny.Lincoln.Meta where - -import qualified Penny.Lincoln.Serial as S -import qualified Data.Text as X - -newtype TopLineLine = TopLineLine { unTopLineLine :: Int } - deriving (Eq, Show) - -newtype TopMemoLine = TopMemoLine { unTopMemoLine :: Int } - deriving (Eq, Show) - -data Side = CommodityOnLeft | CommodityOnRight deriving (Eq, Show) -data SpaceBetween = SpaceBetween | NoSpaceBetween deriving (Eq, Show) - -data Format = - Format { side :: Side - , between :: SpaceBetween } - deriving (Eq, Show) - -newtype Filename = Filename { unFilename :: X.Text } - deriving (Eq, Show) - -newtype PriceLine = PriceLine { unPriceLine :: Int } - deriving (Eq, Show) - -newtype PostingLine = PostingLine { unPostingLine :: Int } - deriving (Eq, Show) - -data PriceMeta = - PriceMeta { priceLine :: Maybe PriceLine - , priceFormat :: Maybe Format } - deriving (Eq, Show) - -newtype GlobalPosting = - GlobalPosting { unGlobalPosting :: S.Serial } - deriving (Eq, Show) - -newtype FilePosting = - FilePosting { unFilePosting :: S.Serial } - deriving (Eq, Show) - -emptyPostingMeta :: PostingMeta -emptyPostingMeta = PostingMeta Nothing Nothing Nothing Nothing - -data PostingMeta = - PostingMeta { postingLine :: Maybe PostingLine - , postingFormat :: Maybe Format - , globalPosting :: Maybe GlobalPosting - , filePosting :: Maybe FilePosting } - deriving (Eq, Show) - -newtype GlobalTransaction = - GlobalTransaction { unGlobalTransaction :: S.Serial } - deriving (Eq, Show) - -newtype FileTransaction = - FileTransaction { unFileTransaction :: S.Serial } - deriving (Eq, Show) - - -emptyTopLineMeta :: TopLineMeta -emptyTopLineMeta = TopLineMeta Nothing Nothing Nothing Nothing Nothing - -data TopLineMeta = - TopLineMeta { topMemoLine :: Maybe TopMemoLine - , topLineLine :: Maybe TopLineLine - , filename :: Maybe Filename - , globalTransaction :: Maybe GlobalTransaction - , fileTransaction :: Maybe FileTransaction } - deriving (Eq, Show) - diff --git a/Penny/Lincoln/NestedMap.hs b/Penny/Lincoln/NestedMap.hs --- a/Penny/Lincoln/NestedMap.hs +++ b/Penny/Lincoln/NestedMap.hs @@ -4,20 +4,21 @@ -- may query the map at any level or insert new labels (and, -- therefore, new keys) at any level. module Penny.Lincoln.NestedMap ( - NestedMap ( NestedMap ), - unNestedMap, + NestedMap ( NestedMap, unNestedMap ), empty, relabel, descend, insert, cumulativeTotal, traverse, - traverseWithTrail ) where + 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 ) @@ -41,7 +42,7 @@ 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) @@ -122,7 +123,7 @@ newL mk = case mk of (Just old) -> old `mappend` l Nothing -> mempty `mappend` l - + totalMap :: (Monoid l) => NestedMap k l @@ -230,6 +231,12 @@ (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)) diff --git a/Penny/Lincoln/Predicates.hs b/Penny/Lincoln/Predicates.hs --- a/Penny/Lincoln/Predicates.hs +++ b/Penny/Lincoln/Predicates.hs @@ -1,15 +1,19 @@ -- | Functions that return a boolean based upon some criterion that --- matches something, often a PostingBox. Useful when filtering +-- matches something, often a PostFam. Useful when filtering -- Postings. module Penny.Lincoln.Predicates where -import Data.Text (Text, singleton) +import Data.List (intersperse) +import Data.Text (Text) +import qualified Data.Text as X +import Data.Time (Day) import qualified Penny.Lincoln.Bits as B -import Penny.Lincoln.HasText (HasText, text, HasTextList, textList, - Delimited(Delimited)) +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 -- * Matching helpers @@ -17,39 +21,42 @@ match f = f . text matchMaybe :: HasText a => (Text -> Bool) -> Maybe a -> Bool -matchMaybe f a = case a of - Nothing -> False - (Just t) -> match f t +matchMaybe f = maybe False (match f) + +-- | Does the given matcher match any of the elements of the Texts in +-- a HasTextList? matchAny :: HasTextList a => (Text -> Bool) -> a -> Bool matchAny f = any f . textList matchAnyMaybe :: HasTextList a => (Text -> Bool) -> Maybe a -> Bool -matchAnyMaybe f ma = case ma of - Nothing -> False - (Just ls) -> matchAny f ls +matchAnyMaybe f = maybe False (matchAny 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 -> Bool) -> a -> Bool matchLevel i f a = let ts = textList a in if i < 0 || i >= length ts then False else f (ts !! i) -matchMemo :: (Text -> Bool) -> B.Memo -> Bool -matchMemo f m = f m' where - m' = text $ Delimited (singleton ' ') (textList m) - +-- | Does the matcher match the text of the memo? Joins each line of +-- the memo with a space. +matchMemo :: (Text -> Bool) -> Maybe B.Memo -> Bool +matchMemo f = maybe False (f . X.intercalate (X.singleton ' ') . B.unMemo) + matchMaybeLevel :: HasTextList a => Int -> (Text -> Bool) -> Maybe a -> Bool -matchMaybeLevel i f ma = case ma of - Nothing -> False - (Just l) -> matchLevel i f l +matchMaybeLevel i f = maybe False (matchLevel i f) + -- * Pattern matching fields payee :: (Text -> Bool) -> PostFam -> Bool @@ -76,6 +83,12 @@ date f c = f (Q.dateTime c) +localDay :: + (Day -> Bool) + -> PostFam + -> Bool +localDay f = f . Q.localDay + -- * Qty qty :: @@ -102,27 +115,17 @@ => Text -> (Text -> Bool) -> a -> Bool -matchDelimited d f = f . text . Delimited d . textList +matchDelimited d f = f . X.concat . intersperse d . textList -- * Commodity -commodity :: Text -> (Text -> Bool) -> PostFam -> Bool -commodity t f = matchDelimited t f - . B.unCommodity - . Q.commodity - -commodityLevel :: Int -> (Text -> Bool) -> PostFam -> Bool -commodityLevel i f = matchLevel i f . Q.commodity - -commodityAny :: (Text -> Bool) -> PostFam -> Bool -commodityAny f = matchAny f . Q.commodity +commodity :: (Text -> Bool) -> PostFam -> Bool +commodity f = f . text . Q.commodity -- * Account account :: Text -> (Text -> Bool) -> PostFam -> Bool -account t f = matchDelimited t f - . B.unAccount - . Q.account +account t f = matchDelimited t f . Q.account accountLevel :: Int -> (Text -> Bool) -> PostFam -> Bool accountLevel i f = matchLevel i f . Q.account @@ -134,3 +137,59 @@ tag :: (Text -> Bool) -> PostFam -> Bool tag f = matchAny f . Q.tags +-- * Combining predicates +(&&&) :: (a -> Bool) -> (a -> Bool) -> (a -> Bool) +(&&&) l r = \a -> l a && r a + +infixr 3 &&& + +(|||) :: (a -> Bool) -> (a -> Bool) -> (a -> Bool) +(|||) l r = \a -> l a || r a + +infixr 2 ||| + + +-- * Clones + +-- | 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/PriceDb.hs b/Penny/Lincoln/PriceDb.hs --- a/Penny/Lincoln/PriceDb.hs +++ b/Penny/Lincoln/PriceDb.hs @@ -13,10 +13,8 @@ ) where import qualified Control.Monad.Exception.Synchronous as Ex -import qualified Data.Foldable as Fdbl import qualified Data.Map as M import qualified Data.Time as T -import qualified Penny.Lincoln.NestedMap as NM import qualified Penny.Lincoln.Bits as B type CpuMap = M.Map T.UTCTime B.CountPerUnit @@ -24,79 +22,43 @@ -- | The PriceDb holds information about prices. Create an empty one -- using 'emptyDb' then fill it with values using foldl or similar. -newtype PriceDb = PriceDb (NM.NestedMap B.SubCommodity ToMap) +newtype PriceDb = PriceDb (M.Map B.From ToMap) -- | An empty PriceDb emptyDb :: PriceDb -emptyDb = PriceDb NM.empty +emptyDb = PriceDb M.empty -- | Add a single price to the PriceDb. addPrice :: PriceDb -> B.PricePoint -> PriceDb -addPrice (PriceDb db) pp@(B.PricePoint _ pr _) = - PriceDb $ NM.relabel db ls where - ls = firsts ++ [lst] - cmdtyList = Fdbl.toList . B.unCommodity . B.unFrom . B.from $ pr - firsts = map toFst (init cmdtyList) where - toFst cty = (cty, f) - f maybeL = case maybeL of - Nothing -> M.empty - Just m -> m - lst = (last cmdtyList, insertIntoToMap pp) +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 --- | Returns a function to use when inserting a new value into the --- ToMap label of a PriceDb. -insertIntoToMap :: - B.PricePoint - -> Maybe ToMap - -> ToMap -insertIntoToMap (B.PricePoint dt pr _) = - let toCmdty = B.to pr - newToMap oldMap = M.alter alterTo toCmdty oldMap - alterTo mayCpuMap = - let newKey = dateTimeToUTC dt - newVal = B.countPerUnit pr - in Just $ case mayCpuMap of - Nothing -> M.singleton newKey newVal - Just m -> M.insert newKey newVal m - relabeler maybeToMap = - newToMap (maybe M.empty id maybeToMap) - in relabeler -dateTimeToUTC :: B.DateTime -> T.UTCTime -dateTimeToUTC dt = T.localTimeToUTC tz lt where - tz = T.minutesToTimeZone . B.offsetToMins $ tzo - lt = B.localTime dt - tzo = B.timeZone dt - - -- | 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. -- --- First, tries to find the best possible From match. For example, if --- From is LUV:2001, first tries to see if there is a From match for --- LUV:2001. If there is not an exact match for LUV:2001 but there --- is a match for LUV, then LUV is used. If there is not a match --- for either LUV:2001 or for LUV, then FromNotFound is thrown. --- --- The To commodity must match exactly. So, if the TO commodity is --- LUV:2001, only LUV:2001 will do. If the To commodity is not --- found, ToNotFound is thrown. --- -- 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. --- --- There is no backtracking on earlier decisions. For example, if From --- is LUV:2001, and there is indeed at least one From price in the --- PriceDb and CpuNotFound occurs, getPrice does not check to see if --- the computation would have succeeded had it used LUV rather than --- LUV:2001. getPrice :: PriceDb @@ -105,23 +67,18 @@ -> B.DateTime -> Ex.Exceptional PriceDbError B.CountPerUnit getPrice (PriceDb db) fr to dt = do - let utc = dateTimeToUTC dt - subs = Fdbl.toList . B.unCommodity . B.unFrom $ fr - toMap <- case NM.descend subs db of - [] -> Ex.throw FromNotFound - xs -> return . snd . last $ xs - cpuMap <- case M.lookup to toMap of - Nothing -> Ex.throw ToNotFound - Just m -> return m + 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 - cpu <- case exact of + case exact of Just c -> return c Nothing -> if M.null lower then Ex.throw CpuNotFound else return . snd . M.findMax $ lower - return cpu + -- | 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 @@ -132,8 +89,10 @@ -> B.DateTime -> B.To -> B.Amount - -> Ex.Exceptional PriceDbError B.Amount -convert db dt to (B.Amount qt fr) = do - cpu <- fmap B.unCountPerUnit (getPrice db (B.From fr) to dt) - let qt' = B.mult cpu qt - return $ B.Amount qt' (B.unTo to) + -> 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 --- a/Penny/Lincoln/Queries.hs +++ b/Penny/Lincoln/Queries.hs @@ -1,10 +1,10 @@ module Penny.Lincoln.Queries where import qualified Penny.Lincoln.Bits as B -import qualified Penny.Lincoln.Meta as M 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 best :: (T.Posting -> Maybe a) @@ -25,15 +25,18 @@ flag :: T.PostFam -> Maybe B.Flag flag = best T.pFlag T.tFlag -postingMemo :: T.PostFam -> B.Memo +postingMemo :: T.PostFam -> Maybe B.Memo postingMemo = T.pMemo . child . T.unPostFam -transactionMemo :: T.PostFam -> B.Memo +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 @@ -58,35 +61,32 @@ commodity :: T.PostFam -> B.Commodity commodity = B.commodity . amount -postingMeta :: T.PostFam -> M.PostingMeta -postingMeta = T.pMeta . child . T.unPostFam - -topLineMeta :: T.PostFam -> M.TopLineMeta -topLineMeta = T.tMeta . parent . T.unPostFam +topMemoLine :: T.PostFam -> Maybe B.TopMemoLine +topMemoLine = T.tTopMemoLine . parent . T.unPostFam -topMemoLine :: T.PostFam -> Maybe M.TopMemoLine -topMemoLine = M.topMemoLine . topLineMeta +topLineLine :: T.PostFam -> Maybe B.TopLineLine +topLineLine = T.tTopLineLine . parent . T.unPostFam -topLineLine :: T.PostFam -> Maybe M.TopLineLine -topLineLine = M.topLineLine . topLineMeta +filename :: T.PostFam -> Maybe B.Filename +filename = T.tFilename . parent . T.unPostFam -filename :: T.PostFam -> Maybe M.Filename -filename = M.filename . topLineMeta +globalTransaction :: T.PostFam -> Maybe B.GlobalTransaction +globalTransaction = T.tGlobalTransaction . parent . T.unPostFam -globalTransaction :: T.PostFam -> Maybe M.GlobalTransaction -globalTransaction = M.globalTransaction . topLineMeta +fileTransaction :: T.PostFam -> Maybe B.FileTransaction +fileTransaction = T.tFileTransaction . parent . T.unPostFam -fileTransaction :: T.PostFam -> Maybe M.FileTransaction -fileTransaction = M.fileTransaction . topLineMeta +postingLine :: T.PostFam -> Maybe B.PostingLine +postingLine = T.pPostingLine . child . T.unPostFam -postingLine :: T.PostFam -> Maybe M.PostingLine -postingLine = M.postingLine . postingMeta +side :: T.PostFam -> Maybe B.Side +side = B.side . amount -postingFormat :: T.PostFam -> Maybe M.Format -postingFormat = M.postingFormat . postingMeta +spaceBetween :: T.PostFam -> Maybe B.SpaceBetween +spaceBetween = B.spaceBetween . amount -globalPosting :: T.PostFam -> Maybe M.GlobalPosting -globalPosting = M.globalPosting . postingMeta +globalPosting :: T.PostFam -> Maybe B.GlobalPosting +globalPosting = T.pGlobalPosting . child . T.unPostFam -filePosting :: T.PostFam -> Maybe M.FilePosting -filePosting = M.filePosting . postingMeta +filePosting :: T.PostFam -> Maybe B.FilePosting +filePosting = T.pFilePosting . child . T.unPostFam diff --git a/Penny/Lincoln/Serial.hs b/Penny/Lincoln/Serial.hs --- a/Penny/Lincoln/Serial.hs +++ b/Penny/Lincoln/Serial.hs @@ -1,105 +1,58 @@ module Penny.Lincoln.Serial ( - Serial, forward, backward, serials, - serialItems, serialItemsM, - serialChildrenInFamily, serialEithers, - NextFwd, NextBack, initNexts) where - -import Control.Monad (zipWithM) -import Control.Monad.Trans.Class (lift) -import qualified Data.Either as E -import qualified Penny.Lincoln.Family as F -import qualified Control.Monad.Trans.State as St - --- | A type for serial numbers, used widely for different purposes --- throughout Penny. - -data Serial = Serial { - -- | Numbered from first to last, beginning at zero. - forward :: !Int - - -- | Numbered from last to first, ending at zero. - , backward :: !Int + Serial, forward, backward, GenSerial, + incrementBack, getSerial, makeSerials, serialItems, + nSerials ) where - } deriving (Eq, Show) - +import Control.Applicative (Applicative, (<*>), pure, (*>)) +import Control.Monad (ap) --- | Label a list of items with serials. -serialItems :: (Serial -> a -> b) - -> [a] - -> [b] -serialItems f as = - let ss = serials as - in zipWith f ss as +data SerialSt = SerialSt + { nextFwd :: Int + , nextBack :: Int + } deriving Show --- | Label a list of items with serials, in a monad. -serialItemsM :: - Monad m - => (Serial -> a -> m b) - -> [a] - -> m [b] -serialItemsM f as = - let ss = serials as - in zipWithM f ss as +data Serial = Serial + { forward :: Int + , backward :: Int + } deriving (Eq, Show, Ord) --- | Applied to a list of items, return a list of Serials usable to --- identify the list of items. -serials :: [a] -> [Serial] -serials as = zipWith Serial fs rs where - len = length as - fs = take len . iterate succ $ 0 - rs = take len . iterate pred $ (len - 1) +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') -serialChildrenInFamily :: - (Serial -> cOld -> cNew) - -> F.Family p cOld - -> St.State (NextFwd, NextBack) (F.Family p cNew) -serialChildrenInFamily f = F.mapChildrenM (serialItemSt f) +instance Applicative GenSerial where + pure = return + (<*>) = ap -newtype NextFwd = NextFwd Int deriving Show -newtype NextBack = NextBack Int deriving Show +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' -serialItemSt :: - (Serial -> cOld -> cNew) - -> cOld - -> St.State (NextFwd, NextBack) cNew -serialItemSt f old = do - (NextFwd fwd, NextBack bak) <- St.get - let s = Serial fwd bak - St.put (NextFwd $ succ fwd, NextBack $ pred bak) - return (f s old) +incrementBack :: GenSerial () +incrementBack = GenSerial $ \s -> + let s' = SerialSt (nextFwd s) (nextBack s + 1) + in ((), s') -newtype Index = Index Int deriving (Eq, Ord, Show) -newtype Total = Total Int deriving (Eq, Ord, Show) +getSerial :: GenSerial Serial +getSerial = GenSerial $ \s -> + let s' = SerialSt (nextFwd s + 1) (nextBack s - 1) + in (Serial (nextFwd s) (nextBack s), s') -serialEithers :: - Monad m - => (Serial -> a -> m c) - -> (Serial -> b -> m d) - -> [Either a b] - -> m [Either c d] -serialEithers fa fb ls = - let allA = E.lefts ls - allB = E.rights ls - totA = Total . length $ allA - totB = Total . length $ allB - initState = (0 :: Int, 0 :: Int) - k e = do - (nextA, nextB) <- St.get - case e of - Left a -> do - c <- lift $ fa (serial totA (Index nextA)) a - St.put (succ nextA, nextB) - return $ Left c - Right b -> do - d <- lift $ fb (serial totB (Index nextB)) b - St.put (nextA, succ nextB) - return $ Right d - in St.evalStateT (mapM k ls) initState +makeSerials :: GenSerial a -> a +makeSerials (GenSerial k) = + let (r, _) = k (SerialSt 0 0) in r -serial :: Total -> Index -> Serial -serial (Total t) (Index i) = Serial i b where - b = t - i - 1 +serialItems :: (Serial -> a -> b) -> [a] -> [b] +serialItems f as = zipWith f (nSerials (length as)) as -initNexts :: Int -> (NextFwd, NextBack) -initNexts i = (NextFwd 0, NextBack $ i - 1) +nSerials :: Int -> [Serial] +nSerials n = + makeSerials $ + (sequence . replicate n $ incrementBack) + *> (sequence . replicate n $ getSerial) diff --git a/Penny/Lincoln/TextNonEmpty.hs b/Penny/Lincoln/TextNonEmpty.hs deleted file mode 100644 --- a/Penny/Lincoln/TextNonEmpty.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Penny.Lincoln.TextNonEmpty ( - TextNonEmpty (TextNonEmpty, first, rest), - unsafeTextNonEmpty, - any, all, - toText) where - -import Prelude hiding (any, all) -import Data.Text ( Text, pack, cons ) -import qualified Data.Text as X - -data TextNonEmpty = TextNonEmpty { first :: Char - , rest :: Text } - deriving (Eq, Ord, Show) - -unsafeTextNonEmpty :: String -> TextNonEmpty -unsafeTextNonEmpty s = TextNonEmpty (head s) (pack . tail $ s) - -any :: (Char -> Bool) -> TextNonEmpty -> Bool -any f (TextNonEmpty c ts) = f c || X.any f ts - -all :: (Char -> Bool) -> TextNonEmpty -> Bool -all f (TextNonEmpty c ts) = f c && X.all f ts - -toText :: TextNonEmpty -> Text -toText (TextNonEmpty t ts) = t `cons` ts diff --git a/Penny/Lincoln/Transaction.hs b/Penny/Lincoln/Transaction.hs --- a/Penny/Lincoln/Transaction.hs +++ b/Penny/Lincoln/Transaction.hs @@ -19,50 +19,62 @@ -- 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), + PostFam, + unPostFam, - -- * Making transactions + -- * Making and deconstructing transactions transaction, + RTransaction(..), + rTransaction, Error ( UnbalancedError, CouldNotInferError), - + toUnverified, + -- * Querying postings Inferred(Inferred, NotInferred), pPayee, pNumber, pFlag, pAccount, pTags, - pEntry, pMemo, pInferred, pMeta, changePostingMeta, + pEntry, pMemo, pInferred, pPostingLine, + pGlobalPosting, pFilePosting, -- * Querying transactions TopLine, - tDateTime, tFlag, tNumber, tPayee, tMemo, tMeta, - unTransaction, postFam, changeTransactionMeta, - - -- * Adding serials - addSerialsToList, addSerialsToEithers, - + tDateTime, tFlag, tNumber, tPayee, tMemo, tTopLineLine, + tTopMemoLine, tFilename, tGlobalTransaction, tFileTransaction, + unTransaction, postFam, + -- * Box - Box ( Box, boxMeta, boxPostFam ) - + 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.Meta as M 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 qualified Penny.Lincoln.Serial as Ser import Control.Monad.Exception.Synchronous ( Exceptional (Exception, Success) , throw ) import qualified Control.Monad.Exception.Synchronous as Ex -import qualified Data.Either as E import qualified Data.Foldable as Fdbl -import Data.Maybe ( catMaybes ) +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 ) @@ -74,15 +86,18 @@ -- | 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 :: B.Memo + 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 - , pMeta :: M.PostingMeta } + , 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 @@ -90,11 +105,15 @@ -- appears on the top line.) data TopLine = TopLine { tDateTime :: B.DateTime - , tFlag :: (Maybe B.Flag) - , tNumber :: (Maybe B.Number) - , tPayee :: (Maybe B.Payee) - , tMemo :: B.Memo - , tMeta :: M.TopLineMeta } + , 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 @@ -103,7 +122,7 @@ newtype Transaction = Transaction { unTransaction :: F.Family TopLine Posting } deriving (Eq, Show) - + -- | Errors that can arise when making a Transaction. data Error = UnbalancedError | CouldNotInferError @@ -127,6 +146,13 @@ -} +-- | 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 @@ -144,14 +170,14 @@ Fdbl.foldr1 Bal.addBalances . catMaybes . Fdbl.toList - . fmap (fmap Bal.entryToBalance . U.entry) + . fmap (fmap Bal.entryToBalance . U.pEntry) infer :: U.Posting -> Ex.ExceptionalT Error (St.State (Maybe B.Entry)) Posting infer po = - case U.entry po of + case U.pEntry po of Nothing -> do st <- lift St.get case st of @@ -160,7 +186,7 @@ lift $ St.put Nothing return $ toPosting po e Inferred (Just e) -> return $ toPosting po e NotInferred - + runInfer :: Maybe B.Entry -> S.Siblings U.Posting @@ -170,7 +196,7 @@ ext = Ex.runExceptionalT (Tr.mapM infer pos) case finalSt of (Just _) -> throw UnbalancedError - Nothing -> case res of + Nothing -> case res of (Exception e) -> throw e (Success g) -> return g @@ -185,86 +211,153 @@ 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.Posting p n f a t _ m mt) e i = - Posting p n f a t e m i mt +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 (U.TopLine d f n p m mt) = - TopLine d f n p m mt +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 + } --- | Change the metadata on a transaction. -changeTransactionMeta :: - (M.TopLineMeta -> M.TopLineMeta) - -- ^ Function that, when applied to the old top line meta, returns - -- the new meta. - - -> Transaction - -- ^ The old transaction with metadata +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 + } - -> Transaction - -- ^ Transaction with new metadata +data RTransaction = RTransaction + { rtCommodity :: B.Commodity + -- ^ All postings will have this same commodity -changeTransactionMeta fm (Transaction f) = Transaction f' where - f' = F.Family tl c1 c2 cs - (F.Family p c1 c2 cs) = f - tl = p { tMeta = fm (tMeta tl) } + , rtSide :: Maybe B.Side + -- ^ All commodities will be on this side of the amount --- | Change the metadata on a posting. -changePostingMeta :: - (M.PostingMeta -> M.PostingMeta) - -> Transaction - -> Transaction -changePostingMeta f (Transaction fam) = - Transaction . F.mapChildren g $ fam - where - g p = p { pMeta = f (pMeta p) } + , rtSpaceBetween :: Maybe B.SpaceBetween + -- ^ All amounts will have this SpaceBetween -addSerials :: - (Ser.Serial -> M.TopLineMeta -> M.TopLineMeta) - -> (Ser.Serial -> M.PostingMeta -> M.PostingMeta) - -> Ser.Serial - -> Transaction - -> St.State (Ser.NextFwd, Ser.NextBack) Transaction -addSerials ft fp s (Transaction fam) = do - let topMapper pm = pm { tMeta = ft s (tMeta pm) } - pstgMapper ser pstg = pstg { pMeta = fp ser (pMeta pstg) } - fam' = F.mapParent topMapper fam - fam'' <- Ser.serialChildrenInFamily pstgMapper fam' - return $ Transaction fam'' + , rtDrCr :: B.DrCr + -- ^ All postings except the inferred one will have this DrCr -addSerialsToList :: - (Ser.Serial -> M.TopLineMeta -> M.TopLineMeta) - -> (Ser.Serial -> M.PostingMeta -> M.PostingMeta) - -> [Transaction] - -> [Transaction] -addSerialsToList ft fp ls = - let nPstgs = length . concatMap Fdbl.toList . map orphans - . map unTransaction $ ls - initState = Ser.initNexts nPstgs - processor = addSerials ft fp - in St.evalState (Ser.serialItemsM processor ls) initState + , rtTopLine :: U.TopLine + , rtPosting :: U.RPosting + -- ^ You must have at least one posting whose quantity you specify -addSerialsToEithers :: - (Ser.Serial -> M.TopLineMeta -> M.TopLineMeta) - -> (Ser.Serial -> M.PostingMeta -> M.PostingMeta) - -> [Either a Transaction] - -> [Either a Transaction] -addSerialsToEithers ft fp ls = - let txns = E.rights ls - nPstgs = length . concatMap Fdbl.toList . map orphans - . map unTransaction $ txns - initState = Ser.initNexts nPstgs - processA _ a = return a - processTxn = addSerials ft fp - k = Ser.serialEithers processA processTxn ls - in St.evalState k initState + , 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 @@ -276,3 +369,130 @@ 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 --- a/Penny/Lincoln/Transaction/Unverified.hs +++ b/Penny/Lincoln/Transaction/Unverified.hs @@ -1,27 +1,131 @@ +-- | 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 -import qualified Penny.Lincoln.Meta as M data TopLine = TopLine - B.DateTime - (Maybe B.Flag) - (Maybe B.Number) - (Maybe B.Payee) - B.Memo - M.TopLineMeta - deriving (Eq, Show) + { 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 - (Maybe B.Payee) - (Maybe B.Number) - (Maybe B.Flag) - B.Account - B.Tags - (Maybe B.Entry) - B.Memo - M.PostingMeta - deriving (Eq, Show) + { 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) -entry :: Posting -> Maybe B.Entry -entry (Posting _ _ _ _ _ e _ _) = e +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 --- a/Penny/Shield.hs +++ b/Penny/Shield.hs @@ -48,16 +48,15 @@ , currentTime :: B.DateTime , output :: Output } -zonedToDateTime :: T.ZonedTime -> B.DateTime -zonedToDateTime (T.ZonedTime lt tz) = B.dateTime lt off where - off = maybe (error "could not convert time to local time") - id (B.minsToOffset (T.timeZoneMinutes tz)) - runtime :: IO Runtime runtime = Runtime <$> getEnvironment - <*> (zonedToDateTime <$> T.getZonedTime) + <*> (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 @@ -65,7 +64,7 @@ return $ if isTerm then IsTTY else NotTTY screenLines :: Runtime -> Maybe ScreenLines -screenLines r = +screenLines r = (lookup "LINES" . environment $ r) >>= safeRead >>= return . ScreenLines diff --git a/Penny/Zinc.hs b/Penny/Zinc.hs --- a/Penny/Zinc.hs +++ b/Penny/Zinc.hs @@ -1,29 +1,716 @@ -- | Zinc - the Penny command-line interface -module Penny.Zinc (runPenny, P.T(..), - P.defaultFromRuntime) where - -import qualified Control.Monad.Exception.Synchronous as Ex -import qualified System.Console.MultiArg.Prim as M -import System.Console.MultiArg.GetArgs (getArgs) -import System.Exit (exitFailure) -import System.IO (stderr, hPutStrLn) +module Penny.Zinc + ( Defaults(..) + , ColorToFile(..) + , Matcher(..) + , SortField(..) + , runZinc + ) where +import qualified Penny.Cabin.Chunk as Chk import qualified Penny.Cabin.Interface as I -import qualified Penny.Copper as Cop +import qualified Penny.Cabin.Parsers as P +import qualified Penny.Cabin.Scheme as E +import qualified Penny.Copper as C +import qualified Penny.Liberty as Ly +import qualified Penny.Liberty.Expressions as X +import qualified Penny.Lincoln as L +import qualified Penny.Lincoln.Queries as Q import qualified Penny.Shield as S -import qualified Penny.Zinc.Parser as P -runPenny :: - S.Runtime - -> Cop.DefaultTimeZone - -> Cop.RadGroup - -> (S.Runtime -> P.T) +import Control.Applicative ((<$>), (<*>), pure) +import Control.Monad (when) +import qualified Control.Monad.Trans.State as St +import qualified Control.Monad.Exception.Synchronous as Ex +import Data.Char (toUpper, toLower) +import Data.List (isPrefixOf) +import Data.Maybe (mapMaybe, catMaybes) +import Data.Monoid (mappend, mconcat) +import Data.Ord (comparing) +import Data.Text (Text, pack, unpack) +import qualified Data.Text.IO as TIO +import qualified System.Console.MultiArg as MA +import System.Console.MultiArg.GetArgs (getArgs) +import System.Exit (exitSuccess, exitFailure) +import qualified System.IO as IO +import System.IO (hIsTerminalDevice, stdin, stderr, hPutStrLn) +import qualified Text.Matchers.Text as M + +runZinc + :: Defaults + -> S.Runtime -> [I.Report] -> IO () -runPenny rt dtz rg df rs = do +runZinc df rt rs = do as <- getArgs - case M.parse as (P.parser rt dtz rg df rs) of + parseAndPrint df rt rs as + +-- | 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)] + } + +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 + +data State = State + { stSensitive :: M.CaseSensitive + , stFactory :: M.CaseSensitive -> Text + -> Ex.Exceptional Text (Text -> Bool) + , stColorToFile :: ColorToFile + , stScheme :: Maybe E.TextSpecs + } + +stateFromDefaults + :: Defaults + -> State +stateFromDefaults df = State + { stSensitive = sensitive df + , stFactory = 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 + , stColorToFile = colorToFile df + , stScheme = fmap E.textSpecs . defaultScheme $ df + } + +-- +-- ## Option parsing +-- + +-- +-- ## OptResult, and functions dealing with it +-- +data OptResult + = ROperand (M.CaseSensitive + -> Ly.MatcherFactory + -> Ex.Exceptional String Ly.Operand) + | RPostFilter (Ex.Exceptional String Ly.PostFilterFn) + | RMatcherSelect Ly.MatcherFactory + | RCaseSelect M.CaseSensitive + | ROperator (Ly.Token (L.PostFam -> Bool)) + | RSortSpec (Ex.Exceptional String Orderer) + | RHelp + | RColorToFile ColorToFile + | RScheme E.TextSpecs + +isHelp :: OptResult -> Bool +isHelp o = case o of { RHelp -> True; _ -> False } + +getPostFilters + :: [OptResult] + -> Ex.Exceptional String [Ly.PostFilterFn] +getPostFilters = + sequence + . mapMaybe f + where + f o = case o of + RPostFilter pf -> Just pf + _ -> Nothing + +getSortSpec + :: Orderer + -> [OptResult] + -> Ex.Exceptional String 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 + +type Factory = M.CaseSensitive + -> Text -> Ex.Exceptional Text (Text -> Bool) + +makeToken + :: OptResult + -> St.State (M.CaseSensitive, Factory) + (Maybe (Ex.Exceptional String (Ly.Token (L.PostFam -> Bool)))) +makeToken o = case o of + ROperand f -> do + (s, fty) <- St.get + let g = fmap h (f s fty) + h (X.Operand fn) = Ly.TokOperand fn + 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 + :: State + -> [OptResult] + -> Ex.Exceptional String ( [Ly.Token (L.PostFam -> Bool)] + , (M.CaseSensitive, Factory) ) +makeTokens df os = + let initSt = (stSensitive df, stFactory df) + lsSt = mapM makeToken os + (ls, st') = St.runState lsSt initSt + in fmap (\xs -> (xs, st')) . sequence . catMaybes $ ls + + +allOpts :: L.DateTime -> Defaults -> [MA.OptSpec OptResult] +allOpts 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] + ++ [ MA.OptSpec ["help"] "h" (MA.NoArg RHelp) + , optColorToFile ] + ++ let ss = moreSchemes df + in if not . null $ ss then [optScheme ss] else [] + +optColorToFile :: MA.OptSpec OptResult +optColorToFile = MA.OptSpec ["color-to-file"] "" (MA.ChoiceArg ls) + where + ls = [ ("yes", RColorToFile $ ColorToFile True) + , ("no", RColorToFile $ ColorToFile False) ] + +getColorToFile :: State -> [OptResult] -> ColorToFile +getColorToFile d ls = + case mapMaybe getOpt ls of + [] -> stColorToFile 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 :: State -> [OptResult] -> Maybe E.TextSpecs +getScheme d ls = + case mapMaybe getOpt ls of + [] -> stScheme d + xs -> Just $ last xs + where + getOpt o = case o of + RScheme s -> Just s + _ -> Nothing + +data GlobalResult + = NeedsHelp + | RunPenny FilterOpts + +-- | Indicates the result of a successful parse of filtering options. +data FilterOpts = FilterOpts + { _resultFactory :: M.CaseSensitive + -> Text -> Ex.Exceptional Text (Text -> Bool) + -- ^ The factory indicated, so that it can be used in + -- subsequent parses of the same command line. + + , _resultSensitive :: M.CaseSensitive + -- ^ Indicated case sensitivity, so that it can be used in + -- subsequent parses of the command line. + + , _sorterFilterer :: [L.Transaction] -> [L.Box Ly.LibertyMeta] + -- ^ Applied to a list of Transaction, will sort and filter + -- the transactions and assign them LibertyMeta. + + , foTextSpecs :: Maybe E.TextSpecs + + , foColorToFile :: ColorToFile + } + +processGlobal + :: Orderer + -> State + -> [OptResult] + -> Ex.Exceptional String GlobalResult +processGlobal srt st os = + if any isHelp os + then return NeedsHelp + else do + postFilts <- getPostFilters os + sortSpec <- getSortSpec srt os + (toks, (rs, rf)) <- makeTokens st os + let ctf = getColorToFile st os + sch = getScheme st os + err = "could not parse filter expression." + pdct <- Ex.fromMaybe err $ Ly.parsePredicate toks + let sf = Ly.xactionsToFiltered pdct postFilts sortSpec + fo = FilterOpts rf rs sf sch ctf + return $ RunPenny fo + +-- +-- Ledger parsing +-- +warnTerminal :: IO () +warnTerminal = + hPutStrLn stderr $ "penny: warning: reading from standard input, " + ++ "which is a terminal" + +data Filename = + Filename Text + | Stdin + +-- | Converts a Ledgers filename to a Lincoln filename. +convertFilename :: Filename -> L.Filename +convertFilename (Filename x) = L.Filename x +convertFilename Stdin = L.Filename . pack $ "" + +-- | Actually reads the file off disk. For now just let this crash if +-- any of the IO errors occur. +ledgerText :: Filename -> IO Text +ledgerText f = case f of + Stdin -> do + isTerm <- hIsTerminalDevice stdin + when isTerm warnTerminal + TIO.hGetContents stdin + Filename fn -> TIO.readFile (unpack fn) + +-- | Converts a string from the command line to a Filename. +toFilename :: String -> Filename +toFilename s = + if s == "-" + then Stdin + else Filename . pack $ s + +readLedgers :: [String] -> IO [(Filename, Text)] +readLedgers ss = + let fns = if null ss then [Stdin] else map toFilename ss + f fn = (\txt -> (fn, txt)) <$> ledgerText fn + in mapM f fns + + +parseLedgers + :: [(Filename, Text)] + -> Ex.Exceptional String ([L.Transaction], [L.PricePoint]) +parseLedgers ls = + let toPair (f, t) = (convertFilename f, C.FileContents t) + parsed = C.parse (map toPair ls) + folder i (ts, ps) = case i of + C.Transaction t -> (t:ts, ps) + C.PricePoint p -> (ts, p:ps) + _ -> (ts, ps) + toResult (C.Ledger is) = foldr folder ([], []) is + toErr x = "could not parse ledger: " + ++ (unpack . C.unErrorMsg $ x) + in Ex.mapExceptional toErr toResult parsed + + +data DisplayOpts = DisplayOpts ColorToFile (Maybe E.TextSpecs) + +toDisplayOpts :: FilterOpts -> DisplayOpts +toDisplayOpts o = DisplayOpts (foColorToFile o) (foTextSpecs o) + +parseCommandLine + :: Defaults + -> [I.Report] + -> S.Runtime + -> [String] + -> Ex.Exceptional MA.Error + (GlobalResult, Either [()] (DisplayOpts, I.ParseResult)) +parseCommandLine df rs rt ss = + let initSt = stateFromDefaults df + in MA.modes (allOpts (S.currentTime rt) df) + (processGlobal (sortPairsToFn . sorter $ df) initSt) + (whatMode rt rs) ss + +whatMode + :: S.Runtime + -> [I.Report] + -> GlobalResult + -> Either (a -> ()) [MA.Mode (DisplayOpts, I.ParseResult)] +whatMode rt pairFns gr = + case gr of + NeedsHelp -> Left $ const () + RunPenny fo@(FilterOpts fty cs sf _ _) -> + let prs = map snd (pairFns <*> pure rt) + <*> pure cs + <*> pure fty + <*> pure sf + in Right $ map (fmap (\r -> ((toDisplayOpts fo), r))) prs + +handleParseResult + :: S.Runtime + -> Defaults + -> [I.Report] + -> Ex.Exceptional MA.Error + (a, Either b (DisplayOpts, I.ParseResult)) + -> IO () +handleParseResult rt df rs r = + let showErr e = do + IO.hPutStrLn IO.stderr $ "penny: error: " ++ e + exitFailure + in case r of Ex.Exception e -> do - hPutStrLn stderr . show $ e + IO.hPutStr IO.stderr $ MA.formatError "penny" e exitFailure - Ex.Success g -> g + Ex.Success (_, ei) -> + case ei of + Left _ -> putStr (helpText df rt rs) >> exitSuccess + Right ((DisplayOpts ctf sch), ex) -> case ex of + Ex.Exception s -> showErr s + Ex.Success good -> either showHelp runCmd good + where + showHelp h = putStr h >> exitSuccess + runCmd (fns, pr) = do + ledgers <- readLedgers fns + (txns, pps) <- Ex.switch showErr return + $ parseLedgers ledgers + let term = if unColorToFile ctf + then Chk.termFromEnv rt + else Chk.autoTerm rt + Ex.switch (showErr . unpack) + (printChunks term sch) $ pr txns pps + +printChunks + :: Chk.Term + -> Maybe E.TextSpecs + -> [E.PreChunk] + -> IO () +printChunks t mayS = + Chk.printChunks t + . map makeChunk + where + makeChunk pc = case mayS of + Nothing -> Chk.chunk Chk.defaultTextSpec (E.text pc) + Just s -> E.makeChunk s pc + +helpText + :: Defaults + -> S.Runtime + -> [I.Report] + -> String +helpText df rt pairMakers = + mappend (help df) . mconcat . map addHdr . fmap fst $ pairs + where + pairs = pairMakers <*> pure rt + addHdr s = hdr ++ s + hdr = unlines [ "", replicate 50 '=' ] + + +parseAndPrint + :: Defaults + -> S.Runtime + -> [I.Report] + -> [String] + -> IO () +parseAndPrint df rt rs ss = + handleParseResult rt df rs + $ parseCommandLine df rs rt ss + +------------------------------------------------------------ +-- ## 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 String 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 $ "invalid sort key: " ++ a + + + +------------------------------------------------------------ +-- ## Help +------------------------------------------------------------ + +help :: Defaults -> String +help d = unlines $ + [ "usage: penny [posting filters] report [report options] file . . ." + , "" + , "Posting filters" + , "------------------------------------------" + , "" + , "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)" + , "" + , "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" + , "" + , "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" + , "" + , "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) + + , "" + + , "--within" + , " Use \"within\" matcher" + ++ ifDefault (matcher d == Within) + + , "--pcre" + , " Use \"pcre\" matcher" + ++ ifDefault (matcher d == PCRE) + + , "--posix" + , " Use \"posix\" matcher" + ++ ifDefault (matcher d == TDFA) + + , "--exact" + , " Use \"exact\" matcher" + ++ ifDefault (matcher d == Exact) + + , "" + , "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)" + ] + +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/Zinc/Error.hs b/Penny/Zinc/Error.hs deleted file mode 100644 --- a/Penny/Zinc/Error.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Penny.Zinc.Error where - -import Data.Text (Text, pack) - -data Error = - ParseError Text - | ReportError Text - deriving Show - -printError :: Error -> Text -printError = pack . show diff --git a/Penny/Zinc/Help.hs b/Penny/Zinc/Help.hs deleted file mode 100644 --- a/Penny/Zinc/Help.hs +++ /dev/null @@ -1,125 +0,0 @@ -module Penny.Zinc.Help where - -import Data.Text (Text, pack) - -help :: Text -help = pack $ unlines [ - "usage: zinc [posting filters] report [report options] file . . .", - "", - "Posting filters", - "------------------------------------------", - "", - "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)", - "", - "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", - "--commodity-level num pattern", - " Pattern must match sub commodity at given level", - "--commodity-any pattern", - " Pattern must match sub commodity at any level", - "--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", - "", - "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", - "", - "Options affecting patterns", - "--------------------------", - "", - "-i, --case-insensitive", - " Be case insensitive (default)", - "-I, --case-sensitive", - " Be case sensitive", - "", - "--within", - " Use \"within\" matcher (default)", - "--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", - "", - "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.", - "" - ] diff --git a/Penny/Zinc/Parser.hs b/Penny/Zinc/Parser.hs deleted file mode 100644 --- a/Penny/Zinc/Parser.hs +++ /dev/null @@ -1,86 +0,0 @@ -module Penny.Zinc.Parser ( - Defaults.T(..) - , Defaults.defaultFromRuntime - , parser - ) where - -import qualified Control.Monad.Exception.Synchronous as Ex -import Data.Monoid (mappend, mconcat) -import qualified Data.Text as X -import qualified Data.Text.IO as StrictIO -import qualified Data.Text.Lazy.IO as LazyIO -import System.Console.MultiArg.Prim (Parser) -import System.Exit (exitSuccess, exitFailure) -import System.IO (stderr, hPutStrLn) -import qualified Penny.Cabin.Interface as I -import qualified Penny.Shield as S -import qualified Penny.Zinc.Help as Help -import qualified Penny.Zinc.Parser.Filter as F -import qualified Penny.Zinc.Parser.Report as R -import qualified Penny.Zinc.Parser.Ledgers as L -import qualified Penny.Zinc.Parser.Defaults as Defaults - -import Penny.Copper.DateTime (DefaultTimeZone) -import Penny.Copper.Qty (RadGroup) - --- | Parses all command line options and arguments. Returns an IO --- action which will print appropriate error messages if something --- failed, or will print a report and exit successfully if everything --- went well. -parser :: - S.Runtime - -> DefaultTimeZone - -> RadGroup - -> (S.Runtime -> Defaults.T) - -> [I.Report] - -> Parser (IO ()) -parser rt dtz rg getDf rs = do - let df = getDf rt - errFilt <- F.parseFilter df - case errFilt of - Ex.Exception e -> return $ do - hPutStrLn stderr $ ("penny: error: " ++ show e) - exitFailure - Ex.Success r -> case r of - Left F.NeedsHelp -> return $ do - StrictIO.putStrLn . helpText $ rs - exitSuccess - Right rslt -> parseReportsAndFilesAndPrint rt dtz rg rs rslt - - --- | Returns an IO action that will parse the report options and the --- files on the command line and print the resulting report. -parseReportsAndFilesAndPrint :: - S.Runtime - -> DefaultTimeZone - -> RadGroup - -> [I.Report] - -> F.Result - -> Parser (IO ()) -parseReportsAndFilesAndPrint rt dtz rg rs rslt = do - let (F.Result factory sensitive sortFilt) = rslt - parserFunc <- R.report rs - let reportFunc = parserFunc rt sensitive factory - filenames <- L.filenames - return $ do - ledgers <- L.readLedgers filenames - let parsed = L.parseLedgers dtz rg ledgers - case parsed of - Ex.Exception e -> do - hPutStrLn stderr . show $ e - exitFailure - Ex.Success (txns, prices) -> do - let boxes = sortFilt txns - case reportFunc boxes prices of - Ex.Exception bad -> do - StrictIO.putStrLn bad - exitFailure - Ex.Success good -> do - LazyIO.putStr good - exitSuccess - -helpText :: - [I.Report] - -> X.Text -helpText = mappend Help.help . mconcat . fmap I.help - diff --git a/Penny/Zinc/Parser/Defaults.hs b/Penny/Zinc/Parser/Defaults.hs deleted file mode 100644 --- a/Penny/Zinc/Parser/Defaults.hs +++ /dev/null @@ -1,29 +0,0 @@ -module Penny.Zinc.Parser.Defaults where - -import qualified Text.Matchers.Text as M -import qualified Penny.Lincoln as L -import qualified Penny.Copper as Cop -import qualified Penny.Shield as S -import qualified Data.Text as X -import qualified Control.Monad.Exception.Synchronous as Ex - -data T = - T { sensitive :: M.CaseSensitive - , factory :: M.CaseSensitive -> X.Text - -> Ex.Exceptional X.Text (X.Text -> Bool) - , currentTime :: L.DateTime - , defaultTimeZone :: Cop.DefaultTimeZone - , radGroup :: Cop.RadGroup } - -defaultFromRuntime :: - Cop.DefaultTimeZone - -> Cop.RadGroup - -> S.Runtime - -> T -defaultFromRuntime dtz rg rt = - T { sensitive = M.Insensitive - , factory = (\c t -> return (M.within c t)) - , currentTime = S.currentTime rt - , defaultTimeZone = dtz - , radGroup = rg } - diff --git a/Penny/Zinc/Parser/Filter.hs b/Penny/Zinc/Parser/Filter.hs deleted file mode 100644 --- a/Penny/Zinc/Parser/Filter.hs +++ /dev/null @@ -1,265 +0,0 @@ -module Penny.Zinc.Parser.Filter ( - parseFilter - , Error(LibertyError, TokenParseError) - , NeedsHelp(NeedsHelp) - , Result(Result, resultFactory, resultSensitive, sorterFilterer) - ) where - -import Control.Applicative ((<|>), (<$>), Applicative, pure, many) -import Control.Monad ((>=>)) -import qualified Control.Monad.Exception.Synchronous as Ex -import Data.Monoid (mempty, mappend) -import Data.Text (Text) -import qualified Text.Matchers.Text as M -import qualified System.Console.MultiArg.Combinator as C -import System.Console.MultiArg.Prim (Parser) - -import qualified Penny.Copper as Cop -import qualified Penny.Lincoln as L -import qualified Penny.Liberty as Ly -import qualified Penny.Liberty.Expressions as X - -import qualified Penny.Zinc.Parser.Defaults as D -import qualified Penny.Zinc.Parser.Defaults as Defaults - --- | Parses all filtering options. Returns a parser that contains an --- Exception if some error occurred after parsing the options, or a --- Success with a result if the parse was successful. -parseFilter :: - Defaults.T - -> Parser (Ex.Exceptional Error (Either NeedsHelp Result)) -parseFilter d = fmap f (many parser) where - f ls = - let k = foldl (>=>) return ls - in case k (newState d) of - Ex.Success st' -> - if help st' - then return . Left $ NeedsHelp - else - case Ly.parsePredicate . tokens $ st' of - Nothing -> Ex.throw TokenParseError - Just pdct -> - let fn = Ly.xactionsToFiltered pdct - (postFilter st') (orderer st') - r = Result { resultFactory = factory st' - , resultSensitive = sensitive st' - , sorterFilterer = fn } - in return . Right $ r - Ex.Exception e -> Ex.Exception e - -data Error = LibertyError Ly.Error - | TokenParseError - deriving Show - --- | Returned if the user requested help. -data NeedsHelp = NeedsHelp - deriving Show - --- | Indicates the result of a successful parse of filtering options. -data Result = - Result { resultFactory :: M.CaseSensitive - -> Text -> Ex.Exceptional Text (Text -> Bool) - -- ^ The factory indicated, so that it can be used in - -- subsequent parses of the same command line. - - , resultSensitive :: M.CaseSensitive - -- ^ Indicated case sensitivity, so that it can be used in - -- subsequent parses of the command line. - - , sorterFilterer :: [L.Transaction] -> [L.Box Ly.LibertyMeta] - -- ^ Applied to a list of Transaction, will sort and filter - -- the transactions and assign them LibertyMeta. - } - - -data State = - State { sensitive :: M.CaseSensitive - , factory :: M.CaseSensitive - -> Text -> Ex.Exceptional Text (Text -> Bool) - , tokens :: [X.Token (L.PostFam -> Bool)] - , postFilter :: [Ly.PostFilterFn] - , orderer :: Ly.Orderer - , help :: Bool - , currentTime :: L.DateTime - , defaultTimeZone :: Cop.DefaultTimeZone - , radGroup :: Cop.RadGroup } - -newState :: - Defaults.T - -> State -newState d = - State { sensitive = D.sensitive d - , factory = D.factory d - , tokens = [] - , postFilter = [] - , orderer = mempty - , help = False - , currentTime = D.currentTime d - , defaultTimeZone = D.defaultTimeZone d - , radGroup = D.radGroup d } - -parser :: Parser (State -> Ex.Exceptional Error State) -parser = - operand - <|> parsePostFilter - <|> impurify parseMatcherSelect - <|> impurify parseCaseSelect - <|> impurify parseOperator - <|> parseSort - <|> impurify parseHelp - -option :: [String] -> [Char] -> C.ArgSpec a -> Parser a -option ss cs a = C.parseOption [C.OptSpec ss cs a] - -operand :: Parser (State -> Ex.Exceptional Error State) -operand = f <$> Ly.parseOperand - where - f lyFn = - let g st = - let r = lyFn (currentTime st) (defaultTimeZone st) - (radGroup st) (sensitive st) (factory st) - in case r of - Ex.Exception e -> Ex.throw . LibertyError $ e - Ex.Success (X.Operand o) -> - let tok' = tokens st ++ [X.TokOperand o] - in return st { tokens = tok' } - in g - -parsePostFilter :: Parser (State -> Ex.Exceptional Error State) -parsePostFilter = f <$> Ly.parsePostFilter - where - f lyResult = - let g st = case lyResult of - Ex.Exception e -> Ex.throw . LibertyError $ e - Ex.Success pf -> - let ls' = postFilter st ++ [pf] - in return st { postFilter = ls' } - in g - -impurify :: - (Functor f, Applicative a) - => f (b -> b) - -> f (b -> a b) -impurify = fmap (pure .) - -parseMatcherSelect :: Parser (State -> State) -parseMatcherSelect = f <$> Ly.parseMatcherSelect - where - f fty = g - where - g st = st { factory = fty } - -parseCaseSelect :: Parser (State -> State) -parseCaseSelect = f <$> Ly.parseCaseSelect - where - f sel = g - where - g st = st { sensitive = sel } - -parseOperator :: Parser (State -> State) -parseOperator = f <$> Ly.parseOperator - where - f tok = g - where - g st = st { tokens = tokens st ++ [tok] } - -parseSort :: Parser (State -> Ex.Exceptional Error State) -parseSort = f <$> Ly.parseSort - where - f exOrd = g - where - g st = case exOrd of - Ex.Exception e -> Ex.throw . LibertyError $ e - Ex.Success o -> - return st { orderer = mappend o (orderer st) } - -parseHelp :: Parser (State -> State) -parseHelp = option ["help"] ['h'] (C.NoArg f) - where - f st = st { help = True } - -{- -wrapLiberty :: - DefaultTimeZone - -> DateTime - -> RadGroup - -> State - -> ParserE Error State -wrapLiberty dtz dt rg st = let - toLibSt = LF.State { LF.sensitive = sensitive st - , LF.factory = factory st - , LF.tokens = tokens st - , LF.postFilter = postFilter st } - fromLibSt libSt = State { sensitive = LF.sensitive libSt - , factory = LF.factory libSt - , tokens = LF.tokens libSt - , postFilter = LF.postFilter libSt - , orderer = orderer st - , help = help st } - in fromLibSt <$> LF.parseOption dtz dt rg toLibSt - -wrapOrderer :: State -> ParserE Error State -wrapOrderer st = mkSt <$> S.sort where - mkSt o = st { orderer = o `mappend` (orderer st) } - -helpOpt :: ParserE Error () -helpOpt = do - let lo = makeLongOpt . pack $ "help" - so = makeShortOpt 'h' - _ <- mixedNoArg lo [] [so] - return () - -wrapHelp :: State -> ParserE Error State -wrapHelp st = (\_ -> st { help = Help }) <$> helpOpt - -parseOption :: - DefaultTimeZone - -> DateTime - -> RadGroup - -> State - -> ParserE Error State -parseOption dtz dt rg st = - wrapLiberty dtz dt rg st - <|> wrapOrderer st - <|> wrapHelp st - -parseOptions :: - DefaultTimeZone - -> DateTime - -> RadGroup - -> State - -> ParserE Error State -parseOptions dtz dt rg st = - option st $ do - rs <- runUntilFailure (parseOption dtz dt rg) st - if null rs then return st else return (last rs) - -parseFilter :: - DefaultTimeZone - -> DateTime - -> RadGroup - -> ParserE Error (Either NeedsHelp Result) -parseFilter dtz dt rg = do - st' <- parseOptions dtz dt rg newState - case help st' of - Help -> return . Left $ NeedsHelp - NoHelp -> do - p <- case Oo.getPredicate (tokens st') of - Just pr -> return pr - Nothing -> throw E.BadExpression - let f = sortFilterAndPostFilter (orderer st') p (postFilter st') - r = Result { resultFactory = factory st' - , resultSensitive = sensitive st' - , sorterFilterer = f } - return . Right $ r - -sortFilterAndPostFilter :: - S.Orderer - -> (T.PostingInfo -> Bool) - -> ([T.PostingInfo] -> [T.PostingInfo]) - -> [PostingBox] -> [T.PostingInfo] -sortFilterAndPostFilter o p pf = - pf - . filter p - . PSq.sortedPostingInfos o --} diff --git a/Penny/Zinc/Parser/Ledgers.hs b/Penny/Zinc/Parser/Ledgers.hs deleted file mode 100644 --- a/Penny/Zinc/Parser/Ledgers.hs +++ /dev/null @@ -1,79 +0,0 @@ -module Penny.Zinc.Parser.Ledgers ( - filenames - , parseLedgers - , readLedgers - ) where - -import Control.Applicative ((<$>), many, optional) -import Control.Monad (when) -import qualified Control.Monad.Exception.Synchronous as Ex -import Data.Text (Text, pack, unpack) -import qualified Data.Text.IO as TIO - -import qualified Penny.Copper as C -import qualified Penny.Lincoln as L -import qualified Penny.Zinc.Error as ZE -import System.Console.MultiArg.Prim (Parser, nextArg) -import System.IO (hIsTerminalDevice, stdin, stderr, hPutStrLn) - - -warnTerminal :: IO () -warnTerminal = - hPutStrLn stderr $ "zinc: warning: reading from standard input, " - ++ "which is a terminal" - -data Filename = - Filename Text - | Stdin - --- | Converts a Ledgers filename to a Lincoln filename. -convertFilename :: Filename -> L.Filename -convertFilename (Filename x) = L.Filename x -convertFilename Stdin = L.Filename . pack $ "" - --- | Actually reads the file off disk. For now just let this crash if --- any of the IO errors occur. -ledgerText :: Filename -> IO Text -ledgerText f = case f of - Stdin -> do - isTerm <- hIsTerminalDevice stdin - when isTerm warnTerminal - TIO.hGetContents stdin - Filename fn -> TIO.readFile (unpack fn) - -readLedgers :: [Filename] -> IO [(Filename, Text)] -readLedgers = mapM f where - f fn = (\txt -> (fn, txt)) <$> ledgerText fn - -parseLedgers :: - C.DefaultTimeZone - -> C.RadGroup - -> [(Filename, Text)] - -> Ex.Exceptional ZE.Error ([L.Transaction], [L.PricePoint]) -parseLedgers dtz rg ls = - let toPair (f, t) = (convertFilename f, C.FileContents t) - parsed = C.parse dtz rg (map toPair ls) - folder i (ts, ps) = case snd i of - C.Transaction t -> (t:ts, ps) - C.Price p -> (ts, p:ps) - _ -> (ts, ps) - toResult (C.Ledger is) = foldr folder ([], []) is - toErr (C.ErrorMsg x) = ZE.ParseError x - in Ex.mapExceptional toErr toResult parsed - - -filename :: Parser Filename -filename = f <$> nextArg - where - f a = if a == "-" - then Stdin - else Filename . pack $ a - -filenames :: Parser [Filename] -filenames = do - fn1 <- optional filename - case fn1 of - Nothing -> return [Stdin] - Just fn -> do - fns <- many filename - return (fn:fns) diff --git a/Penny/Zinc/Parser/Report.hs b/Penny/Zinc/Parser/Report.hs deleted file mode 100644 --- a/Penny/Zinc/Parser/Report.hs +++ /dev/null @@ -1,30 +0,0 @@ -module Penny.Zinc.Parser.Report (report) where - -import System.Console.MultiArg.Prim (Parser) -import qualified System.Console.MultiArg.Combinator as C - -import qualified Penny.Cabin.Interface as I -import qualified Data.Set as Set - --- | Given a Runtime and a list of available Reports, returns a Parser --- that will return a function corresponding to the report the user --- desires. The parser returned assumes that the filtering options --- have already been parsed. The returned parser parses all options --- corresponding to report options in order to return the function. -report :: - [I.Report] - -- ^ List of available Reports - - -> Parser I.ReportFunc -report rs = do - let toPair r = (I.name r, I.parseReport r) - alist = map toPair rs - set = Set.fromList . map fst $ alist - (_, n) <- C.matchApproxWord set - case lookup n alist of - Nothing -> error $ "Penny.Zinc.Parser.Report: error: " - ++ "report not found" - Just rptFunc -> rptFunc - - - diff --git a/penny-lib.cabal b/penny-lib.cabal --- a/penny-lib.cabal +++ b/penny-lib.cabal @@ -1,9 +1,9 @@ Name: penny-lib -Version: 0.4.0.0 +Version: 0.6.0.0 Cabal-version: >=1.8 Build-Type: Simple -License: MIT -Copyright: 2012 Omari Norman. +License: BSD3 +Copyright: 2012-2013 Omari Norman. author: Omari Norman maintainer: omari@smileystation.com stability: Experimental @@ -11,280 +11,130 @@ bug-reports: omari@smileystation.com Category: Console, Finance License-File: LICENSE + synopsis: Extensible double-entry accounting system - library description: Penny is a double-entry accounting system. It is inspired by, but incompatible with, John Wiegley's Ledger, which is available - at . You will want to install the package - penny-bin by using cabal install penny-bin, which will install the - executable program and this library as well. Features: - - . - - * Penny is a double-entry accounting system. It uses traditional - accounting terminology, such as the terms \"Debit\" and - \"Credit\". If you need a refresher on the basics of double-entry - accounting, pick up a used accounting textbook from your favorite - bookseller (they can be had cheaply, for less than ten U.S. dollars - including shipping) or check out - , a great free online text. - - . - - * Penny is based around "Penny.Lincoln", a core library to represent - transactions and postings and their components, such as their - amounts and whether they are debits and credits. You can use - Lincoln all by itself even if you don't use the other components - of Penny, which you may find handy if you are a Haskell - programmer. I wrote Penny because I wanted a precise library to - represent my accounting data so I could analyze it programatically - and verify its consistency. I wrote it in Haskell not because I - wanted to write something in Haskell but because Haskell is the - best tool for this job (I used to use the shell, combined with - Ledger, which is a messy combination.) - - . - - * Penny's command line interface, Zinc, and its reports, Cabin, give - you unparalleled flexibility to filter and sort postings. Each - posting within a transaction may have its own flags assigned - (e.g. to indicate whether the posting is cleared) and each posting - may have infinite \"tags\" assigned to it, giving you another way - to categorize your postings. For instance, you might have vacation - related postings in several different accounts, but you can give - them all a \"vacation\" tag. - - . - - * Full Unicode support. Also, you may set which characters you wish - to use to represent the radix point and the digit grouping - character in your ledger file. - - . - - * Penny's reports, in "Penny.Cabin", have color baked in from the - beginning. You do not have to use color, though, which is handy if - you are sending output to a file or if, well, you just don't like - color. - - . - - * Penny's reports are customizable in Haskell, giving you an easy - and powerful way to make your own reports without writing cryptic - formatting strings. - - . - - * Penny handles multiple commodities (for example, multiple - currencies, stocks and bonds, tracking other assets, etc.) in an - easy and transparent way that is consistent with double-entry - accounting principles. It embraces the philosophy outlined in this - tutorial on multiple commodity accounting: - . - - . - - * Penny stores amounts using only integers, building from the - Data.Decimal library available at - . This ensures the - accuracy of your data, as using floating point values to represent - money is a bad idea. Here is one explanation: - . The - use of integer arithmetic also makes Penny simpler internally, as - there is no need for arbitrary rounding to compensate for the - bizarre and inaccurate results that sometimes arise from the use of - floating-point values to represent currencies. - - . - - * Freely licensed under the MIT license. If you take this code, - improve it, lock it up and make it proprietary, and sell it, - AWESOME! I haven't lost anything because I still have my code and, - what's more, then maybe I can buy your product and not have to - maintain this one any more! - - . - - * Uses no GHC extensions. However, the code is only tested under GHC - and for all practical purposes it will only run under GHC at this - time because it uses libraries such as Data.Text that are - available only under GHC. Despite this I expect I will continue to - avoid language extensions. - - . - - Non-features / disadvantages: - - . - - * Written in Haskell. Yes, I think Haskell is the best tool ever, - but its compiler is not as commonly installed as compilers for C - or C++, and non-Haskellers will probably find Penny to be more - difficult to install than Ledger, as the latter is written in C++. - - . - - * Handling commodities requires that you set up multiple accounts; - some might find this cumbersome. - - . - - * Young and not well tested yet. Also, only tested on Unix. It - probably would not be difficult to make Penny run on Windows; if - someone wants to do that, go ahead. - - . - - * Full Penny functionality is available without a Haskell compiler; - you could even use a pre-compiled binary. However, to fully - customize Penny, you will need a Haskell compiler installed. - - . - - * Can be slow and memory hungry with large data sets. I have a - ledger file with about 28,000 lines. On my least capable machine - (which has an Intel Core 2 Duo at 1.6 GHz) this takes about 1.4 - seconds to parse. Not horrible but not instantaneous - either. Generating a report about all these transactions can take - about seven seconds and a little less than 300 MB of memory. I - have eliminated all the obvious slowness from the code and - attempted a rewrite of the parser, which made no difference; other - ideas to speed up Penny with large data sets would involve - substantial changes and this is not at the top of my list because - the program is currently usable with relatively recent hardware. + at . . - More details about the organization of the Penny modules is - available by examining the top "Penny" module. + This package is a library. To start using Penny you will want to + install the penny-bin package, which has the executable programs. It + is available on Hackage and by running "cabal install penny-bin". . - This is only a library. For the executable package, which also - includes more documentation, search for the penny-bin package on - Hackage. + The Penny library is a full system to work with double-entry + accounting transactions and postings and to make reports with them. source-repository head - type: git - location: git://github.com/massysett/penny.git + type: git + location: git://github.com/massysett/penny.git Library - Build-depends: - base ==4.*, - text ==0.11.*, - explicit-exception ==0.1.*, - containers ==0.4.*, - transformers == 0.2.*, - time ==1.2.*, - Decimal >= 0.2.2 && < 0.3, - parsec >= 3.1.2 && < 3.2, - multiarg ==0.4.*, - matchers ==0.2.*, - old-locale ==1.0.*, - semigroups ==0.8.*, - split ==0.1.* + Build-depends: + base ==4.* + , bytestring ==0.9.* + , cereal ==0.3.* + , containers ==0.4.* + , explicit-exception ==0.1.* + , matchers ==0.4.* + , monad-loops ==0.3.* + , multiarg ==0.8.* + , old-locale ==1.0.* + , parsec >= 3.1.2 && < 3.2 + , pretty-show ==1.2.* + , semigroups ==0.8.* + , split ==0.2.* + , strict ==0.3.* + , terminfo == 0.3.* + , text ==0.11.* + , time ==1.4.* + , transformers == 0.3.* - Exposed-modules: - Penny, - Penny.Cabin, - Penny.Cabin.Allocate, - Penny.Cabin.Balance, - Penny.Cabin.Balance.Parser, - Penny.Cabin.Balance.Help, - Penny.Cabin.Balance.Tree, - Penny.Cabin.Chunk, - Penny.Cabin.Chunk.Switch, - Penny.Cabin.Colors, - Penny.Cabin.Colors.DarkBackground, - Penny.Cabin.Colors.LightBackground, - Penny.Cabin.Interface, - Penny.Cabin.Meta, - Penny.Cabin.Options, - Penny.Cabin.Posts, - Penny.Cabin.Posts.Allocate, - Penny.Cabin.Posts.Allocated, - Penny.Cabin.Posts.BottomRows, - Penny.Cabin.Posts.Fields, - Penny.Cabin.Posts.Growers, - Penny.Cabin.Posts.Chunk, - Penny.Cabin.Posts.Help, - Penny.Cabin.Posts.Meta, - Penny.Cabin.Posts.Parser, - Penny.Cabin.Posts.Spacers, - Penny.Cabin.Posts.Types, - Penny.Cabin.Row, - Penny.Cabin.TextFormat, - Penny.Copper, - Penny.Copper.Account, - Penny.Copper.Amount, - Penny.Copper.Comments, - Penny.Copper.Commodity, - Penny.Copper.DateTime, - Penny.Copper.Entry, - Penny.Copper.Flag, - Penny.Copper.Item, - Penny.Copper.Memos.Posting, - Penny.Copper.Memos.Transaction, - Penny.Copper.Number, - Penny.Copper.Payees, - Penny.Copper.Posting, - Penny.Copper.Price, - Penny.Copper.Qty, - Penny.Copper.Tags, - Penny.Copper.TopLine, - Penny.Copper.Transaction, - Penny.Copper.Util, - Penny.Liberty, - Penny.Liberty.Expressions, - Penny.Liberty.Expressions.Infix, - Penny.Liberty.Expressions.RPN, - Penny.Lincoln, - Penny.Lincoln.Balance, - Penny.Lincoln.Bits, - Penny.Lincoln.Bits.Account, - Penny.Lincoln.Bits.Amount, - Penny.Lincoln.Bits.Commodity, - Penny.Lincoln.Bits.DateTime, - Penny.Lincoln.Bits.DrCr, - Penny.Lincoln.Bits.Entry, - Penny.Lincoln.Bits.Flag, - Penny.Lincoln.Bits.Memo, - Penny.Lincoln.Bits.Number, - Penny.Lincoln.Bits.Payee, - Penny.Lincoln.Bits.Price, - Penny.Lincoln.Bits.PricePoint, - Penny.Lincoln.Bits.Qty, - Penny.Lincoln.Bits.Tags, - Penny.Lincoln.Builders, - Penny.Lincoln.Family, - Penny.Lincoln.Family.Child, - Penny.Lincoln.Family.Family, - Penny.Lincoln.Family.Siblings, - Penny.Lincoln.HasText, - Penny.Lincoln.Matchers, - Penny.Lincoln.Meta, - Penny.Lincoln.NestedMap, - Penny.Lincoln.Predicates, - Penny.Lincoln.PriceDb, - Penny.Lincoln.Queries, - Penny.Lincoln.Serial, - Penny.Lincoln.TextNonEmpty, - Penny.Lincoln.Transaction, - Penny.Lincoln.Transaction.Unverified, - Penny.Shield, - Penny.Zinc, - Penny.Zinc.Error, - Penny.Zinc.Help, - Penny.Zinc.Parser, - Penny.Zinc.Parser.Defaults, - Penny.Zinc.Parser.Filter, - Penny.Zinc.Parser.Ledgers, - Penny.Zinc.Parser.Report + Exposed-modules: + Penny + , Penny.Brenner + , Penny.Brenner.Amex + , Penny.Brenner.BofA + , Penny.Brenner.Clear + , Penny.Brenner.Database + , Penny.Brenner.Import + , Penny.Brenner.Merge + , Penny.Brenner.Print + , Penny.Brenner.Types + , Penny.Brenner.Util + , Penny.Cabin + , Penny.Cabin.Balance + , Penny.Cabin.Balance.Convert + , Penny.Cabin.Balance.Convert.Chunker + , Penny.Cabin.Balance.Convert.Options + , Penny.Cabin.Balance.Convert.Parser + , Penny.Cabin.Balance.MultiCommodity + , Penny.Cabin.Balance.MultiCommodity.Chunker + , Penny.Cabin.Balance.MultiCommodity.Parser + , Penny.Cabin.Balance.Util + , Penny.Cabin.Chunk + , Penny.Cabin.Chunk.Switch + , Penny.Cabin.Interface + , Penny.Cabin.Meta + , Penny.Cabin.Options + , Penny.Cabin.Parsers + , Penny.Cabin.Posts + , Penny.Cabin.Posts.Allocated + , Penny.Cabin.Posts.BottomRows + , Penny.Cabin.Posts.Fields + , Penny.Cabin.Posts.Growers + , Penny.Cabin.Posts.Chunk + , Penny.Cabin.Posts.Meta + , Penny.Cabin.Posts.Parser + , Penny.Cabin.Posts.Spacers + , Penny.Cabin.Posts.Types + , Penny.Cabin.Row + , Penny.Cabin.Scheme + , Penny.Cabin.Scheme.Schemes + , Penny.Cabin.TextFormat + , Penny.Copper + , Penny.Copper.Parsec + , Penny.Copper.Render + , Penny.Copper.Terminals + , Penny.Copper.Types + , Penny.Liberty + , Penny.Liberty.Expressions + , Penny.Liberty.Expressions.Infix + , Penny.Liberty.Expressions.RPN + , Penny.Lincoln + , Penny.Lincoln.Balance + , Penny.Lincoln.Bits + , Penny.Lincoln.Bits.DateTime + , Penny.Lincoln.Bits.Open + , 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.HasText + , Penny.Lincoln.Matchers + , Penny.Lincoln.NestedMap + , Penny.Lincoln.Predicates + , Penny.Lincoln.PriceDb + , Penny.Lincoln.Queries + , Penny.Lincoln.Serial + , Penny.Lincoln.Transaction + , Penny.Lincoln.Transaction.Unverified + , Penny.Shield + , Penny.Zinc - ghc-options: -Wall - if flag(debug) - ghc-options: -auto-all -caf-all + ghc-options: -Wall + if flag(debug) + ghc-options: -auto-all -caf-all + Flag debug - Description: turns on some debugging options - Default: False + Description: turns on some debugging options + Default: False +