Add CI configuration

.github/workflows/ci.yml

@@ -0,0 +1,62 @@
+name: CI
+
+on: [push]
+
+jobs:
+  build:
+    runs-on: ubuntu-latest
+    steps:
+    - name: Install dependencies
+      run: |
+        sudo apt-get update
+        sudo apt-get install libssl-dev zlib1g-dev libsqlite3-dev
+    - name: Checkout Gambit
+      uses: actions/checkout@v2
+      with:
+        repository: gambit/gambit
+        ref: v4.9.3
+        path: gambit
+    - name: Install Gambit
+      run: |
+        cd gambit
+        ./configure --prefix=/usr/local/gambit \
+            --enable-single-host \
+            --enable-multiple-versions \
+            --enable-openssl \
+            --enable-default-runtime-options=f8,-8,t8 \
+            --enable-poll
+        make -j
+        make check
+        sudo make install
+        echo "/usr/local/gambit/current/bin" >> $GITHUB_PATH
+    - name: Checkout Gerbil
+      uses: actions/checkout@v2
+      with:
+        repository: vyzo/gerbil
+        path: gerbil
+    - name: Install Gerbil
+      env:
+        LD_LIBRARY_PATH: /usr/local/gambit/current/lib
+      run: |
+        cd gerbil/src
+        ./configure --prefix=/usr/local/gerbil
+        GERBIL_BUILD_CORES=2 ./build.sh
+        sudo env "PATH=$PATH" ./install
+        echo "GERBIL_HOME=/usr/local/gerbil" >> $GITHUB_ENV
+        echo "/usr/local/gerbil/bin" >> $GITHUB_PATH
+    - name: Checkout project
+      uses: actions/checkout@v2
+      with:
+        path: repo
+    - name: Build
+      env:
+        LD_LIBRARY_PATH: /usr/local/gambit/current/lib
+      run: |
+        cd repo
+        ./build.ss
+    - name: Run demo
+      env:
+        LD_LIBRARY_PATH: /usr/local/gambit/current/lib
+      run: |
+        cd repo
+        ./demo.ss

.gitignore

@@ -1,3 +1,2 @@
 *\~
-TAGS
 build-deps

README.org

@@ -8,10 +8,9 @@ Fancy pretty-printing utilities for [[https://cons.io/][Gerbil Scheme]].
 ** Features
 
 - [[https://en.wikipedia.org/wiki/ANSI_escape_code#CSI_(Control_Sequence_Introducer)_sequences][ANSI control codes]] for styling and cursor movement
-- Table formatting with [[https://unicode-table.com/en/blocks/box-drawing/][Unicode box drawing characters]] or in Markdown syntax
+- Table formatting with [[https://unicode-table.com/en/blocks/box-drawing/][Unicode box drawing characters]]
 - Horizontal rules
 - Spinners
-- Progress bars
 
 ** References
 

build.ss

@@ -6,6 +6,4 @@
   '("fancy/format"
     "fancy/table"
     "fancy/rule"
-    "fancy/progress"
+    "fancy/spinner"))
-    "fancy/spinner")
-  optimize: #t debug: 'src)

demo.ss

@@ -8,11 +8,10 @@
 	:dlozeve/fancy/format
 	:dlozeve/fancy/table
 	:dlozeve/fancy/rule
-	:dlozeve/fancy/progress
 	:dlozeve/fancy/spinner)
 
 (def (main)
-  (display (rule "[bold green]Fancy demo" style: 'simple width: 100))
+  (display (rule "[bold green]Fancy demo" style: 'simple))
   (displayln)
   (displayln (parse-markup
 	      "[bold red]Lorem ipsum[/bold red] dolor sit amet, [underline]consectetur[/underline] adipiscing elit, sed do
@@ -31,11 +30,6 @@ culpa qui officia deserunt mollit anim id est laborum."))
   (display (table-footer tab))
   (displayln)
   (displayln)
-  (def pbar (progress-bar 100 "[green]Progress: " percent: #f style: 'line))
-  (for ((i (in-range 100)))
-    (display (progress pbar (1+ i)))
-    (thread-sleep! 0.05))
-  (displayln)
   (for ((i (in-range 20)))
     (display (spinner i "[yellow]Waiting:" (format "(computing ~d/20)" (1+ i))
 		      style: 'dots))

fancy/format.ss

@@ -81,7 +81,7 @@
     ((? (lambda (t) (assgetq t +basic-bg-colors+)) => code) (format "4~d" code))
     (else #!void)))
 
-(def (graphics-style (style []))
+(def (graphics-style style)
   (def colors (lset-intersection eq? style (map car +basic-colors+)))
   (def bg-colors (lset-intersection eq? style (map car +basic-bg-colors+)))
   (def style-without-colors (lset-difference eq? style

fancy/progress.ss

@@ -1,39 +0,0 @@
-(export (struct-out progress-bar)
-	progress)
-
-(import :std/misc/string
-	:std/format
-	:dlozeve/fancy/format)
-
-(def +progress-styles+
-  '((ascii  . (#\[ #\= #\> #\  #\]))
-    (line   . (#\┝ #\━ #\━ #\  #\┥))
-    (double . (#\╞ #\═ #\═ #\  #\╡))
-    (block  . (#\│ #\█ #\█ #\ #\│))
-    (halfblock . (#\╻ #\▄ #\▄ #\ #\╻))
-    (dots   . (#\⣿ #\⠶ #\⠶ #\⠀ #\⣿))))
-
-(defstruct progress-bar (total description length style percent)
-  constructor: :init!)
-
-(defmethod {:init! progress-bar}
-  (lambda (self total (description #f) length: (length 80) style: (style 'line) percent: (percent #f))
-    (struct-instance-init! self total description length style percent)))
-
-(def (progress pbar n)
-  (with ((progress-bar total description length style percent) pbar)
-    (let* ((n (min total (max 0 n)))
-	   (n-done (inexact->exact (floor (* (- length 3) (/ n total)))))
-	   (n-remaining (inexact->exact (ceiling (* (- length 3) (/ (- total n) total)))))
-	   (progress-chars (assgetq style +progress-styles+))
-	   (bar (format "~c~a~c~a~c"
-			(list-ref progress-chars 0)
-			(make-string n-done (list-ref progress-chars 1))
-			(list-ref progress-chars 2)
-			(make-string n-remaining (list-ref progress-chars 3))
-			(list-ref progress-chars 4)))
-	   (progress (if percent
-		       (format "~3,0F%" (* 100 (/ n total)))
-		       (format "(~d/~d)"  n total))))
-      (str (cursor-up 1)
-	   (parse-markup description) bar " " progress "\n"))))

fancy/table.ss

@@ -6,47 +6,25 @@
 (import :std/misc/string
 	:dlozeve/fancy/format)
 
-(defstruct table (names widths style)
+(defstruct table (names widths))
-  constructor: :init!)
 
-(defmethod {:init! table}
+(def (column-text text width)
-  (lambda (self names widths (style #f))
+  (str " "
-    (set! (table-names self) names)
+       (parse-markup text)
-    (set! (table-widths self) widths)
+       (make-string (- width (string-length (remove-markup text)) 1) #\ )))
-    (set! (table-style self) style)))
-
-(def (column-text text width (style #f))
-  (match style
-    ('markdown
-     (str " " (remove-markup text) (make-string (- width (string-length (remove-markup text)) 1) #\ )))
-    (else
-     (str " "
-	  (parse-markup text)
-	  (make-string (- width (string-length (remove-markup text)) 1) #\ )))))
 
 (def (table-header tab)
-  (match tab
+  (with ((table names widths) tab)
-    ((table names widths 'markdown)
+    (str "┌" (string-join (map (lambda (w) (make-string (+ 2 w) #\─)) widths) #\┬) "┐\n"
-     (str "|" (string-join (map (lambda (name width) (column-text name (+ 2 width) 'markdown)) names widths) #\|) "|\n"
+	 "│" (string-join (map (lambda (name width) (column-text name (+ 2 width))) names widths) #\│) "│\n"
-	  "|" (string-join (map (lambda (w) (make-string (+ 2 w) #\-)) widths) #\|) "|\n"))
+	 "├" (string-join (map (lambda (w) (make-string (+ 2 w) #\─)) widths) #\┼) "┤\n")))
-    ((table names widths _)
-     (str "┌" (string-join (map (lambda (w) (make-string (+ 2 w) #\─)) widths) #\┬) "┐\n"
-	  "│" (string-join (map (lambda (name width) (column-text name (+ 2 width))) names widths) #\│) "│\n"
-	  "├" (string-join (map (lambda (w) (make-string (+ 2 w) #\─)) widths) #\┼) "┤\n"))))
 
 (def (table-row tab . args)
-  (match tab
+  (with ((table names widths) tab)
-    ((table names widths 'markdown)
+    (str "│"
-     (str "|"
+	 (string-join (map (lambda (text width) (column-text text (+ 2 width))) args widths) #\│)
-	  (string-join (map (lambda (text width) (column-text text (+ 2 width) 'markdown)) args widths) #\|)
+	 "│\n")))
-	  "|\n"))
-    ((table names widths _)
-     (str "│"
-	  (string-join (map (lambda (text width) (column-text text (+ 2 width))) args widths) #\│)
-	  "│\n"))))
 
 (def (table-footer tab)
-  (match tab
+  (with ((table names widths) tab)
-    ((table names widths 'markdown) "\n")
+    (str "└" (string-join (map (lambda (w) (make-string (+ 2 w) #\─)) widths) #\┴) "┘\n")))
-    ((table names widths _)
-     (str "└" (string-join (map (lambda (w) (make-string (+ 2 w) #\─)) widths) #\┴) "┘\n"))))