Merge pull request #549 from oubiwann/add-lfe-support

Added support for LFE (Lisp Flavored Erlang).

lib/linguist/languages.yml

@@ -697,6 +697,13 @@ Kotlin:
   - .ktm
   - .kts
+LFE:
+  type: programming
+  primary_extension: .lfe
+  color: "#004200"
+  lexer: Common Lisp
+  group: Erlang
+
 LLVM:
   primary_extension: .ll

samples/LFE/church.lfe

+;; Copyright (c) 2013 Duncan McGreggor <oubiwann@cogitat.io>
+;;
+;; Licensed under the Apache License, Version 2.0 (the "License");
+;; you may not use this file except in compliance with the License.
+;; You may obtain a copy of the License at
+;;
+;;     http://www.apache.org/licenses/LICENSE-2.0
+;;
+;; Unless required by applicable law or agreed to in writing, software
+;; distributed under the License is distributed on an "AS IS" BASIS,
+;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;; See the License for the specific language governing permissions and
+;; limitations under the License.
+
+;; File    : church.lfe
+;; Author  : Duncan McGreggor
+;; Purpose : Demonstrating church numerals from the lambda calculus
+
+;; The code below was used to create the section of the user guide here:
+;;    http://lfe.github.io/user-guide/recursion/5.html
+;;
+;; Here is some example usage:
+;;
+;; > (slurp '"church.lfe")
+;; #(ok church)
+;; > (zero)
+;; #Fun<lfe_eval.10.53503600>
+;; > (church->int1 (zero))
+;; 0
+;; > (church->int1 (three))
+;; 3
+;; > (church->int1 (five))
+;; 5
+;; > (church->int2 #'five/0)
+;; 5
+;; > (church->int2 (lambda () (get-church 25)))
+;; 25
+
+(defmodule church
+  (export all))
+
+(defun zero ()
+  (lambda (s)
+    (lambda (x) x)))
+
+(defun one ()
+  (lambda (s)
+    (lambda (x)
+      (funcall s x))))
+
+(defun two ()
+  (lambda (s)
+    (lambda (x)
+      (funcall s
+        (funcall s x)))))
+
+(defun three ()
+  (lambda (s)
+    (lambda (x)
+      (funcall s
+        (funcall s
+          (funcall s x))))))
+
+(defun four ()
+  (lambda (s)
+    (lambda (x)
+      (funcall s
+        (funcall s
+          (funcall s
+            (funcall s x)))))))
+
+(defun five ()
+  (get-church 5))
+
+(defun int-successor (n)
+  (+ n 1))
+
+(defun church->int1 (church-numeral)
+  "
+  Converts a called church numeral to an integer, e.g.:
+  > (church->int1 (five))
+  "
+  (funcall
+    (funcall church-numeral #'int-successor/1) 0))
+
+(defun church->int2 (church-numeral)
+  "
+  Converts a non-called church numeral to an integer, e.g.:
+  > (church->int2 #'five/0)
+  "
+  (funcall
+    (funcall
+      (funcall church-numeral) #'int-successor/1) 0))
+
+(defun church-successor (church-numeral)
+  (lambda (s)
+    (lambda (x)
+      (funcall s
+        (funcall
+          (funcall church-numeral s) x)))))
+
+(defun get-church (church-numeral count limit)
+  (cond ((== count limit) church-numeral)
+        ((/= count limit)
+         (get-church
+           (church-successor church-numeral)
+           (+ 1 count)
+           limit))))
+
+(defun get-church (integer)
+  (get-church (zero) 0 integer))

samples/LFE/gps1.lfe

+;;; -*- Mode: LFE; -*-
+;;; Code from Paradigms of Artificial Intelligence Programming
+;;; Copyright (c) 1991 Peter Norvig
+
+;;;; File gps1.lisp: First version of GPS (General Problem Solver)
+
+;;;; Converted to LFE by Robert Virding
+
+;; Define macros for global variable access. This is a hack and very naughty!
+(defsyntax defvar
+  ([name val] (let ((v val)) (put 'name v) v)))
+
+(defsyntax setvar
+  ([name val] (let ((v val)) (put 'name v) v)))
+
+(defsyntax getvar
+  ([name] (get 'name)))
+
+;; Module definition.
+
+(defmodule gps1
+  (export (gps 2) (gps 3) (school-ops 0))
+  (import (from lists (member 2) (all 2) (any 2))
+      ;; Rename lists functions to be more CL like.
+      (rename lists ((all 2) every) ((any 2) some) ((filter 2) find-all))))
+
+;; An operation.
+(defrecord op
+  action preconds add-list del-list)
+
+;; General Problem Solver: achieve all goals using *ops*.
+(defun gps (state goals ops)
+  ;; Set global variables
+  (defvar *state* state)    ;The current state: a list of conditions.
+  (defvar *ops* ops)        ;A list of available operators.
+  (if (every (fun achieve 1) goals) 'solved))
+
+(defun gps (state goals)
+  ;; Set global variables, but use existing *ops*
+  (defvar *state* state)    ;The current state: a list of conditions.
+  (if (every (fun achieve 1) goals) 'solved))
+
+;; A goal is achieved if it already holds or if there is an
+;; appropriate op for it that is applicable."
+(defun achieve (goal)
+  (orelse (member goal (getvar *state*))
+      (some (fun apply-op 1)
+        (find-all (lambda (op) (appropriate-p goal op))
+              (getvar *ops*)))))
+
+;; An op is appropriate to a goal if it is in its add list.
+(defun appropriate-p (goal op)
+  (member goal (op-add-list op)))
+
+;; Print a message and update *state* if op is applicable.
+(defun apply-op (op)
+  (if (every (fun achieve 1) (op-preconds op))
+    (progn
+      (: io fwrite '"executing ~p\n" (list (op-action op)))
+      (setvar *state* (set-difference (getvar *state*) (op-del-list op)))
+      (setvar *state* (union (getvar *state*) (op-add-list op)))
+      'true)))
+
+;; Define the set functions to work on list, a listsets module really.
+(defun set-difference
+  ([(cons e es) s2]
+   (if (member e s2)
+     (set-difference es s2)
+     (cons e (set-difference es s2))))
+  ([() s2] ()))
+
+(defun union
+  ([(cons e es) s2]
+   (if (member e s2) (union es s2) (cons e (union es s2))))
+  ([() s2] ()))
+
+;;; ==============================
+
+(defun school-ops ()
+  (list
+    (make-op action 'drive-son-to-school
+         preconds '(son-at-home car-works)
+         add-list '(son-at-school)
+         del-list '(son-at-home))
+    (make-op action 'shop-installs-battery
+         preconds '(car-needs-battery shop-knows-problem shop-has-money)
+         add-list '(car-works)
+         del-list ())
+    (make-op action 'tell-shop-problem
+         preconds '(in-communication-with-shop)
+         add-list '(shop-knows-problem)
+         del-list ())
+    (make-op action 'telephone-shop
+         preconds '(know-phone-number)
+         add-list '(in-communication-with-shop)
+         del-list ())
+    (make-op action 'look-up-number
+         preconds '(have-phone-book)
+         add-list '(know-phone-number)
+         del-list ())
+    (make-op action 'give-shop-money
+         preconds '(have-money)
+         add-list '(shop-has-money)
+         del-list '(have-money))))

samples/LFE/mnesia_demo.lfe

+;; Copyright (c) 2008-2013 Robert Virding
+;;
+;; Licensed under the Apache License, Version 2.0 (the "License");
+;; you may not use this file except in compliance with the License.
+;; You may obtain a copy of the License at
+;;
+;;     http://www.apache.org/licenses/LICENSE-2.0
+;;
+;; Unless required by applicable law or agreed to in writing, software
+;; distributed under the License is distributed on an "AS IS" BASIS,
+;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;; See the License for the specific language governing permissions and
+;; limitations under the License.
+
+;; File    : mnesia_demo.lfe
+;; Author  : Robert Virding
+;; Purpose : A simple Mnesia demo file for LFE.
+
+;; This file contains a simple demo of using LFE to access Mnesia
+;; tables.  It shows how to use the emp-XXXX macro (ETS match pattern)
+;; together with mnesia:match_object, match specifications with
+;; mnesia:select and Query List Comprehensions.
+
+(defmodule mnesia_demo
+  (export (new 0) (by_place 1) (by_place_ms 1) (by_place_qlc 1)))
+
+(defrecord person name place job)
+
+(defun new ()
+  ;; Start mnesia and create a table, we will get an in memory only schema.
+  (: mnesia start)
+  (: mnesia create_table 'person '(#(attributes (name place job))))
+  ;; Initialise the table.
+  (let ((people '(
+          ;; First some people in London.
+          #(fred london waiter)
+          #(bert london waiter)
+          #(john london painter)
+          #(paul london driver)
+          ;; Now some in Paris.
+          #(jean paris waiter)
+          #(gerard paris driver)
+          #(claude paris painter)
+          #(yves paris waiter)
+          ;; And some in Rome.
+          #(roberto rome waiter)
+          #(guiseppe rome driver)
+          #(paulo rome painter)
+          ;; And some in Berlin.
+          #(fritz berlin painter)
+          #(kurt berlin driver)
+          #(hans berlin waiter)
+          #(franz berlin waiter)
+          )))
+    (: lists foreach (match-lambda
+               ([(tuple n p j)]
+            (: mnesia transaction
+              (lambda ()
+                (let ((new (make-person name n place p job j)))
+                  (: mnesia write new))))))
+       people)))
+
+;; Match records by place using match_object and the emp-XXXX macro.
+(defun by_place (place)
+  (: mnesia transaction
+    (lambda () (: mnesia match_object (emp-person place place)))))
+
+;; Use match specifications to match records
+(defun by_place_ms (place)
+  (let ((f (lambda () (: mnesia select 'person
+             (match-spec ([(match-person name n place p job j)]
+                      (when (=:= p place))
+                      (tuple n j)))))))
+    (: mnesia transaction f)))
+
+;; Use Query List Comprehensions to match records
+(defun by_place_qlc (place)
+  (let ((f (lambda ()
+         (let ((q (qlc (lc ((<- person (: mnesia table 'person))
+                (=:= (person-place person) place))
+                 person))))
+           (: qlc e q)))))
+    (: mnesia transaction f)))

samples/LFE/object.lfe

+;; Copyright (c) 2013 Duncan McGreggor <oubiwann@cogitat.io>
+;;
+;; Licensed under the Apache License, Version 2.0 (the "License");
+;; you may not use this file except in compliance with the License.
+;; You may obtain a copy of the License at
+;;
+;;     http://www.apache.org/licenses/LICENSE-2.0
+;;
+;; Unless required by applicable law or agreed to in writing, software
+;; distributed under the License is distributed on an "AS IS" BASIS,
+;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;; See the License for the specific language governing permissions and
+;; limitations under the License.
+
+;; File    : object.lfe
+;; Author  : Duncan McGreggor
+;; Purpose : Demonstrating simple OOP with closures
+
+;; The simple object system demonstrated below shows how to do the following:
+;;  * create objects
+;;  * call methods on those objects
+;;  * have methods which can call other methods
+;;  * update the state of an instance variable
+;;
+;; Note, however, that his example does not demonstrate inheritance.
+;;
+;; To use the code below in LFE, do the following:
+;;
+;;  $ cd examples
+;;  $ ../bin/lfe -pa ../ebin
+;;
+;; Load the file and create a fish-class instance:
+;;
+;; > (slurp '"object.lfe")
+;; #(ok object)
+;; > (set mommy-fish (fish-class '"Carp"))
+;; #Fun<lfe_eval.10.91765564>
+;;
+;; Execute some of the basic methods:
+;;
+;; > (get-species mommy-fish)
+;; "Carp"
+;; > (move mommy-fish 17)
+;; The Carp swam 17 feet!
+;; ok
+;; > (get-id mommy-fish)
+;; "47eebe91a648f042fc3fb278df663de5"
+;;
+;; Now let's look at "modifying" state data (e.g., children counts):
+;;
+;; > (get-children mommy-fish)
+;; ()
+;; > (get-children-count mommy-fish)
+;; 0
+;; > (set (mommy-fish baby-fish-1) (reproduce mommy-fish))
+;; (#Fun<lfe_eval.10.91765564> #Fun<lfe_eval.10.91765564>)
+;; > (get-id mommy-fish)
+;; "47eebe91a648f042fc3fb278df663de5"
+;; > (get-id baby-fish-1)
+;; "fdcf35983bb496650e558a82e34c9935"
+;; > (get-children-count mommy-fish)
+;; 1
+;; > (set (mommy-fish baby-fish-2) (reproduce mommy-fish))
+;; (#Fun<lfe_eval.10.91765564> #Fun<lfe_eval.10.91765564>)
+;; > (get-id mommy-fish)
+;; "47eebe91a648f042fc3fb278df663de5"
+;; > (get-id baby-fish-2)
+;; "3e64e5c20fb742dd88dac1032749c2fd"
+;; > (get-children-count mommy-fish)
+;; 2
+;; > (get-info mommy-fish)
+;; id: "47eebe91a648f042fc3fb278df663de5"
+;; species: "Carp"
+;; children: ["fdcf35983bb496650e558a82e34c9935",
+;;            "3e64e5c20fb742dd88dac1032749c2fd"]
+;; ok
+
+(defmodule object
+ (export all))
+
+(defun fish-class (species)
+  "
+  This is the constructor that will be used most often, only requiring that
+  one pass a 'species' string.
+
+  When the children are not defined, simply use an empty list.
+  "
+  (fish-class species ()))
+
+(defun fish-class (species children)
+  "
+  This contructor is mostly useful as a way of abstracting out the id
+  generation from the larger constructor. Nothing else uses fish-class/2
+  besides fish-class/1, so it's not strictly necessary.
+
+  When the id isn't know, generate one."
+  (let* (((binary (id (size 128))) (: crypto rand_bytes 16))
+         (formatted-id (car
+                         (: io_lib format
+                           '"~32.16.0b" (list id)))))
+    (fish-class species children formatted-id)))
+
+(defun fish-class (species children id)
+  "
+  This is the constructor used internally, once the children and fish id are
+  known.
+  "
+  (let ((move-verb '"swam"))
+    (lambda (method-name)
+      (case method-name
+        ('id
+          (lambda (self) id))
+        ('species
+          (lambda (self) species))
+        ('children
+          (lambda (self) children))
+        ('info
+          (lambda (self)
+            (: io format
+              '"id: ~p~nspecies: ~p~nchildren: ~p~n"
+              (list (get-id self)
+                    (get-species self)
+                    (get-children self)))))
+        ('move
+          (lambda (self distance)
+            (: io format
+              '"The ~s ~s ~p feet!~n"
+              (list species move-verb distance))))
+        ('reproduce
+          (lambda (self)
+            (let* ((child (fish-class species))
+                   (child-id (get-id child))
+                   (children-ids (: lists append
+                                   (list children (list child-id))))
+                   (parent-id (get-id self))
+                   (parent (fish-class species children-ids parent-id)))
+              (list parent child))))
+        ('children-count
+          (lambda (self)
+            (: erlang length children)))))))
+
+(defun get-method (object method-name)
+  "
+  This is a generic function, used to call into the given object (class
+  instance).
+  "
+  (funcall object method-name))
+
+; define object methods
+(defun get-id (object)
+  (funcall (get-method object 'id) object))
+
+(defun get-species (object)
+  (funcall (get-method object 'species) object))
+
+(defun get-info (object)
+  (funcall (get-method object 'info) object))
+
+(defun move (object distance)
+  (funcall (get-method object 'move) object distance))
+
+(defun reproduce (object)
+  (funcall (get-method object 'reproduce) object))
+
+(defun get-children (object)
+  (funcall (get-method object 'children) object))
+
+(defun get-children-count (object)
+  (funcall (get-method object 'children-count) object))
\ No newline at end of file