001  (ns beowulf.reader.simplify
002    "Simplify parse trees. Be aware that this is very tightly coupled
003     with the parser."
004    (:require [beowulf.oblist :refer [*options*]]
005              [instaparse.failure :as f])
006    (:import [instaparse.gll Failure]))
007  
008  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
009  ;;;
010  ;;; Copyright (C) 2022-2023 Simon Brooke
011  ;;;
012  ;;; This program is free software; you can redistribute it and/or
013  ;;; modify it under the terms of the GNU General Public License
014  ;;; as published by the Free Software Foundation; either version 2
015  ;;; of the License, or (at your option) any later version.
016  ;;; 
017  ;;; This program is distributed in the hope that it will be useful,
018  ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
019  ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
020  ;;; GNU General Public License for more details.
021  ;;; 
022  ;;; You should have received a copy of the GNU General Public License
023  ;;; along with this program; if not, write to the Free Software
024  ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
025  ;;;
026  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
027  
028  (declare simplify-tree)
029  
030  (defn remove-optional-space
031    [tree]
032    (if (vector? tree)
033      (if (= :opt-space (first tree))
034        nil
035        (let [v (remove nil?
036                        (map remove-optional-space tree))]
037          (if (seq v)
038            (apply vector v)
039            v)))
040      tree))
041  
042  (defn remove-nesting
043    [tree context]
044    (let [tree' (remove-optional-space tree)]
045      (if-let [key (when (and (vector? tree') 
046                              (keyword? (first tree'))) 
047                     (first tree'))]
048        (loop [r tree']
049          (if (and r (vector? r) (keyword? (first r)))
050            (if (= (first r) key)
051              (recur (simplify-tree (second r) context))
052              r)
053            r))
054        tree')))
055  
056  (defn simplify-tree
057    "Simplify this parse tree `p`. If `p` is an instaparse failure object, throw
058     an `ex-info`, with `p` as the value of its `:failure` key.
059     
060     **NOTE THAT** it is assumed that `remove-optional-space` has been run on the
061     parse tree **BEFORE** it is passed to `simplify-tree`."
062    ([p]
063     (if
064      (instance? Failure p)
065       (throw (ex-info
066               (str "Ic ne behæfd: " (f/pprint-failure p))
067               {:cause :parse-failure
068                :phase   :simplify
069                :failure p}))
070       (simplify-tree p :expr)))
071    ([p context]
072     (cond
073       (string? p) p
074       (coll? p) (apply
075                  vector
076                  (remove
077                   #(when (coll? %) (empty? %))
078                   (case (first p)
079                     (:λexpr
080                      :args :bindings :body :cond :cond-clause :defn :dot-terminal 
081                      :fncall :lhs :quoted-expr :rhs ) (map #(simplify-tree % context) p)
082                     (:arg :expr :coefficient :fn-name :number) (simplify-tree (second p) context)
083                     (:arrow :dot :e :lpar :lsqb  :opt-comment :opt-space :q :quote :rpar :rsqb
084                             :semi-colon :sep :space) nil
085                     :atom (if
086                            (= context :mexpr)
087                             [:quoted-expr p]
088                             p)
089                     :comment (when
090                               (:strict *options*)
091                                (throw
092                                 (ex-info "Cannot parse comments in strict mode"
093                                          {:cause :strict})))
094                     (:decimal :integer :mconst :octal :scientific) p
095                     :dotted-pair (if
096                                   (= context :mexpr)
097                                    [:fncall
098                                     [:mvar "cons"]
099                                     [:args
100                                      (simplify-tree (nth p 1) context)
101                                      (simplify-tree (nth p 2) context)]]
102                                    (map #(simplify-tree % context) p))
103                     :iexp (simplify-tree (second p) context)
104                     :iexpr [:iexpr
105                             [:lhs (simplify-tree (second p) context)]
106                             (simplify-tree (nth p 2) context) ;; really should be the operator
107                             [:rhs (simplify-tree (nth p 3) context)]]
108                     :mexpr (if
109                             (:strict *options*)
110                              (throw
111                               (ex-info "Cannot parse meta expressions in strict mode"
112                                        {:cause :strict}))
113                              [:mexpr (simplify-tree (second p) :mexpr)])
114                     :list (if
115                            (= context :mexpr)
116                             [:fncall
117                              [:mvar "list"]
118                              [:args (apply vector (map simplify-tree (rest p)))]]
119                             (map #(simplify-tree % context) p))
120                     :raw (first (remove empty? (map simplify-tree (rest p))))
121                     :sexpr [:sexpr (simplify-tree (second p) :sexpr)]
122            ;;default
123                     p)))
124       :else p)))
125  
126  (defn simplify
127    "Simplify this parse tree `p`. If `p` is an instaparse failure object, throw
128     an `ex-info`, with `p` as the value of its `:failure` key. Calls 
129     `remove-optional-space` before processing."
130    [p]
131    (simplify-tree (remove-optional-space p)))