From 78217e1cee942a84ca14eb25f5a1e4dcdb02e95f Mon Sep 17 00:00:00 2001 From: saarin Date: Sun, 23 Feb 2014 05:22:39 +0100 Subject: [PATCH] Add shen language in linguist --- lib/linguist/languages.yml | 6 + samples/Shen/graph.shen | 321 +++++++++++++++++++++++++++++++++++++ samples/Shen/html.shen | 102 ++++++++++++ samples/Shen/json.shen | 39 +++++ 4 files changed, 468 insertions(+) create mode 100644 samples/Shen/graph.shen create mode 100644 samples/Shen/html.shen create mode 100644 samples/Shen/json.shen diff --git a/lib/linguist/languages.yml b/lib/linguist/languages.yml index 53dbce8c..b666d4a1 100644 --- a/lib/linguist/languages.yml +++ b/lib/linguist/languages.yml @@ -1614,6 +1614,12 @@ Shell: filenames: - Dockerfile +Shen: + type: programming + color: "#120F14" + lexer: Text only + primary_extension: .shen + Slash: type: programming color: "#007eff" diff --git a/samples/Shen/graph.shen b/samples/Shen/graph.shen new file mode 100644 index 00000000..1c42bb55 --- /dev/null +++ b/samples/Shen/graph.shen @@ -0,0 +1,321 @@ +\* graph.shen --- a library for graph definition and manipulation + +Copyright (C) 2011, Eric Schulte + +*** License: + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + - Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + - Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +*** Commentary: + +Graphs are represented as two dictionaries one for vertices and one +for edges. It is important to note that the dictionary implementation +used is able to accept arbitrary data structures as keys. This +structure technically encodes hypergraphs (a generalization of graphs +in which each edge may contain any number of vertices). Examples of a +regular graph G and a hypergraph H with the corresponding data +structure are given below. + + +--G=------------------------------------------------ + Vertices Edges + ---------- ------- + +----Graph G-----+ hash | key -> value hash | key -> value + | | -----+------>-------- -----+-------->--------- + | a---b---c g | 1 | a -> [1] 1 | [a b] -> [1 2] + | | | | 2 | b -> [1 2 3] 2 | [b c] -> [2 3] + | d---e---f | 3 | c -> [2 4] 3 | [b d] -> [2 4] + | | 4 | d -> [3 5] 4 | [c e] -> [3 5] + +----------------+ 5 | e -> [4 5 6] 5 | [d e] -> [4 5] + 6 | f -> [6] 6 | [e f] -> [5 6] + 7 | g -> [] + + +--H=------------------------------------------------ + Vertices Edges + ---------- ------- + hash | key -> value hash | key -> value + +-- Hypergraph H----+ -----+------>-------- -----+-------->--------- + | | 1 | a -> [1] 1 | [a b [1 2 + | +------+ | 2 | b -> [1] | c d -> 3 4 + | +------+------+ | 3 | c -> [1] | e f] 5 6] + | |a b c |d e f | | 4 | d -> [1 2] | + | +------+------+ | 5 | e -> [1 2] 2 | [d e [4 5 + | |g h i | j | 6 | f -> [1 2] | f g -> 6 7 + | +------+ | 7 | g -> [2] | h i] 8 9] + | | 8 | h -> [2] + +-------------------+ 9 | i -> [2] + 10 | j -> [] + + +--G=-------Graph with associated edge/vertex data--------- + Vertices Edges + ---------- ------- + +----Graph G-----+ hash | key -> value hash | key -> value + | 4 6 7 | -----+------>-------- -----+-------->--------- + |0a---b---c g | 1 | a -> (@p 0 [1]) 1 | [a b] -> (@p 4 [1 2]) + | 1| 3| | 2 | b -> [1 2 3] 2 | [b c] -> (@p 6 [2 3]) + | d---e---f | 3 | c -> [2 4] 3 | [b d] -> (@p 1 [2 4]) + | 2 5 | 4 | d -> [3 5] 4 | [c e] -> (@p 3 [3 5]) + +----------------+ 5 | e -> [4 5 6] 5 | [d e] -> (@p 2 [4 5]) + 6 | f -> [6] 6 | [e f] -> (@p 5 [5 6]) + 7 | g -> (@p 7 []) + +V = # of vertices +E = # of edges +M = # of vertex edge associations + +size = size of all vertices + all vertices stored in Vertices dict + M * sizeof(int) * 4 + indices into Vertices & Edge dicts + V * sizeof(dict entry) + storage in the Vertex dict + E * sizeof(dict entry) + storage in the Edge dict + 2 * sizeof(dict) the Vertices and Edge dicts + +*** Code: *\ +(require dict) +(require sequence) + +(datatype graph + Vertices : dictionary; + Edges : dictoinary; + =================== + (vector symbol Vertices Edges);) + +(package graph- [graph graph? vertices edges add-vertex + add-edge has-edge? has-vertex? edges-for + neighbors connected-to connected? connected-components + vertex-partition bipartite? + \* included from the sequence library\ *\ + take drop take-while drop-while range flatten + filter complement seperate zip indexed reduce + mapcon partition partition-with unique frequencies + shuffle pick remove-first interpose subset? + cartesian-product + \* included from the dict library\ *\ + dict? dict dict-> <-dict contents key? keys vals + dictionary make-dict] + +(define graph? + X -> (= graph (<-address X 0))) + +(define make-graph + \* create a graph with specified sizes for the vertex dict and edge dict *\ + {number --> number --> graph} + Vertsize Edgesize -> + (let Graph (absvector 3) + (do (address-> Graph 0 graph) + (address-> Graph 1 (make-dict Vertsize)) + (address-> Graph 2 (make-dict Edgesize)) + Graph))) + +(defmacro graph-macro + \* return a graph taking optional sizes for the vertex and edge dicts *\ + [graph] -> [make-graph 1024 1024] + [graph N] -> [make-graph N 1024] + [graph N M] -> [make-graph N M]) + +(define vert-dict Graph -> (<-address Graph 1)) + +(define edge-dict Graph -> (<-address Graph 2)) + +(define vertices + {graph --> (list A)} + Graph -> (keys (vert-dict Graph))) + +(define edges + {graph --> (list (list A))} + Graph -> (keys (edge-dict Graph))) + +(define get-data + Value V -> (if (tuple? Value) + (fst Value) + (error (make-string "no data for ~S~%" V)))) + +(define vertex-data + Graph V -> (get-data (<-dict (vert-dict Graph) V) V)) + +(define edge-data + Graph V -> (get-data (<-dict (edge-dict Graph) V) V)) + +(define resolve + {(vector (list A)) --> (@p number number) --> A} + Vector (@p Index Place) -> (nth (+ 1 Place) (<-vector Vector Index))) + +(define resolve-vert + {graph --> (@p number number) --> A} + Graph Place -> (resolve (<-address (vert-dict Graph) 2) Place)) + +(define resolve-edge + {graph --> (@p number number) --> A} + Graph Place -> (resolve (<-address (edge-dict Graph) 2) Place)) + +(define edges-for + {graph --> A --> (list (list A))} + Graph Vert -> (let Val (trap-error (<-dict (vert-dict Graph) Vert) (/. E [])) + Edges (if (tuple? Val) (snd Val) Val) + (map (lambda X (fst (resolve-edge Graph X))) Val))) + +(define add-vertex-w-data + \* add a vertex to a graph *\ + {graph --> A --> B --> A} + G V Data -> (do (dict-> (vert-dict G) V (@p Data (edges-for G V))) V)) + +(define add-vertex-w/o-data + \* add a vertex to a graph *\ + {graph --> A --> B --> A} + G V -> (do (dict-> (vert-dict G) V (edges-for G V)) V)) + +(defmacro add-vertex-macro + [add-vertex G V] -> [add-vertex-w/o-data G V] + [add-vertex G V D] -> [add-vertex-w-data G V D]) + +(define update-vert + \* in a dict, add an edge to a vertex's edge list *\ + {vector --> (@p number number) --> A --> number} + Vs Edge V -> (let Store (<-address Vs 2) + N (hash V (limit Store)) + VertLst (trap-error (<-vector Store N) (/. E [])) + Contents (trap-error (<-dict Vs V) (/. E [])) + (do (dict-> Vs V (if (tuple? Contents) + (@p (fst Contents) + (adjoin Edge (snd Contents))) + (adjoin Edge Contents))) + (@p N (length VertLst))))) + +(define update-edges-vertices + \* add an edge to a graph *\ + {graph --> (list A) --> (list A)} + Graph Edge -> + (let Store (<-address (edge-dict Graph) 2) + EdgeID (hash Edge (limit Store)) + EdgeLst (trap-error (<-vector Store EdgeID) (/. E [])) + (map (update-vert (vert-dict Graph) (@p EdgeID (length EdgeLst))) Edge))) + +(define add-edge-w-data + G E D -> (do (dict-> (edge-dict G) E (@p D (update-edges-vertices G E))) E)) + +(define add-edge-w/o-data + G E -> (do (dict-> (edge-dict G) E (update-edges-vertices G E)) E)) + +(defmacro add-edge-macro + [add-edge G E] -> [add-edge-w/o-data G E] + [add-edge G E V] -> [add-edge-w-data G E V]) + +(define has-edge? + {graph --> (list A) --> boolean} + Graph Edge -> (key? (edge-dict Graph) Edge)) + +(define has-vertex? + {graph --> A --> boolean} + Graph Vertex -> (key? (vert-dict Graph) Vertex)) + +(define neighbors + \* Return the neighbors of a vertex *\ + {graph --> A --> (list A)} + Graph Vert -> (unique (mapcon (remove-first Vert) (edges-for Graph Vert)))) + +(define connected-to- + {graph --> (list A) --> (list A) --> (list A)} + Graph [] Already -> Already + Graph New Already -> + (let Reachable (unique (mapcon (neighbors Graph) New)) + New (difference Reachable Already) + (connected-to- Graph New (append New Already)))) + +(define connected-to + \* return all vertices connected to the given vertex, including itself *\ + {graph --> A --> (list A)} + Graph V -> (connected-to- Graph [V] [V])) + +(define connected? + \* return if a graph is fully connected *\ + {graph --> boolean} + Graph -> (reduce (/. V Acc + (and Acc + (subset? (vertices Graph) (connected-to Graph V)))) + true (vertices Graph))) + +(define connected-components- + \* given a graph return a list of connected components *\ + {graph --> (list A) --> (list (list A)) --> (list graph)} + Graph [] _ -> [] + Graph VS [] -> (map (/. V (let Component (graph 1 0) + (do (add-vertex Component V) Component))) + VS) + Graph [V|VS] ES -> + (let Con-verts (connected-to Graph V) + Con-edges (filter (/. E (subset? E Con-verts)) ES) + Component (graph (length Con-verts) (length Con-edges)) + (do (map (add-edge-w/o-data Component) Con-edges) + (cons Component (connected-components- Graph + (difference VS Con-verts) + (difference ES Con-edges)))))) + +(define connected-components + {graph --> (list graph)} + Graph -> (connected-components- Graph (vertices Graph) (edges Graph))) + +(define place-vertex + \* given a graph, vertex and list of partitions, partition the vertex *\ + {graph --> A --> (list (list A)) --> (list (list A))} + Graph V [] -> (if (element? V (neighbors Graph V)) + (simple-error + (make-string "self-loop ~S, no vertex partition" V)) + [[V]]) + Graph V [C|CS] -> (let Neighbors (neighbors Graph V) + (if (element? V Neighbors) + (simple-error + (make-string "self-loop ~S, no vertex partition" V)) + (if (empty? (intersection C Neighbors)) + [[V|C]|CS] + [C|(place-vertex Graph V CS)])))) + +(define vertex-partition + \* partition the vertices of a graph *\ + {graph --> (list (list A))} + Graph -> (reduce (place-vertex Graph) [] (vertices Graph))) + +(define bipartite? + \* check if a graph is bipartite *\ + {graph --> boolean} + Graph -> (= 2 (length (vertex-partition Graph)))) + +) + +\* simple tests + +(set g (graph)) +(add-edge (value g) [chris patton]) +(add-edge (value g) [eric chris]) +(add-vertex (value g) nobody) +(has-edge? (value g) [patton chris]) +(edges-for (value g) chris) +(neighbors (value g) chris) +(neighbors (value g) nobody) +(connected-to (value g) chris) +(connected? (value g)) +(connected-components (value g)) <- fail when package wrapper is used +(map (function vertices) (connected-components (value g))) + +*\ \ No newline at end of file diff --git a/samples/Shen/html.shen b/samples/Shen/html.shen new file mode 100644 index 00000000..62d93c30 --- /dev/null +++ b/samples/Shen/html.shen @@ -0,0 +1,102 @@ +\* html.shen --- html generation functions for shen + +Copyright (C) 2011, Eric Schulte + +*** License: + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + - Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + - Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +*** Commentary: + +The standard lisp-to-html conversion tool suite. Follows some of +the convertions of Clojure's hiccup. + + an example... + +(8-) (html [ul#todo1.tasks.stuff [: [title "today"]] + (map (lambda Str [li Str]) ["get milk" "dishes"])]) +"
    +
  • get milk
  • dishes
" + +*** Code: *\ +(trap-error + (require string) + (/. E (load "../string/string.shen"))) + +(package string- [html + \* symbols included from string *\ + takestr dropstr substr length-str index-str + reverse-str starts-with substr? replace-str + join split trim-left trim-right chomp trim] + +(define to-str + \* return argument as a string, if already a string do not change *\ + X -> X where (string? X) + X -> (str X)) + +(define gassoc + X Y -> (hd (tl (assoc X Y)))) + +(define dassoc + X Y -> (remove (assoc X Y) Y)) + +(define passoc + [] Y -> Y + [X XV] Y -> (let Orig (gassoc X Y) + New (if (cons? Orig) [XV|Orig] XV) + [[X New]|(dassoc X Y)])) + +(define html + X -> X where (string? X) + [Tag [: |Attrs] |Body] -> + (let Tag-comps (css-parse-symbol Tag) + Tag (gassoc tag Tag-comps) + New-attrs (passoc (assoc class Tag-comps) + (passoc (assoc id Tag-comps) Attrs)) + (@s (make-string "<~S" Tag) (attributes New-attrs) ">" + (html Body) + (make-string "" Tag))) where (symbol? Tag) + [Tag|Body] -> (html [Tag [:] Body]) where (symbol? Tag) + [H|HS] -> (@s (html H) (html HS)) + [] -> "") + +(define css-parse-symbol + {symbol --> [[symbol A]]} + Symbol -> (let String (str Symbol) + Class-split (split (str .) String) + Class (map (function intern) (tl Class-split)) + Id-split (split (str #) (hd Class-split)) + Tag (hd Id-split) + Id (tl Id-split) + ((if (= [] Id) (/. X X) (cons [id (intern (hd Id))])) + ((if (= [] Class) (/. X X) (cons [class Class])) + [[tag (intern Tag)]])))) + +(define attributes + [] -> "" + [[K V]|AS] -> (@s " " (to-str K) "='" + (if (cons? V) (join " " (map (function str) V)) (to-str V)) + "'" (attributes AS))) + +) \ No newline at end of file diff --git a/samples/Shen/json.shen b/samples/Shen/json.shen new file mode 100644 index 00000000..b330c5c6 --- /dev/null +++ b/samples/Shen/json.shen @@ -0,0 +1,39 @@ +(load "grammar.shen") + +\* + +JSON Lexer + +1. Read a stream of characters +2. Whitespace characters not in strings should be discarded. +3. Whitespace characters in strings should be preserved +4. Strings can contain escaped double quotes. e.g. "\"" + +*\ + +(define whitespacep + \* e.g. ASCII 32 == #\Space. *\ + \* All the others are whitespace characters from an ASCII table. *\ + Char -> (member Char ["c#9;" "c#10;" "c#11;" "c#12;" "c#13;" "c#32;"])) + +(define replace-whitespace + "" -> "" + (@s Whitespace Suffix) -> (@s "" (replace-whitespace Suffix)) where (whitespacep Whitespace) + (@s Prefix Suffix) -> (@s Prefix (replace-whitespace Suffix))) + +(define fetch-until-unescaped-doublequote + [] -> [] + ["\" "c#34;" | Chars] -> ["\" "c#34;" | (fetch-until-unescaped-doublequote Chars)] + ["c#34;" | Chars] -> [] + [Char | Chars] -> [Char | (fetch-until-unescaped-doublequote Chars)]) + +\* (define strip-whitespace-chars *\ +\* [] -> [] *\ +\* ["c#34;" | Chars] -> ["c#34;" | ( *\ +\* [WhitespaceChar | Chars] -> (strip-whitespace-chars Chars) where (whitespace? WhitespaceChar) *\ +\* [Char | Chars] -> [Char | (strip-whitespace-chars Chars)]) *\ + +(define tokenise + JSONString -> + (let CharList (explode JSONString) + CharList)) \ No newline at end of file