summaryrefslogtreecommitdiff
path: root/lib/Penny/Wheat.hs
blob: 4dd2f4747337bb8844b928a72fb8b27fd189d16e (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
{-# LANGUAGE OverloadedStrings #-}

-- | Wheat - Penny ledger tests
--
-- Wheat helps you build tests to check all the postings in your
-- ledger. Perhaps you want to make sure all the account names are
-- valid, or that your checking account has no unreconciled
-- transactions. With Wheat you can easily build a command line
-- program that will check all the postings in a ledger for you
-- against criteria that you specify.

module Penny.Wheat
  ( -- * Configuration
    WheatConf(..)

    -- * Tests
  , eachPostingMustBeTrue
  , atLeastNPostings

    -- * Convenience functions
  , futureFirstsOfTheMonth

    -- * Running tests
  , main
  ) where

import Data.Either (partitionEithers)
import Data.Maybe (mapMaybe)
import qualified Penny.Copper as Cop
import qualified Penny.Copper.Parsec as CP
import qualified Penny.Lincoln as L
import qualified Penny.Liberty as Ly
import qualified Data.Text as X
import qualified Data.Time as Time
import qualified Text.Matchers as M
import qualified Text.Parsec as Parsec
import qualified System.Exit as Exit
import qualified System.IO as IO
import qualified Penny.Shield as S
import qualified Data.Sums as Su

import qualified Data.Version as V
import qualified Data.Prednote.Test as TT
import qualified Data.Prednote.Pdct as Pe
import qualified System.Console.Rainbow as Rb
import qualified System.Console.MultiArg as MA
import System.Locale (defaultTimeLocale)

------------------------------------------------------------
-- Other conveniences
------------------------------------------------------------


-- | A non-terminating list of starting with the first day of the
-- first month following the given day, followed by successive first
-- days of the month.
futureFirstsOfTheMonth :: Time.Day -> [Time.Day]
futureFirstsOfTheMonth d = iterate (Time.addGregorianMonthsClip 1) d1
  where
    d1 = Time.fromGregorian yr mo 1
    (yr, mo, _) = Time.toGregorian $ Time.addGregorianMonthsClip 1 d

------------------------------------------------------------
-- CLI
------------------------------------------------------------

-- | Record holding all data to configure Wheat.
data WheatConf = WheatConf
  { briefDescription :: String
    -- ^ This is displayed at the beginning of the online help. It
    -- should be a one-line description of what this program does--for
    -- example, what it checks for.

  , moreHelp :: [String]
    -- ^ Displayed at the end of the online help. It should be a list
    -- of lines, wich each line not terminated by a newline
    -- character. It is displayed at the end of the online help.

  , tests :: [Time.UTCTime -> TT.Test L.Posting]
    -- ^ The actual tests to run. The UTCTime is the @base time@. Each
    -- test may decide what to do with the base time--for example, the
    -- test might say that all postings have to have a date on or
    -- before that date. Or the test might just ignore the base time.

  , indentAmt :: Pe.IndentAmt
    -- ^ How many spaces to indent each level in a tree of tests.

  , verbosity :: Maybe TT.TestVerbosity
    -- ^ If Just, use this verbosity. If Nothing, use the default
    -- verbosity provided by the tests themselves.

  , testPred :: TT.Name -> Bool
    -- ^ Test names are filtered with this function; a test is only
    -- run if this function returns True.

  , stopOnFail :: Bool
    -- ^ If True, then tests will stop running immediately after a
    -- single test fails. If False, all tests are always run.

  , colorToFile :: Bool
    -- ^ Use colors even if stdout is not a file?

  , baseTime :: Time.UTCTime
    -- ^ Tests may use this date and time as they wish; see
    -- 'tests'. Typically you will set this to the current instant.

  , formatQty :: [Cop.LedgerItem] -> L.Amount L.Qty -> X.Text
  -- ^ How to format quantities

  }

parseBaseTime :: String -> Either MA.InputError Time.UTCTime
parseBaseTime s = case Parsec.parse CP.dateTime  "" (X.pack s) of
  Left e -> Left (MA.ErrorMsg $ "could not parse date: " ++ show e)
  Right g -> return . L.toUTC $ g

parseRegexp :: String -> Either MA.InputError (TT.Name -> Bool)
parseRegexp s = case M.pcre M.Sensitive (X.pack s) of
  Left e -> Left . MA.ErrorMsg $
    "could not parse regular expression: " ++ X.unpack e
  Right m -> return . M.match $ m

allOpts :: [MA.OptSpec (WheatConf -> WheatConf)]
allOpts =
  [ MA.OptSpec ["indentation"] "i"
    (fmap (\i p -> p { indentAmt = i }) (MA.OneArg MA.reader))

  , MA.OptSpec ["test-regexp"] "t"
    (fmap (\f p -> p { testPred = f }) (MA.OneArg parseRegexp))

  , MA.OptSpec ["stop-on-failure"] ""
    ( MA.NoArg (\p -> p { stopOnFail
                          = not (stopOnFail p) }))

  , MA.OptSpec ["color-to-file"] ""
    ( MA.NoArg (\p -> p { colorToFile
                          = not (colorToFile p) }))

  , MA.OptSpec ["base-date"] ""
    (fmap (\d p -> p { baseTime = d }) (MA.OneArg parseBaseTime))
  ]

-- | Applied to the default WheatConf, returns a new WheatConf based
-- on what was parsed from the command line, and a list of strings
-- corresponding to the ledger files provided on the command line.
parseArgs :: V.Version -> WheatConf -> IO (WheatConf, [String])
parseArgs ver c = do
  parsed <- MA.simpleHelpVersion (help c) (Ly.version ver)
            (map (fmap Right) allOpts) MA.Intersperse
            (return . Left)
  let (args, opts) = partitionEithers parsed
      fn = foldl (flip (.)) id opts
      c' = fn c
  return (c', args)


-- | Runs Wheat tests. Prints the result to standard output. Exits
-- unsuccessfully if the user gave bad command line options or if at
-- least a single test failed; exits successfully if all tests
-- succeeded. Shows the version number and exits successfully if that
-- was requested.
main
  :: V.Version
  -- ^ Version of the binary
  -> (S.Runtime -> WheatConf) -> IO ()
main ver getWc = do
  rt <- S.runtime
  (conf, args) <- parseArgs ver (getWc rt)
  term <-
    if colorToFile conf
    then Rb.termFromEnv
    else Rb.smartTermFromEnv IO.stdout
  items <- Cop.open args
  let pstgs = getItems items
      formatter = formatQty conf items
  let tsts = filter ((testPred conf) . TT.testName)
             . map ($ (L.toUTC . S.currentTime $ rt))
             . tests
             $ conf
  bs <- mapM (runTest formatter conf pstgs term) tsts
  if and bs
    then Exit.exitSuccess
    else Exit.exitFailure

-- | Shows the result of a test. Exits with a failure if stopOnFail is
-- set and if the test failed. Otherwise, returns whether the test
-- succeeded or failed.
runTest
  :: (L.Amount L.Qty -> X.Text)
  -> WheatConf
  -> [L.Posting]
  -> Rb.Term
  -> TT.Test L.Posting
  -> IO Bool
runTest fmt c ps term test = do
  let rslt = TT.evalTest test ps
      cks = TT.showResult (indentAmt c) (L.display fmt)
                          (verbosity c) rslt
  Rb.putChunks term cks
  if stopOnFail c && not (TT.resultPass rslt)
    then Exit.exitFailure
    else return (TT.resultPass rslt)

getItems :: [Cop.LedgerItem] -> [L.Posting]
getItems
  = concatMap L.transactionToPostings
  . mapMaybe ( let cn = const Nothing
               in Su.caseS4 Just cn cn cn)

--
-- Tests
--

-- | Passes only if each posting is True.
eachPostingMustBeTrue
  :: TT.Name
  -> Pe.Pdct L.Posting
  -> TT.Test L.Posting
eachPostingMustBeTrue n pd = TT.eachSubjectMustBeTrue pd n

-- | Passes if at least a particular number of postings is True.
atLeastNPostings
  :: Int
  -- ^ The number of postings that must be true for the test to pass
  -> TT.Name
  -> Pe.Pdct L.Posting
  -> TT.Test L.Posting
atLeastNPostings i n pd = TT.nSubjectsMustBeTrue pd n i

--
-- Help
--

help
  :: WheatConf
  -> String
  -- ^ Program name
  -> String
help wc pn = unlines
  [ "usage: " ++ pn ++ " [options] [FILE...]"
  , ""
  , briefDescription wc
  , ""
  , "Options:"
  , "  -i, --indentation AMT"
  , "    Indent each level by this many spaces"
  , "    " ++ dflt (show . indentAmt $ wc)
  , "  -t, --test-regexp REGEXP"
  , "    Run only tests whose name matches the given"
  , "    Perl-compatible regular expression"
  , "    (overrides the compiled-in default)"
  , "  --stop-on-failure"
  , "    Stop running tests after a single test fails"
  , "    " ++ dflt (show . stopOnFail $ wc)
  , "  --color-to-file"
  , "    Use color even when standard output is not a terminal"
  , "    " ++ dflt (show . colorToFile $ wc)
  , "  --base-date DATE"
  , "    Use this date as a basis for checks"
  , "    " ++ dflt ( Time.formatTime defaultTimeLocale "%c"
                     . baseTime $ wc)
  , ""
  ]
  ++ unlines (moreHelp wc)

dflt :: String -> String
dflt s = "(default: " ++ s ++ ")"