complete type annotations
This commit is contained in:
parent
fdb1c05985
commit
894f62384e
30
parking.scm
30
parking.scm
@ -1,13 +1,21 @@
|
|||||||
;;;; A program to print out the current real-time status of the computer parking terminal equipped
|
;;;; A program to print out the current real-time status of the computer parking terminal equipped
|
||||||
;;;; parking garages in the city of Linköping using the municipal open data API.
|
;;;; parking garages in the city of Linköping using the municipal open data API.
|
||||||
|
|
||||||
(import medea)
|
|
||||||
(import http-client)
|
(import http-client)
|
||||||
(import srfi-1)
|
(import srfi-1)
|
||||||
(import (chicken io))
|
(import (chicken io))
|
||||||
(import srfi-13)
|
(import srfi-13)
|
||||||
(import srfi-14)
|
(import srfi-14)
|
||||||
(import (chicken condition))
|
(import (chicken condition))
|
||||||
|
(import medea)
|
||||||
|
|
||||||
|
;; We want members to be parsed as lowercase symbols, and arrays to be parsed as lists.
|
||||||
|
;; This is not a legal way to parse json, which requires case-sensitive members
|
||||||
|
;; but makes for neater scheme code.
|
||||||
|
(json-parsers (append `((member . ,(lambda (k v)
|
||||||
|
(cons (string->symbol (string-downcase k)) v)))
|
||||||
|
(array . ,identity)
|
||||||
|
(null . ,(constantly '()))) (json-parsers)))
|
||||||
|
|
||||||
(: curry (procedure * --> procedure))
|
(: curry (procedure * --> procedure))
|
||||||
(define (curry fn a)
|
(define (curry fn a)
|
||||||
@ -23,7 +31,7 @@
|
|||||||
(define (perhaps fn a)
|
(define (perhaps fn a)
|
||||||
(if a (fn a) a))
|
(if a (fn a) a))
|
||||||
|
|
||||||
(: upon ((* -> boolean) procedure * -> *))
|
(: upon (('a -> boolean) ('a -> 'b) 'a -> (or 'a 'b)))
|
||||||
(define (upon pred? fn a)
|
(define (upon pred? fn a)
|
||||||
(if (pred? a) (fn a) a))
|
(if (pred? a) (fn a) a))
|
||||||
|
|
||||||
@ -86,7 +94,14 @@
|
|||||||
(apply string-append
|
(apply string-append
|
||||||
(map (curry2 upon symbol? (compose ->string (curry (flip value) ln))) statement)))
|
(map (curry2 upon symbol? (compose ->string (curry (flip value) ln))) statement)))
|
||||||
|
|
||||||
|
(define-type json *)
|
||||||
|
(define-type json
|
||||||
|
(or string boolean number float null
|
||||||
|
(list-of json)
|
||||||
|
(list-of (pair symbol json))))
|
||||||
|
|
||||||
;;; Get data from a uri and parse it as json.
|
;;; Get data from a uri and parse it as json.
|
||||||
|
(: simple-json-request (string -> json))
|
||||||
(define (simple-json-request uri)
|
(define (simple-json-request uri)
|
||||||
(condition-case (with-input-from-request uri #f read-json)
|
(condition-case (with-input-from-request uri #f read-json)
|
||||||
((exn i/o net) (begin (display-newline "Connection failed.")
|
((exn i/o net) (begin (display-newline "Connection failed.")
|
||||||
@ -105,30 +120,29 @@
|
|||||||
;;; it returns nothing. This bug may be platform related; as of this writing the server system providing the API
|
;;; it returns nothing. This bug may be platform related; as of this writing the server system providing the API
|
||||||
;;; runs on Windows Server 2016 via IIS 10.0.
|
;;; runs on Windows Server 2016 via IIS 10.0.
|
||||||
;;; The second bug involves returning only partial data upon request - no pattern to this bug has been observed.
|
;;; The second bug involves returning only partial data upon request - no pattern to this bug has been observed.
|
||||||
|
(: get-parking-lots (-> json))
|
||||||
(define (get-parking-lots)
|
(define (get-parking-lots)
|
||||||
(value 'parkingareanewlist
|
(value 'parkingareanewlist
|
||||||
(simple-json-request (string-append "http://parkering.linkoping.se/Parkeringsdata/ParkeringsdataV1.svc/GetParkeringsYtaList/" parking-key "/0"))))
|
(simple-json-request (string-append "http://parkering.linkoping.se/Parkeringsdata/ParkeringsdataV1.svc/GetParkeringsYtaList/" parking-key "/0"))))
|
||||||
|
|
||||||
;;; Only lots tracked by parking lot computer terminals have the parkingspacesavailable key.
|
;;; Only lots tracked by parking lot computer terminals have the parkingspacesavailable key.
|
||||||
|
(: computerized (json --> boolean))
|
||||||
(define (computerized? lot)
|
(define (computerized? lot)
|
||||||
(has-key? 'parkingspacesavailable lot))
|
(has-key? 'parkingspacesavailable lot))
|
||||||
|
|
||||||
;;; The handicap lots are tracked as separate lots with duplicate names in the data set.
|
;;; The handicap lots are tracked as separate lots with duplicate names in the data set.
|
||||||
|
(: only-has-handicap-spots? (json --> boolean))
|
||||||
(define (only-has-handicap-spots? lot)
|
(define (only-has-handicap-spots? lot)
|
||||||
(equal? '(4) (value 'parkingtypes lot)))
|
(equal? '(4) (value 'parkingtypes lot)))
|
||||||
|
|
||||||
;;; Electric car lots have a separate lot type, and the downtown parking garages have spaces with charging stations
|
;;; Electric car lots have a separate lot type, and the downtown parking garages have spaces with charging stations
|
||||||
;;; but they are not implemented in the data set.
|
;;; but they are not implemented in the data set.
|
||||||
|
(: electric-car-lot? (json --> boolean))
|
||||||
(define (electric-car-lot? lot)
|
(define (electric-car-lot? lot)
|
||||||
(member? 3 (value 'parkingtypes lot)))
|
(member? 3 (value 'parkingtypes lot)))
|
||||||
|
|
||||||
|
(: main (-> undefined))
|
||||||
(define (main)
|
(define (main)
|
||||||
;; We want members to be parsed as lowercase symbols, and arrays to be parsed as lists.
|
|
||||||
;; This is not a legal way to parse json, which requires case-sensitive members
|
|
||||||
;; but makes for neater scheme code.
|
|
||||||
(json-parsers (append `((member . ,(lambda (k v)
|
|
||||||
(cons (string->symbol (string-downcase k)) v)))
|
|
||||||
(array . ,identity)) (json-parsers)))
|
|
||||||
(display-newline "Parking spaces available:")
|
(display-newline "Parking spaces available:")
|
||||||
(map (compose display-newline (curry format-assoc '(name ": " parkingspacesavailable "/" parkingspaces)))
|
(map (compose display-newline (curry format-assoc '(name ": " parkingspacesavailable "/" parkingspaces)))
|
||||||
(sort-via string-ci<? (curry value 'name)
|
(sort-via string-ci<? (curry value 'name)
|
||||||
|
Loading…
Reference in New Issue
Block a user