REBOL [
    Title: "Software engineering: design by contract"
    Date: 18-May-2001/9:21:57+2:00
    Version: 1.0.1
    File: %contract.r
    Author: "Maarten Koopmans"
    Purpose: "Facilitates design by contract"
    Email: m.koopmans2@chello.nl
    library: [
        level: 'advanced 
        platform: 'all 
        type: [Tool module] 
        domain: [UI user-interface] 
        tested-under: none 
        support: none 
        license: none 
        see-also: none
    ]
]



system/error/user: make system/error/user [ pre-error: [ "The precondition " :arg1 " was not met" ]  ]
system/error/user: make system/error/user [ post-error: [ "The postcondition " :arg1 " was not met" ]  ]


block-all: func [ { Block variant on all.  Evaluates al netsed blocks as conditions.} a [any-block!]][

    ;Are we @ the tail? Then we have evaluated all the conditions succesfully. Return true.
    either tail? a
    ; We are at the end of the conditions, return true
    [ return true]
    [
      ; Is the block empty or does it contain none
      either any [ empty? first a none? first first a]
      [
        ;yes, skip and do the next condition
        block-all next a
      ]
      [
        ;Continue... we have a valid condition
        ;If the first condition is true, recursively call block-all on the next
        either do first a
        [ block-all next a]
        [return false]
      ];either any
    ]
]

find-false: func [ {Finds the first false block in a block of blocks and return at the start of it.}  a [any-block!] ]
                 [
                   ;Initialize. Skip all empty and none! conditions
                   ;until [ either any [ empty? first a none? first first a]  [a: next a ] [true ] ]
                   while [all [(not tail? a) (do first a)] ]
                   [
                     ;go to the next element and skip empty ones and ones of type none!
                     until [ either any [ empty? first a none? first first a]  [a: next a false] [a: next a true ] ]
                   ]
                   return  copy a
                 ]

contract: func [ {Contracts are functions that support pre and post conditions, aka design by contract.
                                    Note that your code should return a value (at least none) for this to work.}
                 args [any-block!] {Function arguments.}
                 conditions [any-block!] { conditions in the format: [ pre [ [cond1] [cond2]] post [[cond3] ..]}
                 locals [any-block!] {Local variables to the function.}
                 body [any-block!] {The body of the function, should ALWAYS return a value (at least none).}
                 /local pre-cond post-cond pre-code post-code func-args func-body
                                    cond-block do-func inner-func do-body
               ]
               [
                 pre-code: copy []
                 post-code: copy []

                 ;Find the pre conditions
                 pre-cond: select conditions 'pre
                 if (not none? pre-cond)
                 [
                    ;Pre-code is the code for the precondition.
                    pre-code: copy compose/deep [ if not block-all compose/deep [(pre-cond)]]
                    ;Append some code. We need to split the compose because we use a compose again in the resulting code :)
                    append cond-block: copy compose/deep [ cond: mold first find-false compose/deep [(pre-cond)]] [ make error! compose [ user pre-error (cond)]]
                    ;And append the cond-block to pre-code. Now we have our pre-code ready.
                    append/only pre-code cond-block
                 ]

                 post-cond: select conditions 'post
                 ;Find the pre conditions
                 if (not none? post-cond)
                 [
                    ;Pre-code is the code for the precondition.
                    post-code: copy compose/deep [ if not block-all compose/deep [(post-cond)]]
                    ;Append and compose some code. We need to split the compose because we use a compose again in the resulting code :)
                    append cond-block: copy compose/deep [ cond: mold first find-false compose/deep [(post-cond)]] [ make error! compose [ user post-error (cond)]]
                    ;And append the cond-block to pre-code. Now we have our pre-code ready.
                    append/only post-code cond-block
                 ]

                                 ;Append the local variables to the argument block
                 append func-args: copy args /local
                                 append func-args [ __return __ret_err]
                                 append func-args locals

                                 ;if the body is empty, make sure it returns none
                                 if body = []
                                 [
                                    body: copy [ none ]
                                 ]

                                 ;We evaluate the body as an anonymous function with access to all or locals
                                 do-body:  copy compose/deep [ __innerfunc: func [] [(:body)]]


                 ; Change the function body to include the conditions
                                 func-body: copy []
                                 ; we at least return none
                                 insert func-body copy [ __return: none ]
                                 append func-body copy pre-code
                                 append func-body do-body
                                 append func-body copy [ __return: __innerfunc ]
                 append func-body copy post-code
                                 append func-body copy [ __return ]

                 ;Create and return the function
                 return func func-args func-body

               ]