Demonstration

Running ghcih inside neovim inside emacs

asciinema recording

Create the ghcih script

1
2
3
4
5
6
#!/bin/bash
export TTY

( hs "$(basename "$0")" "$@" "#" "<==" "$(ps -o comm= $PPID)" 0</dev/null ) &>/dev/null

xs ghci -H "$@"

Create the ghci case in xs

When -H is provided, it will split the input code by assuming that the initial part is a haskell module and anything from the first ghci : command and onwards is ghci code.

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
hs|ghci) {
    while [ $# -gt 0 ]; do opt="$1"; case "$opt" in
        "") { shift; }; ;;
        -H) {
            # interpret the starting code as a haskell module to be
            # loaded instead
            hybrid=y
            shift
        }
        ;;

        *) break;
    esac; done

    cmd="$1"
    shift

    if stdin_exists; then
        tfghciin="$(cat | tf ghci)"
        cmd="$tfghciin" # a file path
    else
        : ${cmd:="foldl (/) 64 [4,2,4]"}
    fi

    # x -cd "$(pwd)" -sh "ghci" -r "^.*[^ ]>" -s "$cmd" -c m "$@" -o

    exec <&1
    # echo "$cmd" 1>&2
    # exit 0

    if test -n "$cmd"; then
        if test -f "$cmd"; then
            if test "$hybrid" = "y"; then
                tfhsin="$(cat "$cmd" | sed '/^:/{d;q}' | tf hs)"
                sed -i -n '/^:/,$p' "$cmd"
                # incmd="-s $(aqf ":load $tfhsin") -c m -e $(aqf "module loaded") -sf $(aqf "$cmd")"

                {
                    echo ":load $tfhsin"
                    cat "$cmd"
                } | sponge "$cmd"
            fi
            incmd="-sf $(aqf "$cmd")"
        else
            incmd="-s $(aqf "$cmd")"
        fi
    fi

    # Unfortunately, piping into ghci quits when finished, therefore we need
    # expect.
    # echo :t 5 | ghciol

    is_tty() {
        # If stout is a tty
        [[ -t 1 ]]
    }

    if is_tty; then
        fullcmd="x -cd \"$(pwd)\" -sh \"ghci\" -r \"^.*[^ ]>\" $incmd -c m \"\$@\" -a"
    else
        if test -f "$cmd"; then
            ghci -v0 < "$cmd"
        fi
    fi
    # vim
    # echo "$fullcmd" | tv &>/dev/null
    # exit 0
    eval "$fullcmd"
}
;;

The following should now work

Split the terminal and start a ghci with the module loaded and ghci commands entered

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
data JsonValue
  = JsonNull
  | JsonBool Bool
  | JsonNumber Integer -- NOTE: no support for floats
  | JsonString String
  | JsonArray [JsonValue]
  | JsonObject [(String, JsonValue)]
  deriving (Show, Eq)

newtype Parser a = MkParser
  { runParser :: String -> Maybe (String, a)
  }

jsonValue :: Parser JsonValue
jsonValue = undefined

:t runParser
-- runParser :: Parser a -> String -> Maybe (String, a)

:t runParser jsonValue
-- runParser jsonValue :: String -> Maybe (String, JsonValue)

:t runParser jsonValue "hello"
-- runParser jsonValue "hello" :: Maybe (String, JsonValue)

Run all commands by piping into ghci and placing the output into the org document

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
data JsonValue
  = JsonNull
  | JsonBool Bool
  | JsonNumber Integer -- NOTE: no support for floats
  | JsonString String
  | JsonArray [JsonValue]
  | JsonObject [(String, JsonValue)]
  deriving (Show, Eq)

newtype Parser a = MkParser
  { runParser :: String -> Maybe (String, a)
  }

jsonValue :: Parser JsonValue
jsonValue = undefined

:t runParser
-- runParser :: Parser a -> String -> Maybe (String, a)

:t runParser jsonValue
-- runParser jsonValue :: String -> Maybe (String, JsonValue)

:t runParser jsonValue "hello"
-- runParser jsonValue "hello" :: Maybe (String, JsonValue)
runParser :: Parser a -> String -> Maybe (String, a)
runParser jsonValue :: String -> Maybe (String, JsonValue)
runParser jsonValue "hello" :: Maybe (String, JsonValue)

Everything that from the first ghci command onwards should go into the ghci file. The rest should be compiled as a haskell module and loaded.

Demonstration

Running intermixed haskell and ghci code

asciinema recording

Babel with term-mode

In order to get babel working with term, I had to provide new parameters to the babel interpreter

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
modified   config/my-babel.el
@@ -39,7 +39,9 @@
   ":interpreter executes body like 'interpreter file'
 :interpreter filters the source like 'cat source | filter'"
   (let ((interpreter (or (cdr (assoc :interpreter params))
-                         (cdr (assoc :i params))))
+                         (cdr (assoc :i params))
+                         (cdr (assoc :sph params))
+                         (cdr (assoc :esph params))))
         (filter (or (cdr (assoc :filter params))
                     (cdr (assoc :f params))))
         (tmp (org-babel-temp-file "generic-")))
@@ -49,8 +51,12 @@
     (if (and (boundp 'filter) filter)
         (setq filter (concat "| " filter))
       (setq filter ""))
+
     ;; The str here are not superfluous. They check for nil
-    (shell-command-to-string (format "%s %s %s" (str interpreter) (str tmp) (str filter)))))
+    (let ((cmd (format "%s %s %s" (str interpreter) (str tmp) (str filter))))
+      (cond ((assoc :sph params) (sph cmd))
+            ((assoc :esph params) (sph-term cmd))
+            (t (shell-command-to-string cmd))))))

 (defun org-babel-execute-src-block (&optional arg info params)
   "Execute the current source code block.
@@ -80,7 +86,9 @@ block."
       (cl-callf org-babel-process-params (nth 2 info))
       (let* ((params (nth 2 info))
              (interpreter (or (cdr (assq :interpreter params))
-                              (cdr (assq :i params))))
+                              (cdr (assq :i params))
+                              (cdr (assq :sph params))
+                              (cdr (assq :esph params))))
              (filter (or (cdr (assq :filter params))
                          (cdr (assq :f params))))
              (cache (let ((c (cdr (assq :cache params))))

Highlighting for ghci commands

I changed this line to add ghci commands.

It’s the :[a-z] at the start.

1
("^\\(?::[a-z]+\\|#\\(?:[^\\\n]\\|\\\\\\(?:.\\|\n\\|\\'\\)\\)*\\(?:\n\\|\\'\\)\\)" 0 'font-lock-preprocessor-face t)
  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
;; Run this after redefining
;; (haskell-font-lock-defaults-create)
(defun haskell-font-lock-keywords ()
  ;; this has to be a function because it depends on global value of
  ;; `haskell-font-lock-symbols'
  "Generate font lock eywords."
  (let* (;; Bird-style literate scripts start a line of code with
         ;; "^>", otherwise a line of code starts with "^".
         (line-prefix "^\\(?:> ?\\)?")

         (varid "[[:lower:]_][[:alnum:]'_]*")
         ;; We allow ' preceding conids because of DataKinds/PolyKinds
         (conid "'?[[:upper:]][[:alnum:]'_]*")
         (sym "\\s.+")

         ;; Top-level declarations
         (topdecl-var
          (concat line-prefix "\\(" varid "\\(?:\\s-*,\\s-*" varid "\\)*" "\\)"
                  ;; optionally allow for a single newline after identifier
                  "\\(\\s-+\\|\\s-*[\n]\\s-+\\)"
                  ;; A toplevel declaration can be followed by a definition
                  ;; (=), a type (::) or (โˆท), a guard, or a pattern which can
                  ;; either be a variable, a constructor, a parenthesized
                  ;; thingy, or an integer or a string.
                  "\\(" varid "\\|" conid "\\|::\\|โˆท\\|=\\||\\|\\s(\\|[0-9\"']\\)"))
         (topdecl-var2
          (concat line-prefix "\\(" varid "\\|" conid "\\)\\s-*`\\(" varid "\\)`"))
         (topdecl-bangpat
          (concat line-prefix "\\(" varid "\\)\\s-*!"))
         (topdecl-sym
          (concat line-prefix "\\(" varid "\\|" conid "\\)\\s-*\\(" sym "\\)"))
         (topdecl-sym2 (concat line-prefix "(\\(" sym "\\))"))

         keywords)

    (setq keywords
          `(;; NOTICE the ordering below is significant
            ;;\\(?:ghci> \\)?
            ("^\\(?:[ \t]*\\(?:ghci> :[a-z]+\\|ghci> \\|:[a-z]+\\)\\|#\\(?:[^\\\n]\\|\\\\\\(?:.\\|\n\\|\\'\\)\\)*\\(?:\n\\|\\'\\)\\)" 0 'font-lock-preprocessor-face t)

            ,@(haskell-font-lock-symbols-keywords)

            ;; Special case for `as', `hiding', `safe' and `qualified', which are
            ;; keywords in import statements but are not otherwise reserved.
            ("\\<import[ \t]+\\(?:\\(safe\\>\\)[ \t]*\\)?\\(?:\\(qualified\\>\\)[ \t]*\\)?\\(?:\"[^\"]*\"[\t ]*\\)?[^ \t\n()]+[ \t]*\\(?:\\(\\<as\\>\\)[ \t]*[^ \t\n()]+[ \t]*\\)?\\(\\<hiding\\>\\)?"
             (1 'haskell-keyword-face nil lax)
             (2 'haskell-keyword-face nil lax)
             (3 'haskell-keyword-face nil lax)
             (4 'haskell-keyword-face nil lax))

            ;; Special case for `foreign import'
            ;; keywords in foreign import statements but are not otherwise reserved.
            ("\\<\\(foreign\\)[ \t]+\\(import\\)[ \t]+\\(?:\\(ccall\\|stdcall\\|cplusplus\\|jvm\\|dotnet\\)[ \t]+\\)?\\(?:\\(safe\\|unsafe\\|interruptible\\)[ \t]+\\)?"
             (1 'haskell-keyword-face nil lax)
             (2 'haskell-keyword-face nil lax)
             (3 'haskell-keyword-face nil lax)
             (4 'haskell-keyword-face nil lax))

            ;; Special case for `foreign export'
            ;; keywords in foreign export statements but are not otherwise reserved.
            ("\\<\\(foreign\\)[ \t]+\\(export\\)[ \t]+\\(?:\\(ccall\\|stdcall\\|cplusplus\\|jvm\\|dotnet\\)[ \t]+\\)?"
             (1 'haskell-keyword-face nil lax)
             (2 'haskell-keyword-face nil lax)
             (3 'haskell-keyword-face nil lax))

            ;; Special case for `type family' and `data family'.
            ;; `family' is only reserved in these contexts.
            ("\\<\\(type\\|data\\)[ \t]+\\(family\\>\\)"
             (1 'haskell-keyword-face nil lax)
             (2 'haskell-keyword-face nil lax))

            ;; Special case for `type role'
            ;; `role' is only reserved in this context.
            ("\\<\\(type\\)[ \t]+\\(role\\>\\)"
             (1 'haskell-keyword-face nil lax)
             (2 'haskell-keyword-face nil lax))

            ;; Toplevel Declarations.
            ;; Place them *before* generic id-and-op highlighting.
            (,topdecl-var  (1 (unless (member (match-string 1) haskell-font-lock-keywords)
                                'haskell-definition-face)))
            (,topdecl-var2 (2 (unless (member (match-string 2) haskell-font-lock-keywords)
                                'haskell-definition-face)))
            (,topdecl-bangpat  (1 (unless (member (match-string 1) haskell-font-lock-keywords)
                                    'haskell-definition-face)))
            (,topdecl-sym  (2 (unless (member (match-string 2) '("\\" "=" "->" "โ†’" "<-" "โ†" "::" "โˆท" "," ";" "`"))
                                'haskell-definition-face)))
            (,topdecl-sym2 (1 (unless (member (match-string 1) '("\\" "=" "->" "โ†’" "<-" "โ†" "::" "โˆท" "," ";" "`"))
                                'haskell-definition-face)))

            ;; These four are debatable...
            ("(\\(,*\\|->\\))" 0 'haskell-constructor-face)
            ("\\[\\]" 0 'haskell-constructor-face)

            ("`"
             (0 (if (or (elt (syntax-ppss) 3) (elt (syntax-ppss) 4))
                    (parse-partial-sexp (point) (point-max) nil nil (syntax-ppss)
                                        'syntax-table)
                  (when (save-excursion
                          (goto-char (match-beginning 0))
                          (haskell-lexeme-looking-at-backtick))
                    (goto-char (match-end 0))
                    (unless (text-property-not-all (match-beginning 1) (match-end 1) 'face nil)
                      (put-text-property (match-beginning 1) (match-end 1) 'face 'haskell-operator-face))
                    (unless (text-property-not-all (match-beginning 2) (match-end 2) 'face nil)
                      (put-text-property (match-beginning 2) (match-end 2) 'face 'haskell-operator-face))
                    (unless (text-property-not-all (match-beginning 4) (match-end 4) 'face nil)
                      (put-text-property (match-beginning 4) (match-end 4) 'face 'haskell-operator-face))
                    (add-text-properties
                     (match-beginning 0) (match-end 0)
                     '(font-lock-fontified t fontified t font-lock-multiline t))))))

            (,haskell-lexeme-idsym-first-char
             (0 (if (or (elt (syntax-ppss) 3) (elt (syntax-ppss) 4))
                    (parse-partial-sexp (point) (point-max) nil nil (syntax-ppss)
                                        'syntax-table)
                  (when (save-excursion
                          (goto-char (match-beginning 0))
                          (haskell-lexeme-looking-at-qidsym))
                    (goto-char (match-end 0))
                    ;; note that we have to put face ourselves here because font-lock
                    ;; will use match data from the original matcher
                    (haskell-font-lock--put-face-on-type-or-constructor)))))))
    keywords))

;; Update the faces
(haskell-font-lock-defaults-create)

Also set the preprocessor face

1
2
;; ghci commands, c++ #include, etc.
(set-face-background 'font-lock-preprocessor-face "#550055")

Plus you can make constructors look nice.

1
(set-face-background 'haskell-constructor-face "#222222")