use-modules
  goblins
  goblins actor-lib methods
  ice-9 match

;; Cells (used later)
;; ==================

;; to make the next one prettier
define (return x)
  x

define (^cell bcom val)
  methods
    (get)
      return val
    (set new-val)
      bcom : ^cell bcom new-val


;; Blogpost rendering utilities
;; ============================

define (render-post-content post-content)
  match post-content
    ('*post* post-title post-author post-body)
      let* ((title (or post-title "<<No Title>>"))
            (title-underline (make-string (string-length title) #\=))
            (author (or post-author "<<Anonymous>>"))
            (body (or post-body "<<Empty blogpost!>>")))
        format #f "~a\n~a\n  By: ~a\n\n~a\n"
               . title title-underline author body

define (render-blog-header blog-title)
  define title-stars
    make-string
      + 6 (string-length blog-title)
      . #\*
  format #f "~a\n** ~a **\n~a\n"
         . title-stars blog-title title-stars

define (display-post-content post-content)
  display
    render-post-content post-content

define (display-blog-header blog-title)
  display
    render-blog-header blog-title

define (display-post post)
  display "\n"
  display-post-content
    $ post 'get-content
  display "\n"

define (display-blog blog)
  display-blog-header
    $ blog 'get-title
  for-each display-post
    $ blog 'get-posts


;; Blogpost main code
;; ==================

define* (spawn-post-and-editor #:key title author body)
  ;; The public blogpost
  define (^post _bcom)
    methods
      (get-content)
        cons '*post*
          $ editor 'get-data

  ;; The editing interface
  define (^editor bcom)
    let update-beh ((title title) (author author) (body body))
      methods
        (update #:key (title title) (author author) (body body))
          bcom : update-beh title author body
        (get-data)
          list title author body

  ;; spawn and return the post and editor
  define post : spawn ^post
  define editor : spawn ^editor
  values post editor


;; Blog main code
;; ==============

define (spawn-blog-and-admin title)
  define posts
    spawn ^cell '()

  define (^blog _bcom)
    methods
      (get-title)
        return title
      (get-posts)
        return : $ posts 'get

  define (^admin bcom)
    methods
      (add-post post)
        define current-posts
          $ posts 'get
        define new-posts
          cons post current-posts
        $ posts 'set new-posts

  define blog : spawn ^blog
  define admin : spawn ^admin
  values blog admin


;;; Guest post with review
;;; ======================

;; The restricted-editor user can only change the title and body, but
;; not their name.
;; They cannot conspire with their teacher to be someone else on the
;; newspaper.
;;
;; The teacher cannot do anything but approve the student's post to
;; go live.  They cannot change the student's choice of language,
;; only ask them to change it before approval.

define (spawn-post-guest-editor-and-reviewer author blog-admin)
  define-values (post editor)
    spawn-post-and-editor #:author author

  define submitted-already?
    spawn ^cell #f

  define (ensure-not-submitted)
    when : $ submitted-already? 'get
      error "Already submitted!"

  define (^reviewer _bcom)
    methods
      (approve)
        ensure-not-submitted
        $ blog-admin 'add-post post
        $ submitted-already? 'set #t

  define (^restricted-editor _bcom)
    methods
      (set-title new-title)
        ensure-not-submitted
        $ editor 'update #:title new-title
      (set-body new-body)
        ensure-not-submitted
        $ editor 'update #:body new-body

  define reviewer : spawn ^reviewer
  define restricted-editor : spawn ^restricted-editor
  values post restricted-editor reviewer