🎨 [derivation] Derivation of ASK and `LOOKUP'

Problem:
- The derivation of `ASK` and `LOOKUP` are done directly in the
`INITIALIZE-INSTANCE` method for `MONAD-ENVIRONMENT-OPERATORS` class
which means they cannot be reused for specific implementations of of
environment monads.

Solution:
- Make separate macros and functions for the derivation of `ASK` and
`LOOKUP` and replace the derivation in `MONAD-ENVIRONMENT-OPERATORS`
with calls to the functions.

src/contextual.lisp

@@ -549,8 +549,9 @@ not occur in the arguments, return `NIL'."
         (let ((lookup (get-argument-or-slot-value args :lookup obj 'lookup)))
           (if lookup
               (setf (slot-value obj 'ask)
-                    (lambda () (funcall lookup #'identity)))
+                    (lambda/lookup-to-ask :lookup lookup))
               (error "`ASK' was not provided and cannot be derived for `MONAD-ENVIRONMENT-OPERATORS'")))))
+
   (let ((lookup (get-argument-or-slot-value args :lookup obj 'lookup)))
     (if lookup
         (setf (slot-value obj 'lookup) lookup)
@@ -559,7 +560,7 @@ not occur in the arguments, return `NIL'."
           (assert ask)
           (assert fmap)
           (setf (slot-value obj 'lookup)
-                (lambda (f) (funcall fmap f (funcall ask)))))))
+                (lambda/ask-to-lookup :ask ask :fmap fmap)))))
 
   (let ((local (getf args :local)))
     (if local (setf (slot-value obj 'local) local)

src/derivation.lisp

@@ -12,7 +12,9 @@
    #:defun/product-to-fapply       #:lambda/product-to-fapply
    #:defun/fapply-to-fmap          #:lambda/fapply-to-fmap
    #:defun/duplicate-to-extend     #:lambda/duplicate-to-extend
-   #:defun/extend-to-duplicate     #:lambda/extend-to-duplicate))
+   #:defun/extend-to-duplicate     #:lambda/extend-to-duplicate
+   #:defun/ask-to-lookup           #:lambda/ask-to-lookup
+   #:defun/lookup-to-ask           #:lambda/lookup-to-ask))
 (in-package :contextual-derivation)
 
 (defmacro with-syms ((&rest names) &body body)
@@ -258,3 +260,28 @@ to `some-context' with an identity function."
   (flet ((extend (f wx)
            (funcall extend f wx)))
     (lambda (wx) (extend (lambda (wx) wx) wx))))
+
+(defmacro defun/ask-to-lookup (name &key ask fmap documentation)
+  (let ((documentation (if documentation (list documentation) nil)))
+    (with-syms (f)
+      `(defun ,name (,f)
+         ,@documentation
+         (,fmap ,f (,ask))))))
+
+(defun lambda/ask-to-lookup (&key ask fmap)
+  (flet ((ask () (funcall ask))
+         (fmap (f mx) (funcall fmap f mx)))
+    (lambda (f)
+      (fmap f (ask)))))
+
+
+(defmacro defun/lookup-to-ask (name &key lookup documentation)
+  (let ((documentation (if documentation (list documentation) nil)))
+    `(defun ,name ()
+       ,@documentation
+       (,lookup #'identity))))
+
+(defun lambda/lookup-to-ask (&key lookup)
+  (flet ((lookup (f) (funcall lookup f)))
+    (lambda ()
+      (lookup #'identity))))