mirror of
https://github.com/correl/calrissian.git
synced 2024-11-23 11:09:58 +00:00
commit
e488fb2225
9 changed files with 76 additions and 68 deletions
|
@ -1,5 +1,5 @@
|
||||||
(defmacro evaluate-m (monad mval)
|
(defmacro evaluate-m (monad mval)
|
||||||
`(cond ((: calrissian-util implements? 'calrissian-state ,monad)
|
`(cond ((calrissian-util:implements? 'calrissian-state ,monad)
|
||||||
(call ,monad 'run ,mval 'undefined))
|
(call ,monad 'run ,mval 'undefined))
|
||||||
('true ,mval)))
|
('true ,mval)))
|
||||||
|
|
||||||
|
|
|
@ -3,14 +3,14 @@
|
||||||
;; Provide the state monad in terms of the state transformer
|
;; Provide the state monad in terms of the state transformer
|
||||||
(''state `(transformer 'state 'identity))
|
(''state `(transformer 'state 'identity))
|
||||||
(_
|
(_
|
||||||
`(list_to_atom (lists:flatten (list "calrissian-"
|
`(list_to_atom (lists:flatten `("calrissian-"
|
||||||
(atom_to_list ,name)
|
,(atom_to_list ,name)
|
||||||
"-monad"))))))
|
"-monad"))))))
|
||||||
|
|
||||||
(defmacro transformer (name inner-monad)
|
(defmacro transformer (name inner-monad)
|
||||||
`(tuple (list_to_atom (lists:flatten (list "calrissian-"
|
`(tuple (list_to_atom (lists:flatten `("calrissian-"
|
||||||
(atom_to_list ,name)
|
,(atom_to_list ,name)
|
||||||
"-transformer")))
|
"-transformer")))
|
||||||
(monad ,inner-monad)))
|
(monad ,inner-monad)))
|
||||||
|
|
||||||
(defmacro do-m args
|
(defmacro do-m args
|
||||||
|
@ -31,7 +31,7 @@
|
||||||
`(call ,monad 'fail ,expr))
|
`(call ,monad 'fail ,expr))
|
||||||
|
|
||||||
(defmacro sequence (monad list)
|
(defmacro sequence (monad list)
|
||||||
`(: lists foldr
|
`(lists:foldr
|
||||||
(lambda (m acc) (mcons ,monad m acc))
|
(lambda (m acc) (mcons ,monad m acc))
|
||||||
(return ,monad [])
|
(return ,monad [])
|
||||||
,list))
|
,list))
|
||||||
|
|
|
@ -5,9 +5,9 @@
|
||||||
(fail 1)))
|
(fail 1)))
|
||||||
|
|
||||||
(defun >>=
|
(defun >>=
|
||||||
(((tuple 'error reason) f)
|
((`#(error ,reason) f)
|
||||||
(tuple 'error reason))
|
`#(error ,reason))
|
||||||
(((tuple 'ok value) f)
|
((`#(ok ,value) f)
|
||||||
(funcall f value))
|
(funcall f value))
|
||||||
(('ok f)
|
(('ok f)
|
||||||
(funcall f 'ok)))
|
(funcall f 'ok)))
|
||||||
|
@ -16,7 +16,7 @@
|
||||||
(('ok)
|
(('ok)
|
||||||
'ok)
|
'ok)
|
||||||
((x)
|
((x)
|
||||||
(tuple 'ok x)))
|
`#(ok ,x)))
|
||||||
|
|
||||||
(defun fail (reason)
|
(defun fail (reason)
|
||||||
(tuple 'error reason))
|
`#(error ,reason))
|
||||||
|
|
|
@ -8,4 +8,6 @@
|
||||||
(funcall f x))
|
(funcall f x))
|
||||||
|
|
||||||
(defun return (x) x)
|
(defun return (x) x)
|
||||||
(defun fail (x) (throw (tuple 'error x)))
|
|
||||||
|
(defun fail (x)
|
||||||
|
(throw `#(error ,x)))
|
||||||
|
|
|
@ -7,8 +7,11 @@
|
||||||
(defun >>=
|
(defun >>=
|
||||||
(('nothing f)
|
(('nothing f)
|
||||||
'nothing)
|
'nothing)
|
||||||
(((tuple 'just x) f)
|
((`#(just ,x) f)
|
||||||
(funcall f x)))
|
(funcall f x)))
|
||||||
|
|
||||||
(defun return (x) (tuple 'just x))
|
(defun return (x)
|
||||||
(defun fail (_) 'nothing)
|
`#(just ,x))
|
||||||
|
|
||||||
|
(defun fail (_)
|
||||||
|
'nothing)
|
||||||
|
|
|
@ -3,15 +3,17 @@
|
||||||
(do-transform 2)))
|
(do-transform 2)))
|
||||||
|
|
||||||
(defun behaviour_info
|
(defun behaviour_info
|
||||||
(('callbacks) (list #(>>= 2)
|
(('callbacks) '(#(>>= 2)
|
||||||
#(return 1)
|
#(return 1)
|
||||||
#(fail 1)))
|
#(fail 1)))
|
||||||
((_) 'undefined))
|
((_) 'undefined))
|
||||||
|
|
||||||
(defun do-transform
|
(defun do-transform
|
||||||
((monad (cons h '())) h)
|
((monad `(,h . ()))
|
||||||
((monad (cons (list f '<- m) t)) (list '>>= monad
|
h)
|
||||||
m
|
((monad `((,f <- ,m) . ,t))
|
||||||
(list 'lambda (list f) (do-transform monad t))))
|
`(>>= ,monad
|
||||||
((monad (cons h t)) (list '>> monad h (do-transform monad t)))
|
,m
|
||||||
)
|
(lambda (,f) ,(do-transform monad t))))
|
||||||
|
((monad `(,h . ,t))
|
||||||
|
`(>> ,monad ,h ,(do-transform monad t))))
|
||||||
|
|
|
@ -4,57 +4,57 @@
|
||||||
(include-lib "include/monads.lfe")
|
(include-lib "include/monads.lfe")
|
||||||
|
|
||||||
(defun new (inner-monad)
|
(defun new (inner-monad)
|
||||||
(tuple 'calrissian-state-transformer inner-monad))
|
`#(calrissian-state-transformer ,inner-monad))
|
||||||
|
|
||||||
(defun return
|
(defun return
|
||||||
((x (tuple 'calrissian-state-transformer inner-monad))
|
((x `#(calrissian-state-transformer ,inner-monad))
|
||||||
(lambda (s) (call inner-monad 'return (tuple x s)))))
|
(lambda (s) (call inner-monad 'return (tuple x s)))))
|
||||||
|
|
||||||
(defun fail
|
(defun fail
|
||||||
((reason (tuple 'calrissian-state-transformer inner-monad))
|
((reason `#(calrissian-state-transformer ,inner-monad))
|
||||||
(lambda (_) (call inner-monad 'fail reason))))
|
(lambda (_) (call inner-monad 'fail reason))))
|
||||||
|
|
||||||
(defun >>=
|
(defun >>=
|
||||||
((x f (tuple 'calrissian-state-transformer inner-monad))
|
((x f `#(calrissian-state-transformer ,inner-monad))
|
||||||
(lambda (s)
|
(lambda (s)
|
||||||
(call inner-monad '>>=
|
(call inner-monad '>>=
|
||||||
(funcall x s)
|
(funcall x s)
|
||||||
(match-lambda (((tuple x1 s1)) (funcall (funcall f x1) s1)))))))
|
(match-lambda ((`#(,x1 ,s1)) (funcall (funcall f x1) s1)))))))
|
||||||
|
|
||||||
(defun get (_)
|
(defun get (_)
|
||||||
(lambda (s)
|
(lambda (s)
|
||||||
(tuple s s)))
|
`#(,s ,s)))
|
||||||
|
|
||||||
(defun put (s _)
|
(defun put (s _)
|
||||||
(lambda (_)
|
(lambda (_)
|
||||||
(tuple 'ok s)))
|
`#(ok ,s)))
|
||||||
|
|
||||||
(defun modify
|
(defun modify
|
||||||
((f (tuple 'calrissian-state-transformer inner-monad))
|
((f `#(calrissian-state-transformer ,inner-monad))
|
||||||
(lambda (s)
|
(lambda (s)
|
||||||
(tuple 'ok (call inner-monad 'return (funcall f s))))))
|
`#(ok ,(call inner-monad 'return (funcall f s))))))
|
||||||
|
|
||||||
(defun modify-and-return
|
(defun modify-and-return
|
||||||
((f (tuple 'calrissian-state-transformer inner-monad))
|
((f `#(calrissian-state-transformer ,inner-monad))
|
||||||
(lambda (s)
|
(lambda (s)
|
||||||
(let ((newstate (call inner-monad 'return (funcall f s))))
|
(let ((newstate (call inner-monad 'return (funcall f s))))
|
||||||
(tuple newstate newstate)))))
|
`#(,newstate ,newstate)))))
|
||||||
|
|
||||||
(defun eval
|
(defun eval
|
||||||
((m s (tuple 'calrissian-state-transformer inner-monad))
|
((m s `#(calrissian-state-transformer ,inner-monad))
|
||||||
(call inner-monad '>>=
|
(call inner-monad '>>=
|
||||||
(funcall m s)
|
(funcall m s)
|
||||||
(match-lambda (((tuple x s1))
|
(match-lambda ((`#(,x ,s1))
|
||||||
(call inner-monad 'return x))))))
|
(call inner-monad 'return x))))))
|
||||||
|
|
||||||
(defun exec
|
(defun exec
|
||||||
((m s (tuple 'calrissian-state-transformer inner-monad))
|
((m s `#(calrissian-state-transformer ,inner-monad))
|
||||||
(call inner-monad '>>=
|
(call inner-monad '>>=
|
||||||
(funcall m s)
|
(funcall m s)
|
||||||
(match-lambda (((tuple x s1))
|
(match-lambda ((`#(,x ,s1))
|
||||||
(call inner-monad 'return s1))))))
|
(call inner-monad 'return s1))))))
|
||||||
|
|
||||||
(defun run
|
(defun run
|
||||||
((m s (tuple 'calrissian-state-transformer inner-monad))
|
((m s `#(calrissian-state-transformer ,inner-monad))
|
||||||
(funcall m s)))
|
(funcall m s)))
|
||||||
|
|
||||||
|
|
|
@ -2,11 +2,11 @@
|
||||||
(export (behaviour_info 1)))
|
(export (behaviour_info 1)))
|
||||||
|
|
||||||
(defun behaviour_info
|
(defun behaviour_info
|
||||||
(('callbacks) (list #(run 2)
|
(('callbacks) `(#(run 2)
|
||||||
#(get 0)
|
#(get 0)
|
||||||
#(put 1)
|
#(put 1)
|
||||||
#(modify 1)
|
#(modify 1)
|
||||||
#(modify-and-return 1)
|
#(modify-and-return 1)
|
||||||
#(exec 2)
|
#(exec 2)
|
||||||
#(eval 2)))
|
#(eval 2)))
|
||||||
((_) 'undefined))
|
((_) 'undefined))
|
|
@ -14,31 +14,32 @@
|
||||||
`(#(calrissian ,(get-version)))))
|
`(#(calrissian ,(get-version)))))
|
||||||
|
|
||||||
(defun module-info
|
(defun module-info
|
||||||
(((tuple module _args))
|
((`#(,module ,_args))
|
||||||
;; Report exported function arities as (arity - 1) to account for
|
;; Report exported function arities as (arity - 1) to account for
|
||||||
;; the extra argument supplied to tuple modules
|
;; the extra argument supplied to tuple modules
|
||||||
(let ((fix-info (lambda (info-plist)
|
(let ((fix-info (lambda (info-plist)
|
||||||
(let* ((exports (: proplists get_value 'exports info-plist))
|
(let* ((exports (proplists:get_value 'exports info-plist))
|
||||||
(fix-arity (match-lambda
|
(fix-arity (match-lambda
|
||||||
;; module_info is added by the compiler and therefore remains as-is
|
;; module_info is added by the compiler and therefore remains as-is
|
||||||
(((tuple 'module_info arity)) (tuple 'module_info arity))
|
((`#(module_info ,arity)) `#(module_info ,arity))
|
||||||
(((tuple fun arity)) (tuple fun (- arity 1)))))
|
((`#(,fun ,arity)) `#(,fun ,(- arity 1)))))
|
||||||
(info-dict (: dict from_list info-plist))
|
(info-dict (dict:from_list info-plist))
|
||||||
(new-dict (: dict store 'exports (: lists map fix-arity exports) info-dict))
|
(new-dict (dict:store 'exports (lists:map fix-arity exports) info-dict))
|
||||||
(new-plist (: dict to_list new-dict)))
|
(new-plist (dict:to_list new-dict)))
|
||||||
new-plist))))
|
new-plist))))
|
||||||
(funcall fix-info (module-info module))))
|
(funcall fix-info (module-info module))))
|
||||||
((module) (call module 'module_info)))
|
((module)
|
||||||
|
(call module 'module_info)))
|
||||||
|
|
||||||
(defun module-info (module key)
|
(defun module-info (module key)
|
||||||
(: proplists get_value key (module-info module)))
|
(proplists:get_value key (module-info module)))
|
||||||
|
|
||||||
(defun implements? (behaviour module)
|
(defun implements? (behaviour module)
|
||||||
(let* ((exports (module-info module 'exports))
|
(let* ((exports (module-info module 'exports))
|
||||||
(exported? (lambda (definition) (: lists member definition exports))))
|
(exported? (lambda (definition) (lists:member definition exports))))
|
||||||
(: lists all exported?
|
(lists:all exported?
|
||||||
(call behaviour 'behaviour_info 'callbacks))))
|
(call behaviour 'behaviour_info 'callbacks))))
|
||||||
|
|
||||||
(defun exports? (definition module)
|
(defun exports? (definition module)
|
||||||
(: lists member definition
|
(lists:member definition
|
||||||
(module-info module 'exports)))
|
(module-info module 'exports)))
|
||||||
|
|
Loading…
Reference in a new issue