1;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2;;
3;; This program is free software; you can redistribute it and/or
4;; modify it under the terms of the GNU General Public License as
5;; published by the Free Software Foundation; either version 2 of
6;; the License, or (at your option) any later version.
7;;
8;; This program is distributed in the hope that it will be useful,
9;; but WITHOUT ANY WARRANTY; without even the implied warranty of
10;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
11;; GNU General Public License for more details.
12;;
13;; You should have received a copy of the GNU General Public License
14;; along with this program; if not, contact:
15;;
16;; Free Software Foundation           Voice:  +1-617-542-5942
17;; 51 Franklin Street, Fifth Floor    Fax:    +1-617-542-2652
18;; Boston, MA  02110-1301,  USA       gnu@gnu.org
19;;
20;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
21
22(define-module (gnucash reports standard ifrs-cost-basis))
23
24(use-modules (srfi srfi-1))
25(use-modules (srfi srfi-9))
26(use-modules (ice-9 match))
27(use-modules (gnucash utilities))
28(use-modules (gnucash report))
29(use-modules (gnucash core-utils))
30(use-modules (gnucash app-utils))
31(use-modules (gnucash engine))
32
33(define disclaimer
34  (gnc:make-html-text
35   (gnc:html-markup-p "This report is designed for cost basis
36accumulation and capital gain/loss reporting using the weighted
37average cost basis method, which is most consistent with typical
38accounting frameworks (US GAAP, IFRS, etc.).  This report allows for
39for the choice to capitalize (most consistent with typical accounting
40frameworks) vs expense (used by some taxing jurisdictions) commissions
41paid on purchase.")
42   (gnc:html-markup-p "This report is not appropriate for FIFO, LIFO, or
43specific-identification methods for cost basis accumulation and
44capital gain/loss reporting.  This report may not be appropriate for
45tax purposes, if the taxing jurisdiction requires a method other than
46the weighted average cost basis method.")
47   (gnc:html-markup-p "This report is not designed with options
48reporting in mind.  If your activity involves options and/or futures
49that are purchased, written, and/or exercised, there is no guarantee
50that this report will accurately portray this options activity.")))
51
52(define reportname "IFRS weighted-average cost basis report")
53
54(define optname-startdate (N_ "Start Date"))
55(define optname-enddate (N_ "End Date"))
56
57(define optname-stock-acct "Stock Account")
58(define optname-proceeds-acct "Proceeds Account")
59(define optname-dividend-acct "Dividend Account")
60(define optname-capgains-acct "Cap Gains Account")
61(define optname-fees-acct "Fees Account")
62(define optname-report-currency "Report's currency")
63
64(define optname-format-cells "Format monetary cells")
65(define opthelp-format-cells "Check this option to show cells with currency")
66
67(define optname-format-short "Alternative row-style for shorts")
68(define opthelp-format-short "Check this option to use alternate style \
69for shorts. Disable to use alternate style every other row")
70
71(define optname-cap-purch-costs "Capitalise purchase commissions")
72(define opthelp-cap-purch-costs "Check this option to capitalise purchase \
73commissions in cumulative average cost and gain/loss after commission")
74
75(define optname-cap-fee-action "Action field filter for fees")
76(define opthelp-cap-fee-action "This string will be used to compare with \
77the split action field to detect capitalized fees on stock activity")
78
79(define (options-generator)
80  (let ((options (gnc:new-options)))
81
82    (define (add-option new-option)
83      (gnc:register-option options new-option))
84
85    (gnc:options-add-date-interval!
86     options gnc:pagename-general optname-startdate optname-enddate " ")
87
88    (gnc:options-add-currency!
89     options gnc:pagename-general optname-report-currency "a")
90
91    (add-option
92     (gnc:make-account-sel-limited-option
93      gnc:pagename-general optname-stock-acct "b" "Stock Account"
94      #f #f (list ACCT-TYPE-STOCK ACCT-TYPE-MUTUAL)))
95
96    (add-option
97     (gnc:make-account-sel-limited-option
98      gnc:pagename-general optname-proceeds-acct "c" "Proceeds Account"
99      #f #f (list ACCT-TYPE-ASSET ACCT-TYPE-BANK)))
100
101    (add-option
102     (gnc:make-account-sel-limited-option
103      gnc:pagename-general optname-dividend-acct "c" "Dividend Account"
104      #f #f (list ACCT-TYPE-INCOME)))
105
106    (add-option
107     (gnc:make-account-sel-limited-option
108      gnc:pagename-general optname-capgains-acct "d" "Cap Gains Account"
109      #f #f (list ACCT-TYPE-INCOME)))
110
111    (add-option
112     (gnc:make-account-sel-limited-option
113      gnc:pagename-general optname-fees-acct "c5" "Fees Account"
114      #f #f (list ACCT-TYPE-EXPENSE)))
115
116    (add-option
117     (gnc:make-string-option
118      gnc:pagename-general optname-cap-fee-action "d5" opthelp-cap-fee-action "Fee"))
119
120    (add-option
121     (gnc:make-simple-boolean-option
122      gnc:pagename-general optname-format-cells "e" opthelp-format-cells #t))
123
124    (add-option
125     (gnc:make-simple-boolean-option
126      gnc:pagename-general optname-format-short "f" opthelp-format-short #t))
127
128    (add-option
129     (gnc:make-simple-boolean-option
130      gnc:pagename-general optname-cap-purch-costs "g" opthelp-cap-purch-costs #t))
131
132    options))
133
134(define M+
135  (case-lambda
136    (() (error "M+ needs at least 1 arg"))
137    ((a b) (if a (if b (+ a b) a) b))
138    ((head . tail) (fold M+ head tail))))
139
140(define M-abs
141  (case-lambda
142    (() (error "M-abs needs 1 arg"))
143    ((a) (and a (abs a)))))
144
145(define M*
146  (case-lambda
147    (() (error "M* needs at least 1 arg"))
148    ((a b) (and a b (* a b)))
149    ((head . tail) (fold M* head tail))))
150
151(define M-
152  (case-lambda
153    (() (error "M- needs at least 1 arg"))
154    ((n) (and n (- n)))
155    ((minuend head . tail) (M+ minuend (M- (fold M+ head tail))))))
156
157(define M/
158  (case-lambda
159    (() (error "M/ needs at least 1 arg"))
160    ((n) (and n (not (zero? n)) (/ n)))
161    ((divisor head . tail) (M* divisor (M/ (fold M* head tail))))))
162
163(define-record-type :txn-info
164  (make-txn-info stock-amt stock-val proceeds-val
165                 fees-cap-val fees-exp-val dividend-val capgains-val)
166  txn-info?
167  (stock-amt get-stock-amt set-stock-amt!)
168  (stock-val get-stock-val set-stock-val!)
169  (proceeds-val get-proceeds-val set-proceeds-val!)
170  (fees-cap-val get-fees-cap-val set-fees-cap-val!)
171  (fees-exp-val get-fees-exp-val set-fees-exp-val!)
172  (dividend-val get-dividend-val set-dividend-val!)
173  (capgains-val get-capgains-val set-capgains-val!))
174
175;; "bitfield" Nabc a=neg b=zero c=pos
176(define (N001 x) (if (number? x) (>  x 0) #f))
177(define (N100 x) (if (number? x) (<  x 0) #f))
178(define (N010 x) (if (number? x) (=  x 0) #t))
179(define (N011 x) (if (number? x) (>= x 0) #t))
180(define (N110 x) (if (number? x) (<= x 0) #t))
181(define (N111 x) #t)
182;; N000 should be (not x) however we can accept a zero-amount split too
183(define (N000 x) (if (number? x) (=  x 0) #t))
184
185;;       --stock-- cash cap  exp  divi capg
186;;       amt  val       fees fees
187
188(define open-types
189  (list
190   (list N001 N001 N100 N011 N000 N000 N000 "Open Long")
191   (list N100 N100 N001 N011 N000 N000 N000 "Open Short")))
192
193(define long-types
194  (list
195   (list N001 N001 N100 N011 N000 N000 N000 "Buy")
196   (list N100 N100 N011 N000 N011 N000 N111 "Sell")
197   (list N000 N000 N001 N000 N011 N100 N000 "Dividend")
198   (list N001 N001 N001 N011 N000 N100 N000 "Dividend reinvestment (w/ remainder)")
199   (list N001 N001 N000 N011 N000 N100 N000 "Dividend reinvestment (w/o remainder)")
200   (list N000 N100 N001 N011 N000 N000 N000 "Return of Capital")
201   (list N000 N001 N000 N000 N011 N100 N000 "Notional distribution")
202   (list N001 N000 N000 N011 N000 N000 N000 "Stock split")
203   (list N100 N000 N000 N011 N000 N000 N000 "Reverse split")
204   (list N100 N100 N001 N000 N011 N000 N111 "Reverse split w/ cash in lieu for fractionals")))
205
206(define short-types
207  (list
208   (list N100 N100 N001 N011 N000 N000 N000 "Short Sell")
209   (list N001 N001 N110 N000 N011 N000 N111 "Cover Buy")
210   (list N000 N000 N100 N000 N011 N001 N000 "Compensatory dividend")
211   (list N000 N000 N000 N011 N000 N000 N000 "Dividend reinvestment (w remainder)")
212   (list N000 N000 N000 N011 N000 N000 N000 "Dividend reinvestment (w/o remainder)")
213   (list N000 N001 N100 N011 N000 N000 N000 "Compensatory return of capital")
214   (list N000 N100 N000 N000 N011 N001 N000 "Compensatory notional distribution")
215   (list N100 N000 N000 N011 N000 N000 N000 "Stock split")
216   (list N001 N000 N000 N011 N000 N000 N000 "Reverse split")
217   (list N001 N001 N100 N000 N011 N000 N111 "Reverse split w/ cash in lieu for fractionals")))
218
219(define (cmp amt neg zero pos)
220  (cond ((< amt 0) neg)
221        ((= amt 0) zero)
222        (else pos)))
223
224(define shown-headers? #f)
225(define (txn-identify trans txn-info cumul-units)
226  (let lp ((types (cmp cumul-units short-types open-types long-types)))
227    (match types
228      (()
229       ;; (gnc:pk (qof-print-date (xaccTransGetDate trans)) txn-info)
230       "Unknown")
231      (((amt-fn val-fn proc-fn fee-cap-fn fee-exp-fn div-fn capg-fn res) . tail)
232       (if (and (amt-fn (get-stock-amt txn-info))
233                (val-fn (get-stock-val txn-info))
234                (proc-fn (get-proceeds-val txn-info))
235                (fee-cap-fn (get-fees-cap-val txn-info))
236                (fee-exp-fn (get-fees-exp-val txn-info))
237                (div-fn (get-dividend-val txn-info))
238                (capg-fn (get-capgains-val txn-info)))
239           res
240           (lp tail))))))
241
242(define (txn->info txn stock-acct cap-fee-action
243                   proceeds-acct capgains-acct expenses-acct dividend-acct)
244  (define (from-acct? acct)
245    (lambda (split)
246      (equal? (xaccSplitGetAccount split) acct)))
247  (define (cap-expenses? split)
248    (and ((from-acct? stock-acct) split)
249         (equal? (gnc-get-action-num txn split) cap-fee-action)))
250  (let lp ((splits (xaccTransGetSplitList txn))
251           (stock-amt #f)
252           (stock-val #f)
253           (proceeds-val #f)
254           (fees-cap-val #f)
255           (fees-exp-val #f)
256           (dividend-val #f)
257           (capgains-val #f))
258    (match splits
259      (() (make-txn-info stock-amt stock-val proceeds-val fees-cap-val
260                         fees-exp-val dividend-val capgains-val))
261
262      (((? (from-acct? proceeds-acct) split) . rest)
263       (lp rest stock-amt stock-val
264           (M+ proceeds-val (xaccSplitGetAmount split))
265           fees-cap-val fees-exp-val dividend-val capgains-val))
266
267      (((? (from-acct? capgains-acct) split) . rest)
268       (lp rest stock-amt stock-val proceeds-val fees-cap-val fees-exp-val dividend-val
269           (M+ capgains-val (xaccSplitGetAmount split))))
270
271      (((? (from-acct? expenses-acct) split) . rest)
272       (lp rest stock-amt stock-val proceeds-val fees-cap-val
273           (M+ fees-exp-val (xaccSplitGetAmount split))
274           dividend-val capgains-val))
275
276      (((? (from-acct? dividend-acct) split) . rest)
277       (lp rest stock-amt stock-val proceeds-val fees-cap-val fees-exp-val
278           (M+ dividend-val (xaccSplitGetAmount split))
279           capgains-val))
280
281      ;; testing capitalized fees must take place *before* processing
282      ;; stock amt/val because it belongs to the stock account.
283      (((? cap-expenses? split) . rest)
284       (lp rest stock-amt stock-val proceeds-val
285           (M+ fees-cap-val (xaccSplitGetValue split))
286           fees-exp-val dividend-val capgains-val))
287
288      (((? (from-acct? stock-acct) split) . rest)
289       (lp rest
290           (M+ stock-amt (xaccSplitGetAmount split))
291           (M+ stock-val (xaccSplitGetValue split))
292           proceeds-val fees-cap-val fees-exp-val dividend-val capgains-val))
293
294      ((_ . rest)
295       (lp rest stock-amt stock-val proceeds-val fees-cap-val fees-exp-val
296           dividend-val capgains-val)))))
297
298(define (ifrs-cost-basis-renderer report-obj)
299  (define (opt-val section name)
300    (gnc:option-value
301     (gnc:lookup-option (gnc:report-options report-obj) section name)))
302
303  (define opt-startdate (opt-val gnc:pagename-general optname-startdate))
304  (define opt-enddate   (opt-val gnc:pagename-general optname-enddate))
305  (define startdate
306    (gnc:time64-start-day-time
307     (gnc:date-option-absolute-time opt-startdate)))
308  (define enddate
309    (gnc:time64-start-day-time
310     (gnc:date-option-absolute-time opt-enddate)))
311  (define stock-acct   (opt-val gnc:pagename-general optname-stock-acct))
312  (define proceeds-acct (opt-val gnc:pagename-general optname-proceeds-acct))
313  (define dividend-acct (opt-val gnc:pagename-general optname-dividend-acct))
314  (define capgains-acct (opt-val gnc:pagename-general optname-capgains-acct))
315  (define fees-acct (opt-val gnc:pagename-general optname-fees-acct))
316  (define report-currency (opt-val gnc:pagename-general optname-report-currency))
317  (define format-cells (opt-val gnc:pagename-general optname-format-cells))
318  (define short-alternate-format? (opt-val gnc:pagename-general optname-format-short))
319  (define cap-purch-costs? (opt-val gnc:pagename-general optname-cap-purch-costs))
320  (define cap-fee-action (opt-val gnc:pagename-general optname-cap-fee-action))
321  (define document (gnc:make-html-document))
322
323  (define large 10000000)
324  (define (get-fx db from to time)
325    (/ (gnc-pricedb-convert-balance-nearest-price-t64 db large from to time)
326       large))
327
328  (define (to-cell elt)
329    (gnc:make-html-table-cell/markup "number-cell" elt))
330
331  (gnc:html-document-set-title! document "IFRS weighted average cost basis Report")
332
333  (cond
334   ((null? stock-acct)
335    (gnc:html-document-add-object!
336     document (gnc:html-make-generic-options-warning
337               reportname (gnc:report-id report-obj))))
338
339   (else
340    (let ((commodity (xaccAccountGetCommodity stock-acct))
341          (currency (gnc-account-get-currency-or-parent stock-acct))
342          (pricedb (gnc-pricedb-get-db (gnc-get-current-book)))
343          (splits
344           (let ((query (qof-query-create-for-splits)))
345             (qof-query-set-book query (gnc-get-current-book))
346             (xaccQueryAddSingleAccountMatch query stock-acct QOF-QUERY-AND)
347             (let ((result (xaccQueryGetSplitsUniqueTrans query)))
348               (qof-query-destroy query)
349               result))))
350
351      (define (to-commodity amt)
352        (if format-cells
353            (and amt (gnc:make-gnc-monetary commodity amt))
354            amt))
355
356      (define (to-orig-currency amt)
357        (if format-cells
358            (and amt (gnc:make-gnc-monetary currency amt))
359            amt))
360
361      (define (to-report-currency amt)
362        (if format-cells
363            (and amt (gnc:make-gnc-monetary report-currency amt))
364            amt))
365
366      (define table (gnc:make-html-table))
367
368      (gnc:html-document-set-title!
369       document
370       (gnc:format "Average-Cost (Basis) Report: From ${startdate} to ${enddate}. Report-currency ${currency}"
371                   'startdate (qof-print-date startdate)
372                   'enddate (qof-print-date enddate)
373                   'currency (gnc-commodity-get-mnemonic report-currency)))
374
375      (gnc:html-table-set-col-headers!
376       table (list "date" "description" "trans-units" "cumul-units" "note"
377                   "curr" "fx" "purchase-val" "purchase-cost" "cash-dividends"
378                   "proceeds-val" "proceeds-cost" "conv-purchase-val"
379                   "conv-purchase-cost" "conv-dividends"
380                   "conv-proceeds-val" "conv-proceeds-cost"
381                   "cumulative-average-cost-basis"
382                   "average-cost-basis/unit-for-sale" "average-cost-basis-of-sale"
383                   "net-proceeds" "gain-post-commission" "gain-pre-commission"
384                   "cumul-gross-profit" "cumul-net-profit" "cumul-tot-return"))
385
386      (let lp ((splits splits)
387               (odd-row? #t)
388               (cumul-units 0)
389               (cumul-average-cost-basis 0)
390               (cumul-gross-profit 0)
391               (cumul-net-profit 0)
392               (cumul-tot-return 0))
393
394        (match splits
395          (() (gnc:html-document-add-object! document table))
396
397          ((split . rest-splits)
398           (let* ((trans (xaccSplitGetParent split))
399                  (txn-info (txn->info trans stock-acct cap-fee-action proceeds-acct
400                                       capgains-acct fees-acct dividend-acct))
401                  (trans-units (get-stock-amt txn-info))
402                  (cash-value (get-proceeds-val txn-info))
403                  (dividends-val (get-dividend-val txn-info))
404                  (capgains-val (get-capgains-val txn-info))
405                  (fees-expense (get-fees-exp-val txn-info))
406                  (fees-value (M+ (get-fees-cap-val txn-info) fees-expense))
407                  (trans-value (M+ (get-stock-val txn-info)
408                                   (get-fees-cap-val txn-info)))
409                  (new-units (M+ cumul-units trans-units))
410
411                  (sale?
412                   (cond
413                    ((< trans-units 0) (<= 0 new-units))
414                    ((> trans-units 0) (<= new-units 0))
415                    (else #f)))
416
417                  (purchase?
418                   (cond
419                    ((= trans-value 0) dividends-val)        ;dividends
420                    ((= trans-units 0) cash-value)           ;return of capital
421                    ((> trans-units 0) (< 0 new-units))      ;regular buy
422                    ((< trans-units 0) (< new-units 0))))    ;buy during short
423
424                  (shorting? (or (< new-units 0)
425                                 (and (= new-units 0) (< 0 trans-units))))
426
427                  (purchase-cost (and purchase? fees-value))
428                  (purchase-val (and purchase? (M- trans-value purchase-cost)))
429                  (cash-dividends (M- dividends-val))
430                  (proceeds-cost (and sale? fees-value))
431                  (proceeds-value (and sale? (M+ cash-value proceeds-cost)))
432
433                  ;; now convert to report-currency
434                  (fx (get-fx pricedb currency report-currency
435                              (time64CanonicalDayTime (xaccTransGetDate trans))))
436                  (conv-purchase-val (M* fx purchase-val))
437                  (conv-purchase-cost (M* fx purchase-cost))
438                  (conv-dividends (M* fx cash-dividends))
439                  (conv-proceeds-value (M* fx proceeds-value))
440                  (conv-proceeds-cost (M* fx proceeds-cost))
441
442                  ;; now perform AVERAGE-COST-BASIS calculations
443                  (average-cost-basis/unit-for-sale
444                   (M-abs (M/ cumul-average-cost-basis cumul-units)))
445                  (average-cost-basis-of-sale
446                   (and proceeds-value (M* average-cost-basis/unit-for-sale
447                                         trans-units)))
448                  (cumul-average-cost-basis
449                   (M+ cumul-average-cost-basis
450                       conv-purchase-val
451                       (and cap-purch-costs? conv-purchase-cost)
452                       average-cost-basis-of-sale))
453
454                  (net-proceeds (M- conv-proceeds-value conv-proceeds-cost))
455                  (gain-post-commission (M+ net-proceeds average-cost-basis-of-sale
456                                            (and (not cap-purch-costs?)
457                                                 conv-purchase-cost)))
458                  (gain-pre-commission (M+ conv-proceeds-value
459                                           average-cost-basis-of-sale))
460
461                  (new-gross-profit (M+ cumul-gross-profit gain-pre-commission))
462                  (new-net-profit (M+ cumul-net-profit gain-post-commission))
463                  (new-tot-return (M+ cumul-tot-return gain-post-commission
464                                      conv-dividends)))
465
466             ;; (gnc:pk trans 'trans-units trans-units 'trans-value trans-value
467             ;;         'cumul-units cumul-units 'proceeds-value proceeds-value
468             ;;         'sale? sale? 'purchase? purchase?)
469             (cond
470              ((not (< startdate (xaccTransGetDate (xaccSplitGetParent (car splits)))
471                       enddate))
472               (lp rest-splits
473                   odd-row?
474                   new-units
475                   cumul-average-cost-basis
476                   new-gross-profit
477                   new-net-profit
478                   new-tot-return))
479
480              (else
481               (gnc:html-table-append-row/markup!
482                table (if short-alternate-format?
483                          (if shorting? "alternate-row" "normal-row")
484                          (if odd-row? "normal-row" "alternate-row"))
485                (list (qof-print-date (xaccTransGetDate trans))
486                      (gnc:html-string-sanitize (xaccTransGetDescription trans))
487                      (to-cell (gnc:html-split-anchor split (to-commodity trans-units)))
488                      (to-cell (to-commodity new-units))
489                      (cond
490                       ((< new-units 0 cumul-units) "ERROR: long→short")
491                       ((< cumul-units 0 new-units) "ERROR: short→long")
492                       (else (txn-identify trans txn-info cumul-units)))
493                      (gnc-commodity-get-mnemonic currency)
494                      (to-cell (gnc:default-price-renderer report-currency fx))
495                      (to-cell (to-orig-currency purchase-val))
496                      (to-cell (to-orig-currency purchase-cost))
497                      (to-cell (to-orig-currency cash-dividends))
498                      (to-cell (to-orig-currency proceeds-value))
499                      (to-cell (to-orig-currency proceeds-cost))
500                      (to-cell (to-report-currency conv-purchase-val))
501                      (to-cell (to-report-currency conv-purchase-cost))
502                      (to-cell (to-report-currency conv-dividends))
503                      (to-cell (to-report-currency conv-proceeds-value))
504                      (to-cell (to-report-currency conv-proceeds-cost))
505                      (to-cell (to-report-currency cumul-average-cost-basis))
506                      (to-cell (to-report-currency average-cost-basis/unit-for-sale))
507                      (to-cell (to-report-currency (M- average-cost-basis-of-sale)))
508                      (to-cell (to-report-currency net-proceeds))
509                      (to-cell (to-report-currency gain-post-commission))
510                      (to-cell (to-report-currency gain-pre-commission))
511                      (to-cell (to-report-currency new-gross-profit))
512                      (to-cell (to-report-currency new-net-profit))
513                      (to-cell (to-report-currency new-tot-return))))
514
515               (lp rest-splits
516                   (not odd-row?)
517                   new-units
518                   cumul-average-cost-basis
519                   new-gross-profit
520                   new-net-profit
521                   new-tot-return))))))))))
522
523  ;; (gnc:dump-all-transactions)
524  (gnc:html-document-add-object! document disclaimer)
525  document)
526
527
528;; Here we define the actual report
529(gnc:define-report
530 'version 1
531 'name reportname
532 'report-guid "15d5b744176c4625a703720338725291"
533 'menu-path (list gnc:menuname-experimental)
534 'options-generator options-generator
535 'renderer ifrs-cost-basis-renderer)
536