packages feed

penny-lib (empty) → 0.2.0.0

raw patch · 98 files changed

+12850/−0 lines, 98 filesdep +Decimaldep +basedep +containerssetup-changed

Dependencies added: Decimal, base, containers, explicit-exception, matchers, multiarg, old-locale, parsec, semigroups, split, text, time, transformers

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2011-2012 Omari Norman.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++    * Redistributions of source code must retain the above copyright+    notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above copyright+    notice, this list of conditions and the following disclaimer in+    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.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Penny.hs view
@@ -0,0 +1,88 @@+{- | Penny - 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.++"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++"Penny.Zinc" - the Penny command-line interface. Depends on Cabin,+Copper, Liberty, and Lincoln.++The dependencies are represented as a dot file in doc/dependencies.dot+in the Penny git repository.++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).++-}+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+  ) where++import qualified Penny.Cabin as Cabin+import qualified Penny.Copper as Copper+import qualified Penny.Lincoln as L+import qualified Penny.Shield as S+import qualified Penny.Zinc as Z++-- | 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++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++customPenny ::+  Copper.DefaultTimeZone+  -> Copper.RadGroup+  -> (S.Runtime -> Z.T)+  -> [Cabin.Report]+  -> IO ()+customPenny dtz rg gd rs = do+  rt <- S.runtime+  Z.runPenny rt dtz rg gd rs
+ Penny/Cabin.hs view
@@ -0,0 +1,15 @@+-- | 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++allReportsWithDefaults ::+  C.DefaultTimeZone+  -> C.RadGroup+  -> [I.Report]+allReportsWithDefaults dtz rg =+  [B.defaultBalanceReport, P.defaultPostsReport dtz rg]+
+ Penny/Cabin/Allocate.hs view
@@ -0,0 +1,72 @@+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)
+ Penny/Cabin/Balance.hs view
@@ -0,0 +1,21 @@+-- | The Penny balance report+module Penny.Cabin.Balance (balanceReport, O.defaultOptions,+                            O.Options(..),+                            defaultBalanceReport) where++import qualified Penny.Cabin.Balance.Parser as P+import qualified Penny.Cabin.Balance.Options as O+import qualified Penny.Cabin.Balance.Help as H+import qualified Penny.Cabin.Interface as I+import qualified Penny.Shield as S++balanceReport :: (S.Runtime -> O.Options) -> I.Report+balanceReport getOpts = I.Report H.help "balance" pr+  where+    pr = do+      fn <- P.parser+      let f rt _ _ bs ps = fn rt (getOpts rt) bs ps+      return f++defaultBalanceReport :: I.Report+defaultBalanceReport = balanceReport O.defaultOptions
+ Penny/Cabin/Balance/Help.hs view
@@ -0,0 +1,34 @@+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]\"",+  ""+  ]+
+ Penny/Cabin/Balance/Options.hs view
@@ -0,0 +1,37 @@+-- | Options for the Balance report.+module Penny.Cabin.Balance.Options where++import qualified Data.Text as X+import qualified Penny.Lincoln as L+import qualified Penny.Cabin.Chunk as Chunk+import qualified Penny.Cabin.Colors as C+import qualified Penny.Cabin.Options as O+import qualified Penny.Shield as S+import qualified Penny.Cabin.Colors.DarkBackground as DB+import qualified Penny.Copper.DateTime as DT+import qualified Penny.Lincoln.Balance as Bal++data Options = Options {+  drCrColors :: C.DrCrColors+  , baseColors :: C.BaseColors+  , balanceFormat :: L.BottomLine -> X.Text+  , colorPref :: Chunk.Colors+  , showZeroBalances :: O.ShowZeroBalances+  , convert :: Maybe (L.Commodity, L.DateTime)+  , defaultTimeZone :: DT.DefaultTimeZone+  }++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++defaultOptions :: S.Runtime -> Options+defaultOptions rt = Options {+  drCrColors = DB.drCrColors+  , baseColors = DB.baseColors+  , balanceFormat = balanceAsIs+  , colorPref = O.maxCapableColors rt+  , showZeroBalances = O.ShowZeroBalances False+  , convert = Nothing+  , defaultTimeZone = DT.utcDefault }
+ Penny/Cabin/Balance/Parser.hs view
@@ -0,0 +1,148 @@+module Penny.Cabin.Balance.Parser (parser) where++import qualified Data.Text as X+import qualified Data.Text.Lazy as XL+import Control.Applicative ((<|>), many)+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.Balance.Options as O+import qualified Penny.Cabin.Balance.Tree as Tree+import qualified Penny.Cabin.Options as CO+import qualified Penny.Copper.Commodity as CC+import qualified Penny.Copper.DateTime as CD+import qualified Penny.Liberty as Ly+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 Error = BadColorName String+           | BadBackground String+           | BadCommodity String+           | BadDate String+             deriving Show++parser ::+  Parser (S.Runtime+          -> O.Options+          -> [L.Box Ly.LibertyMeta]+          -> [L.PricePoint]+          -> Ex.Exceptional X.Text XL.Text)+parser = do+  ls <- many opts+  let f rt opInit bs ps = do+        let ls' = map (\fn -> fn rt) ls+            errOpParsed = (foldl (>=>) return ls') opInit+        opParsed <- case errOpParsed of+          Ex.Exception e -> Ex.throw . X.pack . show $ e+          Ex.Success g -> return g+        bits <- Tree.report opParsed bs ps+        return+          . Chk.chunksToText (O.colorPref opParsed)+          . concat+          $ bits+  return f++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+                 -> O.Options+                 -> Ex.Exceptional Error O.Options)+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 { O.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 (O.Options -> Ex.Exceptional Error O.Options)+background = parseOpt ["background"] "" (C.OneArg f)+  where+    f a1 op = case processBackgroundArg a1 of+      Nothing -> Ex.throw . BadBackground $ a1+      Just (dc, base) ->+        return op { O.drCrColors = dc+                  , O.baseColors = base }++showZeroBalances ::+  Parser (O.Options -> Ex.Exceptional a O.Options)+showZeroBalances = parseOpt ["show-zero-balances"] "" (C.NoArg f)+  where+    f op =+      return (op {O.showZeroBalances = CO.ShowZeroBalances True })++hideZeroBalances ::+  Parser (O.Options -> Ex.Exceptional a O.Options)+hideZeroBalances = parseOpt ["hide-zero-balances"] "" (C.NoArg f)+  where+    f op =+      return (op {O.showZeroBalances = CO.ShowZeroBalances False })++convertLong ::+  Parser (O.Options -> Ex.Exceptional Error O.Options)+convertLong = parseOpt ["convert"] "" (C.TwoArg f)+  where+    f a1 a2 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 (O.defaultTimeZone op)+      dt <- case Parsec.parse parseDate "" (X.pack a2) of+        Left _ -> Ex.throw . BadDate $ a2+        Right g -> return g+      let op' = op { O.convert = Just (cty, dt) }+      return op'++convertShort :: Parser (S.Runtime+                        -> O.Options+                        -> Ex.Exceptional Error O.Options)+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 { O.convert = Just (cty, dt) }+      return op'+        ++opts :: Parser (S.Runtime+                -> O.Options+                -> Ex.Exceptional Error O.Options)+opts =+  color+  <|> mkTwoArg background+  <|> mkTwoArg showZeroBalances+  <|> mkTwoArg hideZeroBalances+  <|> mkTwoArg convertLong+  <|> convertShort+  where+    mkTwoArg p = do+      f <- p+      return (\_ op -> f op)
+ Penny/Cabin/Balance/Tree.hs view
@@ -0,0 +1,448 @@+-- | 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) 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.Balance.Options as O+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 }++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++converter ::+  O.Options+  -> [L.PricePoint]+  -> [L.Box Ly.LibertyMeta]+  -> Ex.Exceptional X.Text [PriceConverted]+converter os pbs bs = case O.convert os of+  Nothing ->+    let f b = PriceConverted en ac where+          p = L.boxPostFam b+          en = Q.entry p+          ac = Q.account p+    in return . map f $ bs+  Just pair ->+    let f b = let p = L.boxPostFam b+                  en = Q.entry p+                  ac = Q.account p+                 in do+                   en' <- convertOne db pair en+                   return (PriceConverted en' ac)+        db = buildDb pbs+    in 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 :: O.Options -> [PriceConverted] -> FlatMap+toFlatMap o = FlatMap . foldr f M.empty where+  remove = not . CO.unShowZeroBalances . O.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 ::+  O.Options+  -> 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 . O.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 = (O.balanceFormat os) bl+      in (getTs . O.drCrColors $ os, dcT, qTxt)+++fillTextSpec ::+  O.Options+  -> IsEven+  -> Chunk.TextSpec+fillTextSpec os isEven = let+  getTs = if isEven then C.evenColors else C.oddColors+  in getTs . O.baseColors $ os+  ++bottomLineCells ::+  O.Options+  -> IsEven+  -> SummedBal+  -> (PreSpec, PreSpec, PreSpec)+bottomLineCells os isEven mayBal = let+  fill = fillTextSpec os isEven+  tsZero = if isEven+           then C.evenZero . O.drCrColors $ os+           else C.oddZero . O.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 ::+  O.Options+  -> IsEven+  -> Int+  -> L.SubAccountName+  -> PreSpec+accountPreSpec os isEven lvl acct = PreSpec j ts [bit] where+  j = R.LeftJustify+  ts = if isEven+       then C.evenColors . O.baseColors $ os+       else C.oddColors . O.baseColors $ os+  bit = Chunk.chunk ts txt where+    txt = pad `X.append` (L.text acct)+    pad = X.replicate (padding * lvl) (X.singleton ' ')+++makePreSpec ::+  O.Options+  -> [(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 ::+  O.Options+  -> [(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 ::+  O.Options+  -> (SummedWithIsEven, TotalBal)+  -> (PreSpecMap, TotalBal)+makePreSpecMap os (sb, tb) = (cim, tb) where+  cim = Id.runIdentity (NM.traverseWithTrail (traverser os) sb)++-- Step 7+makeTotalCells ::+  O.Options+  -> 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 :: O.Options -> (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 ::+  O.Options+  -> IsEven+  -> Columns R.ColumnSpec+  -> [Chunk.Chunk]+colsToBits os isEven (Columns a dc c q) = let+  fillSpec = if isEven+             then C.evenColors . O.baseColors $ os+             else C.oddColors . O.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 ::+  O.Options+  -> [Columns R.ColumnSpec]+  -> [[Chunk.Chunk]]+colsListToBits os = zipWith f bools where+  f b c = colsToBits os b c+  bools = iterate not True+++-- Tie it all together++report ::+  O.Options+  -> [L.Box Ly.LibertyMeta]+  -> [L.PricePoint]+  -> Ex.Exceptional X.Text [[Chunk.Chunk]]+report os ps rs = do+  pcs <- converter os rs ps+  return+    . colsListToBits os+    . resizeColumnsInList+    . makeColumnList os+    . makePreSpecMap os+    . makeSummedWithIsEven+    . sumBalances+    . rawBalances+    . toFlatMap os+    $ pcs
+ Penny/Cabin/Chunk.hs view
@@ -0,0 +1,2408 @@+-- | 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"+
+ Penny/Cabin/Chunk/Switch.hs view
@@ -0,0 +1,26 @@+module Penny.Cabin.Chunk.Switch where++import qualified Penny.Cabin.Chunk as C++-- | Switch the foreground colors for new ones.+switchForeground ::+  C.Foreground8+  -> C.Foreground256+  -> C.TextSpec+  -> C.TextSpec+switchForeground c8 c256 ts = ts' where+  ts' = C.TextSpec s8' s256'+  s8' = (C.style8 ts) { C.foreground8 = c8 }+  s256' = (C.style256 ts) { C.foreground256 = c256 }++-- | Switch the background colors for new ones.+switchBackground ::+  C.Background8+  -> C.Background256+  -> C.TextSpec+  -> C.TextSpec+switchBackground c8 c256 ts = ts' where+  ts' = C.TextSpec s8' s256'+  s8' = (C.style8 ts) { C.background8 = c8 }+  s256' = (C.style256 ts) { C.background256 = c256 }+
+ Penny/Cabin/Colors.hs view
@@ -0,0 +1,50 @@+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
+ Penny/Cabin/Colors/DarkBackground.hs view
@@ -0,0 +1,38 @@+-- | 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)++
+ Penny/Cabin/Colors/LightBackground.hs view
@@ -0,0 +1,35 @@+-- | 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)++
+ Penny/Cabin/Interface.hs view
@@ -0,0 +1,55 @@+-- | An interface for other Penny components to use. A report is+-- anything that is a 'Report'.+module Penny.Cabin.Interface where++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 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.++  -> 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.+++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.+         }
+ Penny/Cabin/Meta.hs view
@@ -0,0 +1,15 @@+module Penny.Cabin.Meta (VisibleNum, unVisibleNum,+                         visibleNums ) where++import qualified Penny.Lincoln as L++newtype VisibleNum = VisibleNum { unVisibleNum :: L.Serial }+                     deriving (Eq, Show)++visibleNums ::+  (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+
+ Penny/Cabin/Options.hs view
@@ -0,0 +1,33 @@+-- | Options applicable to multiple Cabin reports.++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)+
+ Penny/Cabin/Posts.hs view
@@ -0,0 +1,146 @@+-- | The Penny Postings report+--+-- The Postings report displays postings in a tabular format designed+-- to be read by humans. Some terminology used in the Postings report:+--+-- [@row@] The smallest unit that spans from left to right. A row,+-- however, might consist of more than one screen line. For example,+-- the running balance is shown on the far right side of the Postings+-- report. The running balance might consist of more than one+-- commodity. Each commodity is displayed on its own screen+-- line. However, all these lines put together are displayed in a+-- single row.+--+-- [@column@] The smallest unit that spans from top to bottom.+--+-- [@tranche@] Each posting is displayed in several rows. The group of+-- rows that is displayed for a single posting is called a tranche.+--+-- [@tranche row@] Each tranche has a particular number of rows+-- (currently four); each of these rows is known as a tranche row.+--+-- [@field@] Corresponds to a particular element of the posting, such+-- as whether it is a debit or credit or its payee. The user can+-- select which fields to see.+--+-- [@allocation@] The width of the Payee and Account fields is+-- variable. Generally their width will adjust to fill the entire+-- width of the screen. The allocations of the Payee and Account+-- fields determine how much of the remaining space each field will+-- receive.+--+-- The Postings report is easily customized from the command line to+-- show various fields. However, the order of the fields is not+-- configurable without editing the source code (sorry).++module Penny.Cabin.Posts (+  -- * Defaults+  defaultPostsReport+  +  -- * Custom report+  , customPostsReport++  -- * Options+  , O.T(..)+  , O.ReportWidth(..)+  , O.ymd, O.qtyAsIs, O.balanceAsIs, O.defaultWidth+  , O.columnsVarToWidth, O.defaultOptions, O.widthFromRuntime+  , O.defaultFields+  ) where++import Control.Applicative ((<$>))+import qualified Control.Monad.Exception.Synchronous as Ex+import qualified Data.Text as X+import qualified Data.Text.Lazy as XL+import qualified Penny.Cabin.Chunk as Chk+import qualified Penny.Cabin.Interface as I+import qualified Penny.Cabin.Posts.Options as O+import qualified Penny.Cabin.Posts.Meta as M+import Penny.Cabin.Posts.Chunk (makeChunk)+import Penny.Cabin.Posts.Parser (parseOptions)+import Penny.Cabin.Posts.Help (help)+import qualified Penny.Copper as C+import qualified Penny.Lincoln as L+import qualified Penny.Liberty as Ly+import qualified Penny.Shield as S+import System.Console.MultiArg.Prim (Parser)+import Text.Matchers.Text (CaseSensitive)++-- | When applied to a DefaultTimeZone and a RadGroup, returns a+-- report with the default options.+defaultPostsReport ::+  C.DefaultTimeZone+  -> C.RadGroup+  -> I.Report+defaultPostsReport dtz rg = makeReport f where+  f = parseReportOpts (\rt -> O.defaultOptions dtz rg rt)++-- | Generate a custom Posts report.+customPostsReport ::+  (S.Runtime -> O.T)+  -- ^ Function that, when applied to a Runtime, returns the default+  -- options for the posts report. The options will be overridden by+  -- any options on the command line.++  -> I.Report+customPostsReport = makeReport . parseReportOpts++-- | When passed a ParseReportOpts, makes a Report.+makeReport ::+  Parser I.ReportFunc+  -> I.Report+makeReport f =+  I.Report { I.help = help+           , I.name = "posts"+           , I.parseReport = f }++type Factory = CaseSensitive -> X.Text+                 -> Ex.Exceptional X.Text (X.Text -> Bool)++parseReportOpts ::+  (S.Runtime -> O.T)+  -> Parser (S.Runtime+             -> CaseSensitive+             -> Factory+             -> [L.Box Ly.LibertyMeta]+             -> a+             -> Ex.Exceptional X.Text XL.Text)+parseReportOpts frt = do+  getOpts <- parseOptions+  let f rt cs fty bs _ = do+        let optsDefault = frt rt+            optsInit = optsDefault { O.sensitive = cs+                                   , O.factory = fty }+        optsParsed <- case getOpts rt optsInit of+          Ex.Exception e -> Ex.throw . X.pack . show $ e+          Ex.Success g -> return g+        makeReportTxt optsParsed bs+  return f+            ++-- | Using the options parsed from the command line, print out the+-- report.+makeReportTxt ::+  O.T+  -> [L.Box Ly.LibertyMeta]+  -> Ex.Exceptional X.Text XL.Text+makeReportTxt op bs = fmap mkText postMetaBoxes+  where+    e = X.pack "posts report: filter expression parse failure"+    postMetaBoxes = Ex.fromMaybe e (filterAndAssignMeta op bs)+    mkText = Chk.chunksToText (O.colorPref op) . makeChunk op+    ++-- | Takes a list of Box with LibertyMeta and options as processed+-- from the command line.  Filters the list of Box and processes the+-- post filter, then assigns the post metadata. Fails if the+-- expression fails to produce a result.+filterAndAssignMeta ::+  O.T+  -> [L.Box Ly.LibertyMeta]+  -> Maybe [L.Box M.PostMeta]+filterAndAssignMeta op bs =+  M.addMetadata (O.showZeroBalances op)+  <$> M.filterBoxes (O.tokens op) (O.postFilter op) bs++
+ Penny/Cabin/Posts/Allocate.hs view
@@ -0,0 +1,65 @@+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)
+ Penny/Cabin/Posts/Allocated.hs view
@@ -0,0 +1,284 @@+-- | Calculates the allocated cells -- the Payee cell and the Account+-- cell. Here is the logic for this process:+--+-- 1. If neither Payee nor Account appears, do nothing.+--+-- 2. Obtain the width of the growing cells, including the+-- spacers. One of the spacers attached to a field might be omitted:+--+-- a. If the rightmost growing field is TotalQty, include all spacers.+--+-- b. If the rightmost growing field is to the left of Payee, include+-- all spacers.+--+-- c. If the rightmost growing field is to the right of Account but is+-- not TotalQty, omit its spacer.+--+-- 2. Subtract from this sum the width of the Payee and Account+-- spacers:+--+-- a. Subtract the width of Payee spacer if it appears.+--+-- b. Subtract the width of the Account spacer if it appears.+--+-- 3. If the remaining width is 0 or less, do nothing. Return, but+-- indicate in return value that neither Payee nor Account is showing.+--+-- 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.+--+-- 5. Fill cell contents. Return filled cells.+module Penny.Cabin.Posts.Allocated (payeeAndAcct, Fields(..)) where++import Control.Applicative(Applicative((<*>), pure), (<$>))+import Data.Maybe (catMaybes, isJust)+import Data.List (intersperse)+import qualified Data.Foldable as Fdbl+import qualified Data.Sequence as Seq+import qualified Data.Traversable as T+import qualified Data.Text as X+import qualified 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.Fields as F+import qualified Penny.Cabin.Posts.Growers as G+import qualified Penny.Cabin.Posts.Meta as M+import qualified Penny.Cabin.Posts.Options as Options+import qualified Penny.Cabin.Posts.Options as O+import qualified Penny.Cabin.Posts.Spacers as S+import qualified Penny.Cabin.Posts.Spacers as Spacers+import qualified Penny.Cabin.TextFormat as TF+import qualified Penny.Lincoln as L+import qualified Penny.Lincoln.Queries as Q+import qualified Penny.Lincoln.HasText as HT++type Box = L.Box M.PostMeta ++data Fields a = Fields {+  payee :: a+  , account :: a+  } deriving (Eq, Show)++-- | Creates Payee and Account cells. The user must have requested the+-- cells. In addition, no cells are created if there is not enough+-- space for them in the report. Returns a Fields; each element of the+-- Fields is Nothing if no cells were created (either because the user+-- did not ask for them, or because there was no room) or Just cs i,+-- where cs is a list of all the cells, and i is the width of all the+-- cells.+payeeAndAcct ::+  G.Fields (Maybe Int)+  -> Options.T+  -> [Box]+  -> Fields (Maybe ([R.ColumnSpec], Int))+payeeAndAcct fs os = allocateCells os ws where+  ws = fieldWidth os ss fs rw+  ss = O.spacers os+  rw = O.width os+++-- | 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 ::+  Options.T+  -> Fields Int+  -> [Box]+  -> Fields (Maybe ([R.ColumnSpec], Int))+allocateCells os fs is = let+  cellMakers = Fields allocPayee allocAcct+  mkCells width maker =+    if width > 0+    then Just (map (maker width os) is)+    else Nothing+  unShrunkCells = mkCells <$> fs <*> cellMakers+  in fmap (fmap removeExtraSpace) unShrunkCells+++-- | 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 }++-- | Gets the width of the two allocated fields.+fieldWidth ::+  Options.T+  -> Spacers.T Int+  -> G.Fields (Maybe Int)+  -> O.ReportWidth+  -> Fields Int+fieldWidth os ss fs (O.ReportWidth rw) = let+  flds = optionsToFields os+  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 (O.payeeAllocation os) (O.accountAllocation os)+  in if widthForCells < 1+     then pure 0+     else A.allocate allocs widthForCells+++optionsToFields :: Options.T -> Fields Bool+optionsToFields os = let f = O.fields os in Fields {+  payee = F.payee f+  , account = F.account f }+++-- | Sums spacers for growing cells. This function is intended for use+-- only by the functions that allocate cells for the report, so it+-- assumes that either the Payee or the Account field is showing. Sums+-- all spacers, UNLESS the rightmost field is from PostingDrCr to+-- TotalCmdty, in which case the rightmost spacer is omitted. Apply to+-- the second element of the tuple returned by growCells (which+-- reflects which fields actually have width) and to the accompanying+-- Spacers.+sumSpacers ::+  G.Fields (Maybe a)+  -> Spacers.T Int+  -> Int+sumSpacers fs =+  sum+  . map fst+  . appearingSpacers+  . catMaybes+  . Fdbl.toList+  . fmap toWidth+  . pairedWithSpacers fs+  ++-- | Takes a triple:+--+-- * The first element is Just _ if the field appears in the report;+-- Nothing if not+--+-- * The second element is Maybe Int for the width of the spacer+-- (TotalQty has no spacer, so it will be Nothing)+--+-- * The third element is the EFields tag+--+-- Returns Nothing if the field does not appear in the report. Returns+-- Just a pair if the field does appear in the report, where the first+-- element is the width of the spacer, and the second element is the+-- EFields tag.+toWidth :: (Maybe a, Maybe Int, t) -> Maybe (Int, t)+toWidth (maybeShowing, maybeWidth, tag) =+  if isJust maybeShowing+  then case maybeWidth of+    Just w -> Just (w, tag)+    Nothing -> Just (0, tag)+  else Nothing+++-- | Given a list of all spacers that are attached to the fields that+-- are present in a report, return a list of the spacers that will+-- actually appear in the report. The rightmost spacer does not appear+-- if it is to the right of Account (unless there is a TotalQty field,+-- in which case, all spacers appear because TotalQty has no spacer.)+appearingSpacers :: [(Int, G.EFields)] -> [(Int, G.EFields)]+appearingSpacers ss = case ss of+  [] -> []+  l -> case snd $ last l of+    G.ETotalQty -> l+    t -> if t > G.ENumber+         then init l+         else l++-- | Applied to two arguments: first, a Fields, and second, a+-- Spacers. Combines each Field with its corresponding Spacer and with+-- the GFields, which indicates each particular field.+pairedWithSpacers ::+  G.Fields a+  -> Spacers.T b+  -> G.Fields (a, Maybe b, G.EFields)+pairedWithSpacers f s =+  (\(a, b) c -> (a, b, c))+  <$> G.pairWithSpacer f s+  <*> G.eFields++-- | Sums the contents of growing cells and their accompanying+-- spacers; makes the adjustments described in sumSpacers.+sumGrowersAndSpacers ::+  G.Fields (Maybe Int)+  -> Spacers.T Int+  -> Int+sumGrowersAndSpacers fs ss = spacers + flds where+  spacers = sumSpacers fs ss+  flds = Fdbl.foldr f 0 fs where+    f maybeI acc = case maybeI of+      Nothing -> acc+      Just i -> acc + i+++allocPayee :: Int -> Options.T -> Box -> R.ColumnSpec+allocPayee w os i = let+  pb = L.boxPostFam i+  ts = PC.colors (M.visibleNum . L.boxMeta $ i) (O.baseColors os)+  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+++allocAcct :: Int -> Options.T -> Box -> R.ColumnSpec+allocAcct aw os i = let+  pb = L.boxPostFam i+  ts = PC.colors (M.visibleNum . L.boxMeta $ i) (O.baseColors os) in+  R.ColumnSpec R.LeftJustify (C.Width aw) ts $ let+    target = TF.Target aw+    shortest = TF.Shortest . O.subAccountLength $ os+    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]++instance Functor Fields where+  fmap f i = Fields {+    payee = f (payee i)+    , account = f (account i) }++instance Applicative Fields where+  pure a = Fields a a+  ff <*> fa = Fields {+    payee = payee ff (payee fa)+    , account = account ff (account fa) }++instance Fdbl.Foldable Fields where+  foldr f z flds =+    f (payee flds) (f (account flds) z)++instance T.Traversable Fields where+  traverse f flds =+    Fields <$> f (payee flds) <*> f (account flds)+
+ Penny/Cabin/Posts/BottomRows.hs view
@@ -0,0 +1,623 @@+-- | Fills the bottom rows, which contain the tags, memo, and+-- filename. These rows are formatted as follows:+--+-- * If the columns for TotalDrCr, TotalCmdty, and TotalQty are all+-- present, AND if there are at least TWO other columns present, then+-- there will be a hanging indent. The bottom rows will begin at the+-- SECOND column and end with the last column to the left of+-- TotalDrCr. In this case, each bottom row will have three cells: one+-- padding on the left, one main content, and one padding on the+-- right.+--+-- * Otherwise, if there are NO columns in the top row, these rows+-- will take the entire width of the report. Each bottom row will have+-- one cell.+--+-- * Otherwise, the bottom rows are as wide as all the top cells+-- combined. Each bottom row will have one cell.++module Penny.Cabin.Posts.BottomRows (+  bottomRows, Fields(..), TopRowCells(..), mergeWithSpacers,+  topRowCells) where++import Control.Applicative((<$>), Applicative(pure,  (<*>)))+import qualified Data.Foldable as Fdbl+import Control.Monad (guard)+import Data.List (intersperse, find)+import qualified Data.List.NonEmpty as NE+import Data.Maybe (catMaybes)+import Data.Monoid (mappend, mempty, First(First, getFirst))+import qualified Data.Sequence as Seq+import qualified Data.Text as X+import qualified Data.Traversable as T+import qualified Penny.Cabin.Chunk as C+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 Fields+import qualified Penny.Cabin.Posts.Fields as F+import qualified Penny.Cabin.Posts.Growers as G+import qualified Penny.Cabin.Posts.Meta as M+import qualified Penny.Cabin.Posts.Options as Options+import qualified Penny.Cabin.Posts.Options as O+import qualified Penny.Cabin.Posts.Spacers as Spacers+import qualified Penny.Cabin.Posts.Spacers as S+import qualified Penny.Lincoln as L+import qualified Penny.Lincoln.HasText as HT+import qualified Penny.Lincoln.Queries as Q++type Box = L.Box M.PostMeta ++bottomRows ::+  G.Fields (Maybe Int)+  -> A.Fields (Maybe Int)+  -> Options.T+  -> [Box]+  -> Fields (Maybe [[C.Chunk]])+bottomRows gf af os is = makeRows is pcs where+  pcs = infoProcessors topSpecs rw wanted+  wanted = requestedMakers os+  topSpecs = topCellSpecs gf af (O.spacers os)+  rw = O.width os+++data Fields a = Fields {+  tags :: a+  , memo :: a+  , filename :: a+  } deriving (Show, Eq)++instance Fdbl.Foldable Fields where+  foldr f z d =+    f (tags d)+    (f (memo d)+     (f (filename d) z))++instance Functor Fields where+  fmap f (Fields t m fn) =+    Fields (f t) (f m) (f fn)++instance Applicative Fields where+  pure a = Fields a a a+  ff <*> fa = Fields {+    tags = (tags ff) (tags fa)+    , memo = (memo ff) (memo fa)+    , filename = (filename ff) (filename fa)+    }++bottomRowsFields :: Fields.T a -> Fields a+bottomRowsFields f = Fields {+  tags = F.tags f+  , memo = F.memo f+  , filename = F.filename f }+++data Hanging a = Hanging {+  leftPad :: a+  , mainCell :: a+  , rightPad :: a+  } deriving (Show, Eq)+++newtype SpacerWidth = SpacerWidth Int deriving (Show, Eq)+newtype ContentWidth = ContentWidth Int deriving (Show, Eq)+++hanging ::+  [TopCellSpec]+  -> Maybe ((Box -> Int -> (C.TextSpec, R.ColumnSpec))+            -> Box -> [C.Chunk])+hanging specs = hangingWidths specs+                >>= return . hangingInfoProcessor++hangingInfoProcessor ::+  Hanging Int+  -> (Box -> Int -> (C.TextSpec, R.ColumnSpec))+  -> Box+  -> [C.Chunk]+hangingInfoProcessor widths mkr info = row where+  row = R.row [left, mid, right]+  (ts, mid) = mkr info (mainCell widths)+  mkPad w = R.ColumnSpec R.LeftJustify (C.Width w) ts []+  left = mkPad (leftPad widths)+  right = mkPad (rightPad widths)++widthOfTopColumns ::+  [TopCellSpec]+  -> Maybe ((Box -> Int -> (C.TextSpec, R.ColumnSpec))+            -> Box -> [C.Chunk])+widthOfTopColumns ts =+  if null ts+  then Nothing+  else Just $ makeSpecificWidth w where+    w = Fdbl.foldl' f 0 ts+    f acc (_, maySpcWidth, (ContentWidth cw)) =+      acc + cw + maybe 0 (\(SpacerWidth sw) -> sw) maySpcWidth+++widthOfReport ::+  O.ReportWidth+  -> (Box -> Int -> (C.TextSpec, R.ColumnSpec))+  -> Box+  -> [C.Chunk]+widthOfReport (O.ReportWidth rw) fn info =+  makeSpecificWidth rw fn info++chooseProcessor ::+  [TopCellSpec]+  -> O.ReportWidth+  -> (Box -> Int -> (C.TextSpec, R.ColumnSpec))+  -> Box+  -> [C.Chunk]+chooseProcessor specs rw fn = let+  firstTwo = First (hanging specs)+             `mappend` First (widthOfTopColumns specs)+  in case getFirst firstTwo of+    Nothing -> widthOfReport rw fn+    Just r -> r fn++infoProcessors ::+  [TopCellSpec]+  -> O.ReportWidth+  -> Fields (Maybe (Box -> Int -> (C.TextSpec, R.ColumnSpec)))+  -> Fields (Maybe (Box -> [C.Chunk]))+infoProcessors specs rw flds = let+  chooser = chooseProcessor specs rw+  mkProcessor mayFn = case mayFn of+    Nothing -> Nothing+    Just fn -> Just $ chooser fn+  in mkProcessor <$> flds+++makeRows ::+  [Box]+  -> Fields (Maybe (Box -> [C.Chunk]))+  -> Fields (Maybe [[C.Chunk]])+makeRows is flds = let+  mkRow fn = map fn is+  in fmap (fmap mkRow) flds+++-- | Calculates column widths for a Hanging report. If it cannot+-- calculate the widths (because these cells do not support hanging),+-- returns Nothing.+hangingWidths :: [TopCellSpec]+                 -> Maybe (Hanging Int)+hangingWidths ls = do+  let len = length ls+  guard (len > 4)+  let matchColumn x (c, _, _) = x == c+  totDrCr <- find (matchColumn ETotalDrCr) ls+  totCmdty <- find (matchColumn ETotalCmdty) ls+  totQty <- find (matchColumn ETotalQty) ls+  let (first:middle) = take (len - 3) ls+  mid <- NE.nonEmpty middle+  return $ calcHangingWidths first mid (totDrCr, totCmdty, totQty)++type TopCellSpec = (ETopRowCells, Maybe SpacerWidth, ContentWidth)++-- | Given the first column in the top row, at least one middle+-- column, and the last three columns, calculate the width of the+-- three columns in the hanging report.+calcHangingWidths ::+  TopCellSpec+  -> NE.NonEmpty TopCellSpec+  -> (TopCellSpec, TopCellSpec, TopCellSpec)+  -> Hanging Int+calcHangingWidths l m r = Hanging left middle right where+  calcWidth (_, maybeSp, (ContentWidth c)) =+    c + maybe 0 (\(SpacerWidth w) -> abs w) maybeSp+  left = calcWidth l+  middle = Fdbl.foldl' f 0 m where+    f acc c = acc + calcWidth c+  (totDrCr, totCmdty, totQty) = r+  right = calcWidth totDrCr + calcWidth totCmdty+          + calcWidth totQty+++topCellSpecs :: G.Fields (Maybe Int)+                -> A.Fields (Maybe Int)+                -> Spacers.T Int+                -> [TopCellSpec]+topCellSpecs gFlds aFlds spcs = let+  allFlds = topRowCells gFlds aFlds+  cws = fmap (fmap ContentWidth) allFlds+  merged = mergeWithSpacers cws spcs+  tripler e (cw, maybeSpc) = (e, (fmap SpacerWidth maybeSpc), cw)+  list = Fdbl.toList $ tripler <$> eTopRowCells <*> merged+  toMaybe (e, maybeS, maybeC) = case maybeC of+    Nothing -> Nothing+    Just c -> Just (e, maybeS, c)+  in catMaybes (map toMaybe list)+  ++-- | Merges a TopRowCells with a Spacers. Returns Maybes because+-- totalQty has no spacer.+mergeWithSpacers ::+  TopRowCells a+  -> Spacers.T b+  -> TopRowCells (a, Maybe b)+mergeWithSpacers t s = TopRowCells {+  globalTransaction = (globalTransaction t, Just (S.globalTransaction s))+  , revGlobalTransaction = (revGlobalTransaction t, Just (S.revGlobalTransaction s))+  , globalPosting = (globalPosting t, Just (S.globalPosting s))+  , revGlobalPosting = (revGlobalPosting t, Just (S.revGlobalPosting s))+  , fileTransaction = (fileTransaction t, Just (S.fileTransaction s))+  , revFileTransaction = (revFileTransaction t, Just (S.revFileTransaction s))+  , filePosting = (filePosting t, Just (S.filePosting s))+  , revFilePosting = (revFilePosting t, Just (S.revFilePosting s))+  , filtered = (filtered t, Just (S.filtered s))+  , revFiltered = (revFiltered t, Just (S.revFiltered s))+  , sorted = (sorted t, Just (S.sorted s))+  , revSorted = (revSorted t, Just (S.revSorted s))+  , visible = (visible t, Just (S.visible s))+  , revVisible = (revVisible t, Just (S.revVisible s))+  , lineNum = (lineNum t, Just (S.lineNum s))+  , date = (date t, Just (S.date s))+  , flag = (flag t, Just (S.flag s))+  , number = (number t, Just (S.number s))+  , payee = (payee t, Just (S.payee s))+  , account = (account t, Just (S.account s))+  , postingDrCr = (postingDrCr t, Just (S.postingDrCr s))+  , postingCmdty = (postingCmdty t, Just (S.postingCmdty s))+  , postingQty = (postingQty t, Just (S.postingQty s))+  , totalDrCr = (totalDrCr t, Just (S.totalDrCr s))+  , totalCmdty = (totalCmdty t, Just (S.totalCmdty s))+  , totalQty = (totalQty t, Nothing) }+++-- | Applied to a function that, when applied to the width of a cell,+-- returns a cell filled with data, returns a Row with that cell.+makeSpecificWidth :: Int -> (Box -> Int -> (a, R.ColumnSpec))+                     -> Box -> [C.Chunk]+makeSpecificWidth w f i = R.row [c] where+  (_, c) = f i w+++type Maker = Options.T -> Box -> Int -> (C.TextSpec, R.ColumnSpec)++makers :: Fields Maker+makers = Fields tagsCell memoCell filenameCell++-- | Applied to an Options, indicating which reports the user wants,+-- returns a Fields (Maybe Maker) with a Maker in each respective+-- field that the user wants to see.+requestedMakers ::+  Options.T+  -> Fields (Maybe (Box -> Int -> (C.TextSpec, R.ColumnSpec)))+requestedMakers os = let+  flds = bottomRowsFields (O.fields os)+  filler b mkr = if b then Just $ mkr os else Nothing+  in filler <$> flds <*> makers++tagsCell :: Options.T -> Box -> Int -> (C.TextSpec, R.ColumnSpec)+tagsCell os 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 (O.baseColors os)+  cs =+    Fdbl.toList+    . fmap toBit+    . TF.unLines+    . TF.wordWrap w+    . TF.Words+    . Seq.fromList+    . map (X.cons '*')+    . HT.textList+    . Q.tags+    . L.boxPostFam+    $ info+  toBit (TF.Words ws) = C.chunk ts 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+  cs = Fdbl.toList+       . fmap toBit+       . TF.unLines+       . TF.wordWrap w+       . TF.Words+       . Seq.fromList+       . X.words+       . HT.text+       . HT.Delimited (X.singleton ' ')+       . HT.textList+       $ m+  toBit (TF.Words ws) = C.chunk ts (X.unwords . Fdbl.toList $ ws)+++memoCell :: Options.T -> Box -> Int -> (C.TextSpec, R.ColumnSpec)+memoCell os info width = (ts, cell) where+  w = C.Width width+  vn = M.visibleNum . L.boxMeta $ info+  cell = R.ColumnSpec R.LeftJustify w ts cs+  ts = PC.colors vn (O.baseColors os)+  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+  ++filenameCell :: Options.T -> Box -> Int -> (C.TextSpec, R.ColumnSpec)+filenameCell os info width = (ts, cell) where+  w = C.Width width+  vn = M.visibleNum . L.boxMeta $ info+  cell = R.ColumnSpec R.LeftJustify w ts cs+  toBit n = C.chunk ts+            . 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 (O.baseColors os)++++data TopRowCells a = TopRowCells {+  globalTransaction      :: a+  , revGlobalTransaction :: a+  , globalPosting        :: a+  , revGlobalPosting     :: a+  , fileTransaction      :: a+  , revFileTransaction   :: a+  , filePosting          :: a+  , revFilePosting       :: a+  , filtered             :: a+  , revFiltered          :: a+  , sorted               :: a+  , revSorted            :: a+  , visible              :: a+  , revVisible           :: a+  , lineNum              :: a+    -- ^ The line number from the posting's metadata+  , date                 :: a+  , flag                 :: a+  , number               :: a+  , payee                :: a+  , account              :: a+  , postingDrCr          :: a+  , postingCmdty         :: a+  , postingQty           :: a+  , totalDrCr            :: a+  , totalCmdty           :: a+  , totalQty             :: a }+  deriving (Show, Eq)++topRowCells :: G.Fields a -> A.Fields a -> TopRowCells a+topRowCells g a = TopRowCells {+  globalTransaction      = G.globalTransaction g+  , revGlobalTransaction = G.revGlobalTransaction g+  , globalPosting        = G.globalPosting g+  , revGlobalPosting     = G.revGlobalPosting g+  , fileTransaction      = G.fileTransaction g+  , revFileTransaction   = G.revFileTransaction g+  , filePosting          = G.filePosting g+  , revFilePosting       = G.revFilePosting g+  , filtered             = G.filtered g+  , revFiltered          = G.revFiltered g+  , sorted               = G.sorted g+  , revSorted            = G.revSorted g+  , visible              = G.visible g+  , revVisible           = G.revVisible g+  , lineNum              = G.lineNum g+  , date                 = G.date g+  , flag                 = G.flag g+  , number               = G.number g+  , payee                = A.payee a+  , account              = A.account a+  , postingDrCr          = G.postingDrCr g+  , postingCmdty         = G.postingCmdty g+  , postingQty           = G.postingQty g+  , totalDrCr            = G.totalDrCr g+  , totalCmdty           = G.totalCmdty g+  , totalQty             = G.totalQty g }+++data ETopRowCells =+  EGlobalTransaction+  | ERevGlobalTransaction+  | EGlobalPosting+  | ERevGlobalPosting+  | EFileTransaction+  | ERevFileTransaction+  | EFilePosting+  | ERevFilePosting+  | EFiltered+  | ERevFiltered+  | ESorted+  | ERevSorted+  | EVisible+  | ERevVisible+  | ELineNum+  | EDate+  | EFlag+  | ENumber+  | EPayee+  | EAccount+  | EPostingDrCr+  | EPostingCmdty+  | EPostingQty+  | ETotalDrCr+  | ETotalCmdty+  | ETotalQty+  deriving (Show, Eq, Enum)++eTopRowCells :: TopRowCells ETopRowCells+eTopRowCells = TopRowCells {+  globalTransaction      = EGlobalTransaction+  , revGlobalTransaction = ERevGlobalTransaction+  , globalPosting        = EGlobalPosting+  , revGlobalPosting     = ERevGlobalPosting+  , fileTransaction      = EFileTransaction+  , revFileTransaction   = ERevFileTransaction+  , filePosting          = EFilePosting+  , revFilePosting       = ERevFilePosting+  , filtered             = EFiltered+  , revFiltered          = ERevFiltered+  , sorted               = ESorted+  , revSorted            = ERevSorted+  , visible              = EVisible+  , revVisible           = ERevVisible+  , lineNum              = ELineNum+  , date                 = EDate+  , flag                 = EFlag+  , number               = ENumber+  , payee                = EPayee+  , account              = EAccount+  , postingDrCr          = EPostingDrCr+  , postingCmdty         = EPostingCmdty+  , postingQty           = EPostingQty+  , totalDrCr            = ETotalDrCr+  , totalCmdty           = ETotalCmdty+  , totalQty             = ETotalQty }++instance Functor TopRowCells where+  fmap f t = TopRowCells {+    globalTransaction      = f (globalTransaction    t)+    , revGlobalTransaction = f (revGlobalTransaction t)+    , globalPosting        = f (globalPosting        t)+    , revGlobalPosting     = f (revGlobalPosting     t)+    , fileTransaction      = f (fileTransaction      t)+    , revFileTransaction   = f (revFileTransaction   t)+    , filePosting          = f (filePosting          t)+    , revFilePosting       = f (revFilePosting       t)+    , filtered             = f (filtered             t)+    , revFiltered          = f (revFiltered          t)+    , sorted               = f (sorted               t)+    , revSorted            = f (revSorted            t)+    , visible              = f (visible              t)+    , revVisible           = f (revVisible           t)+    , lineNum              = f (lineNum              t)+    , date                 = f (date                 t)+    , flag                 = f (flag                 t)+    , number               = f (number               t)+    , payee                = f (payee                t)+    , account              = f (account              t)+    , postingDrCr          = f (postingDrCr          t)+    , postingCmdty         = f (postingCmdty         t)+    , postingQty           = f (postingQty           t)+    , totalDrCr            = f (totalDrCr            t)+    , totalCmdty           = f (totalCmdty           t)+    , totalQty             = f (totalQty             t) }++instance Applicative TopRowCells where+  pure a = TopRowCells {+    globalTransaction      = a+    , revGlobalTransaction = a+    , globalPosting        = a+    , revGlobalPosting     = a+    , fileTransaction      = a+    , revFileTransaction   = a+    , filePosting          = a+    , revFilePosting       = a+    , filtered             = a+    , revFiltered          = a+    , sorted               = a+    , revSorted            = a+    , visible              = a+    , revVisible           = a+    , lineNum              = a+    , date                 = a+    , flag                 = a+    , number               = a+    , payee                = a+    , account              = a+    , postingDrCr          = a+    , postingCmdty         = a+    , postingQty           = a+    , totalDrCr            = a+    , totalCmdty           = a+    , totalQty             = a }++  ff <*> fa = TopRowCells {+    globalTransaction      = globalTransaction    ff (globalTransaction    fa)+    , revGlobalTransaction = revGlobalTransaction ff (revGlobalTransaction fa)+    , globalPosting        = globalPosting        ff (globalPosting        fa)+    , revGlobalPosting     = revGlobalPosting     ff (revGlobalPosting     fa)+    , fileTransaction      = fileTransaction      ff (fileTransaction      fa)+    , revFileTransaction   = revFileTransaction   ff (revFileTransaction   fa)+    , filePosting          = filePosting          ff (filePosting          fa)+    , revFilePosting       = revFilePosting       ff (revFilePosting       fa)+    , filtered             = filtered             ff (filtered             fa)+    , revFiltered          = revFiltered          ff (revFiltered          fa)+    , sorted               = sorted               ff (sorted               fa)+    , revSorted            = revSorted            ff (revSorted            fa)+    , visible              = visible              ff (visible              fa)+    , revVisible           = revVisible           ff (revVisible           fa)+    , lineNum              = lineNum              ff (lineNum              fa)+    , date                 = date                 ff (date                 fa)+    , flag                 = flag                 ff (flag                 fa)+    , number               = number               ff (number               fa)+    , payee                = payee                ff (payee                fa)+    , account              = account              ff (account              fa)+    , postingDrCr          = postingDrCr          ff (postingDrCr          fa)+    , postingCmdty         = postingCmdty         ff (postingCmdty         fa)+    , postingQty           = postingQty           ff (postingQty           fa)+    , totalDrCr            = totalDrCr            ff (totalDrCr            fa)+    , totalCmdty           = totalCmdty           ff (totalCmdty           fa)+    , totalQty             = totalQty             ff (totalQty             fa) }++instance Fdbl.Foldable TopRowCells where+  foldr f z o =+    f (globalTransaction o)+    (f (revGlobalTransaction o)+     (f (globalPosting o)+      (f (revGlobalPosting o)+       (f (fileTransaction o)+        (f (revFileTransaction o)+         (f (filePosting o)+          (f (revFilePosting o)+           (f (filtered o)+            (f (revFiltered o)+             (f (sorted o)+              (f (revSorted o)+               (f (visible o)+                (f (revVisible o)+                 (f (lineNum o)+                  (f (date o)+                   (f (flag o)+                    (f (number o)+                     (f (payee o)+                      (f (account o)+                       (f (postingDrCr o)+                        (f (postingCmdty o)+                         (f (postingQty o)+                          (f (totalDrCr o)+                           (f (totalCmdty o)+                            (f (totalQty o) z)))))))))))))))))))))))))++instance T.Traversable TopRowCells where+  traverse f t =+    TopRowCells+    <$> f (globalTransaction t)+    <*> f (revGlobalTransaction t)+    <*> f (globalPosting t)+    <*> f (revGlobalPosting t)+    <*> f (fileTransaction t)+    <*> f (revFileTransaction t)+    <*> f (filePosting t)+    <*> f (revFilePosting t)+    <*> f (filtered t)+    <*> f (revFiltered t)+    <*> f (sorted t)+    <*> f (revSorted t)+    <*> f (visible t)+    <*> f (revVisible t)+    <*> f (lineNum t)+    <*> f (date t)+    <*> f (flag t)+    <*> f (number t)+    <*> f (payee t)+    <*> f (account t)+    <*> f (postingDrCr t)+    <*> f (postingCmdty t)+    <*> f (postingQty t)+    <*> f (totalDrCr t)+    <*> f (totalCmdty t)+    <*> f (totalQty t)+
+ Penny/Cabin/Posts/Chunk.hs view
@@ -0,0 +1,104 @@+module Penny.Cabin.Posts.Chunk (makeChunk) where++import qualified Data.Foldable as Fdbl+import Data.List (transpose)+import Data.Maybe (isNothing, catMaybes)+import qualified Penny.Cabin.Posts.Growers as G+import qualified Penny.Cabin.Posts.Allocated as A+import qualified Penny.Cabin.Posts.BottomRows as B+import qualified Penny.Cabin.Posts.Options as Options+import qualified Penny.Cabin.Row as R+import qualified Penny.Cabin.Chunk as C+import qualified Penny.Cabin.Colors as PC+import qualified Penny.Lincoln as L+import qualified Penny.Cabin.Posts.Meta as M++type Box = L.Box M.PostMeta ++makeChunk :: Options.T -> [Box] -> [C.Chunk]+makeChunk os is = let+  fmapSnd flds = fmap (fmap snd) flds+  fmapFst flds = fmap (fmap fst) flds+  gFldW = fmapSnd gFlds+  aFldW = fmapSnd aFlds+  gFlds = G.growCells os is+  aFlds = A.payeeAndAcct gFldW os is+  bFlds = B.bottomRows gFldW aFldW os is+  topCells = B.topRowCells (fmapFst gFlds) (fmapFst aFlds)+  withSpacers = B.mergeWithSpacers topCells (Options.spacers os)+  topRows = makeTopRows (Options.baseColors os) withSpacers+  bottomRows = makeBottomRows bFlds+  in makeAllRows topRows bottomRows+++topRowsCells ::+  PC.BaseColors+  -> B.TopRowCells (Maybe [R.ColumnSpec], Maybe Int)+  -> [[(R.ColumnSpec, Maybe R.ColumnSpec)]]+topRowsCells bc t = let+  toWithSpc (mayCs, maySp) = case mayCs of+    Nothing -> Nothing+    Just cs -> Just (makeSpacers bc 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.row . foldr f [] where+  f (c, mayC) acc = case mayC of+    Nothing -> c:acc+    Just spcr -> c:spcr:acc+++makeSpacers ::+  PC.BaseColors+  -> [R.ColumnSpec]+  -> Maybe Int+  -> [(R.ColumnSpec, Maybe R.ColumnSpec)]+makeSpacers bc cs mayI = case mayI of+  Nothing -> map (\c -> (c, Nothing)) cs+  Just i -> makeEvenOddSpacers bc cs i++makeEvenOddSpacers ::+  PC.BaseColors+  -> [R.ColumnSpec]+  -> Int+  -> [(R.ColumnSpec, Maybe R.ColumnSpec)]+makeEvenOddSpacers bc 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+    in zip cs spcrs++makeTopRows ::+  PC.BaseColors+  -> B.TopRowCells (Maybe [R.ColumnSpec], Maybe Int)+  -> Maybe [[C.Chunk]]+makeTopRows bc trc =+  if Fdbl.all (isNothing . fst) trc+  then Nothing+  else Just $ map makeRow . topRowsCells bc $ trc+++makeBottomRows ::+  B.Fields (Maybe [[C.Chunk]])+  -> Maybe [[[C.Chunk]]]+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 mayrs mayrrs = case (mayrs, mayrrs) of+  (Nothing, Nothing) -> []+  (Just rs, Nothing) -> concat rs+  (Nothing, Just rrs) -> concat . concat $ rrs+  (Just rs, Just rrs) -> concat $ zipWith f rs rrs where+    f topRow botRows = concat [topRow, concat botRows]++
+ Penny/Cabin/Posts/Fields.hs view
@@ -0,0 +1,166 @@+-- | Fields that can appear in the Posts report.+module Penny.Cabin.Posts.Fields where++import Control.Applicative(Applicative(pure, (<*>)))+import qualified Data.Foldable as F++data T a = T {+  globalTransaction :: a+  , revGlobalTransaction :: a+  , globalPosting :: a+  , revGlobalPosting :: a+  , fileTransaction :: a+  , revFileTransaction :: a+  , filePosting :: a+  , revFilePosting :: a+  , filtered :: a+  , revFiltered :: a+  , sorted :: a+  , revSorted :: a+  , visible :: a+  , revVisible :: a+  , lineNum :: a+    -- ^ The line number from the posting's metadata+  , date :: a+  , flag :: a+  , number :: a+  , payee :: a+  , account :: a+  , postingDrCr :: a+  , postingCmdty :: a+  , postingQty :: a+  , totalDrCr :: a+  , totalCmdty :: a+  , totalQty :: a+  , tags :: a+  , memo :: a+  , filename :: a }+  deriving (Show, Eq)++instance Functor T where+  fmap f fa = T {+    globalTransaction = f (globalTransaction fa)+    , revGlobalTransaction = f (revGlobalTransaction fa)+    , globalPosting = f (globalPosting fa)+    , revGlobalPosting = f (revGlobalPosting fa)+    , fileTransaction = f (fileTransaction fa)+    , revFileTransaction = f (revFileTransaction fa)+    , filePosting = f (filePosting fa)+    , revFilePosting = f (revFilePosting fa)+    , filtered = f (filtered fa)+    , revFiltered = f (revFiltered fa)+    , sorted = f (sorted fa)+    , revSorted = f (revSorted fa)+    , visible = f (visible fa)+    , revVisible = f (revVisible fa)+    , lineNum = f (lineNum fa)+    , date = f (date fa)+    , flag = f (flag fa)+    , number = f (number fa)+    , payee = f (payee fa)+    , account = f (account fa)+    , postingDrCr = f (postingDrCr fa)+    , postingCmdty = f (postingCmdty fa)+    , postingQty = f (postingQty fa)+    , totalDrCr = f (totalDrCr fa)+    , totalCmdty = f (totalCmdty fa)+    , totalQty = f (totalQty fa)+    , tags = f (tags fa)+    , memo = f (memo fa)+    , filename = f (filename fa) }++instance Applicative T where+  pure a = T {+    globalTransaction = a+    , revGlobalTransaction = a+    , globalPosting = a+    , revGlobalPosting = a+    , fileTransaction = a+    , revFileTransaction = a+    , filePosting = a+    , revFilePosting = a+    , filtered = a+    , revFiltered = a+    , sorted = a+    , revSorted = a+    , visible = a+    , revVisible = a+    , lineNum = a+    , date = a+    , flag = a+    , number = a+    , payee = a+    , account = a+    , postingDrCr = a+    , postingCmdty = a+    , postingQty = a+    , totalDrCr = a+    , totalCmdty = a+    , totalQty = a+    , tags = a+    , memo = a+    , filename = a }++  ff <*> fa = T {+    globalTransaction = globalTransaction ff (globalTransaction fa)+    , revGlobalTransaction = revGlobalTransaction ff+                             (revGlobalTransaction fa)+    , globalPosting = globalPosting ff (globalPosting fa)+    , revGlobalPosting = revGlobalPosting ff (revGlobalPosting fa)+    , fileTransaction = fileTransaction ff (fileTransaction fa)+    , revFileTransaction = revFileTransaction ff (revFileTransaction fa)+    , filePosting = filePosting ff (filePosting fa)+    , revFilePosting = revFilePosting ff (revFilePosting fa)+    , filtered = filtered ff (filtered fa)+    , revFiltered = revFiltered ff (revFiltered fa)+    , sorted = sorted ff (sorted fa)+    , revSorted = revSorted ff (revSorted fa)+    , visible = visible ff (visible fa)+    , revVisible = revVisible ff (revVisible fa)+    , lineNum = lineNum ff (lineNum fa)+    , date = date ff (date fa)+    , flag = flag ff (flag fa)+    , number = number ff (number fa)+    , payee = payee ff (payee fa)+    , account = account ff (account fa)+    , postingDrCr = postingDrCr ff (postingDrCr fa)+    , postingCmdty = postingCmdty ff (postingCmdty fa)+    , postingQty = postingQty ff (postingQty fa)+    , totalDrCr = totalDrCr ff (totalDrCr fa)+    , totalCmdty = totalCmdty ff (totalCmdty fa)+    , totalQty = totalQty ff (totalQty fa)+    , tags = tags ff (tags fa)+    , memo = memo ff (memo fa)+    , filename = filename ff (filename fa) }++instance F.Foldable T where+  foldr f z t =+    f (globalTransaction t)+    (f (revGlobalTransaction t)+     (f (globalPosting t)+      (f (revGlobalPosting t)+       (f (fileTransaction t)+        (f (revFileTransaction t)+         (f (filePosting t)+          (f (revFilePosting t)+           (f (filtered t)+            (f (revFiltered t)+             (f (sorted t)+              (f (revSorted t)+               (f (visible t)+                (f (revVisible t)+                 (f (lineNum t)+                  (f (date t)+                   (f (flag t)+                    (f (number t)+                     (f (payee t)+                      (f (account t)+                       (f (postingDrCr t)+                        (f (postingCmdty t)+                         (f (postingQty t)+                          (f (totalDrCr t)+                           (f (totalCmdty t)+                            (f (totalQty t)+                             (f (tags t)+                              (f (memo t)+                               (f (filename t) z))))))))))))))))))))))))))))
+ Penny/Cabin/Posts/Growers.hs view
@@ -0,0 +1,610 @@+-- | Calculates cells that "grow to fit." These cells grow to fit the+-- widest cell in the column. No information is ever truncated from+-- these cells (what use is a truncated dollar amount?)+module Penny.Cabin.Posts.Growers (+  growCells, Fields(..), grownWidth,+  eFields, EFields(..), pairWithSpacer) where++import Control.Applicative((<$>), Applicative(pure, (<*>)))+import qualified Data.Foldable as Fdbl+import Data.Map (elems, assocs)+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 PC+import qualified Penny.Cabin.Posts.Options as O+import qualified Penny.Cabin.Posts.Options as Options+import qualified Penny.Cabin.Posts.Fields as F+import qualified Penny.Cabin.Posts.Meta as M+import qualified Penny.Cabin.Posts.Spacers as S+import qualified Penny.Cabin.Posts.Spacers as Spacers+import qualified Penny.Cabin.Row as R+import qualified Penny.Liberty as Ly+import qualified Penny.Lincoln as L+import qualified Penny.Lincoln.Queries as Q+++type Box = L.Box M.PostMeta ++-- | Grows the cells that will be GrowToFit cells in the report. First+-- this function fills in all visible cells with text, but leaves the+-- width undetermined. Then it determines the widest line in each+-- column. Finally it adjusts each cell in the column so that it is+-- that maximum width.+--+-- Returns a list of rows, and a Fields holding the width of each+-- cell. Each of these widths will be at least 1; fields that were in+-- the report but that ended up having no width are changed to+-- Nothing.+growCells ::+  Options.T+  -> [Box]+  -> Fields (Maybe ([R.ColumnSpec], Int))+growCells o infos = toPair <$> wanted <*> growers where+  toPair b gwr+    | b = let+      cs = map (gwr o) infos+      w = Fdbl.foldl' f 0 cs where+        f acc c = max acc (widestLine c)+      cs' = map (sizer (R.Width w)) cs+      in if w > 0 then Just (cs', w) else Nothing+    | otherwise = Nothing+  wanted = growingFields o++widestLine :: PreSpec -> Int+widestLine (PreSpec _ _ bs) =+  maximum . map (R.unWidth . C.chunkWidth) $ bs++data PreSpec = PreSpec {+  _justification :: R.Justification+  , _padSpec :: C.TextSpec+  , _bits :: [C.Chunk] }+++-- | Given a PreSpec and a width, create a ColumnSpec of the right+-- size.+sizer :: R.Width -> PreSpec -> R.ColumnSpec+sizer w (PreSpec j ts bs) = R.ColumnSpec j w ts bs++-- | Makes a left justified cell that is only one line long. The width+-- is unset.+oneLine :: Text -> Options.T -> Box -> PreSpec+oneLine t os b =+  let bc = Options.baseColors os+      ts = PC.colors (M.visibleNum . L.boxMeta $ b) bc+      j = R.LeftJustify+      bit = C.chunk ts t+  in PreSpec j ts [bit]++growers :: Fields (Options.T -> Box -> PreSpec)+growers = Fields {+  globalTransaction      = getGlobalTransaction+  , revGlobalTransaction = getRevGlobalTransaction+  , globalPosting        = getGlobalPosting+  , revGlobalPosting     = getRevGlobalPosting+  , fileTransaction      = getFileTransaction+  , revFileTransaction   = getRevFileTransaction+  , filePosting          = getFilePosting+  , revFilePosting       = getRevFilePosting+  , filtered             = getFiltered+  , revFiltered          = getRevFiltered+  , sorted               = getSorted+  , revSorted            = getRevSorted+  , visible              = getVisible+  , revVisible           = getRevVisible+  , lineNum              = getLineNum+  , date                 = getDate+  , flag                 = getFlag+  , number               = getNumber+  , postingDrCr          = getPostingDrCr+  , postingCmdty         = getPostingCmdty+  , postingQty           = getPostingQty+  , totalDrCr            = getTotalDrCr+  , totalCmdty           = getTotalCmdty+  , totalQty             = getTotalQty }++-- | 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.+  +  -> Options.T -> Box -> PreSpec+serialCellMaybe f os b = oneLine t os b+  where+    t = case f (L.boxPostFam b) of+      Nothing -> X.empty+      Just i -> X.pack . show $ i++serialCell ::+  (M.PostMeta -> Int)+  -> Options.T -> Box -> PreSpec+serialCell f os b = oneLine t os b+  where+    t = pack . show . f . L.boxMeta $ b++getGlobalTransaction :: Options.T -> Box -> PreSpec+getGlobalTransaction =+  serialCellMaybe (fmap (L.forward . L.unGlobalTransaction)+                   . Q.globalTransaction)++getRevGlobalTransaction :: Options.T -> Box -> PreSpec+getRevGlobalTransaction =+  serialCellMaybe (fmap (L.backward . L.unGlobalTransaction)+                   . Q.globalTransaction)++getGlobalPosting :: Options.T -> Box -> PreSpec+getGlobalPosting =+  serialCellMaybe (fmap (L.forward . L.unGlobalPosting)+                   . Q.globalPosting)++getRevGlobalPosting :: Options.T -> Box -> PreSpec+getRevGlobalPosting =+  serialCellMaybe (fmap (L.backward . L.unGlobalPosting)+                   . Q.globalPosting)++getFileTransaction :: Options.T -> Box -> PreSpec+getFileTransaction =+  serialCellMaybe (fmap (L.forward . L.unFileTransaction)+                   . Q.fileTransaction)++getRevFileTransaction :: Options.T -> Box -> PreSpec+getRevFileTransaction =+  serialCellMaybe (fmap (L.backward . L.unFileTransaction)+                   . Q.fileTransaction)++getFilePosting :: Options.T -> Box -> PreSpec+getFilePosting =+  serialCellMaybe (fmap (L.forward . L.unFilePosting)+                   . Q.filePosting)++getRevFilePosting :: Options.T -> Box -> PreSpec+getRevFilePosting =+  serialCellMaybe (fmap (L.backward . L.unFilePosting)+                   . Q.filePosting)++getSorted :: Options.T -> Box -> PreSpec+getSorted =+  serialCell (L.forward . Ly.unSortedNum . M.sortedNum)++getRevSorted :: Options.T -> Box -> PreSpec+getRevSorted =+  serialCell (L.backward . Ly.unSortedNum . M.sortedNum)++getFiltered :: Options.T -> Box -> PreSpec+getFiltered =+  serialCell (L.forward . Ly.unFilteredNum . M.filteredNum)++getRevFiltered :: Options.T -> Box -> PreSpec+getRevFiltered =+  serialCell (L.backward . Ly.unFilteredNum . M.filteredNum)++getVisible :: Options.T -> Box -> PreSpec+getVisible =+  serialCell (L.forward . M.unVisibleNum . M.visibleNum)++getRevVisible :: Options.T -> Box -> PreSpec+getRevVisible =+  serialCell (L.backward . M.unVisibleNum . M.visibleNum)+++getLineNum :: Options.T -> Box -> PreSpec+getLineNum os b = oneLine t os b where+  lineTxt = pack . show . L.unPostingLine+  t = maybe empty lineTxt (Q.postingLine . L.boxPostFam $ b)++getDate :: Options.T -> Box -> PreSpec+getDate os i = oneLine t os i where+  t = O.dateFormat os i++getFlag :: Options.T -> Box -> PreSpec+getFlag os i = oneLine t os i where+  t = maybe empty L.text (Q.flag . L.boxPostFam $ i)++getNumber :: Options.T -> Box -> PreSpec+getNumber os i = oneLine t os 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"++-- | Gives a one-line cell that is colored according to whether the+-- posting is a debit or credit.+coloredPostingCell :: Text -> Options.T -> Box -> PreSpec+coloredPostingCell t os i = PreSpec j ts [bit] where+  j = R.LeftJustify+  bit = C.chunk ts t+  dc = Q.drCr . L.boxPostFam $ i+  ts = PC.colors (M.visibleNum . L.boxMeta $ i)+       . PC.drCrToBaseColors dc+       . O.drCrColors+       $ os++getPostingDrCr :: Options.T -> Box -> PreSpec+getPostingDrCr os i = coloredPostingCell t os i where+  t = dcTxt . Q.drCr . L.boxPostFam $ i++getPostingCmdty :: Options.T -> Box -> PreSpec+getPostingCmdty os i = coloredPostingCell t os i where+  t = L.text . L.Delimited (X.singleton ':') +      . L.textList . Q.commodity . L.boxPostFam $ i++getPostingQty :: Options.T -> Box -> PreSpec+getPostingQty os i = coloredPostingCell t os i where+  t = O.qtyFormat os i++getTotalDrCr :: Options.T -> Box -> PreSpec+getTotalDrCr os i = let+  vn = M.visibleNum . L.boxMeta $ i+  ts = PC.colors vn bc+  bc = PC.drCrToBaseColors dc (O.drCrColors os)+  dc = Q.drCr . L.boxPostFam $ i+  bits = case M.balance . L.boxMeta $ i of+    Nothing -> let+      spec = PC.noBalanceColors vn (O.drCrColors os)+      in [C.chunk spec (pack "--")]+    Just bal -> let+      toBit bl = let+        spec = +          PC.colors vn+          . PC.bottomLineToBaseColors (O.drCrColors os)+          $ 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+  j = R.LeftJustify+  in PreSpec j ts bits++getTotalCmdty :: Options.T -> Box -> PreSpec+getTotalCmdty os i = let+  vn = M.visibleNum . L.boxMeta $ i+  j = R.RightJustify+  ts = PC.colors vn bc+  bc = PC.drCrToBaseColors dc (O.drCrColors os)+  dc = Q.drCr . L.boxPostFam $ i+  bits = case M.balance . L.boxMeta $ i of+    Nothing -> let+      spec = PC.noBalanceColors vn (O.drCrColors os)+      in [C.chunk spec (pack "--")]+    Just bal -> let+      toBit (com, nou) = let+        spec =+          PC.colors vn+          . PC.bottomLineToBaseColors (O.drCrColors os)+          $ 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++getTotalQty :: Options.T -> Box -> PreSpec+getTotalQty os i = let+  vn = M.visibleNum . L.boxMeta $ i+  j = R.LeftJustify+  ts = PC.colors vn bc+  bc = PC.drCrToBaseColors dc (O.drCrColors os)+  dc = Q.drCr . L.boxPostFam $ i+  bits = case M.balance . L.boxMeta $ i of+    Nothing -> let+      spec = PC.noBalanceColors vn (O.drCrColors os)+      in [C.chunk spec (pack "--")]+    Just bal -> fmap toChunk . assocs . L.unBalance $ bal where+      toChunk (com, nou) = let+        spec = +          PC.colors vn+          . PC.bottomLineToBaseColors (O.drCrColors os)+          $ nou+        txt = O.balanceFormat os com nou+        in C.chunk spec txt+  in PreSpec j ts bits++growingFields :: Options.T -> Fields Bool+growingFields o = let+  f = O.fields o in Fields {+    globalTransaction      = F.globalTransaction  f+    , revGlobalTransaction = F.revGlobalTransaction  f+    , globalPosting        = F.globalPosting      f+    , revGlobalPosting     = F.revGlobalPosting   f+    , fileTransaction      = F.fileTransaction    f+    , revFileTransaction   = F.revFileTransaction f+    , filePosting          = F.filePosting        f+    , revFilePosting       = F.revFilePosting     f+    , filtered             = F.filtered           f+    , revFiltered          = F.revFiltered        f+    , sorted               = F.sorted             f+    , revSorted            = F.revSorted          f+    , visible              = F.visible            f+    , revVisible           = F.revVisible         f+    , lineNum              = F.lineNum            f+    , date                 = F.date               f+    , flag                 = F.flag               f+    , number               = F.number             f+    , postingDrCr          = F.postingDrCr        f+    , postingCmdty         = F.postingCmdty       f+    , postingQty           = F.postingQty         f+    , totalDrCr            = F.totalDrCr          f+    , totalCmdty           = F.totalCmdty         f+    , totalQty             = F.totalQty           f }++-- | All growing fields, as an ADT.+data EFields =+  EGlobalTransaction+  | ERevGlobalTransaction+  | EGlobalPosting+  | ERevGlobalPosting+  | EFileTransaction+  | ERevFileTransaction+  | EFilePosting+  | ERevFilePosting+  | EFiltered+  | ERevFiltered+  | ESorted+  | ERevSorted+  | EVisible+  | ERevVisible+  | ELineNum+  | EDate+  | EFlag+  | ENumber+  | EPostingDrCr+  | EPostingCmdty+  | EPostingQty+  | ETotalDrCr+  | ETotalCmdty+  | ETotalQty+  deriving (Show, Eq, Ord, Enum)++-- | Returns a Fields where each record has its corresponding EField.+eFields :: Fields EFields+eFields = Fields {+  globalTransaction      = EGlobalTransaction+  , revGlobalTransaction = ERevGlobalTransaction+  , globalPosting        = EGlobalPosting+  , revGlobalPosting     = ERevGlobalPosting+  , fileTransaction      = EFileTransaction+  , revFileTransaction   = ERevFileTransaction+  , filePosting          = EFilePosting+  , revFilePosting       = ERevFilePosting+  , filtered             = EFiltered+  , revFiltered          = ERevFiltered+  , sorted               = ESorted+  , revSorted            = ERevSorted+  , visible              = EVisible+  , revVisible           = ERevVisible+  , lineNum              = ELineNum+  , date                 = EDate+  , flag                 = EFlag+  , number               = ENumber+  , postingDrCr          = EPostingDrCr+  , postingCmdty         = EPostingCmdty+  , postingQty           = EPostingQty+  , totalDrCr            = ETotalDrCr+  , totalCmdty           = ETotalCmdty+  , totalQty             = ETotalQty }++-- | All growing fields.+data Fields a = Fields {+  globalTransaction      :: a+  , revGlobalTransaction :: a+  , globalPosting        :: a+  , revGlobalPosting     :: a+  , fileTransaction      :: a+  , revFileTransaction   :: a+  , filePosting          :: a+  , revFilePosting       :: a+  , filtered             :: a+  , revFiltered          :: a+  , sorted               :: a+  , revSorted            :: a+  , visible              :: a+  , revVisible           :: a+  , lineNum              :: a+    -- ^ The line number from the posting's metadata+  , date                 :: a+  , flag                 :: a+  , number               :: a+  , postingDrCr          :: a+  , postingCmdty         :: a+  , postingQty           :: a+  , totalDrCr            :: a+  , totalCmdty           :: a+  , totalQty             :: a }+  deriving (Show, Eq)++instance Fdbl.Foldable Fields where+  foldr f z i =+    f (globalTransaction i)+    (f (revGlobalTransaction i)+     (f (globalPosting i)+      (f (revGlobalPosting i)+       (f (fileTransaction i)+        (f (revFileTransaction i)+         (f (filePosting i)+          (f (revFilePosting i)+           (f (filtered i)+            (f (revFiltered i)+             (f (sorted i)+              (f (revSorted i)+               (f (visible i)+                (f (revVisible i)+                 (f (lineNum i)+                  (f (date i)+                   (f (flag i)+                    (f (number i)+                     (f (postingDrCr i)+                      (f (postingCmdty i)+                       (f (postingQty i)+                        (f (totalDrCr i)+                         (f (totalCmdty i)+                          (f (totalQty i) z)))))))))))))))))))))))++instance Functor Fields where+  fmap f i = Fields {+    globalTransaction      = f (globalTransaction    i)+    , revGlobalTransaction = f (revGlobalTransaction i)+    , globalPosting        = f (globalPosting        i)+    , revGlobalPosting     = f (revGlobalPosting     i)+    , fileTransaction      = f (fileTransaction      i)+    , revFileTransaction   = f (revFileTransaction   i)+    , filePosting          = f (filePosting          i)+    , revFilePosting       = f (revFilePosting       i)+    , filtered             = f (filtered             i)+    , revFiltered          = f (revFiltered          i)+    , sorted               = f (sorted               i)+    , revSorted            = f (revSorted            i)+    , visible              = f (visible              i)+    , revVisible           = f (revVisible           i)+    , lineNum              = f (lineNum              i)+    , date                 = f (date                 i)+    , flag                 = f (flag                 i)+    , number               = f (number               i)+    , postingDrCr          = f (postingDrCr          i)+    , postingCmdty         = f (postingCmdty         i)+    , postingQty           = f (postingQty           i)+    , totalDrCr            = f (totalDrCr            i)+    , totalCmdty           = f (totalCmdty           i)+    , totalQty             = f (totalQty             i) }++instance Applicative Fields where+  pure a = Fields {+    globalTransaction      = a+    , revGlobalTransaction = a+    , globalPosting        = a+    , revGlobalPosting     = a+    , fileTransaction      = a+    , revFileTransaction   = a+    , filePosting          = a+    , revFilePosting       = a+    , filtered             = a+    , revFiltered          = a+    , sorted               = a+    , revSorted            = a+    , visible              = a+    , revVisible           = a+    , lineNum              = a+    , date                 = a+    , flag                 = a+    , number               = a+    , postingDrCr          = a+    , postingCmdty         = a+    , postingQty           = a+    , totalDrCr            = a+    , totalCmdty           = a+    , totalQty             = a }++  fl <*> fa = Fields {+    globalTransaction      = globalTransaction    fl (globalTransaction    fa)+    , revGlobalTransaction = revGlobalTransaction fl (revGlobalTransaction fa)+    , globalPosting        = globalPosting        fl (globalPosting        fa)+    , revGlobalPosting     = revGlobalPosting     fl (revGlobalPosting     fa)+    , fileTransaction      = fileTransaction      fl (fileTransaction      fa)+    , revFileTransaction   = revFileTransaction   fl (revFileTransaction   fa)+    , filePosting          = filePosting          fl (filePosting          fa)+    , revFilePosting       = revFilePosting       fl (revFilePosting       fa)+    , filtered             = filtered             fl (filtered             fa)+    , revFiltered          = revFiltered          fl (revFiltered          fa)+    , sorted               = sorted               fl (sorted               fa)+    , revSorted            = revSorted            fl (revSorted            fa)+    , visible              = visible              fl (visible              fa)+    , revVisible           = revVisible           fl (revVisible           fa)+    , lineNum              = lineNum              fl (lineNum              fa)+    , date                 = date                 fl (date                 fa)+    , flag                 = flag                 fl (flag                 fa)+    , number               = number               fl (number               fa)+    , postingDrCr          = postingDrCr          fl (postingDrCr          fa)+    , postingCmdty         = postingCmdty         fl (postingCmdty         fa)+    , postingQty           = postingQty           fl (postingQty           fa)+    , totalDrCr            = totalDrCr            fl (totalDrCr            fa)+    , totalCmdty           = totalCmdty           fl (totalCmdty           fa)+    , totalQty             = totalQty             fl (totalQty             fa) }++-- | Pairs data from a Fields with its matching spacer field. The+-- spacer field is returned in a Maybe because the TotalQty field does+-- not have a spacer.+pairWithSpacer :: Fields a -> Spacers.T b -> Fields (a, Maybe b)+pairWithSpacer f s = Fields {+  globalTransaction      = (globalTransaction    f, Just (S.globalTransaction    s))+  , revGlobalTransaction = (revGlobalTransaction f, Just (S.revGlobalTransaction s))+  , globalPosting        = (globalPosting        f, Just (S.globalPosting        s))+  , revGlobalPosting     = (revGlobalPosting     f, Just (S.revGlobalPosting     s))+  , fileTransaction      = (fileTransaction      f, Just (S.fileTransaction      s))+  , revFileTransaction   = (revFileTransaction   f, Just (S.revFileTransaction   s))+  , filePosting          = (filePosting          f, Just (S.filePosting          s))+  , revFilePosting       = (revFilePosting       f, Just (S.revFilePosting       s))+  , filtered             = (filtered             f, Just (S.filtered             s))+  , revFiltered          = (revFiltered          f, Just (S.revFiltered          s))+  , sorted               = (sorted               f, Just (S.sorted               s))+  , revSorted            = (revSorted            f, Just (S.revSorted            s))+  , visible              = (visible              f, Just (S.visible              s))+  , revVisible           = (revVisible           f, Just (S.revVisible           s))+  , lineNum              = (lineNum              f, Just (S.lineNum              s))+  , date                 = (date                 f, Just (S.date                 s))+  , flag                 = (flag                 f, Just (S.flag                 s))+  , number               = (number               f, Just (S.number               s))+  , postingDrCr          = (postingDrCr          f, Just (S.postingDrCr          s))+  , postingCmdty         = (postingCmdty         f, Just (S.postingCmdty         s))+  , postingQty           = (postingQty           f, Just (S.postingQty           s))+  , totalDrCr            = (totalDrCr            f, Just (S.totalDrCr            s))+  , totalCmdty           = (totalCmdty           f, Just (S.totalCmdty           s))+  , totalQty             = (totalQty             f, Nothing                        ) }++-- | Reduces a set of Fields to a single value.+reduce :: Semi.Semigroup s => Fields s -> s+reduce f =+  globalTransaction       f+  <> revGlobalTransaction f+  <> globalPosting        f+  <> revGlobalPosting     f+  <> fileTransaction      f+  <> revFileTransaction   f+  <> filePosting          f+  <> revFilePosting       f+  <> filtered             f+  <> revFiltered          f+  <> sorted               f+  <> revSorted            f+  <> visible              f+  <> revVisible           f+  <> lineNum              f+  <> date                 f+  <> flag                 f+  <> number               f+  <> postingDrCr          f+  <> postingCmdty         f+  <> postingQty           f+  <> totalDrCr            f+  <> totalCmdty           f+  <> totalQty             f++-- | Compute the width of all Grown cells, including any applicable+-- spacer cells.+grownWidth ::+  Fields (Maybe Int)+  -> Spacers.T Int+  -> Int+grownWidth fs ss =+  Semi.getSum+  . reduce+  . fmap Semi.Sum+  . fmap fieldWidth+  $ pairWithSpacer fs ss++-- | Compute the field width of a single field and its spacer. The+-- first element of the tuple is the field width, if present; the+-- second element of the tuple is the width of the spacer. If there is+-- no field, returns 0.+fieldWidth :: (Maybe Int, Maybe Int) -> Int+fieldWidth (m1, m2) = case m1 of+  Nothing -> 0+  Just i1 -> case m2 of+    Just i2 -> if i2 > 0 then i1 + i2 else i1+    Nothing -> i1+
+ Penny/Cabin/Posts/Help.hs view
@@ -0,0 +1,66 @@+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",+  ""+  ]
+ Penny/Cabin/Posts/Meta.hs view
@@ -0,0 +1,70 @@+module Penny.Cabin.Posts.Meta (+  M.VisibleNum(M.unVisibleNum)+  , PostMeta(filteredNum, sortedNum, visibleNum, balance)+  , filterBoxes+  , addMetadata+  ) where++import Data.List (mapAccumL)+import qualified Penny.Lincoln as L+import qualified Penny.Lincoln.Queries as Q+import qualified Penny.Liberty as Ly+import qualified Penny.Liberty.Expressions as Exp+import qualified Penny.Cabin.Meta as M+import qualified Penny.Cabin.Options as CO++data PostMeta =+  PostMeta { filteredNum :: Ly.FilteredNum+            , sortedNum :: Ly.SortedNum+            , visibleNum :: M.VisibleNum+            , balance :: Maybe L.Balance }+  deriving Show+++-- | Takes a list of Box with LibertyMeta, and a list of tokens from+-- the command line, and a list of post filters. Filters the list of+-- Box and processes the post filter. Fails if the expression fails to+-- produce a result.+filterBoxes ::+  [Exp.Token (L.Box Ly.LibertyMeta -> Bool)]+  -> [Ly.PostFilterFn]+  -> [L.Box Ly.LibertyMeta]+  -> Maybe [L.Box Ly.LibertyMeta]+filterBoxes tks pfs bs = fmap fltr (Ly.parsePredicate tks)+  where+    fltr p =+      Ly.processPostFilters pfs . filter p $ bs++++-- | Applied to a list of Box that have already been filtered, returns+-- a list of Box with posting metadata.+addMetadata ::+  CO.ShowZeroBalances+  -> [L.Box Ly.LibertyMeta]+  -> [L.Box PostMeta]+addMetadata szb = M.visibleNums f . addBalances szb where+  f vn (lm, mb) =+    PostMeta (Ly.filteredNum lm) (Ly.sortedNum lm) vn mb++addBalances ::+  CO.ShowZeroBalances+  -> [L.Box Ly.LibertyMeta]+  -> [(L.Box (Ly.LibertyMeta, Maybe L.Balance))]+addBalances szb = snd . mapAccumL (balanceAccum szb) Nothing++balanceAccum :: +  CO.ShowZeroBalances+  -> Maybe L.Balance+  -> L.Box Ly.LibertyMeta+  -> (Maybe L.Balance, (L.Box (Ly.LibertyMeta, Maybe L.Balance)))+balanceAccum (CO.ShowZeroBalances szb) mb po =+  let balThis = L.entryToBalance . Q.entry . L.boxPostFam $ po+      balNew = case mb of+        Nothing -> balThis+        Just balOld -> L.addBalances balOld balThis+      balNoZeroes = L.removeZeroCommodities balNew+      bal' = if szb then Just balNew else balNoZeroes+      po' = L.Box (L.boxMeta po, bal') (L.boxPostFam po)+  in (bal', po')+
+ Penny/Cabin/Posts/Options.hs view
@@ -0,0 +1,247 @@+-- | Options for the Posts report.+module Penny.Cabin.Posts.Options where+++import Control.Monad.Exception.Synchronous (Exceptional)+import Data.Text (Text)+import qualified Data.Text as X+import Data.Time (formatTime)+import System.Locale (defaultTimeLocale)+import qualified Data.Time as Time+import qualified Text.Matchers.Text as M++import qualified Penny.Liberty as Ly+import qualified Penny.Liberty.Expressions as Ex+import qualified Penny.Lincoln as L+import qualified Penny.Lincoln.Balance as Bal+import qualified Penny.Lincoln.Bits as Bits+import qualified Penny.Lincoln.Queries as Q+import qualified Penny.Cabin.Posts.Allocate as A+import qualified Penny.Cabin.Chunk as CC+import qualified Penny.Cabin.Colors as C+import qualified Penny.Cabin.Options as O+import qualified Penny.Cabin.Posts.Fields as Fields+import qualified Penny.Cabin.Posts.Fields as F+import qualified Penny.Cabin.Posts.Meta as Meta+import qualified Penny.Cabin.Posts.Spacers as S+import qualified Penny.Cabin.Posts.Spacers as Spacers+import qualified Penny.Cabin.Colors.DarkBackground as Dark+import Penny.Copper.DateTime (DefaultTimeZone)+import Penny.Copper.Qty (RadGroup)+import qualified Penny.Shield as S+++type Box = L.Box Meta.PostMeta++data T =+  T { drCrColors :: C.DrCrColors+      -- ^ Colors to use when displaying debits, credits, and+      -- when displaying balance totals++    , baseColors :: C.BaseColors +      -- ^ Colors to use when displaying everything else++    , dateFormat :: Box -> X.Text+      -- ^ How to display dates. This function is applied to the+      -- a PostingInfo so it has lots of information, but it+      -- should return a date for use in the Date field.+      +    , qtyFormat :: Box -> X.Text+      -- ^ How to display the quantity of the posting. This+      -- function is applied to a PostingInfo so it has lots of+      -- information, but it should return a formatted string of+      -- the quantity. Allows you to format digit grouping,+      -- radix points, perform rounding, etc.+      +    , balanceFormat :: Bits.Commodity -> Bal.BottomLine -> X.Text+      -- ^ How to display balance totals. Similar to+      -- balanceFormat.+      +    , payeeAllocation :: A.Allocation+      -- ^ This and accountAllocation determine how much space+      -- payees and accounts receive. They divide up the+      -- remaining space after everything else is displayed. For+      -- instance if payeeAllocation is 60 and accountAllocation+      -- is 40, the payee takes about 60 percent of the+      -- remaining space and the account takes about 40 percent.+      +    , accountAllocation :: A.Allocation +      -- ^ See payeeAllocation above++    , width :: ReportWidth+      -- ^ Gives the default report width. This can be+      -- overridden on the command line. You can use the+      -- information from the Runtime to make this as wide as+      -- the as the current terminal.++    , subAccountLength :: Int+      -- ^ When shortening the names of sub accounts to make+      -- them fit, they will be this long.++    , colorPref :: CC.Colors+      -- ^ How many colors you want to see, or do it+      -- automatically.++    , timeZone :: DefaultTimeZone+      -- ^ When dates and times are given on the command line+      -- and they have no time zone, they are assumed to be in+      -- this time zone. This has no bearing on how dates are+      -- formatted in the output; for that, see dateFormat+      -- above.++    , radGroup :: RadGroup+      -- ^ The characters used for the radix point for numbers+      -- given on the command line (e.g. a full stop, or a+      -- comma) and for the digit group separator for+      -- numbers parsed from the command line (e.g. a full stop,+      -- or a comma). Affects how inputs are parsed. Has no bearing+      -- on how output is formatted; for that, see qtyFormat and+      -- balanceFormat above.+      +    , sensitive :: M.CaseSensitive+      -- ^ Whether pattern matches are case sensitive by default.+      +    , factory :: M.CaseSensitive+                 -> Text -> Exceptional Text (Text -> Bool)+      -- ^ Default factory for pattern matching+      +    , tokens :: [Ex.Token (L.Box Ly.LibertyMeta -> Bool)]+      -- ^ Default list of tokens used to filter postings.+      +    , postFilter :: [Ly.PostFilterFn]+      -- ^ The entire posting list is transformed by this+      -- function after it is filtered according to the tokens.+      +    , fields :: Fields.T Bool+      -- ^ Default fields to show in the report.+      +    , spacers :: Spacers.T 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.+      +    , showZeroBalances :: O.ShowZeroBalances+    }++newtype ReportWidth = ReportWidth { unReportWidth :: Int }+                      deriving (Eq, Show, Ord)++ymd :: Box -> X.Text+ymd p = X.pack (formatTime defaultTimeLocale fmt d) where+  d = Time.localDay+      . Bits.localTime+      . Q.dateTime+      . L.boxPostFam+      $ p+  fmt = "%Y-%m-%d"++qtyAsIs :: Box -> X.Text+qtyAsIs p = X.pack . show . Bits.unQty . Q.qty . L.boxPostFam $ p++balanceAsIs :: Bits.Commodity -> Bal.BottomLine -> X.Text+balanceAsIs _ n = case n of+  Bal.Zero -> X.pack "--"+  Bal.NonZero c -> X.pack . show . Bits.unQty . Bal.qty $ c++defaultWidth :: ReportWidth+defaultWidth = ReportWidth 80++columnsVarToWidth :: Maybe String -> ReportWidth+columnsVarToWidth ms = case ms of+  Nothing -> defaultWidth+  Just str -> case reads str of+    [] -> defaultWidth+    (i, []):[] -> if i > 0 then ReportWidth i else defaultWidth+    _ -> defaultWidth++defaultOptions ::+  DefaultTimeZone+  -> RadGroup+  -> S.Runtime+  -> T+defaultOptions dtz rg rt =+  T { drCrColors = Dark.drCrColors+    , baseColors = Dark.baseColors+    , dateFormat = ymd+    , qtyFormat = qtyAsIs+    , balanceFormat = balanceAsIs+    , payeeAllocation = A.allocation 40+    , accountAllocation = A.allocation 60+    , width = widthFromRuntime rt+    , subAccountLength = 2+    , colorPref = O.autoColors O.PrefAuto rt+    , timeZone = dtz+    , radGroup = rg+    , sensitive = M.Insensitive+    , factory = \s t -> (return (M.within s t))+    , tokens = []+    , postFilter = []+    , fields = defaultFields+    , spacers = defaultSpacerWidth+    , showZeroBalances = O.ShowZeroBalances False }++widthFromRuntime :: S.Runtime -> ReportWidth+widthFromRuntime rt = case S.screenWidth rt of+  Nothing -> defaultWidth+  Just w -> ReportWidth . S.unScreenWidth $ w++defaultFields :: Fields.T Bool+defaultFields =+  Fields.T { F.globalTransaction    = False+           , F.revGlobalTransaction = False+           , F.globalPosting        = False+           , F.revGlobalPosting     = False+           , F.fileTransaction      = False+           , F.revFileTransaction   = False+           , F.filePosting          = False+           , F.revFilePosting       = False+           , F.filtered             = False+           , F.revFiltered          = False+           , F.sorted               = False+           , F.revSorted            = False+           , F.visible              = False+           , F.revVisible           = False+           , F.lineNum              = False+           , F.date                 = True+           , F.flag                 = False+           , F.number               = False+           , F.payee                = True+           , F.account              = True+           , F.postingDrCr          = True+           , F.postingCmdty         = True+           , F.postingQty           = True+           , F.totalDrCr            = True+           , F.totalCmdty           = True+           , F.totalQty             = True+           , F.tags                 = False+           , F.memo                 = False+           , F.filename             = False }++defaultSpacerWidth :: Spacers.T Int+defaultSpacerWidth =+  Spacers.T { S.globalTransaction    = 1+            , S.revGlobalTransaction = 1+            , S.globalPosting        = 1+            , S.revGlobalPosting     = 1+            , S.fileTransaction      = 1+            , S.revFileTransaction   = 1+            , S.filePosting          = 1+            , S.revFilePosting       = 1+            , S.filtered             = 1+            , S.revFiltered          = 1+            , S.sorted               = 1+            , S.revSorted            = 1+            , S.visible              = 1+            , S.revVisible           = 1+            , S.lineNum              = 1+            , S.date                 = 1+            , S.flag                 = 1+            , S.number               = 1+            , S.payee                = 4+            , S.account              = 1+            , S.postingDrCr          = 1+            , S.postingCmdty         = 1+            , S.postingQty           = 1+            , S.totalDrCr            = 1+            , S.totalCmdty           = 1 }+
+ Penny/Cabin/Posts/Parser.hs view
@@ -0,0 +1,326 @@+module Penny.Cabin.Posts.Parser (parseOptions) where++import Control.Applicative ((<|>), (<$>), pure, many, (<*>))+import Control.Monad ((>=>))+import qualified Control.Monad.Exception.Synchronous as Ex+import Data.Char (toLower)+import qualified Data.Foldable as F+import qualified System.Console.MultiArg.Combinator as C+import System.Console.MultiArg.Prim (Parser)++import qualified Penny.Cabin.Chunk as CC+import qualified Penny.Cabin.Colors as PC+import qualified Penny.Cabin.Posts.Fields as Fl+import qualified Penny.Cabin.Posts.Options as Op+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.Liberty as Ly+import qualified Penny.Liberty.Expressions as Exp+import qualified Penny.Lincoln as L+import qualified Penny.Shield as S++data Error = BadColorName String+             | BadBackgroundArg String+             | BadWidthArg String+             | NoMatchingFieldName+             | MultipleMatchingFieldNames [String]+             | LibertyError Ly.Error+             | BadNumber String+             | BadComparator String+             deriving Show++-- | Parses the command line from the first word remaining up until,+-- but not including, the first non-option argment.+parseOptions ::+  Parser (S.Runtime -> Op.T -> Ex.Exceptional Error Op.T)+parseOptions = f <$> many parseOption where+  f ls =+    let g rt op =+          let ls' = map (\fn -> fn rt) ls+          in (foldl (>=>) return ls') op+    in g+++parseOption ::+  Parser (S.Runtime -> Op.T -> Ex.Exceptional Error Op.T)+parseOption =+  operand+  <|> mkTwoArg boxFilters+  <|> mkTwoArg postFilter+  <|> mkTwoArg matcherSelect+  <|> mkTwoArg caseSelect+  <|> mkTwoArg operator+  <|> color+  <|> mkTwoArg background+  <|> mkTwoArg width+  <|> mkTwoArg showField+  <|> mkTwoArg hideField+  <|> mkTwoArg showAllFields+  <|> mkTwoArg hideAllFields+  <|> mkTwoArg showZeroBalances+  <|> mkTwoArg hideZeroBalances+  where+    mkTwoArg p = do+      f <- p+      return (\_ o -> f o)++operand :: Parser (S.Runtime -> Op.T -> Ex.Exceptional Error Op.T)+operand = f <$> Ly.parseOperand+  where+    f lyFn rt op =+      let dtz = Op.timeZone op+          rg = Op.radGroup op+          dt = S.currentTime rt+          cs = Op.sensitive op+          fty = Op.factory op+      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' = Op.tokens op ++ [Exp.TokOperand g']+          in return op { Op.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 (Op.T -> Ex.Exceptional Error Op.T)++optBoxSerial ls ss f = parseOpt ls ss (C.TwoArg g)+  where+    g a1 a2 op = do+      cmp <- Ex.fromMaybe (BadComparator a1) (Ly.parseComparer a1)+      i <- parseInt a2+      let h box =+            let ser = f . L.boxMeta $ box+            in ser `cmp` i+          tok = Exp.TokOperand h+      return op { Op.tokens = Op.tokens op ++ [tok] }++optFilteredNum :: Parser (Op.T -> Ex.Exceptional Error Op.T)+optFilteredNum = optBoxSerial ["filtered"] "" f+  where+    f = L.forward . Ly.unFilteredNum . Ly.filteredNum++optRevFilteredNum :: Parser (Op.T -> Ex.Exceptional Error Op.T)+optRevFilteredNum = optBoxSerial ["revFiltered"] "" f+  where+    f = L.backward . Ly.unFilteredNum . Ly.filteredNum++optSortedNum :: Parser (Op.T -> Ex.Exceptional Error Op.T)+optSortedNum = optBoxSerial ["sorted"] "" f+  where+    f = L.forward . Ly.unSortedNum . Ly.sortedNum++optRevSortedNum :: Parser (Op.T -> Ex.Exceptional Error Op.T)+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 (Op.T -> Ex.Exceptional Error Op.T)+boxFilters =+  optFilteredNum+  <|> optRevFilteredNum+  <|> optSortedNum+  <|> optRevSortedNum+++postFilter :: Parser (Op.T -> Ex.Exceptional Error Op.T)+postFilter = f <$> Ly.parsePostFilter+  where+    f ex op =+      case ex of+        Ex.Exception e -> Ex.throw . LibertyError $ e+        Ex.Success pf ->+          return op { Op.postFilter = Op.postFilter op ++ [pf] }++matcherSelect :: Parser (Op.T -> Ex.Exceptional Error Op.T)+matcherSelect = f <$> Ly.parseMatcherSelect+  where+    f mf op = return op { Op.factory = mf }++caseSelect :: Parser (Op.T -> Ex.Exceptional Error Op.T)+caseSelect = f <$> Ly.parseCaseSelect+  where+    f cs op = return op { Op.sensitive = cs }++operator :: Parser (Op.T -> Ex.Exceptional Error Op.T)+operator = f <$> Ly.parseOperator+  where+    f oo op = return op { Op.tokens = Op.tokens op ++ [oo] }++parseOpt :: [String] -> [Char] -> C.ArgSpec a -> Parser a+parseOpt ss cs a = C.parseOption [C.OptSpec ss cs a]++color :: Parser (S.Runtime -> Op.T -> Ex.Exceptional Error Op.T)+color = parseOpt ["color"] "" (C.OneArg f)+  where+    f a1 rt op = case pickColorArg rt a1 of+      Nothing -> Ex.throw . BadColorName $ a1+      Just c -> return (op { Op.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+++background :: Parser (Op.T -> Ex.Exceptional Error Op.T)+background = parseOpt ["background"] "" (C.OneArg f)+  where+    f a1 op = case pickBackgroundArg a1 of+      Nothing -> Ex.throw . BadBackgroundArg $ a1+      Just (dc, bc) -> return (op { Op.drCrColors = dc+                                  , Op.baseColors = bc } )+++width :: Parser (Op.T -> Ex.Exceptional Error Op.T)+width = parseOpt ["width"] "" (C.OneArg f)+  where+    f a1 op = case reads a1 of+      (i, ""):[] -> return (op { Op.width = Op.ReportWidth i })+      _ -> Ex.throw . BadWidthArg $ a1++showField :: Parser (Op.T -> Ex.Exceptional Error Op.T)+showField = parseOpt ["show"] "" (C.OneArg f)+  where+    f a1 op = do+      fl <- parseField a1+      let newFl = fieldOn (Op.fields op) fl+      return op { Op.fields = newFl }++hideField :: Parser (Op.T -> Ex.Exceptional Error Op.T)+hideField = parseOpt ["hide"] "" (C.OneArg f)+  where+    f a1 op = do+      fl <- parseField a1+      let newFl = fieldOff (Op.fields op) fl+      return op { Op.fields = newFl }++showAllFields :: Parser (Op.T -> Ex.Exceptional a Op.T)+showAllFields = parseOpt ["show-all"] "" (C.NoArg f)+  where+    f op = return (op {Op.fields = pure True})++hideAllFields :: Parser (Op.T -> Ex.Exceptional a Op.T)+hideAllFields = parseOpt ["hide-all"] "" (C.NoArg f)+  where+    f op = return (op {Op.fields = pure False})++showZeroBalances :: Parser (Op.T -> Ex.Exceptional a Op.T)+showZeroBalances = parseOpt ["show-zero-balances"] "" (C.NoArg f)+  where+    f op =+      return (op {Op.showZeroBalances = CO.ShowZeroBalances True })++hideZeroBalances :: Parser (Op.T -> Ex.Exceptional a Op.T)+hideZeroBalances = parseOpt ["hide-zero-balances"] "" (C.NoArg f)+  where+    f op =+      return (op {Op.showZeroBalances = CO.ShowZeroBalances False })++-- | Turns a field on if it is True.+fieldOn ::+  Fl.T Bool+  -- ^ Fields as seen so far++  -> Fl.T Bool+  -- ^ Record that should have one True element indicating a field+  -- name seen on the command line; other elements should be False+  +  -> Fl.T Bool+  -- ^ Fields as seen so far, with new field added++fieldOn old new = (||) <$> old <*> new++-- | Turns off a field if it is True.+fieldOff ::+  Fl.T Bool+  -- ^ Fields seen so far+  +  -> Fl.T Bool+  -- ^ Record that should have one True element indicating a field+  -- name seen on the command line; other elements should be False+  +  -> Fl.T Bool+  -- ^ Fields as seen so far, with new field added++fieldOff old new = f <$> old <*> new+  where+    f o False = o+    f _ True = False++parseField :: String -> Ex.Exceptional Error (Fl.T 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++-- | Checks the fields with the True value to ensure there is only one.+checkFields :: Fl.T (String, Bool) -> Ex.Exceptional Error (Fl.T Bool)+checkFields fs =+  let f (s, b) ls = if b then s:ls else ls+  in case F.foldr f [] fs of+    [] -> Ex.throw NoMatchingFieldName+    _:[] -> return (snd <$> fs)+    ls -> Ex.throw . MultipleMatchingFieldNames $ ls++++fieldNames :: Fl.T String+fieldNames = Fl.T {+  Fl.globalTransaction = "globalTransaction"+  , Fl.revGlobalTransaction = "revGlobalTransaction"+  , Fl.globalPosting = "globalPosting"+  , Fl.revGlobalPosting = "revGlobalPosting"+  , Fl.fileTransaction = "fileTransaction"+  , Fl.revFileTransaction = "revFileTransaction"+  , Fl.filePosting = "filePosting"+  , Fl.revFilePosting = "revFilePosting"+  , Fl.filtered = "filtered"+  , Fl.revFiltered = "revFiltered"+  , Fl.sorted = "sorted"+  , Fl.revSorted = "revSorted"+  , Fl.visible = "visible"+  , Fl.revVisible = "revVisible"+  , Fl.lineNum = "lineNum"+  , Fl.date = "date"+  , Fl.flag = "flag"+  , Fl.number = "number"+  , Fl.payee = "payee"+  , Fl.account = "account"+  , Fl.postingDrCr = "postingDrCr"+  , Fl.postingCmdty = "postingCmdty"+  , Fl.postingQty = "postingQty"+  , Fl.totalDrCr = "totalDrCr"+  , Fl.totalCmdty = "totalCmdty"+  , Fl.totalQty = "totalQty"+  , Fl.tags = "tags"+  , Fl.memo = "memo"+  , Fl.filename = "filename" }
+ Penny/Cabin/Posts/Spacers.hs view
@@ -0,0 +1,108 @@+-- | Spacer fields in the report. They don't contain any data; they+-- just provide whitespace. Each spacer immediately follows the named+-- field.+module Penny.Cabin.Posts.Spacers where++data T a = T {+  globalTransaction :: a+  , revGlobalTransaction :: a+  , globalPosting :: a+  , revGlobalPosting :: a+  , fileTransaction :: a+  , revFileTransaction :: a+  , filePosting :: a+  , revFilePosting :: a+  , filtered :: a+  , revFiltered :: a+  , sorted :: a+  , revSorted :: a+  , visible :: a+  , revVisible :: a+  , lineNum :: a+    -- ^ The line number from the posting's metadata+  , date :: a+  , flag :: a+  , number :: a+  , payee :: a+  , account :: a+  , postingDrCr :: a+  , postingCmdty :: a+  , postingQty :: a+  , totalDrCr :: a+  , totalCmdty :: a }+  deriving (Show, Eq)++t_globalTransaction :: a -> T a -> T a+t_globalTransaction a f = f { globalTransaction = a }++t_revGlobalTransaction :: a -> T a -> T a+t_revGlobalTransaction a f = f { revGlobalTransaction = a }++t_globalPosting :: a -> T a -> T a+t_globalPosting a f = f { globalPosting = a }++t_revGlobalPosting :: a -> T a -> T a+t_revGlobalPosting a f = f { revGlobalPosting = a }++t_fileTransaction :: a -> T a -> T a+t_fileTransaction a f = f { fileTransaction = a }++t_revFileTransaction :: a -> T a -> T a+t_revFileTransaction a f = f { revFileTransaction = a }++t_filePosting :: a -> T a -> T a+t_filePosting a f = f { filePosting = a }++t_revFilePosting :: a -> T a -> T a+t_revFilePosting a f = f { revFilePosting = a }++t_filtered :: a -> T a -> T a+t_filtered a f = f { filtered = a }++t_revFiltered :: a -> T a -> T a+t_revFiltered a f = f { revFiltered = a }++t_sorted :: a -> T a -> T a+t_sorted a f = f { sorted = a }++t_revSorted :: a -> T a -> T a+t_revSorted a f = f { revSorted = a }++t_visible :: a -> T a -> T a+t_visible a f = f { visible = a }++t_revVisible :: a -> T a -> T a+t_revVisible a f = f { revVisible = a }++t_lineNum :: a -> T a -> T a+t_lineNum a f = f { lineNum = a }++t_date :: a -> T a -> T a+t_date a f = f { date = a }++t_flag :: a -> T a -> T a+t_flag a f = f { flag = a }++t_number :: a -> T a -> T a+t_number a f = f { number = a }++t_payee :: a -> T a -> T a+t_payee a f = f { payee = a }++t_account :: a -> T a -> T a+t_account a f = f { account = a }++t_postingDrCr :: a -> T a -> T a+t_postingDrCr a f = f { postingDrCr = a }++t_postingCmdty :: a -> T a -> T a+t_postingCmdty a f = f { postingCmdty = a }++t_postingQty :: a -> T a -> T a+t_postingQty a f = f { postingQty = a }++t_totalDrCr :: a -> T a -> T a+t_totalDrCr a f = f { totalDrCr = a }++t_totalCmdty :: a -> T a -> T a+t_totalCmdty a f = f { totalCmdty = a }
+ Penny/Cabin/Row.hs view
@@ -0,0 +1,113 @@+module Penny.Cabin.Row (+  Justification(LeftJustify, RightJustify),+  ColumnSpec(ColumnSpec, justification, width, padSpec, bits),+  C.Width(Width, unWidth),+  row ) where++import Data.List (transpose)+import qualified Data.Text as X+import qualified Penny.Cabin.Chunk as C++-- | How to justify cells. LeftJustify leaves the right side+-- ragged. RightJustify leaves the left side ragged.+data Justification =+  LeftJustify+  | RightJustify+  deriving Show++-- | A cell of text output. You tell the cell how to justify itself+-- and how wide it is. You also tell it the background colors to+-- use. The cell will be appropriately justified (that is, text+-- aligned between left and right margins) and padded (with lines of+-- blank text added on the bottom as needed) when joined with other+-- cells into a Row.+data ColumnSpec =+  ColumnSpec { justification :: Justification+             , width :: C.Width+             , padSpec :: C.TextSpec+             , bits :: [C.Chunk] }++newtype JustifiedCell = JustifiedCell (Either (C.Chunk, C.Chunk) C.Chunk)+data JustifiedColumn = JustifiedColumn {+  justifiedCells :: [JustifiedCell]+  , _justifiedWidth :: C.Width+  , _justifiedPadSpec :: C.TextSpec }++newtype PaddedColumns = PaddedColumns [[JustifiedCell]]+newtype CellsByRow = CellsByRow [[JustifiedCell]]+newtype CellRowsWithNewlines = CellRowsWithNewlines [[JustifiedCell]]+++justify ::+  C.TextSpec+  -> C.Width+  -> Justification+  -> C.Chunk+  -> JustifiedCell+justify ts (C.Width w) j b+  | origWidth < w = JustifiedCell . Left $ pair+  | otherwise = JustifiedCell . Right $ b+    where+      origWidth = C.unWidth . C.chunkWidth $ b+      pad = C.chunk ts t+      t = X.replicate (w - origWidth) (X.singleton ' ')+      pair = case j of+        LeftJustify -> (b, pad)+        RightJustify -> (pad, b)++newtype Height = Height { _unHeight :: Int }+                 deriving (Show, Eq, Ord)++height :: [[a]] -> Height+height = Height . maximum . map length++row :: [ColumnSpec] -> [C.Chunk]+row =+  concat+  . concat+  . toBits+  . toCellRowsWithNewlines+  . toCellsByRow+  . bottomPad+  . map justifiedColumn++justifiedColumn :: ColumnSpec -> JustifiedColumn+justifiedColumn (ColumnSpec j w ts bs) = JustifiedColumn cs w ts where+  cs = map (justify ts 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+    l = length cs+    nPads = h - l+    pad = C.chunk ts t+    t = X.replicate w (X.singleton ' ')+    pads = replicate nPads . JustifiedCell . Right $ pad+    cs'+      | l < h = cs ++ pads+      | otherwise = cs+    in cs'+++toCellsByRow :: PaddedColumns -> CellsByRow+toCellsByRow (PaddedColumns cs) = CellsByRow (transpose cs)+++toCellRowsWithNewlines :: CellsByRow -> CellRowsWithNewlines+toCellRowsWithNewlines (CellsByRow bs) =+  CellRowsWithNewlines bs' where+    bs' = foldr f [] bs+    newline = JustifiedCell . Right+              $ C.chunk C.defaultTextSpec (X.singleton '\n')+    f cells acc = (cells ++ [newline]) : acc+    ++toBits :: CellRowsWithNewlines -> [[[C.Chunk]]]+toBits (CellRowsWithNewlines cs) = map (map toB) cs where+  toB (JustifiedCell c) = case c of+    Left (lb, rb) -> [lb, rb]+    Right b -> [b]+
+ Penny/Cabin/TextFormat.hs view
@@ -0,0 +1,173 @@+module Penny.Cabin.TextFormat (+  Lines(Lines, unLines),+  Words(Words, unWords),+  CharsPerLine(unCharsPerLine),+  txtWords,+  wordWrap,+  Target(Target, unTarget),+  Shortest(Shortest, unShortest),+  shorten) where++import qualified Control.Monad.Trans.State as St+import qualified Data.Foldable as F+import Data.Sequence ((|>), ViewR((:>)), ViewL((:<)))+import qualified Data.Sequence as S+import qualified Data.Text as X+import qualified Data.Traversable as T++data Lines = Lines { unLines :: S.Seq Words } deriving Show+data Words = Words { unWords :: S.Seq X.Text } deriving Show+newtype CharsPerLine =+  CharsPerLine { unCharsPerLine :: Int } deriving Show++-- | Splits a blank-separated text into words.+txtWords :: X.Text -> Words+txtWords = Words . S.fromList . X.words++-- | Wraps a sequence of words into a sequence of lines, where each+-- line is no more than a given maximum number of characters long.+--+-- If the maximum number of characters per line is less than 1,+-- returns a Lines that is empty.+--+-- An individual word will be split across multiple lines only if that+-- word is too long to fit into a single line. No hyphenation is done;+-- the word is simply broken across two lines.+wordWrap :: Int -> Words -> Lines+wordWrap l (Words wsq) =+  if l < 1+  then Lines (S.empty)+  else F.foldl f (Lines S.empty) wsq where+    f (Lines sws) w = let+      (back, ws) = case S.viewr sws of+        S.EmptyR -> (S.empty, Words S.empty)+        (b :> x) -> (b, x)+      in case addWord l ws w of+        (Just ws') -> Lines $ back |> ws'+        Nothing ->+          if X.length w > l+          then addPartialWords l (Lines sws) w+          else Lines (back |> ws |> (Words (S.singleton w)))++lenWords :: Words -> Int+lenWords (Words s) = case S.length s of+  0 -> 0+  l -> (F.sum . fmap X.length $ s) + (l - 1)++-- | Adds a word to a Words, but only if it will not make the Words+-- exceed the given length.+addWord :: Int -> Words -> X.Text -> Maybe Words+addWord l (Words ws) w =+  let words' = Words (ws |> w)+  in if lenWords words' > l+     then Nothing+     else Just words'++-- | Adds a word to a Words. If the word is too long to fit, breaks it+-- and adds the longest portion possible. Returns the new Words, and a+-- Text with the part of the word that was not added (if any; if all+-- of the word was added, return an empty Text.)+addPartialWord :: Int -> Words -> X.Text -> (Words, X.Text)+addPartialWord l (Words ws) t = case addWord l (Words ws) t of+  (Just ws') -> (ws', X.empty)+  Nothing ->+    let maxChars =+          if S.null ws then l+          else max 0 (l - lenWords (Words ws) - 1)+        (begin, end) = X.splitAt maxChars t+    in (Words (if X.null begin then ws else ws |> begin), end)++addPartialWords :: Int -> Lines -> X.Text -> Lines+addPartialWords l (Lines wsq) t = let+  (back, ws) = case S.viewr wsq of+    S.EmptyR -> (S.empty, Words S.empty)+    (b :> x) -> (b, x)+  (rw, rt) = addPartialWord l ws t+  in if X.null rt+     then Lines (back |> rw)+     else addPartialWords l (Lines (back |> rw |> Words (S.empty))) rt++newtype Target = Target { unTarget :: Int } deriving Show+newtype Shortest = Shortest { unShortest :: Int } deriving Show++-- | Takes a list of words and shortens it so that it fits in the+-- space allotted. You specify the minimum length for each word, x. It+-- will shorten the farthest left word first, until it is only x+-- characters long; then it will shorten the next word until it is+-- only x characters long, etc. This proceeds until all words are just+-- x characters long. Then words are shortened to one+-- character. Then the leftmost words are deleted as necessary.+--+-- Assumes that the words will be printed with a separator, which+-- matters when lengths are calculated.+shorten :: Shortest -> Target -> Words -> Words+shorten (Shortest s) (Target t) wsa@(Words wsq) = let+  nToRemove = max (lenWords wsa - t) 0+  (allWords, _) = shortenUntilOne s nToRemove wsq+  in stripWordsUntil t (Words allWords)++-- | Shorten a word by x characters or until it is y characters long,+-- whichever comes first. Returns the word and the number of+-- characters removed.+shortenUntil :: Int -> Int -> X.Text -> (X.Text, Int)+shortenUntil by shortest t = let+  removable = max (X.length t - shortest) 0+  toRemove = min removable (max by 0)+  prefix = X.length t - toRemove+  in (X.take prefix t, toRemove)++-- | Shortens a word until it is x characters long or by the number of+-- characters indicated in the state, whichever is less. Subtracts the+-- number of characters removed from the state.+shortenSt :: Int -> X.Text -> St.State Int X.Text+shortenSt shortest t = do+  by <- St.get+  let (r, nRemoved) = shortenUntil by shortest t+  St.put (by - nRemoved)+  return r++-- | Shortens each word in a list, from left to right, until a+-- particular number of characters have been reduced or until each+-- word is x characters long, whichever happens first. Returns the new+-- list and the number of characters that still need to be reduced.+shortenEachInList ::+  T.Traversable t+  => Int -- ^ Shortest word length+  -> Int -- ^ Total number to remove+  -> t X.Text+  -> (t X.Text, Int)+shortenEachInList shortest by ts = (r, left) where+  k = T.mapM (shortenSt shortest) ts+  (r, left) = St.runState k by++shortenUntilOne ::+  T.Traversable t+  => Int -- ^ Shortest word length to start with+  -> Int -- ^ Total number of characters to remove+  -> t X.Text+  -> (t X.Text, Int)+shortenUntilOne shortest by ts = let+  r@(ts', left) = shortenEachInList shortest by ts+  in if shortest == 1 || left == 0+     then r+     else shortenUntilOne (pred shortest) left ts'++-- | Eliminates words until the length of the words, as indicated by+-- lenWords, is less than or equal to the value given.+stripWordsUntil :: Int -> Words -> Words+stripWordsUntil i wsa@(Words ws) = case S.viewl ws of+  S.EmptyL -> Words (S.empty)+  (_ :< rest) ->+    if lenWords wsa <= (max i 0)+    then wsa+    else stripWordsUntil (max i 0) (Words rest)++  +--+-- Testing+--+_words :: Words+_words = Words . S.fromList . map X.pack $ ws where +  ws = [ "these", "are", "fragilisticwonderfulgood",+         "good", "", "x", "xy", "xyza",+         "longlonglongword" ]
+ Penny/Copper.hs view
@@ -0,0 +1,132 @@+-- | 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),++  -- * Items+  I.Item(Transaction, Price, CommentItem, BlankLine),+  I.Line(unLine),++  -- * Parsing+  Ledger(Ledger, unLedger),+  parse,+  +  -- * Rendering+  I.render+  ) where+++import Control.Applicative ((<$>))+import qualified Control.Monad.Exception.Synchronous as Ex+import qualified Data.Text as X+import Text.Parsec ( manyTill, eof )+import qualified Text.Parsec as P++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++newtype FileContents = FileContents { unFileContents :: X.Text }+                       deriving (Eq, Show)++newtype ErrorMsg = ErrorMsg { unErrorMsg :: X.Text }+                   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+      fnStr = X.unpack . L.unFilename $ fn+  in case P.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'+++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'++parse ::+  DT.DefaultTimeZone+  -> Q.RadGroup+  -> [(L.Filename, FileContents)]+  -> Ex.Exceptional ErrorMsg Ledger+parse dtz rg ps =+  mapM (parseFile dtz rg) ps+  >>= (return . Ledger . addGlobalMetadata)++data Other = OPrice L.PricePoint+             | OCommentItem C.Comment+             | OBlankLine+             deriving Show++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++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+
+ Penny/Copper/Account.hs view
@@ -0,0 +1,131 @@+-- | 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
+ Penny/Copper/Amount.hs view
@@ -0,0 +1,96 @@+-- | 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]
+ Penny/Copper/Comments.hs view
@@ -0,0 +1,35 @@+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
+ Penny/Copper/Commodity.hs view
@@ -0,0 +1,187 @@+-- | 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))
+ Penny/Copper/DateTime.hs view
@@ -0,0 +1,138 @@+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
+ Penny/Copper/Entry.hs view
@@ -0,0 +1,43 @@+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
+ Penny/Copper/Flag.hs view
@@ -0,0 +1,30 @@+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
+ Penny/Copper/Item.hs view
@@ -0,0 +1,68 @@+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'+
+ Penny/Copper/Memos/Posting.hs view
@@ -0,0 +1,39 @@+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
+ Penny/Copper/Memos/Transaction.hs view
@@ -0,0 +1,45 @@+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
+ Penny/Copper/Number.hs view
@@ -0,0 +1,29 @@+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
+ Penny/Copper/Payees.hs view
@@ -0,0 +1,87 @@+-- | 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
+ Penny/Copper/Posting.hs view
@@ -0,0 +1,126 @@+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]
+ Penny/Copper/Price.hs view
@@ -0,0 +1,97 @@+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:++<price> ::= "dateTime" <fromCmdty> <toAmount>+<fromCmdty> ::= "quotedLvl1Cmdty" | "lvl2Cmdty"+<toAmount> ::= "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'
+ Penny/Copper/Qty.hs view
@@ -0,0 +1,283 @@+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.++<radix> ::= (as specified)+<grouper> ::= (as specified)+<digit> ::= "1" | "2" | "3" | "4" | "5" | "6" | "7" | "8" | "9" | "0"+<digits> ::= <digit> | <digit> <digits>+<firstGroups> ::= <digits> <grouper> <digits>+<nextGroup> ::= <grouper> <digits>+<nextGroups> ::= <nextGroup> | <nextGroup> <nextGroups>+<allGroups> ::= <firstGroups> | <firstGroups> <nextGroups>+<whole> ::= <allGroups> | <digits>+<fractional> ::= <digits>+<number> ::= <whole>+             | <whole> <radix>+             | <whole> <radix> <fractional>+             | <radix> <fractional>+-}++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
+ Penny/Copper/Tags.hs view
@@ -0,0 +1,37 @@+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
+ Penny/Copper/TopLine.hs view
@@ -0,0 +1,59 @@+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'
+ Penny/Copper/Transaction.hs view
@@ -0,0 +1,75 @@+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))+  ++
+ Penny/Copper/Util.hs view
@@ -0,0 +1,150 @@+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
+ Penny/Liberty.hs view
@@ -0,0 +1,692 @@+-- | Liberty - Penny command line parsing utilities+--+-- Both Cabin and Zinc share various functions that aid in parsing+-- command lines. For instance both the Postings report and the Zinc+-- postings filter use common command-line options. However, Zinc+-- already depends on Cabin. To avoid a cyclic dependency whereby+-- Cabin would also depend on Zinc, functions formerly in Zinc that+-- Cabin will also find useful are relocated here, to Liberty.++module Penny.Liberty (+  Error(..),+  MatcherFactory,+  X.evaluate,+  X.Token,+  FilteredNum(FilteredNum, unFilteredNum),+  SortedNum(SortedNum, unSortedNum),+  LibertyMeta(filteredNum, sortedNum),+  xactionsToFiltered,+  ListLength(ListLength, unListLength),+  ItemIndex(ItemIndex, unItemIndex),+  PostFilterFn,+  parseComparer,+  processPostFilters,+  parseTokenList,+  parsePredicate,+  +  -- * Parsers+  Operand,+  parseOperand,+  parsePostFilter,+  parseMatcherSelect,+  parseCaseSelect,+  parseOperator,+  Orderer,+  parseSort+  ) where++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 qualified Data.Text as Text+import qualified System.Console.MultiArg.Combinator as C+import System.Console.MultiArg.Prim (Parser)+import Text.Parsec (parse)+  +import Penny.Copper.DateTime (DefaultTimeZone, dateTime)+import Penny.Copper.Qty (RadGroup, qty)++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 (+  CaseSensitive(Sensitive, Insensitive))+import qualified Text.Matchers.Text as TM++-- | A serial indicating how a post relates to all other postings that+-- made it through the filtering phase.+newtype FilteredNum = FilteredNum { unFilteredNum :: L.Serial }+                      deriving Show++-- | A serial indicating how a posting relates to all other postings+-- that have been sorted.+newtype SortedNum = SortedNum { unSortedNum :: L.Serial }+                    deriving Show++-- | All metadata from Liberty.+data LibertyMeta =+  LibertyMeta { filteredNum :: FilteredNum+              , sortedNum :: SortedNum }+  deriving Show+++-- | Parses a list of tokens. Returns Nothing if the token sequence is+-- invalid (e.g. if two operators are next to each other) or if the+-- resulting RPN expression is bad (there are tokens left on the stack+-- after parsing). Otherwise, returns the expression.+--+-- An empty list will fail to parse. The function calling this one+-- must deal with empty lists if those are a possibility.+parseTokenList :: [X.Token a] -> Maybe a+parseTokenList = X.evaluate++-- | Parses a list of tokens to obtain a predicate. Deals with an+-- empty list of tokens by returning a predicate that is always+-- True. Fails if the list of tokens is not empty and the parse fails.+parsePredicate :: [X.Token (a -> Bool)] -> Maybe (a -> Bool)+parsePredicate ls = case ls of+  [] -> return (const True)+  ts -> parseTokenList ts++-- | Takes a list of transactions, splits them into PostingChild+-- instances, filters them, post-filters them, sorts them, and places+-- them in Box instances with Filtered serials.+xactionsToFiltered ::+  +  (L.PostFam -> Bool)+  -- ^ The predicate to filter the transactions++  -> [PostFilterFn]+  -- ^ Post filter specs++  -> (L.PostFam -> L.PostFam -> Ordering)+  -- ^ The sorter++  -> [L.Transaction]+  -- ^ The transactions to work on (probably parsed in from Copper)+  +  -> [L.Box LibertyMeta]+  -- ^ Sorted, filtered postings++xactionsToFiltered pdct pfs s =+  addSortedNum+  . processPostFilters pfs+  . sortBy (sorter s)+  . addFilteredNum+  . map toBox+  . filter pdct+  . concatMap L.postFam+++-- | Transforms a PostingChild into a Box.+toBox :: L.PostFam -> L.Box ()+toBox = L.Box ()++-- | Takes a list of filtered boxes and adds the Filtered serials.++addFilteredNum :: [L.Box a] -> [L.Box FilteredNum]+addFilteredNum = L.serialItems f where+  f ser = fmap (const (FilteredNum ser))++-- | Wraps a PostingChild sorter to change it to a Box sorter.+sorter :: (L.PostFam -> L.PostFam -> Ordering)+          -> L.Box a+          -> L.Box b+          -> Ordering+sorter f b1 b2 = f (L.boxPostFam b1) (L.boxPostFam b2)++-- | Takes a list of Boxes with metadata and adds a Serial for the+-- Sorted.+addSortedNum ::+  [L.Box FilteredNum]+  -> [L.Box LibertyMeta]+addSortedNum = L.serialItems f where+  f ser = fmap g where+    g filtNum = LibertyMeta filtNum (SortedNum ser)++type MatcherFactory =+  CaseSensitive+  -> Text+  -> Ex.Exceptional Text (Text -> Bool)+type Operand = X.Operand (L.PostFam -> Bool)++newtype ListLength = ListLength { unListLength :: Int }+                     deriving (Eq, Ord, Show)+newtype ItemIndex = ItemIndex { unItemIndex :: Int }+                    deriving (Eq, Ord, Show)++-- | Specifies options for the post-filter stage.+type PostFilterFn = ListLength -> ItemIndex -> Bool+++processPostFilters :: [PostFilterFn] -> [a] -> [a]+processPostFilters pfs ls = foldl processPostFilter ls pfs+++processPostFilter :: [a] -> PostFilterFn -> [a]+processPostFilter as fn = map fst . filter fn' $ zipped where+  len = ListLength $ length as+  fn' (_, idx) = fn len (ItemIndex idx)+  zipped = zip as [0..]+  ++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+------------------------------------------------------------++-- | Given a String from the command line which represents a pattern,+-- and a MatcherFactor, return a Matcher. Fails if the pattern is bad+-- (e.g. it is not a valid regular expression).+getMatcher ::+  String+  -> CaseSensitive+  -> MatcherFactory+  -> Ex.Exceptional Error (Text -> Bool)++getMatcher s cs f = case f cs (pack s) of+  Ex.Exception e -> Ex.Exception $ BadPatternError e+  Ex.Success m -> return m++-- | Parses comparers given on command line to a function.+parseComparer ::+  (Eq a, Ord a)+  => String+  -> Maybe (a -> a -> Bool)+parseComparer t+  | t == "<" = Just (<)+  | t == "<=" = Just (<=)+  | t == "==" = Just (==)+  | t == "=" = Just (==)+  | t == ">" = Just (>)+  | t == ">=" = Just (>=)+  | t == "/=" = Just (/=)+  | t == "!=" = Just (/=)+  | otherwise = Nothing++parseDate :: DefaultTimeZone -> Text -> Exceptional Error L.DateTime+parseDate dtz t = case parse (dateTime dtz) "" t of+  Left _ -> Exception DateParseError+  Right d -> return d++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]++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]++-- | 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+-- False if it does not.+sepOption ::+  String+  -- ^ Long option name+  +  -> Maybe Char+  -- ^ Short option name, if there is one++  -> (Text -> (Text -> Bool) -> L.PostFam -> Bool)+  -- ^ 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]++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)++-- | Creates options that take two arguments, with the first argument+-- being the level to match, and the second being the pattern that+-- should match against that level.  Adds an operand that returns True+-- if the pattern matches.+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]++-- | 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]++-- | The account option; matches if the pattern given matches the+-- colon-separated account name.+account :: Parser (CaseSensitive+                   -> MatcherFactory -> Exceptional Error 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 = 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 = 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 = patternOption "payee" (Just 'p') P.payee++tag :: Parser (CaseSensitive+               -> MatcherFactory -> Exceptional Error Operand)+tag = patternOption "tag" (Just 't') P.tag++number :: Parser (CaseSensitive+                  -> MatcherFactory -> Exceptional Error Operand)+number = patternOption "number" Nothing P.number++flag :: Parser (CaseSensitive+                -> MatcherFactory -> Exceptional Error 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++postingMemo :: Parser (CaseSensitive+                       -> MatcherFactory -> Exceptional Error Operand)+postingMemo = patternOption "posting-memo" Nothing P.postingMemo++transactionMemo :: Parser (CaseSensitive+                           -> MatcherFactory -> Exceptional Error 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]++credit :: Parser Operand+credit =+  let os = C.OptSpec ["credit"] [] (C.NoArg (X.Operand P.credit))+  in C.parseOption [os]++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]++-- | Creates two options suitable for comparison of serial numbers,+-- one for ascending, one for descending.+serialOption ::++  (L.PostFam -> Maybe L.Serial)+  -- ^ Function that, when applied to a PostingChild, returns the serial+  -- you are interested in.++  -> String+  -- ^ Name of the command line option, such as @global-transaction@++  -> Parser (Exceptional Error 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]++-- | Takes a string, adds a prefix and capitalizes the first letter of+-- the old string. e.g. applied to "rev" and "globalTransaction",+-- returns "revGlobalTransaction".+addPrefix :: String -> String -> String+addPrefix pre suf = pre ++ suf' where+  suf' = case suf of+    "" -> ""+    x:xs -> toUpper x : xs++globalTransaction :: Parser (Exceptional Error Operand)+globalTransaction =+  let f = fmap L.unGlobalTransaction+          . L.globalTransaction+          . L.tMeta+          . parent+          . L.unPostFam+  in serialOption f "globalTransaction"++globalPosting :: Parser (Exceptional Error Operand)+globalPosting =+  let f = fmap L.unGlobalPosting+          . L.globalPosting+          . L.pMeta+          . child+          . L.unPostFam+  in serialOption f "globalPosting"++filePosting :: Parser (Exceptional Error Operand)+filePosting =+  let f = fmap L.unFilePosting+          . L.filePosting+          . L.pMeta+          . child+          . L.unPostFam+  in serialOption f "filePosting"++fileTransaction :: Parser (Exceptional Error Operand)+fileTransaction =+  let f = fmap L.unFileTransaction+          . L.fileTransaction+          . L.tMeta+          . 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+++wrapNoArg ::+  Parser (Ex.Exceptional Error Operand)+  -> Parser (L.DateTime+             -> DefaultTimeZone+             -> RadGroup+             -> CaseSensitive+             -> MatcherFactory+             -> Ex.Exceptional Error Operand)+wrapNoArg p = do+  o <- p+  return (\_ _ _ _ _ -> o)++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)++------------------------------------------------------------+-- 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]++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]++parsePostFilter :: Parser (Exceptional Error PostFilterFn)+parsePostFilter = optHead <|> optTail++------------------------------------------------------------+-- Matcher control+------------------------------------------------------------++noArg :: a -> String -> Parser a+noArg a s = let os = C.OptSpec [s] "" (C.NoArg a)+            in C.parseOption [os]++parseInsensitive :: Parser CaseSensitive+parseInsensitive =+  let os = C.OptSpec ["case-insensitive"] ['i'] (C.NoArg Insensitive)+  in C.parseOption [os]++parseSensitive :: Parser CaseSensitive+parseSensitive =+  let os = C.OptSpec ["case-sensitive"] ['I'] (C.NoArg Sensitive)+  in C.parseOption [os]+++within :: Parser MatcherFactory+within = noArg (\c t -> return (TM.within c t)) "within"++pcre :: Parser MatcherFactory+pcre = noArg TM.pcre "pcre"++posix :: Parser MatcherFactory+posix = noArg TM.tdfa "posix"++exact :: Parser MatcherFactory+exact = noArg (\c t -> return (TM.exact c t)) "exact"++parseMatcherSelect :: Parser MatcherFactory+parseMatcherSelect = within <|> pcre <|> posix <|> exact++parseCaseSelect :: Parser CaseSensitive+parseCaseSelect = parseInsensitive <|> parseSensitive++------------------------------------------------------------+-- Operators+------------------------------------------------------------++-- | Open parentheses+open :: Parser (X.Token a)+open = noArg X.TokOpenParen "open"++-- | Close parentheses+close :: Parser (X.Token a)+close = noArg X.TokCloseParen "close"++-- | and operator+parseAnd :: Parser (X.Token (a -> Bool))+parseAnd = noArg X.tokAnd "and"++-- | or operator+parseOr :: Parser (X.Token (a -> Bool))+parseOr = noArg X.tokOr "or"++-- | not operator+parseNot :: Parser (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)+++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]
+ Penny/Liberty/Expressions.hs view
@@ -0,0 +1,63 @@+module Penny.Liberty.Expressions (+  I.Precedence(Precedence),+  +  I.Associativity(ALeft, ARight),+  +  I.Token(TokOperand,+          TokUnaryPostfix,+          TokUnaryPrefix,+          TokBinary,+          TokOpenParen,+          TokCloseParen),++  R.Operand(Operand),+  tokAnd,+  tokOr,+  tokNot,+  evaluate) where++import qualified Data.Foldable as Fdbl+import Penny.Liberty.Expressions.Infix as I+import Penny.Liberty.Expressions.RPN as R+++-- | Tokens should be enqueued from left to right, so that tokens on+-- the left side of the sequence are those at the beginning of the+-- expression.+evaluate ::+  Fdbl.Foldable l+  => l (I.Token a)+  -> Maybe a+evaluate i = I.infixToRPN i >>= R.process++-- | An And token which is left associative with precedence 3.+tokAnd :: I.Token (a -> Bool)+tokAnd = I.TokBinary (I.Precedence 3) I.ALeft f where+  f x y = \a -> x a && y a++-- | An Or token which is left associative with precedence 2.+tokOr :: I.Token (a -> Bool)+tokOr = I.TokBinary (I.Precedence 2) I.ALeft f where+  f x y = \a -> x a || y a++-- | A unary prefix Not token with precedence 4.+tokNot :: I.Token (a -> Bool)+tokNot = I.TokUnaryPrefix (I.Precedence 4) (not .)++--+-- Testing+--+_plus :: I.Token Double+_plus = I.TokBinary (I.Precedence 4) I.ALeft (+)++_minus :: I.Token Double+_minus = I.TokBinary (I.Precedence 4) I.ALeft (-)++_times :: I.Token Double+_times = I.TokBinary (I.Precedence 5) I.ALeft (*)++_divide :: I.Token Double+_divide = I.TokBinary (I.Precedence 5) I.ALeft (/)++_neg :: I.Token Double+_neg = I.TokUnaryPrefix (I.Precedence 5) negate
+ Penny/Liberty/Expressions/Infix.hs view
@@ -0,0 +1,218 @@+-- | Creates RPN expressions from infix inputs.+--+-- Penny accepts only infix expressions, but RPN expressions are+-- easier to process. This module converts infix expressions to RPN+-- expressions for further processing.+--+-- Uses the shunting-yard algorithm, best described at+-- http://www.chris-j.co.uk/parsing.php (be sure to use the \"click to+-- display\" links).+module Penny.Liberty.Expressions.Infix (++  Precedence(Precedence),+  +  Associativity(ALeft,+                ARight),+  +  Token(TokOperand,+        TokUnaryPostfix,+        TokUnaryPrefix,+        TokBinary,+        TokOpenParen,+        TokCloseParen),+  +  infixToRPN+  ) where++import qualified Data.Foldable as Fdbl+import qualified Penny.Liberty.Expressions.RPN as R+import qualified Data.Sequence as Seq+import Data.Sequence((|>), Seq)++-- | Precedence can be any integer; the greater the number, the higher+-- the precedence.+newtype Precedence = Precedence Int deriving (Show, Eq, Ord)++data Associativity = ALeft | ARight deriving Show++data Token a =+  TokOperand a+  | TokUnaryPostfix (a -> a)+  | TokUnaryPrefix Precedence (a -> a)+  | TokBinary Precedence Associativity (a -> a -> a)+  | TokOpenParen+  | TokCloseParen++instance (Show a) => Show (Token a) where+  show (TokOperand a) = "<operand " ++ show a ++ ">"+  show (TokUnaryPostfix _) = "<unary postfix>"+  show (TokUnaryPrefix (Precedence i) _) =+    "<unary prefix, precedence " ++ (show i) ++ ">"+  show (TokBinary (Precedence i) a _) =+    "<binary, precedence " ++ show i ++ " "+    ++ show a ++ ">"+  show TokOpenParen = "<OpenParen>"+  show TokCloseParen = "<CloseParen>"++data StackVal a =+  StkUnaryPrefix Precedence (a -> a)+  | StkBinary Precedence (a -> a -> a)+  | StkOpenParen++instance Show (StackVal a) where+  show (StkUnaryPrefix p _) =+    "<unary prefix, " ++ show p ++ ">"+  show (StkBinary p _) =+    "<binary, " ++ show p ++ ">"+  show StkOpenParen = "<OpenParen>"++-- | Converts an infix expression to an RPN expression.+infixToRPN ::+  Fdbl.Foldable l+  => l (Token a)+  -- ^ Input tokens. These should be in the sequence from left to+  -- right in ordinary infix order. The easiest choice is a list,+  -- though you might want to use Data.Sequence if many appends will+  -- be needed to build the sequence.++  -> Maybe (Seq (R.Token a))+  -- ^ The resulting RPN expression. The token type here is a token+  -- from Penny.Liberty.Expressions.RPN, which is a different type+  -- than the Token in this module. Fails only if there is a close+  -- parenthesis without a matching open parenthesis, or if there is+  -- an open parenthesis without a matching close parenthesis. Other+  -- nonsensical expressions will still parse to an RPN expression+  -- successfully, so the RPN parser has to catch these errors.++infixToRPN ls =+  Fdbl.foldlM processToken ([], Seq.empty) ls+  >>= popRemainingOperators+++-- | Process a single input token. Fails if the token is a close+-- parenthesis and a matching open parenthesis is not+-- found. Otherwise, succeeds and adjusts the stack and the output+-- queue accordingly.+processToken ::+  ([StackVal a], Seq (R.Token a))+  -> Token a+  -> Maybe ([StackVal a], Seq (R.Token a))+processToken (ss, ts) tok =+  case tok of+    TokOperand a -> Just (ss, processOperand a ts)+    TokUnaryPostfix f ->+      Just (ss, processUnaryPostfix f ts)+    TokUnaryPrefix p f ->+      Just (processUnaryPrefix p f ss, ts)+    TokBinary p a f ->+      Just (processBinary p a f (ss, ts))+    TokOpenParen -> Just (processOpenParen ss, ts)+    TokCloseParen -> processCloseParen (ss, ts)++-- | If a token is an operand, append it to the postfix output.+processOperand :: a -> Seq (R.Token a) -> Seq (R.Token a)+processOperand a sq = sq |> (R.TokOperand (R.Operand a))++-- | If a token is a unary postfix operator, append it to the postfix+-- output.+processUnaryPostfix ::+  (a -> a)+  -> Seq (R.Token a)+  -> Seq (R.Token a)+processUnaryPostfix f sq =+  sq |> (R.TokOperator (R.Unary f))++-- | If a token is a unary prefix operator, push it onto the stack.+processUnaryPrefix ::+  Precedence+  -> (a -> a)+  -> [StackVal a]+  -> [StackVal a]+processUnaryPrefix p f s = (StkUnaryPrefix p f):s++-- | Pops tokens from the stack and appends them to the ouptut, as+-- long as the token at the top of the stack is and operator and its+-- precedence meets the given predicate.+popTokens ::+  (Precedence -> Bool)+  -> ([StackVal a], Seq (R.Token a))+  -> ([StackVal a], Seq (R.Token a))+popTokens f (ss, os) =+  case ss of+    [] -> (ss, os)+    x:xs -> case x of+      StkOpenParen -> (ss, os)+      StkUnaryPrefix p g -> popper (R.Unary g) p+      StkBinary p g -> popper (R.Binary g) p+      where+        popper tok pr =+          if f pr+          then+            let output' = os |> (R.TokOperator tok)+            in popTokens f (xs, output')+          else (ss, os)+  ++-- | If the token is a binary operator A, then:+--+-- If A is left associative, while there is an operator B of higher or+-- equal precedence than A at the top of the stack, pop B off the+-- stack and append it to the output.+--+-- If A is right associative, while there is an operator B of higher+-- precedence than A at the top of the stack, pop B off the stack and+-- append it to the output.+--+-- Push A onto the stack.+processBinary ::+  Precedence+  -> Associativity+  -> (a -> a -> a)+  -> ([StackVal a], Seq (R.Token a))+  -> ([StackVal a], Seq (R.Token a))+processBinary p a f pair =+  let pdct = case a of+        ALeft -> (>= p)+        ARight -> (> p)+      (ss, os) = popTokens pdct pair+  in ((StkBinary p f):ss, os)++-- | If the token is an opening parenthesis, push it onto the stack.+processOpenParen :: [StackVal a] -> [StackVal a]+processOpenParen = (StkOpenParen :)++-- | If the token is a closing parenthesis, pop operators off the top+-- of the stack and append them to the output until the operator at+-- the top of the stack is an opening bracket. Pop the opening bracket+-- off the stack.+--+-- Fails if no open paren is found.+processCloseParen ::+  ([StackVal a], Seq (R.Token a))+  -> Maybe ([StackVal a], Seq (R.Token a))+processCloseParen (ss, os) = case ss of+  [] -> Nothing+  (x:xs) ->+    let popper op = processCloseParen (xs, output')+          where+            output' = os |> (R.TokOperator op)+    in case x of+      StkUnaryPrefix _ f -> popper (R.Unary f)        +      StkBinary _ f -> popper (R.Binary f)+      StkOpenParen -> Just (xs, os)++-- | Removes all remaining operators from the stack and puts them on+-- the output queue. Fails if the stack has an open parenthesis; as+-- this is unmatched.+popRemainingOperators ::+  ([StackVal a], Seq (R.Token a))+  -> Maybe (Seq (R.Token a))+popRemainingOperators (s, os) = case s of+  [] -> Just os+  x:xs -> case x of+    StkOpenParen -> Nothing+    StkUnaryPrefix _ f -> pusher (R.Unary f)+    StkBinary _ f -> pusher (R.Binary f)+    where+      pusher op = popRemainingOperators (xs, output') where+        output' = os |> (R.TokOperator op)
+ Penny/Liberty/Expressions/RPN.hs view
@@ -0,0 +1,112 @@+-- | Parses reverse polish notation expressions. This module needs+-- much better error messages (right now it has none).+--+-- An RPN expression consists of operands and operators; a token is+-- either an operand or an operator. For example, in the expression @5+-- 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),+  Operator(Unary, Binary),+  Token(TokOperand, TokOperator),+  process) where++import qualified Data.Foldable as Fdbl++-- | An operand; for example, in the expression @5 4 +@, @5@ and @4@+-- are operands.+newtype Operand a = Operand a deriving Show++-- | Operators; for example, in the expression @5 4 +@, @+@ is an+-- operator. Because this is RPN, there is no operator precedence.+data Operator a =+  Unary (a -> a)+  -- ^ Unary operators take only one operand (for example, a factorial+  -- operator).++  | Binary (a -> a -> a)+    -- ^ Binary operators take two operands (for example, an addition+    -- operator).++instance Show (Operator a) where+  show (Unary _) = "<unary operator>"+  show (Binary _) = "<binary operator>"++-- | A token is either an operator or an operand.+data Token a =+  TokOperand (Operand a)+  | TokOperator (Operator a)+  deriving Show+++-- | Given an operator, and the stack of operands, process the+-- operator. When parsing an RPN expression, encountering an operator+-- at the front of the queue of tokens to be processed means that the+-- correct number of tokens (one, for a unary operator, or two, for a+-- binary operator) must be popped off the stack of operands. The+-- operator is then applied to the operands. For a binary operator,+-- the binary function is applied first to the operand that was lowest+-- on the stack, and then to the operand that was higher up on the+-- stack. The result of the operator is then pushed onto the top of+-- the stack.+--+-- This function fails if there were insufficient operands on the+-- stack to process the operator. If successful, returns the new+-- stack, with the processed operands removed and the result of the+-- operator pushed onto the top of the stack.+processOperator ::+  Operator a+  -> [Operand a]+  -> Maybe ([Operand a])+processOperator t ds = case t of+  (Unary f) -> case ds of+    [] -> Nothing+    (Operand x):xs -> return $ (Operand (f x)) : xs+  (Binary f) -> case ds of+    [] -> Nothing+    (Operand x):dss -> case dss of+      (Operand y):dsss ->+        return $ (Operand (f y x)) : dsss+      [] -> Nothing++-- | Adds an operand to the top of the stack.+processOperand ::+  Operand a+  -> [Operand a]+  -> [Operand a]+processOperand = (:)++-- | Processes the next token. Fails if the next token is an operator+-- and fails; otherwise, returns the new stack of operands.+processToken ::+  [Operand a]+  -> Token a+  -> Maybe ([Operand a])+processToken s tok = case tok of+  TokOperand d -> return (processOperand d s)+  TokOperator t -> processOperator t s++-- | Processes an entire input sequence of RPN tokens.+process ::+  Fdbl.Foldable l+  => l (Token a)+  -- ^ The tokens must be in the sequence from left to right in+  -- postfix order; for example, @5 4 -@ will yield @1@. Typically+  -- many appends will be required in order to build this sequence. If+  -- performance is a concern, you can use a Data.Sequence; if the+  -- list is small (as these lists will typically be) a regular list+  -- will do just fine.++  -> Maybe a+  -- ^ Fails if there is not exactly one operand remaining on the+  -- stack at the end of the parse, or if at any time there are+  -- insufficient operands on the stack to parse an+  -- operator. Otherwise, succeeds and returns the result.+process ls = do+  os <- Fdbl.foldlM processToken [] ls+  (top, rest) <- case os of+    (Operand x) : oss -> return (x, oss)+    _ -> Nothing+  case rest of+    [] -> return top+    _ -> Nothing
+ Penny/Lincoln.hs view
@@ -0,0 +1,210 @@+-- | Lincoln - the Penny core+--+-- Penny's core types and classes are here. This module re-exports the+-- most useful things. For more details you will want to look at the+-- sub-modules. Also, not all types and functions are re-exported due+-- to naming conflicts. In particular, neither+-- "Penny.Lincoln.Predicates" nor "Penny.Lincoln.Queries" is exported+-- from here due to the blizzard of name conflicts that would result.+module Penny.Lincoln (+  -- * Balances+  B.Balance+  , B.unBalance+  , B.Balanced(Balanced, Inferable, NotInferable)+  , B.isBalanced+  , B.entryToBalance+  , B.addBalances+  , B.removeZeroCommodities+  , B.BottomLine (Zero, NonZero)+  , B.Column (Column)+  +    -- * Bits+    -- ** Accounts+  , I.SubAccountName (SubAccountName, unSubAccountName)+  , I.Account(Account, unAccount)+  +    -- ** Amounts+  , I.Amount (Amount, qty, commodity)+  +    -- ** Commodities+  , I.Commodity (Commodity, unCommodity)+  , I.SubCommodity (SubCommodity, unSubCommodity)+  , I.charCommodity+    +    -- ** DateTime+  , I.DateTime+  , I.dateTime+  , I.localTime+  , I.timeZone+  , I.TimeZoneOffset+  , I.minsToOffset+  , I.offsetToMins+  , I.noOffset+    +    -- ** 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)++    -- ** Quantities                               +  , I.Qty+  , I.unQty+  , I.partialNewQty+  , I.newQty+  , I.add+  , I.subt+  , I.mult+  , I.zero+  , I.difference+  , I.Difference(LeftBiggerBy, RightBiggerBy, Equal)+    +    -- ** 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+  , F.adopt+  , F.marryWith+  , F.marry+  , F.divorceWith+  , F.divorce+    +    -- * 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+  , T.transaction+  , T.Error ( UnbalancedError, CouldNotInferError)+  +    -- ** Querying postings+  , T.Inferred(Inferred, NotInferred)+  , T.pPayee+  , T.pNumber+  , T.pFlag+  , T.pAccount+  , T.pTags+  , T.pEntry+  , T.pMemo+  , T.pInferred+  , T.pMeta+  , T.changePostingMeta++    -- ** Querying transactions+  , T.TopLine+  , T.tDateTime+  , T.tFlag+  , T.tNumber+  , T.tPayee+  , T.tMemo+  , T.tMeta+  , T.changeTransactionMeta+  , T.postFam+    +    -- ** Adding serials to transactions+  , T.addSerialsToList+  , T.addSerialsToEithers+    +    -- ** Unwrapping Transactions+  , T.unTransaction+  , T.unPostFam+    +    -- ** Transaction boxes+  , T.Box (Box, boxMeta, boxPostFam)+    +  -- * 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+  +    -- * PriceDb+  , DB.PriceDb+  , DB.emptyDb+  , DB.addPrice+  , DB.getPrice+  , DB.PriceDbError(FromNotFound, ToNotFound, CpuNotFound)+  , DB.convert+    +    -- * Serials+  , S.Serial+  , S.forward+  , S.backward+  , S.serials+  , S.serialItems++  ) where++import qualified Penny.Lincoln.Balance as B+import qualified Penny.Lincoln.Bits as I+import qualified Penny.Lincoln.Builders as Bd+import qualified Penny.Lincoln.Family as F+import qualified Penny.Lincoln.HasText as HT+import qualified Penny.Lincoln.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
+ Penny/Lincoln/Balance.hs view
@@ -0,0 +1,107 @@+module Penny.Lincoln.Balance ( +  Balance,+  unBalance,+  Balanced(Balanced, Inferable, NotInferable),+  isBalanced,+  entryToBalance,+  addBalances,+  removeZeroCommodities,+  BottomLine(Zero, NonZero),+  Column(Column, drCr, qty)+  ) where++import Data.Map ( Map )+import qualified Data.Map as M+import Data.Monoid ( Monoid, mempty, mappend )+import qualified Data.Semigroup as Semi++import Penny.Lincoln.Bits (+  add, difference, Difference(LeftBiggerBy, RightBiggerBy, Equal))+import qualified Penny.Lincoln.Bits as B++-- | A balance summarizes several entries. You do not create a Balance+-- directly. Instead, use 'entryToBalance'. Balance used to be a+-- monoid, but there is nothing appropriate for mempty. Instead,+-- Balance is really a semigroup, but not a monoid.+newtype Balance = Balance (Map B.Commodity BottomLine)+                  deriving (Show, Eq)++-- | The map returned by unBalance is never empty.+unBalance :: Balance -> Map B.Commodity BottomLine+unBalance (Balance m) = m++-- | Returned by 'isBalanced'.+data Balanced = Balanced+              | Inferable B.Entry+              | NotInferable+              deriving (Show, Eq)++-- | Is this balance balanced?+isBalanced :: Balance -> Balanced+isBalanced (Balance m) = M.foldrWithKey f Balanced m where+  f c n b = case n of+    Zero -> b+    (NonZero col) -> case b of+      Balanced -> let+        e = B.Entry dc a+        dc = case drCr col of+          B.Debit -> B.Credit+          B.Credit -> B.Debit+        q = qty col+        a = B.Amount q c+        in Inferable e+      _ -> NotInferable++-- | Converts an Entry to a Balance.+entryToBalance :: B.Entry -> Balance+entryToBalance (B.Entry dc am) = Balance $ M.singleton c no where+  c = B.commodity am+  no = NonZero (Column dc (B.qty am))++data BottomLine = Zero+            | NonZero Column+            deriving (Show, Eq)++instance Monoid BottomLine where+  mempty = Zero+  mappend n1 n2 = case (n1, n2) of+    (Zero, Zero) -> Zero+    (Zero, (NonZero c)) -> NonZero c+    ((NonZero c), Zero) -> NonZero c+    ((NonZero c1), (NonZero c2)) ->+      let (Column dc1 q1) = c1+          (Column dc2 q2) = c2+      in if dc1 == dc2+         then NonZero $ Column dc1 (q1 `add` q2)+         else case difference q1 q2 of+           LeftBiggerBy diff ->+             NonZero $ Column dc1 diff+           RightBiggerBy diff ->+             NonZero $ Column dc2 diff+           Equal -> Zero++data Column = Column { drCr :: B.DrCr+                     , qty :: B.Qty }+              deriving (Show, Eq)++-- | Add two Balances together. Commodities are never removed from the+-- balance, even if their balance is zero. Instead, they are left in+-- the balance. Sometimes you want to know that a commodity was in the+-- account but its balance is now zero.+addBalances :: Balance -> Balance -> Balance+addBalances (Balance t1) (Balance t2) = +    Balance $ M.unionWith mappend t1 t2++instance Semi.Semigroup Balance where+  (<>) = addBalances++-- | 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+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')
+ Penny/Lincoln/Bits.hs view
@@ -0,0 +1,74 @@+-- | Essential data types used to make Transactions and Postings.+module Penny.Lincoln.Bits (+  -- * Accounts+  Ac.SubAccountName(SubAccountName, unSubAccountName),+  Ac.Account(Account, unAccount),++  -- * Amounts+  Am.Amount(Amount, qty, commodity),++  -- * Commodities+  C.Commodity(Commodity, unCommodity),+  C.SubCommodity(SubCommodity, unSubCommodity),+  C.charCommodity,++  -- * DateTime+  DT.DateTime,+  DT.dateTime,+  DT.localTime,+  DT.timeZone,+  DT.TimeZoneOffset,+  DT.minsToOffset, DT.offsetToMins, DT.noOffset,++  -- * Debits and Credits+  DC.DrCr(Debit, Credit),+  DC.opposite,+  +  -- * Entries+  E.Entry(Entry, drCr, amount),++  -- * Flag+  F.Flag(Flag, unFlag),++  -- * Memos+  M.MemoLine(MemoLine, unMemoLine),+  M.Memo(Memo, unMemo),++  -- * Number+  N.Number(Number, unNumber),++  -- * Payee+  Pa.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),++  -- * Quantities+  Q.Qty, Q.unQty, Q.partialNewQty,+  Q.newQty, Q.add, Q.subt, Q.mult, Q.zero,+  Q.difference,+  Q.Difference(Q.LeftBiggerBy, Q.RightBiggerBy, Q.Equal),++  -- * Tags+  T.Tag(Tag, unTag),+  T.Tags(Tags, unTags)) 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.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
+ Penny/Lincoln/Bits/Account.hs view
@@ -0,0 +1,12 @@+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)+
+ Penny/Lincoln/Bits/Amount.hs view
@@ -0,0 +1,8 @@+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)
+ Penny/Lincoln/Bits/Commodity.hs view
@@ -0,0 +1,19 @@+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)) :| [])
+ Penny/Lincoln/Bits/DateTime.hs view
@@ -0,0 +1,57 @@+-- | 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+  , minsToOffset+  , noOffset+  ) where++import qualified Data.Time as T++-- | The number of minutes that this timezone is offset from UTC. Can+-- be positive, negative, or zero.+newtype TimeZoneOffset = TimeZoneOffset { offsetToMins :: Int }+                         deriving (Eq, Ord, Show)++-- | Convert minutes to a time zone offset. I'm having a hard time+-- deciding whether to be liberal or strict in what to accept+-- here. Currently it is somewhat strict in that it will fail if+-- absolute value is greater than 840 minutes; currently the article+-- at http://en.wikipedia.org/wiki/List_of_time_zones_by_UTC_offset+-- says there is no offset greater than 14 hours, or 840 minutes.+minsToOffset :: Int -> Maybe TimeZoneOffset+minsToOffset m = if abs m > 840+                 then Nothing+                 else Just $ TimeZoneOffset m++noOffset :: TimeZoneOffset+noOffset = TimeZoneOffset 0++-- | 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++-- | Construct a DateTime.+dateTime :: T.LocalTime -> TimeZoneOffset -> DateTime+dateTime = DateTime++toUTC :: DateTime -> T.UTCTime+toUTC (DateTime lt (TimeZoneOffset tzo)) = T.localTimeToUTC tz lt where+  tz = T.minutesToTimeZone tzo++instance Eq DateTime where+  l == r = toUTC l == toUTC r++instance Ord DateTime where+  compare l r = compare (toUTC l) (toUTC r)
+ Penny/Lincoln/Bits/DrCr.hs view
@@ -0,0 +1,9 @@+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
+ Penny/Lincoln/Bits/Entry.hs view
@@ -0,0 +1,9 @@+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)+
+ Penny/Lincoln/Bits/Flag.hs view
@@ -0,0 +1,7 @@+module Penny.Lincoln.Bits.Flag where++import Penny.Lincoln.TextNonEmpty (TextNonEmpty)++newtype Flag = Flag { unFlag :: TextNonEmpty }+             deriving (Eq, Show, Ord)+
+ Penny/Lincoln/Bits/Memo.hs view
@@ -0,0 +1,9 @@+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)
+ Penny/Lincoln/Bits/Number.hs view
@@ -0,0 +1,6 @@+module Penny.Lincoln.Bits.Number where++import Penny.Lincoln.TextNonEmpty (TextNonEmpty)++newtype Number = Number { unNumber :: TextNonEmpty }+                 deriving (Eq, Show, Ord)
+ Penny/Lincoln/Bits/Payee.hs view
@@ -0,0 +1,7 @@+module Penny.Lincoln.Bits.Payee where++import Penny.Lincoln.TextNonEmpty ( TextNonEmpty )++newtype Payee = Payee { unPayee :: TextNonEmpty }+              deriving (Eq, Show, Ord)+
+ Penny/Lincoln/Bits/Price.hs view
@@ -0,0 +1,43 @@+module Penny.Lincoln.Bits.Price (+  From ( From, unFrom ),+  To ( To, unTo ),+  CountPerUnit ( CountPerUnit, unCountPerUnit ),+  Price ( from, to, countPerUnit ),+  convert,+  newPrice) where++import Penny.Lincoln.Bits.Amount (Amount(Amount))+import Penny.Lincoln.Bits.Commodity (Commodity)+import Penny.Lincoln.Bits.Qty (Qty, mult)++newtype From = From { unFrom :: Commodity }+               deriving (Eq, Ord, Show)++newtype To = To { unTo :: Commodity }+             deriving (Eq, Ord, Show)++newtype CountPerUnit = CountPerUnit { unCountPerUnit :: Qty }+                       deriving (Eq, Ord, Show)++data Price = Price { from :: From+                   , to :: To+                   , countPerUnit :: CountPerUnit }+             deriving (Eq, Ord, Show)++-- | Convert an amount from the From price to the To price. Fails if+-- the From commodity in the Price is not the same as the commodity in+-- the Amount.+convert :: Price -> Amount -> Maybe Amount+convert p (Amount q c) =+  if (unFrom . from $ p) /= c+  then Nothing+  else let q' = q `mult` (unCountPerUnit . countPerUnit $ p)+       in Just (Amount q' (unTo . to $ p))++-- | Succeeds only if From and To are different commodities.+newPrice :: From -> To -> CountPerUnit -> Maybe Price+newPrice f t cpu =+  if unFrom f == unTo t+  then Nothing+  else Just $ Price f t cpu+
+ Penny/Lincoln/Bits/PricePoint.hs view
@@ -0,0 +1,10 @@+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
+ Penny/Lincoln/Bits/Qty.hs view
@@ -0,0 +1,70 @@+-- | Penny quantities. A quantity is simply a count (possibly+-- fractional) of something. It does not have a commodity or a+-- Debit/Credit.+module Penny.Lincoln.Bits.Qty (+  Qty, unQty, partialNewQty,+  newQty, add, subt, mult,+  zero, Difference(LeftBiggerBy, RightBiggerBy, Equal),+  difference) where++import Data.Decimal ( DecimalRaw ( Decimal ), Decimal )++-- | A quantity is always greater than zero. Various odd questions+-- happen if quantities can be zero. For instance, what if you have a+-- debit whose quantity is zero? Does it require a balancing credit+-- that is also zero? And how can you have a debit of zero anyway?+--+-- I can imagine situations where a quantity of zero might be useful;+-- for instance maybe you want to specifically indicate that a+-- particular posting in a transaction did not happen (for instance,+-- that a paycheck deduction did not take place). I think the better+-- way to handle that though would be through an addition to+-- Debit/Credit - maybe Debit/Credit/Zero. Barring the addition of+-- that, though, the best way to indicate a situation such as this+-- would be through transaction memos.+newtype Qty = Qty Decimal+              deriving (Eq, Ord, Show)++data Difference =+  LeftBiggerBy Qty+  | RightBiggerBy Qty+  | Equal++-- | Subtract the second Qty from the first.+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++-- | Unwrap a Qty to get the underlying Decimal. This Decimal will+-- always be greater than zero.+unQty :: Qty -> Decimal+unQty (Qty d) = d++-- | 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++-- | 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++subt :: Qty -> Qty -> Maybe Qty+subt (Qty q1) (Qty q2) = if q2 > q1 then Nothing else Just $ Qty (q1 - q2)++mult :: Qty -> Qty -> Qty+mult (Qty q1) (Qty q2) = Qty $ q1 * q2++zero :: Qty+zero = Qty $ Decimal 0 0
+ Penny/Lincoln/Bits/Tags.hs view
@@ -0,0 +1,10 @@+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)+
+ Penny/Lincoln/Builders.hs view
@@ -0,0 +1,62 @@+-- | Partial functions that make common types in Lincoln. Some data+-- types in Lincoln are deeply nested, with TextNonEmpty nested inside+-- of a newtype, nested inside of a NonEmptyList, nested inside+-- of... :) All the nesting ensures to the maximum extent possible+-- that the type system reflects the restrictions that exist on+-- Penny's data. For example, it would make no sense to have an empty+-- account (that is, an account with no sub-accounts) or a sub-account+-- whose name is an empty Text.+--+-- The disadvantage of the nesting is that building these data types+-- can be tedious if, for example, you want to build some data within+-- a short custom Haskell program. Thus, this module.++module Penny.Lincoln.Builders ( +  crashy+  , account+  , commodity+  ) 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+
+ Penny/Lincoln/Family.hs view
@@ -0,0 +1,102 @@+-- | A Transaction consists of a TopLine (information common to all+-- postings, such as the DateTime) and of at least two Postings. This+-- data relationship is so important and useful that it is expressed+-- in these modules. This module has its own functions and re-exports+-- functions and types from other modules in this hierarchy. There are+-- handy accessor functions for the records within each of the family+-- types, but these are not exported due to name conflicts; if you+-- want these simply import the necessary module (maybe qualified).+module Penny.Lincoln.Family (+  -- * Family types+  F.Family(Family),+  C.Child(Child),+  S.Siblings(Siblings),+  +  -- * Mapping families+  F.mapChildrenM,+  F.mapChildren,+  F.mapParentM,+  F.mapParent,++  -- * Functions to manipulate families+  children,+  orphans,+  adopt,+  marryWith,+  marry,+  divorceWith,+  divorce,+  S.collapse ) where++import qualified Penny.Lincoln.Family.Family as F+import qualified Penny.Lincoln.Family.Child as C+import qualified Penny.Lincoln.Family.Siblings as S++-- | Gets a family's children. The Child type contains information on+-- the parent, and each Child contains information on the other+-- Siblings.+children :: F.Family p c -> S.Siblings (C.Child p c)+children (F.Family p c1 c2 cRest) = S.Siblings fc sc rc where+  fc = C.Child c1 c2 cRest p+  sc = C.Child c2 c1 cRest p+  rc = map toChild rest+  rest = others cRest+  toChild (c, cs) = C.Child c c1 (c2:cs) p++-- | Separates the children from their parent.+orphans :: F.Family p c -> S.Siblings c+orphans (F.Family _ c1 c2 cs) = S.Siblings c1 c2 cs++-- | Unites a parent and some siblings into one family; the dual of+-- orphans.+adopt :: p -> S.Siblings c -> F.Family p c+adopt p (S.Siblings c1 c2 cs) = F.Family p c1 c2 cs++-- | Marries two families into one. This function is rather cruel: if+-- one family has more children than the other family, then the extra+-- children are discarded. That is, all children must pair one-by-one.+marryWith :: (p1 -> p2 -> p3)+             -> (c1 -> c2 -> c3)+             -> F.Family p1 c1+             -> F.Family p2 c2+             -> F.Family p3 c3+marryWith fp fc (F.Family lp lc1 lc2 lcs) (F.Family rp rc1 rc2 rcs) =+  F.Family (fp lp rp) (fc lc1 rc1) (fc lc2 rc2)+  (zipWith fc lcs rcs)++-- | marryWith a tupling function.+marry :: F.Family p1 c1+         -> F.Family p2 c2+         -> F.Family (p1, p2) (c1, c2)+marry = marryWith (,) (,)+  +-- | Splits up a family.+divorceWith :: (p1 -> (p2, p3))+             -> (c1 -> (c2, c3))+             -> F.Family p1 c1+             -> (F.Family p2 c2, F.Family p3 c3)+divorceWith fp fc (F.Family p c1 c2 cs) = (f2, f3) where+  f2 = F.Family p2 c21 c22 c2s+  f3 = F.Family p3 c31 c32 c3s+  (p2, p3) = fp p+  (c21, c31) = fc c1+  (c22, c32) = fc c2+  cps = map fc cs+  (c2s, c3s) = (map fst cps, map snd cps)++-- | divorceWith an untupling function.+divorce :: F.Family (p1, p2) (c1, c2)+         -> (F.Family p1 c1, F.Family p2 c2)+divorce = divorceWith id id++others :: [a] -> [(a, [a])]+others = map yank . allIndexes++allIndexes :: [a] -> [(Int, [a])]+allIndexes as = zip [0..] (replicate (length as) as)++yank :: (Int, [a]) -> (a, [a])+yank (i, as) = let+  (ys, zs) = splitAt i as+  in (head zs, ys ++ (tail zs))+
+ Penny/Lincoln/Family/Child.hs view
@@ -0,0 +1,9 @@+module Penny.Lincoln.Family.Child where++-- | A Child has at least one sibling and a parent.+data Child p c =+  Child { child :: c+        , sibling1 :: c+        , siblings :: [c]+        , parent :: p }+  deriving Show
+ Penny/Lincoln/Family/Family.hs view
@@ -0,0 +1,50 @@+module Penny.Lincoln.Family.Family where++import qualified Data.Functor.Identity as I++-- | A Family has one parent (ah, the anomie, sorry) and at least two+-- children.+data Family p c =+  Family { parent :: p+         , child1 :: c+         , child2 :: c+         , children :: [c] }+  deriving (Eq, Show)++-- | Maps over all children in a monad, in order starting with child+-- 1, then child 2, then the children in the list from left to right.+mapChildrenM ::+  Monad 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'+++-- | Maps over all children, in order starting with child+-- 1, then child 2, then the children in the list from left to right.+mapChildren ::+  (a -> b)+  -> Family p a+  -> Family p b+mapChildren f fam = I.runIdentity (mapChildrenM f' fam) where+  f' = return . f++-- | Maps over the parent in a monad.+mapParentM ::+  Monad 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++-- | 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
+ Penny/Lincoln/Family/Siblings.hs view
@@ -0,0 +1,54 @@+module Penny.Lincoln.Family.Siblings (+  Siblings(Siblings, first, second, rest),+  collapse+  ) where++import qualified Prelude as P+import Prelude hiding (concat)+import qualified Data.Semigroup as S+import qualified Data.List.NonEmpty as NE+import Data.List.NonEmpty (NonEmpty((:|)))+import qualified Data.Foldable as Foldable+import qualified Data.Traversable as T+import Control.Applicative ((<*>), (<$>))++-- | Describes the siblings of a family, but tells you nothing about+-- the parent. There are always at least two Siblings.+data Siblings a = Siblings { first :: a+                           , second :: a+                           , rest :: [a] }+                  deriving (Eq, Show)++instance S.Semigroup (Siblings a) where+  (Siblings a1 a2 ar) <> (Siblings b1 b2 br) =+    Siblings a1 a2 (ar ++ (b1:b2:br))++instance Functor Siblings where+  fmap g (Siblings f s rs) = Siblings (g f) (g s) (map g rs)++instance Foldable.Foldable Siblings where+  foldr g b (Siblings f s rs) = g f (g s (foldr g b rs))++instance T.Traversable Siblings where+  -- traverse :: Applicative f => (a -> f b) -> t a -> f (t b)+  traverse g (Siblings f s rs) =+    Siblings+    <$> g f+    <*> g s+    <*> T.traverse g rs++-- | Change a Siblings of NonEmpty lists to a Siblings. The original+-- order of the elements contained in the Siblings and within the+-- NonEmpty lists is preserved.+collapse :: Siblings (NE.NonEmpty a)+            -> Siblings a+collapse (Siblings (s1_1:|s1_r) s2@(s2_1:|s2_r) sr) =+  Siblings r1 r2 rr where+    r1 = s1_1+    (r2, rr) = case s1_r of+      [] -> (s2_1, (s2_r ++ concatNE sr))+      x:xs -> (x, xs ++ concatNE (s2 : sr))++concatNE :: [NE.NonEmpty a] -> [a]+concatNE = foldr f [] where+  f (a :| as) soFar = (a:as) ++ soFar
+ Penny/Lincoln/HasText.hs view
@@ -0,0 +1,105 @@+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 qualified Penny.Lincoln.Bits as B+import Penny.Lincoln.TextNonEmpty (TextNonEmpty(TextNonEmpty))++class HasText a where+  text :: a -> Text++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.Flag where+  text = text . B.unFlag++instance HasText B.MemoLine where+  text = text . B.unMemoLine++instance HasText B.Number where+  text = text . B.unNumber++instance HasText B.Payee where+  text = 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++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++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
+ Penny/Lincoln/Meta.hs view
@@ -0,0 +1,71 @@+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)+
+ Penny/Lincoln/NestedMap.hs view
@@ -0,0 +1,268 @@+-- | A nested map. The values in each NestedMap are tuples, with the+-- first element of the tuple being a label that you select and the+-- second value being another NestedMap. Functions are provided so you+-- may query the map at any level or insert new labels (and,+-- therefore, new keys) at any level.+module Penny.Lincoln.NestedMap (+  NestedMap ( NestedMap ),+  unNestedMap,+  empty,+  relabel,+  descend,+  insert,+  cumulativeTotal,+  traverse,+  traverseWithTrail ) where++import Control.Applicative ((<*>), (<$>))+import Data.Map ( Map )+import qualified Data.Foldable as F+import qualified Data.Traversable as T+import qualified Data.Map as M+import Data.Monoid ( Monoid, mconcat, mappend, mempty )++newtype NestedMap k l =+  NestedMap { unNestedMap :: Map k (l, NestedMap k l) }+  deriving (Eq, Show, Ord)++instance Functor (NestedMap k) where+  fmap f (NestedMap m) = let+    g (l, s) = (f l, fmap f s)+    in NestedMap $ M.map g m++instance (Ord k) => F.Foldable (NestedMap k) where+  foldMap = T.foldMapDefault++instance (Ord k) => T.Traversable (NestedMap k) where+  -- traverse :: Applicative f+  --          => (a -> f b)+  --          -> NestedMap k a+  --          -> f (NestedMap k b)+  traverse f (NestedMap m) = let+      f' (l, m') = (,) <$> f l <*> T.traverse f m'+      in NestedMap <$> T.traverse f' m+                 +-- | An empty NestedMap.+empty :: NestedMap k l+empty = NestedMap (M.empty)++-- | Helper function for relabel. For a given key and function+-- that modifies the label, return the new submap to insert into the+-- given map. Does not actually insert the submap though. That way,+-- relabel can then modify the returned submap before+-- inserting it into the mother map with the given label.+newSubmap ::+  (Ord k)+  => NestedMap k l+  -> k+  -> (Maybe l -> l)+  -> (l, NestedMap k l)+newSubmap (NestedMap m) k g = (newL, NestedMap newM) where+  (newL, newM) = case M.lookup k m of+    Nothing -> (g Nothing, M.empty)+    (Just (oldL, (NestedMap oldM))) -> (g (Just oldL), oldM)++-- | Descends through a NestedMap with successive keys in the list,+-- proceeding from left to right. At any given level, if the key+-- given does not already exist, then inserts an empty submap and+-- applies the given label modification function to Nothing to+-- determine the new label. If the given key already does exist, then+-- preserves the existing submap and applies the given label+-- modification function to (Just oldlabel) to determine the new+-- label.+relabel ::+  (Ord k)+  => NestedMap k l+  -> [(k, (Maybe l -> l))]+  -> NestedMap k l+relabel m [] = m+relabel (NestedMap m) ((k, f):vs) = let+  (newL, newM) = newSubmap (NestedMap m) k f+  newM' = relabel newM vs+  in NestedMap $ M.insert k (newL, newM') m++-- | Given a list of keys, find the key that is furthest down in the+-- map that matches the requested list of keys. Returns [(k, l)],+-- where the first item in the list is the topmost key found and its+-- matching label, and the last item in the list is the deepest key+-- found and its matching label. (Often you will be most interested+-- in the deepest key.)+descend ::+  Ord k+  => [k]+  -> NestedMap k l+  -> [(k, l)]+descend keys (NestedMap mi) = descend' keys mi where+  descend' [] _ = []+  descend' (k:ks) m = case M.lookup k m of+    Nothing -> []+    Just (l, (NestedMap im)) -> (k, l) : descend' ks im+++-- | Descends through the NestedMap one level at a time, proceeding+-- key by key from left to right through the list of keys given. At+-- the last key, appends the given label to the labels already+-- present; if no label is present, uses mempty and mappend to create+-- a new label. If the list of keys is empty, does nothing.+insert ::+  (Ord k, Monoid l)+  => NestedMap k l+  -> [k]+  -> l+  -> NestedMap k l+insert m [] _ = m+insert m ks l = relabel m ts where+  ts = firsts ++ [end]+  firsts = map (\k -> (k, keepOld)) (init ks) where+    keepOld mk = case mk of+      (Just old) -> old+      Nothing -> mempty+  end = (key, newL) where+    key = last ks+    newL mk = case mk of+      (Just old) -> old `mappend` l+      Nothing -> mempty `mappend` l+  +totalMap ::+  (Monoid l)+  => NestedMap k l+  -> l+totalMap (NestedMap m) =+  if M.null m+  then mempty+  else mconcat . map totalTuple . M.elems $ m++totalTuple ::+  (Monoid l)+  => (l, NestedMap k l)+  -> l+totalTuple (l, (NestedMap top)) =+  if M.null top+  then l+  else mappend l (totalMap (NestedMap top))++remapWithTotals ::+  (Monoid l)+  => NestedMap k l+  -> NestedMap k l+remapWithTotals (NestedMap top) =+  if M.null top+  then NestedMap M.empty+  else NestedMap $ M.map f top where+    f a@(_, m) = (totalTuple a, remapWithTotals m)++-- | Leaves all keys of the map and submaps the same. Changes each+-- label to reflect the total of that label and of all the labels of+-- the maps within the NestedMap accompanying the label. Returns the+-- total of the entire NestedMap.+cumulativeTotal ::+  (Monoid l)+  => NestedMap k l+  -> (l, NestedMap k l)+cumulativeTotal m = (totalMap m, remapWithTotals m)++-- | Supply a function that takes a key, a label, and a+-- NestedMap. traverse will traverse the NestedMap. For each (label,+-- NestedMap) pair, traverse will first apply the given function to+-- the label before descending through the NestedMap. The function is+-- applied to the present key and label and the accompanying+-- NestedMap. The function you supply must return a Maybe. If the+-- result is Nothing, then the pair is deleted as a value from its+-- parent NestedMap. If the result is (Just s), then the label of this+-- level of the NestedMap is changed to s before descending to the+-- next level of the NestedMap.+--+-- All this is done in a monad, so you can carry out arbitrary side+-- effects such as inspecting or changing a state or doing IO. If you+-- don't need a monad, just use Identity.+--+-- Thus this function can be used to inspect, modify, and prune a+-- NestedMap.+--+-- For a simpler traverse that does not provide you with so much+-- information, NestedMap is also an instance of Data.Traversable.+traverse ::+  (Monad m, Ord k)+  => (k -> l -> NestedMap k l -> m (Maybe a))+  -> NestedMap k l+  -> m (NestedMap k a)+traverse f m = traverseWithTrail (\_ -> f) m++-- | Like traverse, but the supplied function is also applied to a+-- list that tells it about the levels of NestedMap that are parents+-- to this NestedMap.+traverseWithTrail ::+  (Monad m, Ord k)+  => ( [(k, l)] -> k -> l -> NestedMap k l -> m (Maybe a) )+  -> NestedMap k l+  -> m (NestedMap k a)+traverseWithTrail f = traverseWithTrail' f []++traverseWithTrail' ::+  (Monad m, Ord k)+  => ([(k, l)] -> k -> l -> NestedMap k l -> m (Maybe a))+  -> [(k, l)]+  -> NestedMap k l+  -> m (NestedMap k a)+traverseWithTrail' f ts (NestedMap m) =+  if M.null m+  then return $ NestedMap M.empty+  else do+    let ps = M.assocs m+    mlsMaybes <- mapM (traversePairWithTrail f ts) ps+    let ps' = zip (M.keys m) mlsMaybes+        folder (k, ma) rs = case ma of+          (Just r) -> (k, r):rs+          Nothing -> rs+        ps'' = foldr folder [] ps'+    return (NestedMap (M.fromList ps''))++traversePairWithTrail ::+  (Monad m, Ord k)+  => ( [(k, l)] -> k -> l -> NestedMap k l -> m (Maybe a) )+  -> [(k, l)]+  -> (k, (l, NestedMap k l))+  -> m (Maybe (a, NestedMap k a))+traversePairWithTrail f ls (k, (l, m)) = do+  ma <- f ls k l m+  case ma of+    Nothing -> return Nothing+    (Just a) -> do+      m' <- traverseWithTrail' f ((k, l):ls) m+      return (Just (a, m'))++-- For testing+_new :: (k, l) -> (k, (Maybe l -> l))+_new (k, l) = (k, const l)++_map1, _map2, _map3, _map4 :: NestedMap Int String+_map1 = NestedMap M.empty+_map2 = relabel _map1 [_new (5, "hello"), _new (66, "goodbye"), _new (777, "yeah")]+_map3 = relabel _map2 [_new (6, "what"), _new (77, "zeke"), _new (888, "foo")]+_map4 = relabel _map3+       [ (6, (\m -> case m of Nothing -> "_new"; (Just s) -> s ++ "_new"))+       , (77, (\m -> case m of Nothing -> "_new"; (Just s) -> s ++ "more _new")) ]++_printer :: Int -> String -> a -> IO (Maybe ())+_printer i s _ = do+  putStrLn (show i)+  putStrLn s+  return $ Just ()++_printerWithTrail :: [(Int, String)] -> Int -> String -> a -> IO (Maybe ())+_printerWithTrail ps n str _ = do+  let ptr (i, s) = putStr ("(" ++ show i ++ ", " ++ s ++ ") ")+  mapM_ ptr . reverse $ ps+  ptr (n, str)+  putStrLn ""+  return $ Just ()++_showMap4 :: IO ()+_showMap4 = do+  _ <- traverse _printer _map4+  return ()++_showMapWithTrail :: IO ()+_showMapWithTrail = do+  _ <- traverseWithTrail _printerWithTrail _map4+  return ()
+ Penny/Lincoln/Predicates.hs view
@@ -0,0 +1,136 @@+-- | Functions that return a boolean based upon some criterion that+-- matches something, often a PostingBox. Useful when filtering+-- Postings.+module Penny.Lincoln.Predicates where++import Data.Text (Text, singleton)++import qualified Penny.Lincoln.Bits as B+import Penny.Lincoln.HasText (HasText, text, HasTextList, textList,+                              Delimited(Delimited))+import qualified Penny.Lincoln.Queries as Q+import Penny.Lincoln.Transaction (PostFam)++-- * Matching helpers++match :: HasText a => (Text -> Bool) -> a -> Bool+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++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++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)+  ++matchMaybeLevel ::+  HasTextList a+  => Int+  -> (Text -> Bool)+  -> Maybe a+  -> Bool+matchMaybeLevel i f ma = case ma of+  Nothing -> False+  (Just l) -> matchLevel i f l++-- * Pattern matching fields++payee :: (Text -> Bool) -> PostFam -> Bool+payee f = matchMaybe f . Q.payee++number :: (Text -> Bool) -> PostFam -> Bool+number f = matchMaybe f . Q.number++flag :: (Text -> Bool) -> PostFam -> Bool+flag f = matchMaybe f . Q.flag++postingMemo :: (Text -> Bool) -> PostFam -> Bool+postingMemo f = matchMemo f . Q.postingMemo++transactionMemo :: (Text -> Bool) -> PostFam -> Bool+transactionMemo f = matchMemo f . Q.transactionMemo++-- * Date++date ::+  (B.DateTime -> Bool)+  -> PostFam+  -> Bool+date f c = f (Q.dateTime c)+++-- * Qty++qty ::+  (B.Qty -> Bool)+  -> PostFam+  -> Bool+qty f c = f (Q.qty c)+++-- * DrCr+drCr :: B.DrCr -> PostFam -> Bool+drCr dc p = dc == Q.drCr p++debit :: PostFam -> Bool+debit p = Q.drCr p == B.Debit++credit :: PostFam -> Bool+credit p = Q.drCr p == B.Credit++-- * Matching delimited fields++matchDelimited ::+  HasTextList a+  => Text+  -> (Text -> Bool)+  -> a -> Bool+matchDelimited d f = f . text . Delimited 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+++-- * Account+account :: Text -> (Text -> Bool) -> PostFam -> Bool+account t f = matchDelimited t f+                . B.unAccount+                . Q.account++accountLevel :: Int -> (Text -> Bool) -> PostFam -> Bool+accountLevel i f = matchLevel i f . Q.account++accountAny :: (Text -> Bool) -> PostFam -> Bool+accountAny f = matchAny f . Q.account++-- * Tags+tag :: (Text -> Bool) -> PostFam -> Bool+tag f = matchAny f . Q.tags+
+ Penny/Lincoln/PriceDb.hs view
@@ -0,0 +1,139 @@+-- | A database of price information. A PricePoint has a DateTime, a+-- From commodity, a To commodity, and a QtyPerUnit. The PriceDb holds+-- this information for several prices. You can query the database by+-- supplying a from commodity, a to commodity, and a DateTime, and the+-- database will give you the QtyPerUnit, if there is one.+module Penny.Lincoln.PriceDb (+  PriceDb,+  emptyDb,+  addPrice,+  getPrice,+  PriceDbError(FromNotFound, ToNotFound, CpuNotFound),+  convert+  ) where++import qualified Control.Monad.Exception.Synchronous as Ex+import qualified Data.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+type ToMap = M.Map B.To CpuMap++-- | The PriceDb holds information about prices. Create an empty one+-- using 'emptyDb' then fill it with values using foldl or similar.+newtype PriceDb = PriceDb (NM.NestedMap B.SubCommodity ToMap)++-- | An empty PriceDb+emptyDb :: PriceDb+emptyDb = PriceDb NM.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)+++-- | 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+  -> B.From+  -> B.To+  -> 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 (lower, exact, _) = M.splitLookup utc cpuMap+  cpu <- 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+-- fail and throw PriceDbError. Internally uses 'getPrice', so read its+-- documentation for details on how price lookup works.+convert ::+  PriceDb+  -> B.DateTime+  -> B.To+  -> B.Amount+  -> Ex.Exceptional PriceDbError B.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)
+ Penny/Lincoln/Queries.hs view
@@ -0,0 +1,92 @@+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)++best ::+  (T.Posting -> Maybe a)+  -> (T.TopLine -> Maybe a)+  -> T.PostFam+  -> Maybe a+best fp ft c = case fp . child . T.unPostFam $ c of+  Just r -> Just r+  Nothing -> ft . parent . T.unPostFam $ c+++payee :: T.PostFam -> Maybe B.Payee+payee = best T.pPayee T.tPayee++number :: T.PostFam -> Maybe B.Number+number = best T.pNumber T.tNumber++flag :: T.PostFam -> Maybe B.Flag+flag = best T.pFlag T.tFlag++postingMemo :: T.PostFam -> B.Memo+postingMemo = T.pMemo . child . T.unPostFam++transactionMemo :: T.PostFam -> B.Memo+transactionMemo = T.tMemo . parent . T.unPostFam++dateTime :: T.PostFam -> B.DateTime+dateTime = T.tDateTime . parent . T.unPostFam++account :: T.PostFam -> B.Account+account = T.pAccount . child . T.unPostFam++tags :: T.PostFam -> B.Tags+tags = T.pTags . child . T.unPostFam++entry :: T.PostFam -> B.Entry+entry = T.pEntry . child . T.unPostFam++balance :: T.PostFam -> Balance+balance = entryToBalance . entry++drCr :: T.PostFam -> B.DrCr+drCr = B.drCr . entry++amount :: T.PostFam -> B.Amount+amount = B.amount . entry++qty :: T.PostFam -> B.Qty+qty = B.qty . amount++commodity :: T.PostFam -> B.Commodity+commodity = B.commodity . amount++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 M.TopMemoLine+topMemoLine = M.topMemoLine . topLineMeta++topLineLine :: T.PostFam -> Maybe M.TopLineLine+topLineLine = M.topLineLine . topLineMeta++filename :: T.PostFam -> Maybe M.Filename+filename = M.filename . topLineMeta++globalTransaction :: T.PostFam -> Maybe M.GlobalTransaction+globalTransaction = M.globalTransaction . topLineMeta++fileTransaction :: T.PostFam -> Maybe M.FileTransaction+fileTransaction = M.fileTransaction . topLineMeta++postingLine :: T.PostFam -> Maybe M.PostingLine+postingLine = M.postingLine . postingMeta++postingFormat :: T.PostFam -> Maybe M.Format+postingFormat = M.postingFormat . postingMeta++globalPosting :: T.PostFam -> Maybe M.GlobalPosting+globalPosting = M.globalPosting . postingMeta++filePosting :: T.PostFam -> Maybe M.FilePosting+filePosting = M.filePosting . postingMeta
+ Penny/Lincoln/Serial.hs view
@@ -0,0 +1,105 @@+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++  } deriving (Eq, Show)+             ++-- | 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++-- | 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++-- | 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)+++serialChildrenInFamily ::+  (Serial -> cOld -> cNew)+  -> F.Family p cOld+  -> St.State (NextFwd, NextBack) (F.Family p cNew)+serialChildrenInFamily f = F.mapChildrenM (serialItemSt f)++newtype NextFwd = NextFwd Int deriving Show+newtype NextBack = NextBack Int deriving Show++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)++newtype Index = Index Int deriving (Eq, Ord, Show)+newtype Total = Total Int deriving (Eq, Ord, Show)++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++serial :: Total -> Index -> Serial+serial (Total t) (Index i) = Serial i b where+  b = t - i - 1++initNexts :: Int -> (NextFwd, NextBack)+initNexts i = (NextFwd 0, NextBack $ i - 1)
+ Penny/Lincoln/TextNonEmpty.hs view
@@ -0,0 +1,25 @@+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
+ Penny/Lincoln/Transaction.hs view
@@ -0,0 +1,278 @@+-- | Transactions, the heart of Penny. The Transaction data type is+-- abstract, so that only this module can create Transactions. This+-- provides assurance that if a Transaction exists, it is a valid,+-- balanced Transaction. In addition, the Posting data type is+-- abstract as well, so you know that if you have a Posting, it was+-- created as part of a balanced Transaction.+--+-- Functions prefixed with a @p@ query a particular posting for its+-- properties. Functions prefixed with a @t@ query transactions. Every+-- transaction has a single DateTime, and all the postings have this+-- same DateTime, so there is no function to query a posting's+-- DateTime. Just query the parent transaction. For other things such+-- as Number and Flag, the transaction might have data and the posting+-- might have data as well, so functions are provided to query both.+--+-- Often you will want to query a single posting and have a function+-- that gives you, for example, the posting's flag if it has one, or+-- the transaction's flag if it has one, or Nothing if neither the+-- posting nor the transaction has a flag. The functions in+-- "Penny.Lincoln.Queries" do that.+module Penny.Lincoln.Transaction (+  +  -- * Postings and transactions+  Posting,+  Transaction,+  PostFam (unPostFam),++  -- * Making transactions+  transaction,+  Error ( UnbalancedError, CouldNotInferError),+  +  -- * Querying postings+  Inferred(Inferred, NotInferred),+  pPayee, pNumber, pFlag, pAccount, pTags,+  pEntry, pMemo, pInferred, pMeta, changePostingMeta,++  -- * Querying transactions+  TopLine,+  tDateTime, tFlag, tNumber, tPayee, tMemo, tMeta,+  unTransaction, postFam, changeTransactionMeta,+  +  -- * Adding serials+  addSerialsToList, addSerialsToEithers,+  +  -- * Box+  Box ( Box, boxMeta, boxPostFam )+  +  ) 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 qualified Data.Traversable as Tr+import qualified Control.Monad.Trans.State.Lazy as St+import Control.Monad.Trans.Class ( lift )++-- | Indicates whether the entry for this posting was inferred. That+-- is, if the user did not supply an entry for this posting, then it+-- was inferred.+data Inferred = Inferred | NotInferred deriving (Eq, Show)++-- | Each Transaction consists of at least two Postings.+data Posting =+  Posting { pPayee   :: (Maybe B.Payee)+          , pNumber  :: (Maybe B.Number)+          , pFlag    :: (Maybe B.Flag)+          , pAccount :: B.Account+          , pTags    :: B.Tags+          , pEntry   :: B.Entry+          , pMemo    :: B.Memo+          , pInferred :: Inferred+          , pMeta     :: M.PostingMeta }+  deriving (Eq, Show)++-- | The TopLine holds information that applies to all the postings in+-- a transaction (so named because in a ledger file, this information+-- appears on the top line.)+data TopLine =+  TopLine { tDateTime :: B.DateTime+          , tFlag     :: (Maybe B.Flag)+          , tNumber   :: (Maybe B.Number)+          , tPayee    :: (Maybe B.Payee)+          , tMemo     :: B.Memo+          , tMeta     :: M.TopLineMeta }+  deriving (Eq, Show)++-- | All the Postings in a Transaction must produce a Total whose+-- debits and credits are equal. That is, the Transaction must be+-- balanced. No Transactions are created that are not balanced.+newtype Transaction =+  Transaction { unTransaction :: F.Family TopLine Posting }+  deriving (Eq, Show)+  +-- | Errors that can arise when making a Transaction.+data Error = UnbalancedError+           | CouldNotInferError+           deriving (Eq, Show)++newtype PostFam = PostFam { unPostFam :: C.Child TopLine Posting }+                  deriving Show++-- | Get the Postings from a Transaction, with information on the+-- sibling Postings.+postFam :: Transaction -> [PostFam]+postFam (Transaction ps) = map PostFam . Fdbl.toList . children $ ps++{- BNF-like grammar for the various sorts of allowed postings.++postingGroup ::= (inferGroup balancedGroup*) | balancedGroup++inferGroup ::= "at least 1 posting. All postings have same account and+                commodity. The balance is inferable."+balancedGroup ::= "at least 2 postings. All postings have the same+                   account and commodity. The balance is balanced."++-}++-- | Makes transactions.+transaction ::+  F.Family U.TopLine U.Posting+  -> Exceptional Error Transaction+transaction f@(F.Family p _ _ _) = do+  let os = orphans f+      t = totalAll os+      p' = toTopLine p+  a2 <- inferAll os t+  return $ Transaction (adopt p' a2)++totalAll :: S.Siblings U.Posting+         -> Bal.Balance+totalAll =+  Fdbl.foldr1 Bal.addBalances+  . catMaybes+  . Fdbl.toList+  . fmap (fmap Bal.entryToBalance . U.entry)++infer ::+  U.Posting+  -> Ex.ExceptionalT Error+  (St.State (Maybe B.Entry)) Posting+infer po =+  case U.entry po of+    Nothing -> do+      st <- lift St.get+      case st of+        Nothing -> Ex.throwT CouldNotInferError+        (Just e) -> do+          lift $ St.put Nothing+          return $ toPosting po e Inferred+    (Just e) -> return $ toPosting po e NotInferred+          +runInfer ::+  Maybe B.Entry+  -> S.Siblings U.Posting+  -> Exceptional Error (S.Siblings Posting)+runInfer me pos = do+  let (res, finalSt) = St.runState ext me+      ext = Ex.runExceptionalT (Tr.mapM infer pos)+  case finalSt of+    (Just _) -> throw UnbalancedError+    Nothing -> case res of +      (Exception e) -> throw e+      (Success g) -> return g++inferAll ::+  S.Siblings U.Posting+  -> Bal.Balance+  -> Exceptional Error (S.Siblings Posting)+inferAll pos t = do+  en <- case Bal.isBalanced t of+    Bal.Balanced -> return Nothing+    (Bal.Inferable e) -> return $ Just e+    Bal.NotInferable -> throw UnbalancedError+  runInfer en pos++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++toTopLine :: U.TopLine -> TopLine+toTopLine (U.TopLine d f n p m mt) =+  TopLine d f n p m mt+++-- | 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++  -> Transaction+  -- ^ Transaction with new metadata++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) }++-- | 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) }++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''++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+++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++-- | A box stores a family of transaction data along with+-- metadata. The transaction is stored in child form, indicating a+-- particular posting of interest. The metadata is in addition to the+-- metadata associated with the TopLine and with each posting.+data Box m =+  Box { boxMeta :: m+      , boxPostFam :: PostFam }+  deriving Show++instance Functor Box where+  fmap f (Box m pf) = Box (f m) pf
+ Penny/Lincoln/Transaction/Unverified.hs view
@@ -0,0 +1,27 @@+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)++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)++entry :: Posting -> Maybe B.Entry+entry (Posting _ _ _ _ _ e _ _) = e
+ Penny/Shield.hs view
@@ -0,0 +1,88 @@+-- | Shield - the Penny runtime environment+--+-- Both Cabin and Copper can benefit from knowing information about+-- the Penny runtime environment, such as environment variables and+-- whether standard output is a terminal. That information is provided+-- by the Runtime type. In the future this module may also provide+-- information about the POSIX locale configuration. For now, that+-- information would require reaching into the FFI and so it is not+-- implemented.++module Penny.Shield (+  ScreenLines,+  unScreenLines,+  ScreenWidth,+  unScreenWidth,+  Output(IsTTY, NotTTY),+  Term,+  unTerm,+  Runtime,+  environment,+  currentTime,+  output,+  screenLines,+  screenWidth,+  term,+  runtime)+  where++import Control.Applicative ((<$>), (<*>))+import qualified Data.Time as T+import System.Environment (getEnvironment)+import System.IO (hIsTerminalDevice, stdout)++import qualified Penny.Lincoln.Bits as B++data ScreenLines = ScreenLines { unScreenLines :: Int }+                 deriving Show++newtype ScreenWidth = ScreenWidth { unScreenWidth :: Int }+                      deriving Show++data Output = IsTTY | NotTTY++newtype Term = Term { unTerm :: String } deriving Show++-- | Information about the runtime environment.+data Runtime = Runtime { environment :: [(String, String)]+                       , 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)+          <*> findOutput++findOutput :: IO Output+findOutput = do+  isTerm <- hIsTerminalDevice stdout+  return $ if isTerm then IsTTY else NotTTY++screenLines :: Runtime -> Maybe ScreenLines+screenLines r = +  (lookup "LINES" . environment $ r)+  >>= safeRead+  >>= return . ScreenLines++screenWidth :: Runtime -> Maybe ScreenWidth+screenWidth r =+  (lookup "COLUMNS" . environment $ r)+  >>= safeRead+  >>= return . ScreenWidth++term :: Runtime -> Maybe Term+term r =+  (lookup "TERM" . environment $ r)+  >>= return . Term++-- | Read, but without crashes.+safeRead :: (Read a) => String -> Maybe a+safeRead s = case reads s of+  (a, []):[] -> Just a+  _ -> Nothing
+ Penny/Zinc.hs view
@@ -0,0 +1,29 @@+-- | 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)++import qualified Penny.Cabin.Interface as I+import qualified Penny.Copper as Cop+import qualified Penny.Shield as S+import qualified Penny.Zinc.Parser as P++runPenny ::+  S.Runtime+  -> Cop.DefaultTimeZone+  -> Cop.RadGroup+  -> (S.Runtime -> P.T)+  -> [I.Report]+  -> IO ()+runPenny rt dtz rg df rs = do+  as <- getArgs+  case M.parse as (P.parser rt dtz rg df rs) of+    Ex.Exception e -> do+      hPutStrLn stderr . show $ e+      exitFailure+    Ex.Success g -> g
+ Penny/Zinc/Error.hs view
@@ -0,0 +1,11 @@+module Penny.Zinc.Error where++import Data.Text (Text, pack)++data Error =+  ParseError Text+  | ReportError Text+  deriving Show++printError :: Error -> Text+printError = pack . show
+ Penny/Zinc/Help.hs view
@@ -0,0 +1,125 @@+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.",+  ""+  ]
+ Penny/Zinc/Parser.hs view
@@ -0,0 +1,86 @@+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+
+ Penny/Zinc/Parser/Defaults.hs view
@@ -0,0 +1,29 @@+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 }+
+ Penny/Zinc/Parser/Filter.hs view
@@ -0,0 +1,265 @@+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+-}
+ Penny/Zinc/Parser/Ledgers.hs view
@@ -0,0 +1,79 @@+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 $ "<stdin>"++-- | 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)
+ Penny/Zinc/Parser/Report.hs view
@@ -0,0 +1,30 @@+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+++
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ penny-lib.cabal view
@@ -0,0 +1,290 @@+Name: penny-lib+Version: 0.2.0.0+Cabal-version: >=1.8+Build-Type: Simple+License: MIT+Copyright: 2012 Omari Norman.+author: Omari Norman+maintainer: omari@smileystation.com+stability: Experimental+homepage: http://www.github.com/massysett/penny+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 <http://ledger-cli.org/>. 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+  <http://www.principlesofaccounting.com/>, 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:+    <http://www.mscs.dal.ca/~selinger/accounting/tutorial.html>.++  .++  * Penny stores amounts using only integers, building from the+    Data.Decimal library available at+    <http://hackage.haskell.org/package/Decimal>. This ensures the+    accuracy of your data, as using floating point values to represent+    money is a bad idea. Here is one explanation:+    <http://stackoverflow.com/questions/3730019/why-not-use-double-or-float-to-represent-currency>. 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.++  .++  More details about the organization of the Penny modules is+  available by examining the top "Penny" module.++  .++  This is only a library. For the executable package, which also+  includes more documentation, search for the penny-bin package on+  Hackage.++source-repository head+    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.*++    Exposed-modules:+        Penny,+        Penny.Cabin,+        Penny.Cabin.Allocate,+        Penny.Cabin.Balance,+        Penny.Cabin.Balance.Parser,+        Penny.Cabin.Balance.Help,+        Penny.Cabin.Balance.Options,+        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.Options,+        Penny.Cabin.Posts.Parser,+        Penny.Cabin.Posts.Spacers,+        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.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++    ghc-options: -Wall+    if flag(debug)+      ghc-options: -auto-all -caf-all++Flag debug+    Description: turns on some debugging options+    Default: False