Skip to content

Instantly share code, notes, and snippets.

@ahihi

ahihi/tidal.el

Created May 15, 2021
Embed
What would you like to do?
;;; tidal.el --- Interact with TidalCycles for live coding patterns -*- lexical-binding: t; -*-
;; Copyright (C) 2012 alex@slab.org
;; Copyright (C) 2006-2008 rohan drape (hsc3.el)
;; Author: alex@slab.org
;; Homepage: https://github.com/tidalcycles/Tidal
;; Version: 0
;; Keywords: tools
;; Package-Requires: ((haskell-mode "16") (emacs "24"))
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; notes from hsc3:
;; This mode is implemented as a derivation of `haskell' mode,
;; indentation and font locking is courtesy that mode. The
;; inter-process communication is courtesy `comint'. The symbol at
;; point acquisition is courtesy `thingatpt'. The directory search
;; facilities are courtesy `find-lisp'.
;;; Code:
(require 'scheme)
(require 'comint)
(require 'thingatpt)
(require 'find-lisp)
(require 'pulse)
(require 'haskell-mode)
(require 'subr-x)
(defvar tidal-buffer
"*tidal*"
"*The name of the tidal process buffer (default=*tidal*).")
(defvar tidal-interpreter
"ghci"
"*The haskell interpeter to use (default=ghci).")
(defvar tidal-interpreter-version
(substring (shell-command-to-string (concat tidal-interpreter " --numeric-version")) 0 -1)
"*The version of tidal interpreter as a string.")
(defvar tidal-interpreter-arguments
()
"*Arguments to the haskell interpreter (default=none).")
(defvar tidal-boot-script-path
;; (let ((filepath
;; (cond
;; ((string-equal system-type "windows-nt")
;; '(("path" . "echo off && for /f %a in ('ghc-pkg latest tidal') do (for /f \"tokens=2\" %i in ('ghc-pkg describe %a ^| findstr data-dir') do (echo %i))")
;; ("separator" . "\\")
;; ))
;; ((or (string-equal system-type "darwin") (string-equal system-type "gnu/linux"))
;; '(("path" . "ghc-pkg field tidal data-dir")
;; ("separator" . "/")
;; ))
;; )
;; ))
;; (concat
;; (string-trim (cadr (split-string
;; (shell-command-to-string (cdr (assoc "path" filepath))) ":")))
;; (cdr (assoc "separator" filepath))
;; "BootTidal.hs")
;; )
;;
(let ((path (shell-command-to-string "find ~/.cabal -name BootTidal.hs | tail -n 1")))
(if (string= "" path) nil path))
"*Full path to BootTidal.hs (inferred by introspecting ghc-pkg package db).")
(defvar tidal-init-script-path nil
"*Full path to InitTidal.hs (executed after BootTidal.hs).")
(defvar tidal-literate-p
t
"*Flag to indicate if we are in literate mode (default=t).")
(make-variable-buffer-local 'tidal-literate-p)
(defvar tidal-modules nil
"Additional module imports. See `tidal-run-region'.")
(defun tidal-new-d-instances () (mapcar (lambda (x) (cons x 1)) (number-sequence 1 10)))
(defvar tidal-d-instances (tidal-new-d-instances))
(make-variable-buffer-local 'tidal-d-instances)
(defun tidal-unlit (s)
"Remove bird literate marks in S."
(replace-regexp-in-string "^> " "" s))
(defun tidal-intersperse (e l)
"Insert E between every element of list L."
(when l
(cons e (cons (car l) (tidal-intersperse e (cdr l))))))
(defun tidal-start-haskell ()
"Start haskell."
(interactive)
(if (comint-check-proc tidal-buffer)
(error "A tidal process is already running")
(apply
'make-comint
"tidal"
tidal-interpreter
nil
tidal-interpreter-arguments)
(tidal-see-output))
(tidal-send-string (concat ":script " tidal-boot-script-path))
(when tidal-init-script-path
(tidal-send-string (concat ":script " tidal-init-script-path)))
)
(defun tidal-see-output ()
"Show haskell output."
(interactive)
(when (comint-check-proc tidal-buffer)
;; (delete-other-windows)
(with-current-buffer tidal-buffer
(let ((window (display-buffer (current-buffer))))
(goto-char (point-max))
(save-selected-window
(set-window-point window (point-max)))))))
(defun tidal-quit-haskell ()
"Quit haskell."
(interactive)
(kill-buffer tidal-buffer)
;; (delete-other-windows)
)
(defun tidal-chunk-string (n s)
"Split a string S into chunks of N characters."
(let* ((l (length s))
(m (min l n))
(c (substring s 0 m)))
(if (<= l n)
(list c)
(cons c (tidal-chunk-string n (substring s n))))))
(defun tidal-send-string (s)
(if (comint-check-proc tidal-buffer)
(let ((cs (tidal-chunk-string 64 (concat s "\n")))
(buf (current-buffer)))
(set-buffer tidal-buffer)
(delete-region (point-min) (point-max))
(set-buffer buf)
(mapcar (lambda (c) (comint-send-string tidal-buffer c)) cs))
(error "no tidal process running?")))
(defun tidal-transform-and-store (f s)
"Transform example text into compilable form."
(with-temp-file f
(mapc (lambda (module)
(insert (concat module "\n")))
tidal-modules)
(insert "main = do\n")
(insert (if tidal-literate-p (tidal-unlit s) s))))
(defun tidal-get-now ()
"Store the current cycle position in a variable called 'now'."
(interactive)
(tidal-send-string "now' <- getNow")
(tidal-send-string "let now = nextSam now'")
(tidal-send-string "let retrig = (now `rotR`)")
(tidal-send-string "let fadeOut n = spread' (_degradeBy) (retrig $ slow n $ envL)")
(tidal-send-string "let fadeIn n = spread' (_degradeBy) (retrig $ slow n $ (1-) <$> envL)")
)
(defun tidal-run-line ()
"Send the current line to the interpreter."
(interactive)
;(tidal-get-now)
(let* ((s (buffer-substring (line-beginning-position)
(line-end-position)))
(s* (if tidal-literate-p
(tidal-unlit s)
s)))
(tidal-send-string s*))
(pulse-momentary-highlight-one-line (point))
(forward-line)
)
(defun tidal-eval-multiple-lines ()
"Eval the current region in the interpreter as a single line."
;(tidal-get-now)
(mark-paragraph)
(let* ((s (buffer-substring-no-properties (region-beginning)
(region-end)))
(s* (if tidal-literate-p
(tidal-unlit s)
s)))
(tidal-send-string ":{")
(tidal-send-string s*)
(tidal-send-string ":}")
(mark-paragraph)
(pulse-momentary-highlight-region (mark) (point))))
(defun tidal-detect-d-and-instance ()
"Detect the d and instance number of the current paragraph."
(interactive)
(mark-paragraph)
(let ((start (region-beginning))
(end (region-end)))
(if (re-search-forward "d\\([0-9]+\\)" end t)
(let ((n (string-to-number (match-string 1)))
(i 0)
(found nil))
(flet ((find-next-instance ()
(interactive)
(search-forward (concat "d" (number-to-string n)) nil nil 1)
(setq i (+ i 1))
(if (and (<= start (point)) (< (point) end))
(setq found t))))
(goto-char 0)
(while (not found)
(find-next-instance))
(list n i))))))
(defun tidal-detect-and-register-d-and-instance ()
"Detect the d and instance number of the current paragraph, and register them in tidal-d-instances."
(interactive)
(let ((d-and-instance (tidal-detect-d-and-instance)))
(if d-and-instance
(destructuring-bind (n i) d-and-instance
(tidal-register-d-instance n i)))))
(defun tidal-run-multiple-lines (&optional skip-detect-and-register)
"Send the current region to the interpreter as a single line."
(interactive)
(let ((run (lambda () (interactive)
(if (not skip-detect-and-register) (tidal-detect-and-register-d-and-instance))
(tidal-eval-multiple-lines))))
(if (>= emacs-major-version 25)
(save-mark-and-excursion
(funcall-interactively run))
(save-excursion
(funcall-interactively run)))))
(defun tidal-run-d (n &optional i)
"Send the ith instance of dn to the interpreter as a single line."
(interactive)
(let ((i (or i 1)))
(goto-char 0)
(search-forward (concat "d" (number-to-string n)) nil nil i)
(tidal-run-multiple-lines t)))
(defun tidal-reset-d-instances ()
"Reset tidal-d-instances to default values (instance number 1 for each d)."
(interactive)
(setq tidal-d-instances (tidal-new-d-instances)))
(tidal-reset-d-instances)
(defun tidal-register-d-instance (n i)
"Register i as the instance for dn."
(interactive)
(message "d%d: register instance %d" n i)
(setf (cdr (assoc n tidal-d-instances)) i))
(defun tidal-run-d-instance (n)
"Run the registered dn instance."
(interactive)
(tidal-run-d n (cdr (assoc n tidal-d-instances))))
(defun tidal-register-and-run-d-instance (n &optional i)
"Register i as the instance for dn and run it."
(interactive)
(if i (tidal-register-d-instance n i))
(tidal-run-d-instance n))
(defun tidal-stop-d (n &optional fade)
"Stop dn. If fade > 0, fade out over that many cycles."
(interactive)
(tidal-send-string ":{")
(let* ((fade (or fade 0))
(code (if (< 0 fade)
(concat "fadeOut " (number-to-string n) " " (number-to-string fade))
(concat "($ silence) d" (number-to-string n)))))
(tidal-send-string code))
(tidal-send-string ":}"))
(defun tidal-run-d1 (i)
"Run the registered instance for d1. If the prefix argument is specified, first register it as the instance."
(interactive "P")
(tidal-register-and-run-d-instance 1 i))
(defun tidal-run-d2 (i)
"Run the registered instance for d2. If the prefix argument is specified, first register it as the instance."
(interactive "P")
(tidal-register-and-run-d-instance 2 i))
(defun tidal-run-d3 (i)
"Run the registered instance for d3. If the prefix argument is specified, first register it as the instance."
(interactive "P")
(tidal-register-and-run-d-instance 3 i))
(defun tidal-run-d4 (i)
"Run the registered instance for d4. If the prefix argument is specified, first register it as the instance."
(interactive "P")
(tidal-register-and-run-d-instance 4 i))
(defun tidal-run-d5 (i)
"Run the registered instance for d5. If the prefix argument is specified, first register it as the instance."
(interactive "P")
(tidal-register-and-run-d-instance 5 i))
(defun tidal-run-d6 (i)
"Run the registered instance for d6. If the prefix argument is specified, first register it as the instance."
(interactive "P")
(tidal-register-and-run-d-instance 6 i))
(defun tidal-run-d7 (i)
"Run the registered instance for d7. If the prefix argument is specified, first register it as the instance."
(interactive "P")
(tidal-register-and-run-d-instance 7 i))
(defun tidal-run-d8 (i)
"Run the registered instance for d8. If the prefix argument is specified, first register it as the instance."
(interactive "P")
(tidal-register-and-run-d-instance 8 i))
(defun tidal-run-d9 (i)
"Run the registered instance for d9. If the prefix argument is specified, first register it as the instance."
(interactive "P")
(tidal-register-and-run-d-instance 9 i))
(defun tidal-run-d10 (i)
"Run the registered instance for d10. If the prefix argument is specified, first register it as the instance."
(interactive "P")
(tidal-register-and-run-d-instance 10 i))
(defun tidal-stop-d1 (fade)
"Stop d1. If the prefix argument is specified, fade out over that many cycles."
(interactive "P")
(tidal-stop-d 1 fade))
(defun tidal-stop-d2 (fade)
"Stop d2. If the prefix argument is specified, fade out over that many cycles."
(interactive "P")
(tidal-stop-d 2 fade))
(defun tidal-stop-d3 (fade)
"Stop d3. If the prefix argument is specified, fade out over that many cycles."
(interactive "P")
(tidal-stop-d 3 fade))
(defun tidal-stop-d4 (fade)
"Stop d4. If the prefix argument is specified, fade out over that many cycles."
(interactive "P")
(tidal-stop-d 4 fade))
(defun tidal-stop-d5 (fade)
"Stop d5. If the prefix argument is specified, fade out over that many cycles."
(interactive "P")
(tidal-stop-d 5 fade))
(defun tidal-stop-d6 (fade)
"Stop d6. If the prefix argument is specified, fade out over that many cycles."
(interactive "P")
(tidal-stop-d 6 fade))
(defun tidal-stop-d7 (fade)
"Stop d7. If the prefix argument is specified, fade out over that many cycles."
(interactive "P")
(tidal-stop-d 7 fade))
(defun tidal-stop-d8 (fade)
"Stop d8. If the prefix argument is specified, fade out over that many cycles."
(interactive "P")
(tidal-stop-d 8 fade))
(defun tidal-stop-d9 (fade)
"Stop d9. If the prefix argument is specified, fade out over that many cycles."
(interactive "P")
(tidal-stop-d 9 fade))
(defun tidal-stop-d10 (fade)
"Stop d10. If the prefix argument is specified, fade out over that many cycles."
(interactive "P")
(tidal-stop-d 10 fade))
(defun tidal-run-region ()
"Place the region in a do block and compile."
(interactive)
(tidal-transform-and-store
"/tmp/tidal.hs"
(buffer-substring-no-properties (region-beginning) (region-end)))
(tidal-send-string ":load \"/tmp/tidal.hs\"")
(tidal-send-string "main"))
(defun tidal-load-buffer ()
"Load the current buffer."
(interactive)
(save-buffer)
(tidal-send-string (format ":load \"%s\"" buffer-file-name)))
(defun tidal-run-main ()
"Run current main."
(interactive)
(tidal-send-string "main"))
(defun tidal-interrupt-haskell ()
(interactive)
(if (comint-check-proc tidal-buffer)
(with-current-buffer tidal-buffer
(interrupt-process (get-buffer-process (current-buffer))))
(error "no tidal process running?")))
(defvar tidal-mode-map nil
"Tidal keymap.")
(defun tidal-mode-keybindings (map)
"Haskell Tidal keybindings."
(define-key map [?\C-c ?\C-s] 'tidal-start-haskell)
(define-key map [?\C-c ?\C-v] 'tidal-see-output)
(define-key map [?\C-c ?\C-q] 'tidal-quit-haskell)
(define-key map [?\C-c ?\C-c] 'tidal-run-line)
(define-key map [?\C-c ?\C-e] 'tidal-run-multiple-lines)
(define-key map (kbd "<C-return>") 'tidal-run-multiple-lines)
(define-key map [?\C-c ?\C-r] 'tidal-run-region)
(define-key map [?\C-c ?\C-l] 'tidal-load-buffer)
(define-key map [?\C-c ?\C-i] 'tidal-interrupt-haskell)
(define-key map [?\C-c ?\C-m] 'tidal-run-main)
(define-key map [?\C-c ?\C-1] 'tidal-run-d1)
(define-key map [?\C-c ?\C-2] 'tidal-run-d2)
(define-key map [?\C-c ?\C-3] 'tidal-run-d3)
(define-key map [?\C-c ?\C-4] 'tidal-run-d4)
(define-key map [?\C-c ?\C-5] 'tidal-run-d5)
(define-key map [?\C-c ?\C-6] 'tidal-run-d6)
(define-key map [?\C-c ?\C-7] 'tidal-run-d7)
(define-key map [?\C-c ?\C-8] 'tidal-run-d8)
(define-key map [?\C-c ?\C-9] 'tidal-run-d9)
(define-key map [?\C-v ?\C-1] 'tidal-stop-d1)
(define-key map [?\C-v ?\C-2] 'tidal-stop-d2)
(define-key map [?\C-v ?\C-3] 'tidal-stop-d3)
(define-key map [?\C-v ?\C-4] 'tidal-stop-d4)
(define-key map [?\C-v ?\C-5] 'tidal-stop-d5)
(define-key map [?\C-v ?\C-6] 'tidal-stop-d6)
(define-key map [?\C-v ?\C-7] 'tidal-stop-d7)
(define-key map [?\C-v ?\C-8] 'tidal-stop-d8)
(define-key map [?\C-v ?\C-9] 'tidal-stop-d9))
(defun turn-on-tidal-keybindings ()
"Haskell Tidal keybindings in the local map."
(local-set-key [?\C-c ?\C-s] 'tidal-start-haskell)
(local-set-key [?\C-c ?\C-v] 'tidal-see-output)
(local-set-key [?\C-c ?\C-q] 'tidal-quit-haskell)
(local-set-key [?\C-c ?\C-c] 'tidal-run-line)
(local-set-key [?\C-c ?\C-e] 'tidal-run-multiple-lines)
(local-set-key (kbd "<C-return>") 'tidal-run-multiple-lines)
(local-set-key [?\C-c ?\C-r] 'tidal-run-region)
(local-set-key [?\C-c ?\C-l] 'tidal-load-buffer)
(local-set-key [?\C-c ?\C-i] 'tidal-interrupt-haskell)
(local-set-key [?\C-c ?\C-m] 'tidal-run-main)
(local-set-key [?\C-c ?\C-1] 'tidal-run-d1)
(local-set-key [?\C-c ?\C-2] 'tidal-run-d2)
(local-set-key [?\C-c ?\C-3] 'tidal-run-d3)
(local-set-key [?\C-c ?\C-4] 'tidal-run-d4)
(local-set-key [?\C-c ?\C-5] 'tidal-run-d5)
(local-set-key [?\C-c ?\C-6] 'tidal-run-d6)
(local-set-key [?\C-c ?\C-7] 'tidal-run-d7)
(local-set-key [?\C-c ?\C-8] 'tidal-run-d8)
(local-set-key [?\C-c ?\C-9] 'tidal-run-d9)
(local-set-key [?\C-v ?\C-1] 'tidal-stop-d1)
(local-set-key [?\C-v ?\C-2] 'tidal-stop-d2)
(local-set-key [?\C-v ?\C-3] 'tidal-stop-d3)
(local-set-key [?\C-v ?\C-4] 'tidal-stop-d4)
(local-set-key [?\C-v ?\C-5] 'tidal-stop-d5)
(local-set-key [?\C-v ?\C-6] 'tidal-stop-d6)
(local-set-key [?\C-v ?\C-7] 'tidal-stop-d7)
(local-set-key [?\C-v ?\C-8] 'tidal-stop-d8)
(local-set-key [?\C-v ?\C-9] 'tidal-stop-d9))
(defun tidal-mode-menu (map)
"Haskell Tidal menu."
(define-key map [menu-bar tidal]
(cons "Haskell-Tidal" (make-sparse-keymap "Haskell-Tidal")))
(define-key map [menu-bar tidal help]
(cons "Help" (make-sparse-keymap "Help")))
(define-key map [menu-bar tidal expression]
(cons "Expression" (make-sparse-keymap "Expression")))
(define-key map [menu-bar tidal expression load-buffer]
'("Load buffer" . tidal-load-buffer))
(define-key map [menu-bar tidal expression run-main]
'("Run main" . tidal-run-main))
(define-key map [menu-bar tidal expression run-region]
'("Run region" . tidal-run-region))
(define-key map [menu-bar tidal expression run-multiple-lines]
'("Run multiple lines" . tidal-run-multiple-lines))
(define-key map [menu-bar tidal expression run-line]
'("Run line" . tidal-run-line))
(define-key map [menu-bar tidal haskell]
(cons "Haskell" (make-sparse-keymap "Haskell")))
(define-key map [menu-bar tidal haskell quit-haskell]
'("Quit haskell" . tidal-quit-haskell))
(define-key map [menu-bar tidal haskell see-output]
'("See output" . tidal-see-output))
(define-key map [menu-bar tidal haskell start-haskell]
'("Start haskell" . tidal-start-haskell)))
(unless tidal-mode-map
(let ((map (make-sparse-keymap "Haskell-Tidal")))
(tidal-mode-keybindings map)
(tidal-mode-menu map)
(setq tidal-mode-map map)))
;;;###autoload
(define-derived-mode
literate-tidal-mode
tidal-mode
"Literate Haskell Tidal"
"Major mode for interacting with an inferior haskell process."
(set (make-local-variable 'paragraph-start) "\f\\|[ \t]*$")
(set (make-local-variable 'paragraph-separate) "[ \t\f]*$")
(setq tidal-literate-p t)
(setq haskell-literate 'bird)
(turn-on-font-lock))
;;;###autoload
(add-to-list 'auto-mode-alist '("\\.ltidal$" . literate-tidal-mode))
;;(add-to-list 'load-path "/usr/share/emacs/site-lisp/haskell-mode/") ;required by olig1905 on linux
;;(require 'haskell-mode) ;required by olig1905 on linux
;;;###autoload
(define-derived-mode
tidal-mode
haskell-mode
"Haskell Tidal"
"Major mode for interacting with an inferior haskell process."
(set (make-local-variable 'paragraph-start) "\f\\|[ \t]*$")
(set (make-local-variable 'paragraph-separate) "[ \t\f]*$")
(setq tidal-literate-p nil)
(turn-on-font-lock))
;;;###autoload
(add-to-list 'auto-mode-alist '("\\.tidal$" . tidal-mode))
(provide 'tidal)
;;; tidal.el ends here
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment