#lang scheme

(require "monadic-parser.ss")
(provide parse-dta DTAparse Aparse Cparse Eparse Cps DTAs)

; --- Data types ---------------------------------------------------------------------------------------------------------------
(define inspector (make-inspector))

; A physical DTA file can be composed of several logical files. It is represented as a list of structures representing the logical files. 

; A DTA logical file is represented as a structure of 3 parts: part A, one or more instances of part C, and part E.
(define-struct DTA (A Cs E) #:inspector inspector)

; Parts A, C and E are represented by structures containing the relevant fields.
; In addition to simple field members, part C contains a list of structures C-ext, which can be of length 0-n.
(define-struct A (type receiverblz receivername date receiveraccountno) #:inspector inspector)
(define-struct C (transactionBLZ custaccountno key keyext originatorBLZ originatoraccountno amount customername originatorname reasonfortransfer currency extensions) #:inspector inspector)
(define-struct C-ext (exttype exttext) #:inspector inspector)
(define-struct E (noCs sumAccNo sumBLZ sumEUR) #:inspector inspector)


; --- High-granularity parsers used in parsing the different parts -------------------------------------------------------------
; Parsers for part C.
(define size (skip1 (repeat digit 4)))
(define part (skip1 (oneof (char #\A) (char #\C) (char #\E))))
(define firstinvolvedBLZ (skip1 (repeat digit 8)))
(define transactionBLZ (repeat digit 8))
(define custaccountno (repeat digit 10))
(define internal1 (skip digit 13))
(define key (repeat digit 2))
(define keyext (repeat digit 3))
(define reserved1 (skip digit 11))
(define originatorBLZ (repeat digit 8))
(define originatoraccountno (repeat digit 10))
(define amount (repeat digit 11))
(define customername (repeat character 27))
(define maybenewline (many (skip1 newln)))
(define originatorname (repeat character 27))
(define reasonfortransfer (repeat character 27))
(define currency digit)
(define extensionscount (repeat digit 2))
(define exttype (repeat digit 2))
(define exttext (seq (repeat character 27) (skip1 (many space))))
(define extension (bind exttype
                        (lambda (type) (bind exttext
                                             (lambda (txt) (return (make-C-ext type txt)))))))
(define extensions
  (bind extensionscount
        (lambda (extno)(combine-list (build-list (string->number extno) (lambda (dummy) extension))))))

; Parsers for part A.
(define type (oneof (string "LK") (string "GK") (string "LB") (string "GB")))
(define receiverblz (repeat digit 8))
(define zeros (skip (char #\0) 8))
(define receivername (repeat character 27))
(define date (repeat digit 6))
(define receiveraccountno (repeat digit 10))
(define refno (skip character 10))
(define currency-A (skip1 digit))

; Parsers for part E.
(define noCs (repeat digit 7))
(define sumDM (skip1 (repeat digit 13)))
(define sumAccNo (repeat digit 17))
(define sumBLZ (repeat digit 17))
(define sumEUR (repeat digit 13))


; --- Lower-granularity parsers parsing the A, C and E parts, in the same time constructing the data structures ----------------

(define Cparse (bind (combine-list (list size part firstinvolvedBLZ transactionBLZ custaccountno internal1 key keyext (blank 1) reserved1 originatorBLZ originatoraccountno amount (blank 3) customername (blank 8) maybenewline originatorname reasonfortransfer currency (blank 2) extensions))
                (lambda (lst) (return (apply make-C lst)))))
                
(define Cps (combine-list-many1 Cparse))

(define Aparse (bind (combine-list (list size part type receiverblz zeros receivername date (blank 4) receiveraccountno refno (blank 47) currency-A))
                (lambda (lst) (return (apply make-A lst)))))

(define Eparse (bind (combine-list (list size part (blank 5) noCs sumDM sumAccNo sumBLZ sumEUR (blank 51)))
                (lambda (lst) (return (apply make-E lst)))))


; --- Lowest-granularity parsers building the DTA structure and the list of DTAs, in the same time verifying the checksums given in part E ----------------
(define DTAparse (bind Aparse
                  (lambda (x) (bind Cps
                                    (lambda (y) (bind Eparse
                                                      (lambda (z) (return (if (sums-correct? y z)(make-DTA x y z) (error "Checksums not correct, aborting."))))))))))
(define DTAs (combine-list-many1 DTAparse))

(define sums-correct?
  (lambda (cs e)
    (and (= (length cs) (string->number (E-noCs e)))
         (= (string->number (E-sumAccNo e)) (foldl + 0 (map (compose string->number C-custaccountno) cs)))
         (= (string->number (E-sumBLZ e)) (foldl + 0 (map (compose string->number C-originatorBLZ) cs)))
         (= (string->number (E-sumEUR e)) (foldl + 0 (map (compose string->number C-amount) cs))))))
  


; --- Main program -------------------------------------------------------------------------------------------------------------
(define parse-dta
  (lambda (infile)
    (let* ((res (car (DTAs (file->string infile))))
           (value (parse-result-item-value res))
           (remaining (parse-result-item-remaining res)))
      (if (not (= 0 (string-length remaining)))
          (error "DTA parse incomplete, aborting.")
          (map print-dta value)))))

(define print-dta
  (lambda (dta)
    (with-output-to-file (get-output-file-name (DTA-A dta))
      (lambda () (map print-C (DTA-Cs dta))) #:exists 'truncate)))

(define get-output-file-name
  (lambda (astruct)
    (string-append (A-type astruct) "_" (A-date astruct) ".txt")))

(define row-separator #\newline)
(define column-separator "|")

(define print-C
  (lambda (cstruct)
    (let-values (((cmain-vec cext-vec) (vector-split-at-right (struct->vector cstruct) 1)))
      (let ((cmain-list (cdr (vector->list cmain-vec)))
            (cext-list (map (lambda (ext) (string-append (C-ext-exttype ext) ":" (C-ext-exttext ext))) (vector-ref cext-vec 0))))
        (let ((list-with-seps (insert-between (append cmain-list cext-list) column-separator)))
          (map (lambda (item) (printf "~a" item)) list-with-seps)
          (printf "~a" row-separator))))))

(define insert-between
  (lambda (lst item)
    (cond ((null? lst) '())
          ((null? (cdr lst)) (cons (first lst) (insert-between (rest lst) item)))
          (else (cons (first lst) (cons item (insert-between (rest lst) item)))))))


(define remove-newlines
  (lambda (infile outfile)
    (with-input-from-file infile
      (lambda ()
        (with-output-to-file outfile #:exists 'replace
          (lambda ()
            (let loop ((line (read-line)))
              (if (eof-object? line)
                  #t
                  (begin (display line) (loop (read-line)))))))))))