www

Unnamed repository; edit this file 'description' to name the repository.
Log | Files | Refs | README

monad.mlish (3355B)

      1 #lang s-exp "../../../mlish.rkt"
      2 (require "../../rackunit-typechecking.rkt")
      3 
      4 (define-type (Option A)
      5   [None]
      6   [Some A])
      7 
      8 ;; -----------------------------------------------------------------------------
      9 
     10 (define-type (List a)
     11   [Nil]
     12   [∷ a (List a)])
     13 
     14 (define (foldl [f : (→ A B A)] [acc : A] [x* : (List B)] → A)
     15   (match x* with
     16    [Nil -> acc]
     17    [∷ h t -> (foldl f (f acc h) t)]))
     18 
     19 (define (reverse [x* : (List A)] → (List A))
     20   (foldl (λ ([acc : (List A)] [x : A]) (∷ x acc)) Nil x*))
     21 
     22 ;; =============================================================================
     23 ;; === BatchedQueue
     24 
     25 (define-type (BatchedQueue A)
     26   [BQ (List A) (List A)])
     27 
     28 (define (bq-check [f : (List A)] [r : (List A)] → (BatchedQueue A))
     29   (match f with
     30    [Nil -> (BQ (reverse r) Nil)]
     31    [∷ h t -> (BQ f r)]))
     32 
     33 (define (bq-empty → (BatchedQueue A))
     34   (BQ Nil Nil))
     35 
     36 (define (bq-isEmpty [bq : (BatchedQueue A)] → Bool)
     37   (match bq with
     38    [BQ f r ->
     39     (match f with
     40      [Nil -> #t]
     41      [∷ h t -> #f])]))
     42 
     43 (define (bq-snoc [bq : (BatchedQueue A)] [x : A] → (BatchedQueue A))
     44   (match bq with
     45    [BQ f r -> (bq-check f (∷ x r))]))
     46 
     47 (define (bq-head [bq : (BatchedQueue A)] → (Option A))
     48   (match bq with
     49    [BQ f r ->
     50     (match f with
     51      [Nil -> None]
     52      [∷ h t -> (Some h)])]))
     53 
     54 (define (bq-tail [bq : (BatchedQueue A)] → (Option (BatchedQueue A)))
     55   (match bq with
     56    [BQ f* r* ->
     57     (match f* with
     58      [Nil -> None]
     59      [∷ x f* ->
     60       (Some (bq-check f* r*))])]))
     61 
     62 (define (list->bq [x* : (List A)] → (BatchedQueue A))
     63   (foldl
     64     (λ ([q : (BatchedQueue A)] [x : A]) (bq-snoc q x))
     65     (bq-empty) x*))
     66 
     67 ;; -----------------------------------------------------------------------------
     68 
     69 (define digit*
     70   (∷ 1 (∷ 2 (∷ 3 (∷ 4 (∷ 5 (∷ 6 (∷ 7 (∷ 8 (∷ 9 Nil))))))))))
     71 
     72 (check-type digit* : (List Int))
     73 
     74 (define sample-bq
     75   (list->bq digit*))
     76 
     77 (check-type sample-bq : (BatchedQueue Int))
     78 
     79 (check-type (Some sample-bq) : (Option (BatchedQueue Int)))
     80 
     81 (define (>> [f : (→ A (Option B))] [x : (Option A)] → (Option B))
     82   (match x with
     83    [None -> None]
     84    [Some y -> (f y)]))
     85 
     86 (check-type >> : (→/test (→ X (Option Y)) (Option X) (Option Y)))
     87 
     88 (check-type (bq-tail sample-bq) : (Option (BatchedQueue Int)))
     89 
     90 ;; can't pass polymorphic fn? need to inst first
     91 (check-type (>> (inst bq-tail Int) (Some sample-bq)) 
     92   : (Option (BatchedQueue Int)))
     93 
     94 ;(ann (>> bq-tail (Some sample-bq)) : (Option (BatchedQueue Int)))
     95 
     96 (define intbq-tail (inst bq-tail Int))
     97 
     98 (check-type intbq-tail : 
     99             (→/test (BatchedQueue Int) (Option (BatchedQueue Int))))
    100 
    101 (check-type (>> intbq-tail (Some sample-bq)) 
    102   : (Option (BatchedQueue Int)))
    103 
    104 (check-type (inst bq-head Int) : (→/test (BatchedQueue Int) (Option Int)))
    105 
    106 (define bq-tails-result
    107   (>> intbq-tail (>> intbq-tail (>> intbq-tail (Some sample-bq)))))
    108 
    109 (check-type bq-tails-result : (Option (BatchedQueue Int))
    110   ⇒ (Some (BQ (∷ 4 (∷ 5 (∷ 6 (∷ 7 (∷ 8 (∷ 9 Nil)))))) Nil)))
    111 
    112 (check-type (>> (inst bq-head Int) bq-tails-result) : (Option Int) -> (Some 4))
    113 
    114 ;; check match2 nested datatype bug
    115 (check-type
    116     (match bq-tails-result with
    117      [None -> None]
    118      [Some bq -> (bq-head bq)]) : (Option Int) -> (Some 4))
    119 (check-type
    120     (match2 bq-tails-result with
    121      [None -> None]
    122      [Some bq -> (bq-head bq)]) : (Option Int) -> (Some 4))