monads.scm 20 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588
  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2013, 2014, 2015, 2017 Ludovic Courtès <ludo@gnu.org>
  3. ;;;
  4. ;;; This file is part of GNU Guix.
  5. ;;;
  6. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  7. ;;; under the terms of the GNU General Public License as published by
  8. ;;; the Free Software Foundation; either version 3 of the License, or (at
  9. ;;; your option) any later version.
  10. ;;;
  11. ;;; GNU Guix is distributed in the hope that it will be useful, but
  12. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  14. ;;; GNU General Public License for more details.
  15. ;;;
  16. ;;; You should have received a copy of the GNU General Public License
  17. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  18. (define-module (guix monads)
  19. #:use-module ((system syntax)
  20. #:select (syntax-local-binding))
  21. #:use-module (ice-9 match)
  22. #:use-module (srfi srfi-1)
  23. #:use-module (srfi srfi-9)
  24. #:use-module (srfi srfi-26)
  25. #:export (;; Monads.
  26. define-monad
  27. monad?
  28. monad-bind
  29. monad-return
  30. template-directory
  31. ;; Syntax.
  32. >>=
  33. return
  34. with-monad
  35. mlet
  36. mlet*
  37. mbegin
  38. mwhen
  39. munless
  40. lift0 lift1 lift2 lift3 lift4 lift5 lift6 lift7 lift
  41. listm
  42. foldm
  43. mapm
  44. sequence
  45. anym
  46. ;; Concrete monads.
  47. %identity-monad
  48. %state-monad
  49. state-return
  50. state-bind
  51. current-state
  52. set-current-state
  53. state-push
  54. state-pop
  55. run-with-state))
  56. ;;; Commentary:
  57. ;;;
  58. ;;; This module implements the general mechanism of monads, and provides in
  59. ;;; particular an instance of the "state" monad. The API was inspired by that
  60. ;;; of Racket's "better-monads" module (see
  61. ;;; <http://planet.racket-lang.org/package-source/toups/functional.plt/1/1/planet-docs/better-monads-guide/index.html>).
  62. ;;; The implementation and use case were influenced by Oleg Kysielov's
  63. ;;; "Monadic Programming in Scheme" (see
  64. ;;; <http://okmij.org/ftp/Scheme/monad-in-Scheme.html>).
  65. ;;;
  66. ;;; Code:
  67. ;; Record type for monads manipulated at run time.
  68. (define-record-type <monad>
  69. (make-monad bind return)
  70. monad?
  71. (bind monad-bind)
  72. (return monad-return)) ; TODO: Add 'plus' and 'zero'
  73. (define-syntax define-monad
  74. (lambda (s)
  75. "Define the monad under NAME, with the given bind and return methods."
  76. (define prefix (string->symbol "% "))
  77. (define (make-rtd-name name)
  78. (datum->syntax name
  79. (symbol-append prefix (syntax->datum name) '-rtd)))
  80. (syntax-case s (bind return)
  81. ((_ name (bind b) (return r))
  82. (with-syntax ((rtd (make-rtd-name #'name)))
  83. #`(begin
  84. (define rtd
  85. ;; The record type, for use at run time.
  86. (make-monad b r))
  87. ;; Instantiate all the templates, specialized for this monad.
  88. (template-directory instantiations name)
  89. (define-syntax name
  90. ;; An "inlined record", for use at expansion time. The goal is
  91. ;; to allow 'bind' and 'return' to be resolved at expansion
  92. ;; time, in the common case where the monad is accessed
  93. ;; directly as NAME.
  94. (lambda (s)
  95. (syntax-case s (%bind %return)
  96. ((_ %bind) #'b)
  97. ((_ %return) #'r)
  98. (_ #'rtd))))))))))
  99. ;; Expansion- and run-time state of the template directory. This needs to be
  100. ;; available at run time (and not just at expansion time) so we can
  101. ;; instantiate templates defined in other modules, or use instances defined
  102. ;; elsewhere.
  103. (eval-when (load expand eval)
  104. ;; Mapping of syntax objects denoting the template to a pair containing (1)
  105. ;; the syntax object of the parameter over which it is templated, and (2)
  106. ;; the syntax of its body.
  107. (define-once %templates (make-hash-table))
  108. (define (register-template! name param body)
  109. (hash-set! %templates name (cons param body)))
  110. ;; List of template instances, where each entry is a triplet containing the
  111. ;; syntax of the name, the actual parameter for which the template is
  112. ;; specialized, and the syntax object referring to this specialization (the
  113. ;; procedure's identifier.)
  114. (define-once %template-instances '())
  115. (define (register-template-instance! name actual instance)
  116. (set! %template-instances
  117. (cons (list name actual instance) %template-instances))))
  118. (define-syntax template-directory
  119. (lambda (s)
  120. "This is a \"stateful macro\" to register and lookup templates and
  121. template instances."
  122. (define location
  123. (syntax-source s))
  124. (define current-info-port
  125. ;; Port for debugging info.
  126. (const (%make-void-port "w")))
  127. (define location-string
  128. (format #f "~a:~a:~a"
  129. (assq-ref location 'filename)
  130. (and=> (assq-ref location 'line) 1+)
  131. (assq-ref location 'column)))
  132. (define (matching-instance? name actual)
  133. (match-lambda
  134. ((name* instance-param proc)
  135. (and (free-identifier=? name name*)
  136. (or (equal? actual instance-param)
  137. (and (identifier? actual)
  138. (identifier? instance-param)
  139. (free-identifier=? instance-param
  140. actual)))
  141. proc))))
  142. (define (instance-identifier name actual)
  143. (define stem
  144. (string-append
  145. " "
  146. (symbol->string (syntax->datum name))
  147. (if (identifier? actual)
  148. (string-append " " (symbol->string (syntax->datum actual)))
  149. "")
  150. " instance"))
  151. (datum->syntax actual (string->symbol stem)))
  152. (define (instance-definition name template actual)
  153. (match template
  154. ((formal . body)
  155. (let ((instance (instance-identifier name actual)))
  156. (format (current-info-port)
  157. "~a: info: specializing '~a' for '~a' as '~a'~%"
  158. location-string
  159. (syntax->datum name) (syntax->datum actual)
  160. (syntax->datum instance))
  161. (register-template-instance! name actual instance)
  162. #`(begin
  163. (define #,instance
  164. (let-syntax ((#,formal (identifier-syntax #,actual)))
  165. #,body))
  166. ;; Generate code to register the thing at run time.
  167. (register-template-instance! #'#,name #'#,actual
  168. #'#,instance))))))
  169. (syntax-case s (register! lookup exists? instantiations)
  170. ((_ register! name param body)
  171. ;; Register NAME as a template on PARAM with the given BODY.
  172. (begin
  173. (register-template! #'name #'param #'body)
  174. ;; Generate code to register the template at run time. XXX: Because
  175. ;; of this, BODY must not contain ellipses.
  176. #'(register-template! #'name #'param #'body)))
  177. ((_ lookup name actual)
  178. ;; Search for an instance of template NAME for this ACTUAL parameter.
  179. ;; On success, expand to the identifier of the instance; otherwise
  180. ;; expand to #f.
  181. (any (matching-instance? #'name #'actual) %template-instances))
  182. ((_ exists? name actual)
  183. ;; Likewise, but return a Boolean.
  184. (let ((result (->bool
  185. (any (matching-instance? #'name #'actual)
  186. %template-instances))))
  187. (unless result
  188. (format (current-warning-port)
  189. "~a: warning: no specialization of template '~a' for '~a'~%"
  190. location-string
  191. (syntax->datum #'name) (syntax->datum #'actual)))
  192. result))
  193. ((_ instantiations actual)
  194. ;; Expand to the definitions of all the existing templates
  195. ;; specialized for ACTUAL.
  196. #`(begin
  197. #,@(hash-map->list (cut instance-definition <> <> #'actual)
  198. %templates))))))
  199. (define-syntax define-template
  200. (lambda (s)
  201. "Define a template, which is a procedure that can be specialized over its
  202. first argument. In our case, the first argument is typically the identifier
  203. of a monad.
  204. Defining templates for procedures like 'mapm' allows us to make have a
  205. specialized version of those procedures for each monad that we define, such
  206. that calls to:
  207. (mapm %state-monad proc lst)
  208. automatically expand to:
  209. (#{ mapm %state-monad instance}# proc lst)
  210. Here, #{ mapm %state-monad instance}# is specialized for %state-monad, and
  211. thus it contains inline calls to %state-bind and %state-return. This avoids
  212. repeated calls to 'struct-ref' to get the 'bind' and 'return' procedure of the
  213. monad, and allows 'bind' and 'return' to be inlined, which in turn allows for
  214. more optimizations."
  215. (syntax-case s ()
  216. ((_ (name arg0 args ...) body ...)
  217. (with-syntax ((generic-name (datum->syntax
  218. #'name
  219. (symbol-append '#{ %}#
  220. (syntax->datum #'name)
  221. '-generic)))
  222. (original-name #'name))
  223. #`(begin
  224. (template-directory register! name arg0
  225. (lambda (args ...)
  226. body ...))
  227. (define (generic-name arg0 args ...)
  228. ;; The generic instance of NAME, for when no specialization was
  229. ;; found.
  230. body ...)
  231. (define-syntax name
  232. (lambda (s)
  233. (syntax-case s ()
  234. ((_ arg0* args ...)
  235. ;; Expand to either the specialized instance or the
  236. ;; generic instance of template ORIGINAL-NAME.
  237. #'(if (template-directory exists? original-name arg0*)
  238. ((template-directory lookup original-name arg0*)
  239. args ...)
  240. (generic-name arg0* args ...)))
  241. (_
  242. #'generic-name))))))))))
  243. (define-syntax-parameter >>=
  244. ;; The name 'bind' is already taken, so we choose this (obscure) symbol.
  245. (lambda (s)
  246. (syntax-violation '>>= ">>= (bind) used outside of 'with-monad'" s)))
  247. (define-syntax-parameter return
  248. (lambda (s)
  249. (syntax-violation 'return "return used outside of 'with-monad'" s)))
  250. (define-syntax-rule (bind-syntax bind)
  251. "Return a macro transformer that handles the expansion of '>>=' expressions
  252. using BIND as the binary bind operator.
  253. This macro exists to allow the expansion of n-ary '>>=' expressions, even
  254. though BIND is simply binary, as in:
  255. (with-monad %state-monad
  256. (>>= (return 1)
  257. (lift 1+ %state-monad)
  258. (lift 1+ %state-monad)))
  259. "
  260. (lambda (stx)
  261. (define (expand body)
  262. (syntax-case body ()
  263. ((_ mval mproc)
  264. #'(bind mval mproc))
  265. ((x mval mproc0 mprocs (... ...))
  266. (expand #'(>>= (>>= mval mproc0)
  267. mprocs (... ...))))))
  268. (expand stx)))
  269. (define-syntax with-monad
  270. (lambda (s)
  271. "Evaluate BODY in the context of MONAD, and return its result."
  272. (syntax-case s ()
  273. ((_ monad body ...)
  274. (eq? 'macro (syntax-local-binding #'monad))
  275. ;; MONAD is a syntax transformer, so we can obtain the bind and return
  276. ;; methods by directly querying it.
  277. #'(syntax-parameterize ((>>= (bind-syntax (monad %bind)))
  278. (return (identifier-syntax (monad %return))))
  279. body ...))
  280. ((_ monad body ...)
  281. ;; MONAD refers to the <monad> record that represents the monad at run
  282. ;; time, so use the slow method.
  283. #'(syntax-parameterize ((>>= (bind-syntax
  284. (monad-bind monad)))
  285. (return (identifier-syntax
  286. (monad-return monad))))
  287. body ...)))))
  288. (define-syntax mlet*
  289. (syntax-rules (->)
  290. "Bind the given monadic values MVAL to the given variables VAR. When the
  291. form is (VAR -> VAL), bind VAR to the non-monadic value VAL in the same way as
  292. 'let'."
  293. ;; Note: the '->' symbol corresponds to 'is:' in 'better-monads.rkt'.
  294. ((_ monad () body ...)
  295. (with-monad monad body ...))
  296. ((_ monad ((var mval) rest ...) body ...)
  297. (with-monad monad
  298. (>>= mval
  299. (lambda (var)
  300. (mlet* monad (rest ...)
  301. body ...)))))
  302. ((_ monad ((var -> val) rest ...) body ...)
  303. (let ((var val))
  304. (mlet* monad (rest ...)
  305. body ...)))))
  306. (define-syntax mlet
  307. (lambda (s)
  308. (syntax-case s ()
  309. ((_ monad ((var mval ...) ...) body ...)
  310. (with-syntax (((temp ...) (generate-temporaries #'(var ...))))
  311. #'(mlet* monad ((temp mval ...) ...)
  312. (let ((var temp) ...)
  313. body ...)))))))
  314. (define-syntax mbegin
  315. (syntax-rules (%current-monad)
  316. "Bind MEXP and the following monadic expressions in sequence, returning
  317. the result of the last expression. Every expression in the sequence must be a
  318. monadic expression."
  319. ((_ %current-monad mexp)
  320. mexp)
  321. ((_ %current-monad mexp rest ...)
  322. (>>= mexp
  323. (lambda (unused-value)
  324. (mbegin %current-monad rest ...))))
  325. ((_ monad mexp)
  326. (with-monad monad
  327. mexp))
  328. ((_ monad mexp rest ...)
  329. (with-monad monad
  330. (>>= mexp
  331. (lambda (unused-value)
  332. (mbegin monad rest ...)))))))
  333. (define-syntax mwhen
  334. (syntax-rules ()
  335. "When CONDITION is true, evaluate the sequence of monadic expressions
  336. MEXP0..MEXP* as in an 'mbegin'. When CONDITION is false, return *unspecified*
  337. in the current monad. Every expression in the sequence must be a monadic
  338. expression."
  339. ((_ condition mexp0 mexp* ...)
  340. (if condition
  341. (mbegin %current-monad
  342. mexp0 mexp* ...)
  343. (return *unspecified*)))))
  344. (define-syntax munless
  345. (syntax-rules ()
  346. "When CONDITION is false, evaluate the sequence of monadic expressions
  347. MEXP0..MEXP* as in an 'mbegin'. When CONDITION is true, return *unspecified*
  348. in the current monad. Every expression in the sequence must be a monadic
  349. expression."
  350. ((_ condition mexp0 mexp* ...)
  351. (if condition
  352. (return *unspecified*)
  353. (mbegin %current-monad
  354. mexp0 mexp* ...)))))
  355. (define-syntax define-lift
  356. (syntax-rules ()
  357. ((_ liftn (args ...))
  358. (define-syntax liftn
  359. (lambda (s)
  360. "Lift PROC to MONAD---i.e., return a monadic function in MONAD."
  361. (syntax-case s ()
  362. ((liftn proc monad)
  363. ;; Inline the result of lifting PROC, such that 'return' can in
  364. ;; turn be open-coded.
  365. #'(lambda (args ...)
  366. (with-monad monad
  367. (return (proc args ...)))))
  368. (id
  369. (identifier? #'id)
  370. ;; Slow path: Return a closure-returning procedure (we don't
  371. ;; guarantee (eq? LIFTN LIFTN), but that's fine.)
  372. #'(lambda (proc monad)
  373. (lambda (args ...)
  374. (with-monad monad
  375. (return (proc args ...))))))))))))
  376. (define-lift lift0 ())
  377. (define-lift lift1 (a))
  378. (define-lift lift2 (a b))
  379. (define-lift lift3 (a b c))
  380. (define-lift lift4 (a b c d))
  381. (define-lift lift5 (a b c d e))
  382. (define-lift lift6 (a b c d e f))
  383. (define-lift lift7 (a b c d e f g))
  384. (define (lift proc monad)
  385. "Lift PROC, a procedure that accepts an arbitrary number of arguments, to
  386. MONAD---i.e., return a monadic function in MONAD."
  387. (lambda args
  388. (with-monad monad
  389. (return (apply proc args)))))
  390. (define-template (foldm monad mproc init lst)
  391. "Fold MPROC over LST and return a monadic value seeded by INIT.
  392. (foldm %state-monad (lift2 cons %state-monad) '() '(a b c))
  393. => '(c b a) ;monadic
  394. "
  395. (with-monad monad
  396. (let loop ((lst lst)
  397. (result init))
  398. (match lst
  399. (()
  400. (return result))
  401. ((head . tail)
  402. (>>= (mproc head result)
  403. (lambda (result)
  404. (loop tail result))))))))
  405. (define-template (mapm monad mproc lst)
  406. "Map MPROC over LST and return a monadic list.
  407. (mapm %state-monad (lift1 1+ %state-monad) '(0 1 2))
  408. => (1 2 3) ;monadic
  409. "
  410. ;; XXX: We don't use 'foldm' because template specialization wouldn't work
  411. ;; in this context.
  412. (with-monad monad
  413. (let mapm ((lst lst)
  414. (result '()))
  415. (match lst
  416. (()
  417. (return (reverse result)))
  418. ((head . tail)
  419. (>>= (mproc head)
  420. (lambda (head)
  421. (mapm tail (cons head result)))))))))
  422. (define-template (sequence monad lst)
  423. "Turn the list of monadic values LST into a monadic list of values, by
  424. evaluating each item of LST in sequence."
  425. (with-monad monad
  426. (let seq ((lstx lst)
  427. (result '()))
  428. (match lstx
  429. (()
  430. (return (reverse result)))
  431. ((head . tail)
  432. (>>= head
  433. (lambda (item)
  434. (seq tail (cons item result)))))))))
  435. (define-template (anym monad mproc lst)
  436. "Apply MPROC to the list of values LST; return as a monadic value the first
  437. value for which MPROC returns a true monadic value or #f. For example:
  438. (anym %state-monad (lift1 odd? %state-monad) '(0 1 2))
  439. => #t ;monadic
  440. "
  441. (with-monad monad
  442. (let loop ((lst lst))
  443. (match lst
  444. (()
  445. (return #f))
  446. ((head . tail)
  447. (>>= (mproc head)
  448. (lambda (result)
  449. (if result
  450. (return result)
  451. (loop tail)))))))))
  452. (define-syntax listm
  453. (lambda (s)
  454. "Return a monadic list in MONAD from the monadic values MVAL."
  455. (syntax-case s ()
  456. ((_ monad mval ...)
  457. (with-syntax (((val ...) (generate-temporaries #'(mval ...))))
  458. #'(mlet monad ((val mval) ...)
  459. (return (list val ...))))))))
  460. ;;;
  461. ;;; Identity monad.
  462. ;;;
  463. (define-inlinable (identity-return value)
  464. value)
  465. (define-inlinable (identity-bind mvalue mproc)
  466. (mproc mvalue))
  467. (define-monad %identity-monad
  468. (bind identity-bind)
  469. (return identity-return))
  470. ;;;
  471. ;;; State monad.
  472. ;;;
  473. (define-inlinable (state-return value)
  474. (lambda (state)
  475. (values value state)))
  476. (define-inlinable (state-bind mvalue mproc)
  477. "Bind MVALUE, a value in the state monad, and pass it to MPROC."
  478. (lambda (state)
  479. (call-with-values
  480. (lambda ()
  481. (mvalue state))
  482. (lambda (value state)
  483. ;; Note: as of Guile 2.0.11, declaring a variable to hold the result
  484. ;; of (mproc value) prevents a bit of unfolding/inlining.
  485. ((mproc value) state)))))
  486. (define-monad %state-monad
  487. (bind state-bind)
  488. (return state-return))
  489. (define* (run-with-state mval #:optional (state '()))
  490. "Run monadic value MVAL starting with STATE as the initial state. Return
  491. two values: the resulting value, and the resulting state."
  492. (mval state))
  493. (define-inlinable (current-state)
  494. "Return the current state as a monadic value."
  495. (lambda (state)
  496. (values state state)))
  497. (define-inlinable (set-current-state value)
  498. "Set the current state to VALUE and return the previous state as a monadic
  499. value."
  500. (lambda (state)
  501. (values state value)))
  502. (define (state-pop)
  503. "Pop a value from the current state and return it as a monadic value. The
  504. state is assumed to be a list."
  505. (lambda (state)
  506. (match state
  507. ((head . tail)
  508. (values head tail)))))
  509. (define (state-push value)
  510. "Push VALUE to the current state, which is assumed to be a list, and return
  511. the previous state as a monadic value."
  512. (lambda (state)
  513. (values state (cons value state))))
  514. ;;; monads.scm end here