github/calrissian
1
0
Fork 0
mirror of https://github.com/correl/calrissian.git synced 2024-11-23 11:09:58 +00:00
Code Issues Projects Releases Packages Wiki Activity

Merge pull request #4 from lfex/formatting

Browse source 
Formatting changes
This commit is contained in:
Correl Roush 2015-05-21 22:03:37 -04:00
commit e488fb2225
9 changed files with 76 additions and 68 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
include/monad-tests.lfe
View file

@ -1,5 +1,5 @@
(defmacro evaluate-m (monad mval)
`(cond ((: calrissian-util implements? 'calrissian-state ,monad)
`(cond ((calrissian-util:implements? 'calrissian-state ,monad)
(call ,monad 'run ,mval 'undefined))
('true ,mval)))
@ -43,32 +43,32 @@
(f (lambda (n) (return ,monad (* 3 n)))))
(is-equal-m ,monad (>>= ,monad (return ,monad a) f)
(funcall f a))))
(deftest monad-right-identity
(let ((m (return ,monad 3)))
(is-equal-m ,monad (>>= ,monad m (lambda (m') (return ,monad m')))
m)))
(deftest monad-associativity
(let ((m (return ,monad 3))
(f (lambda (n) (return ,monad (* 3 n))))
(g (lambda (n) (return ,monad (+ 5 n)))))
(is-equal-m ,monad (>>= ,monad (>>= ,monad m f) g)
(>>= ,monad m (lambda (x) (>>= ,monad (funcall f x) g))))))
(deftest monad-do-left-identity
(let ((a 3)
(f (lambda (n) (return ,monad (* 3 n)))))
(is-equal-m ,monad (do-m ,monad (a' <- (return ,monad a))
(funcall f a'))
(do-m ,monad (funcall f a)))))
(deftest monad-do-right-identity
(let ((m (return ,monad 3)))
(is-equal-m ,monad (do-m ,monad (x <- m)
(return ,monad x))
(do-m ,monad m))))
(deftest monad-do-associativity
(let ((m (return ,monad 3))
(f (lambda (n) (return ,monad (* 3 n))))

14
include/monads.lfe
View file

@ -3,14 +3,14 @@
;; Provide the state monad in terms of the state transformer
(''state `(transformer 'state 'identity))
(_
`(list_to_atom (lists:flatten (list "calrissian-"
(atom_to_list ,name)
"-monad"))))))
`(list_to_atom (lists:flatten `("calrissian-"
,(atom_to_list ,name)
"-monad"))))))
(defmacro transformer (name inner-monad)
`(tuple (list_to_atom (lists:flatten (list "calrissian-"
(atom_to_list ,name)
"-transformer")))
`(tuple (list_to_atom (lists:flatten `("calrissian-"
,(atom_to_list ,name)
"-transformer")))
(monad ,inner-monad)))
(defmacro do-m args
@ -31,7 +31,7 @@
`(call ,monad 'fail ,expr))
(defmacro sequence (monad list)
`(: lists foldr
`(lists:foldr
(lambda (m acc) (mcons ,monad m acc))
(return ,monad [])
,list))

10
src/calrissian-error-monad.lfe
View file

@ -5,9 +5,9 @@
(fail 1)))
(defun >>=
(((tuple 'error reason) f)
(tuple 'error reason))
(((tuple 'ok value) f)
((`#(error ,reason) f)
`#(error ,reason))
((`#(ok ,value) f)
(funcall f value))
(('ok f)
(funcall f 'ok)))
@ -16,7 +16,7 @@
(('ok)
'ok)
((x)
(tuple 'ok x)))
`#(ok ,x)))
(defun fail (reason)
(tuple 'error reason))
`#(error ,reason))

4
src/calrissian-identity-monad.lfe
View file

@ -8,4 +8,6 @@
(funcall f x))
(defun return (x) x)
(defun fail (x) (throw (tuple 'error x)))
(defun fail (x)
(throw `#(error ,x)))

9
src/calrissian-maybe-monad.lfe
View file

@ -7,8 +7,11 @@
(defun >>=
(('nothing f)
'nothing)
(((tuple 'just x) f)
((`#(just ,x) f)
(funcall f x)))
(defun return (x) (tuple 'just x))
(defun fail (_) 'nothing)
(defun return (x)
`#(just ,x))
(defun fail (_)
'nothing)

20
src/calrissian-monad.lfe
View file

@ -3,15 +3,17 @@
(do-transform 2)))
(defun behaviour_info
(('callbacks) (list #(>>= 2)
#(return 1)
#(fail 1)))
(('callbacks) '(#(>>= 2)
#(return 1)
#(fail 1)))
((_) 'undefined))
(defun do-transform
((monad (cons h '())) h)
((monad (cons (list f '<- m) t)) (list '>>= monad
m
(list 'lambda (list f) (do-transform monad t))))
((monad (cons h t)) (list '>> monad h (do-transform monad t)))
)
((monad `(,h . ()))
h)
((monad `((,f <- ,m) . ,t))
`(>>= ,monad
,m
(lambda (,f) ,(do-transform monad t))))
((monad `(,h . ,t))
`(>> ,monad ,h ,(do-transform monad t))))

32
src/calrissian-state-transformer.lfe
View file

@ -4,57 +4,57 @@
(include-lib "include/monads.lfe")
(defun new (inner-monad)
(tuple 'calrissian-state-transformer inner-monad))
`#(calrissian-state-transformer ,inner-monad))
(defun return
((x (tuple 'calrissian-state-transformer inner-monad))
((x `#(calrissian-state-transformer ,inner-monad))
(lambda (s) (call inner-monad 'return (tuple x s)))))
(defun fail
((reason (tuple 'calrissian-state-transformer inner-monad))
((reason `#(calrissian-state-transformer ,inner-monad))
(lambda (_) (call inner-monad 'fail reason))))
(defun >>=
((x f (tuple 'calrissian-state-transformer inner-monad))
((x f `#(calrissian-state-transformer ,inner-monad))
(lambda (s)
(call inner-monad '>>=
(funcall x s)
(match-lambda (((tuple x1 s1)) (funcall (funcall f x1) s1)))))))
(match-lambda ((`#(,x1 ,s1)) (funcall (funcall f x1) s1)))))))
(defun get (_)
(lambda (s)
(tuple s s)))
`#(,s ,s)))
(defun put (s _)
(lambda (_)
(tuple 'ok s)))
`#(ok ,s)))
(defun modify
((f (tuple 'calrissian-state-transformer inner-monad))
((f `#(calrissian-state-transformer ,inner-monad))
(lambda (s)
(tuple 'ok (call inner-monad 'return (funcall f s))))))
`#(ok ,(call inner-monad 'return (funcall f s))))))
(defun modify-and-return
((f (tuple 'calrissian-state-transformer inner-monad))
((f `#(calrissian-state-transformer ,inner-monad))
(lambda (s)
(let ((newstate (call inner-monad 'return (funcall f s))))
(tuple newstate newstate)))))
`#(,newstate ,newstate)))))
(defun eval
((m s (tuple 'calrissian-state-transformer inner-monad))
((m s `#(calrissian-state-transformer ,inner-monad))
(call inner-monad '>>=
(funcall m s)
(match-lambda (((tuple x s1))
(match-lambda ((`#(,x ,s1))
(call inner-monad 'return x))))))
(defun exec
((m s (tuple 'calrissian-state-transformer inner-monad))
((m s `#(calrissian-state-transformer ,inner-monad))
(call inner-monad '>>=
(funcall m s)
(match-lambda (((tuple x s1))
(match-lambda ((`#(,x ,s1))
(call inner-monad 'return s1))))))
(defun run
((m s (tuple 'calrissian-state-transformer inner-monad))
((m s `#(calrissian-state-transformer ,inner-monad))
(funcall m s)))

14
src/calrissian-state.lfe
View file

@ -2,11 +2,11 @@
(export (behaviour_info 1)))
(defun behaviour_info
(('callbacks) (list #(run 2)
#(get 0)
#(put 1)
#(modify 1)
#(modify-and-return 1)
#(exec 2)
#(eval 2)))
(('callbacks) `(#(run 2)
#(get 0)
#(put 1)
#(modify 1)
#(modify-and-return 1)
#(exec 2)
#(eval 2)))
((_) 'undefined))

29
src/calrissian-util.lfe
View file

@ -14,31 +14,32 @@
`(#(calrissian ,(get-version)))))
(defun module-info
(((tuple module _args))
((`#(,module ,_args))
;; Report exported function arities as (arity - 1) to account for
;; the extra argument supplied to tuple modules
(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
;; module_info is added by the compiler and therefore remains as-is
(((tuple 'module_info arity)) (tuple 'module_info arity))
(((tuple fun arity)) (tuple fun (- arity 1)))))
(info-dict (: dict from_list info-plist))
(new-dict (: dict store 'exports (: lists map fix-arity exports) info-dict))
(new-plist (: dict to_list new-dict)))
((`#(module_info ,arity)) `#(module_info ,arity))
((`#(,fun ,arity)) `#(,fun ,(- arity 1)))))
(info-dict (dict:from_list info-plist))
(new-dict (dict:store 'exports (lists:map fix-arity exports) info-dict))
(new-plist (dict:to_list new-dict)))
new-plist))))
(funcall fix-info (module-info module))))
((module) (call module 'module_info)))
((module)
(call module 'module_info)))
(defun module-info (module key)
(: proplists get_value key (module-info module)))
(proplists:get_value key (module-info module)))
(defun implements? (behaviour module)
(let* ((exports (module-info module 'exports))
(exported? (lambda (definition) (: lists member definition exports))))
(: lists all exported?
(call behaviour 'behaviour_info 'callbacks))))
(exported? (lambda (definition) (lists:member definition exports))))
(lists:all exported?
(call behaviour 'behaviour_info 'callbacks))))
(defun exports? (definition module)
(: lists member definition
(module-info module 'exports)))
(lists:member definition
(module-info module 'exports)))