(ns shen.install
  (:use [clojure.java.io :only (file reader writer)]
        [clojure.pprint :only (pprint)])
  (:require [clojure.string :as string]
            [shen.primitives])
  (:import [java.io StringReader PushbackReader FileNotFoundException]
           [java.util.regex Pattern])
  (:gen-class))

(def shen-namespaces '[sys writer declarations core load macros prolog reader sequent
                       toplevel track t-star printer yacc types])

(def kl-dir (->> ["../../K Lambda" "shen/klambda"]
                 (map file) (filter #(.exists %)) first))

(def cleanup-symbols-pattern
  (re-pattern (str "(\\s+|\\()("
                   (string/join "|" (map #(Pattern/quote %) [":" ";" "{" "}" ":-" ":="
                                                             "/." "@p" "@s" "@v"
                                                             "shen-@s-macro"
                                                             "shen-@v-help"
                                                             "shen-i/o-macro"
                                                             "shen-put/get-macro"
                                                             "XV/Y"]))
                   ")(\\s*\\)|\\s+?)"
                   "(?!~)")))

(defn cleanup-symbols
  [kl] (string/replace kl
                       cleanup-symbols-pattern
                       "$1(intern \"$2\")$3"))

(defn read-kl [kl]
  (with-open [r (PushbackReader. (StringReader. (cleanup-symbols kl)))]
    (doall
     (take-while (complement nil?)
                 (repeatedly #(read r false nil))))))

(defn read-kl-file [file]
  (try
    (cons `(clojure.core/comment ~(str file)) (read-kl (slurp file)))
    (catch Exception e
      (println file e))))

(defn header [ns]
  `(~'ns ~ns
     (:refer-clojure :only [])
     (:use [shen.primitives])
     (:require [clojure.core :as ~'core])
     (:gen-class)))

(def missing-declarations '#{shen-kl-to-lisp FORMAT READ-CHAR})

(defn declarations [clj]
  (into missing-declarations
        (map second (filter #(= 'defun (first %)) clj))))

(defn write-clj-file [dir name forms]
  (with-open [w (writer (file dir (str name ".clj")))]
    (binding [*out* w]
      (doseq [f forms]
        (pprint f)
        (println)))))

(defn project-version []
  (-> (slurp "project.clj") read-string (nth 2)))

(defn kl-to-clj
  ([] (kl-to-clj kl-dir
                 *compile-path*))
  ([dir to-dir]
     (.mkdirs (file to-dir))
     (let [shen (mapcat read-kl-file
                        (map #(file dir (str % ".kl")) shen-namespaces))
           dcl (declarations shen)]
       (write-clj-file to-dir "shen"
                       (concat [(header 'shen)]
                               [`(clojure.core/declare ~@(filter symbol? dcl))]
                               ['(core/intern 'shen.globals (core/with-meta '*language* {:dynamic true}) "Clojure")]
                               [(concat '(core/intern 'shen.globals (core/with-meta '*port* {:dynamic true}))
                                        [(project-version)])]
                               (map #(shen.primitives/shen-kl-to-clj %)
                                    (remove string? shen))
                               ['(clojure.core/load "shen/overwrite")]
                               ['(core/defn -main [] (shen-shen))])))))

(defn install []
  (try
    (require 'shen)
    (catch FileNotFoundException _
      (println "Creating shen.clj")
      (kl-to-clj))))

(defn swank [port]
  (try
    (require 'swank.swank)
    (with-out-str
      ((resolve 'swank.swank/start-repl) port))
    (println "Swank connection opened on" port)
    (catch FileNotFoundException _)))

(defn -main []
  (install)
  (require 'shen)
  (binding [*ns* (the-ns 'shen)]
    (swank 4005)
    ((resolve 'shen/-main))))

(when *compile-files*
  (install))

(defn repl? []
  (->> (Thread/currentThread) .getStackTrace seq
       (map str) (some (partial re-find #"clojure.main.repl"))))

(when (repl?)
  (-main))

(ns shen
  (:refer-clojure :only [])
  (:use [shen.primitives])
  (:require [clojure.core :as core]))

(set '*language* "Clojure")
(set '*implementation* (core/str "Clojure " (core/clojure-version)
                                          " [jvm "(System/getProperty "java.version")"]"))
(set '*porters* "Håkan Råberg")

(set '*stinput* core/*in*)
(set '*home-directory* (System/getProperty "user.dir"))

(shen-initialise_environment)

(defun
 (intern "@p")
 (V706 V707)
 (core/object-array ['shen-tuple V706 V707]))

(defun
 variable?
 (V702)
 (and (core/symbol? V702) (Character/isUpperCase (.charAt (core/name V702) 0))))

(defun
 boolean?
 (V746)
 (core/condp = V746
             true true
             false true
             (intern "true") true
             (intern "false") true
             false))

(defun
  macroexpand
  (V510)
  (let
      Y
    (shen-compose (core/drop-while core/nil?
                                   (core/map #(core/when-let [m (core/ns-resolve 'shen %)] @m)
                                             (value '*macros*))) V510)
    (if (= V510 Y) V510 (shen-walk macroexpand Y))))

(def ^:private shen-doc
  `((* "number --> number --> number" "Number multiplication.")
    (+ "number --> number --> number" "Number addition.")
    (- "number --> number --> number" "Number subtraction.")
    (/ "number --> number --> number" "Number division.")
    (~(intern "/.") "_" "Abstraction builder, receives a variable and an expression; does the job of --> in the lambda calculus.")
    (< "number --> number --> boolean" "Less than.")
    (<-vector nil nil)
    (<= "number --> number --> boolean" "Less than or equal to.")
    (<e> nil nil)
    (= "A --> A --> boolean" "Equal to.")
    (== "A --> B --> boolean" "Equal to.")
    (> "number --> number --> boolean" "Greater than.")
    (>= "number --> number --> boolean" "Greater than or equal to.")
    (~(intern "@p") "_" "Takes two inputs and forms an ordered pair.")
    (~(intern "@s") "_" "Takes two or more inputs and forms a string.")
    (~(intern "@v") "_" "Takes two or more inputs and forms a vector.")
    (abort nil "throw a simple error")
    (adjoin nil "add arg1 to list arg2 if not already a member")
    (and "boolean --> boolean --> boolean" "Boolean and.")
    (append "(list A) --> (list A) --> (list A)" "Appends two lists into one list.")
    (apply "(A --> B) --> (A --> B)" "Applies a function to an input.")
    (arity nil nil)
    (assoc nil nil)
    (assoc-type "symbol --> variable --> symbol" "Associates a Qi type (first input) with  Lisp type (second input)..")
    (average nil "return the average of two numbers")
    (bind nil nil)
    (boolean? "A --> boolean" "Recognisor for booleans.")
    (bound? nil "check is a symbol is bound")
    (byte->string nil "return the string represented by bytes")
    (call nil nil)
    (cd "string --> string" "Changes the home directory. (cd \"My Programs\") will cause (load \"hello_world.txt\") to load MyPrograms/hello_world.txt.   (cd \"\")  is the default.")
    (character? "A --> boolean" "Recognisor for characters.")
    (compile nil nil)
    (complex? "A --> boolean" "Recognisor for complex numbers.")
    (concat "symbol --> symbol --> symbol" "Concatenates two symbols.")
    (congruent? "A --> A --> boolean" "Retrns true if objects are identical or else if they are strings or characters which are identical differing at most in case or numbers of equal value (e.g. 1 and 1.0) or tuples composed of congruent elements.")
    (cons "_" "A special form that takes an object e of type A and a list l of type (list A) and produces a list of type (list A) by adding e to the front of  l.")
    (cons? "--> boolean" "Returns true iff the input is a non-empty list.")
    (core nil nil)
    (cut nil nil)
    (debug "A --> string" "The input is ignored and debugging is returned; but all terminal output is echoed to the file debug.txt until the undebug function is executed.")
    (declare "_" "Takes a function name f and a type t expressed as a list and gives f the type t.")
    (define "_" "Define a function, takes a name, an optional type and a pattern matching body.")
    (delete-file "string --> string" "The file named in the string is deleted and the string returned.")
    (destroy "_" "Receives the name of a function and removes it and its type from the environment.")
    (difference "(list A) --> (list A) --> (list A)" "Subtracts the elements of the second list from the first")
    (do "_" "A special form: receives n well-typed expressions and evaluates each one, returning the normal form of the last one.")
    (dump "string --> string" "Dumps all user-generated Lisp from the file f denoted by the argument into a file f.lsp.")
    (echo "string --> string" "Echoes all terminal input/output to a file named by string (which is either appended to if it exists or created if not) until the command (echo \"\") is received which switches echo off.")
    (element? "A -> (list A) --> boolean" "Returns true iff the first input is an element in the second.")
    (empty? "--> boolean" "Returns true iff the input is [].")
    (error "_" "A special form: takes a string followed by n (n --> 0) expressions. Prints error string.")
    (eval "_" "Evaluates the input.")
    (explode "A --> (list character)" "Explodes an object to a list of characters.")
    (fail nil nil)
    (fix "(A --> A) --> (A --> A)" "Applies a function to generate a fixpoint.")
    (float? "A --> boolean" "Recognisor for floating point numbers.")
    (floor nil nil)
    (format nil "takes a stream, a format string and args, formats and prints to the stream")
    (freeze "A --> (lazy A)" "Returns a frozen version of its input.")
    (fst "(A * B) --> A" "Returns the first element of a tuple.")
    (fwhen nil nil)
    (gensym "_" "Generates a fresh symbol or variable from a string..")
    (get nil "gets property arg2 from object arg1")
    (get-array "(array A) --> (list number) --> A --> A" "3-place function that takes an array of elements of type A, an index to that array as a list of natural numbers and an expression E of type A.  If an object is stored at the index, then it is returned, otherwise the normal form of E is returned.")
    (get-prop "_" "3-place function that takes a symbol S, a pointer P (which can be a string, symbol or number), and an expression E of any kind and returns the value pointed by P from S  (if one exists) or the normal form of E otherwise.")
    (hash nil "hash an object")
    (hdv nil nil)
    (head "(list A) --> A" "Returns the first element of a list.")
    (identical nil nil)
    (if "boolean --> A --> A" "takes a boolean b and two expressions x and y and evaluates x if b evaluates to true and evaluates y if b evaluates to false.")
    (if-with-checking "string --> (list A)" "If type checking is enabled, raises the string as an error otherwise returns the empty list..")
    (if-without-checking "string --> (list A)" "If type checking is disabled, raises the string as an error otherwise returns the empty list.")
    (include "(list symbol) --> (list symbol)" "Includes the datatype theories or synonyms for use in type checking.")
    (include-all-but "(list symbol) --> (list symbol)" "Includes all loaded datatype theories and synonyms for use in type checking apart from those entered.")
    (inferences "A --> number" "The input is ignored. Returns the number of logical inferences executed since the last call to the top level.")
    (input "_" "0-place function. Takes a user input i and returns the normal form of i.")
    (input+ "_" "Special form. Takes inputs of the form : <expr>. Where d(<expr>) is the type denoted by the choice of expression (e.g. \"number\" denotes the type number). Takes a user input i and returns the normal form of i given i is of the type d(<expr>).")
    (integer? "A --> boolean" "Recognisor for integers.")
    (interror nil nil)
    (intersection "(list A) --> (list A) --> (list A)" "Computes the intersection of two lists.")
    (intmake-string nil nil)
    (intoutput nil nil)
    (lambda "_" "Lambda operator from lambda calculus.")
    (length "(list A) --> integer" "Returns the number of elements in a list.")
    (let nil nil)
    (limit nil nil)
    (lineread "_" "Top level reader of read-evaluate-print loop. Reads elements into a list.  lineread terminates with carriage return when brackets are balanced.  ^ aborts lineread.")
    (list "A .. A --> (list A)" "A special form. Assembles n (n  --> 0) inputs into a list.")
    (load "string --> symbol" "Takes a file name and loads the file, returning loaded as a symbol.")
    (macroexpand nil nil)
    (make-string "string A1 - An --> string" "A special form: takes a string followed by n (n --> 0) well-typed expressions; assembles and returns a string.")
    (map "(A --> B) --> (list A) --> (list B)" "The first input is applied to each member of the second input and the results consed into one list..")
    (mapcan "(A --> (list B)) --> (list A) --> (list B)" "The first input is applied to each member of the second input and the results appended into one list.")
    (maxinferences "number --> number" "Returns the input and as a side-effect, sets a global variable to a number that limits the maximum number of inferences that can be expended on attempting to typecheck a program.  The default is 1,000,000.")
    (mod nil "arg1 mod arg2")
    (newsym "symbol --> symbol" "Generates a fresh symbol from a symbol.")
    (newvar "variable --> variable" "Generates a fresh variable from a variable")
    (nl nil nil)
    (not "boolean --> boolean" "Boolean not.")
    (nth "number --> (list A) --> A" "Gets the nth element of a list numbered from 1.")
    (number? "A --> boolean" "Recognisor for numbers.")
    (occurences "A --> B --> number" "Returns the number of times the first argument occurs in the second.")
    (occurrences nil "returns the number of occurrences of arg1 in arg2")
    (occurs-check "symbol --> boolean" "Receives either + or - and enables/disables occur checking in Prolog,    datatype definitions and rule closures.   The default is +.")
    (opaque "symbol --> symbol" "Applied to a Lisp macro makes it opaque to Qi.")
    (or "boolean -->  (boolean --> boolean)" "Boolean or.")
    (output "string A1 - An --> string" "A special form: takes a string followed by n (n --> 0) well-typed expressions; prints a message to the screen and returns an object of type string (the string \"done\").")
    (preclude "(list symbol) --> (list symbol)" "Removes the mentioned datatype theories and synonyms from use in type checking.")
    (preclude-all-but "(list symbol) --> (list symbol)" "Removes all the datatype theories and synonyms from use in type checking apart from the ones given.")
    (print "A --> A" "Takes an object and prints it, returning it as a result.")
    (profile "(A --> B) --> (A --> B)" "Takes a function represented by a function name and inserts profiling code returning the function as an output.")
    (profile-results "A --> symbol" "The input is ignored.  Returns a list of profiled functions and their     timings since  profile-results was last used.")
    (ps "_" "Receives a symbol  denoting a Qi function and prints the Lisp source    code associated with the function.")
    (put nil "puts value of arg3 as property arg2 in object arg1")
    (put-array "(array A) --> (list number) --> A --> A" "3-place function that takes an array of elements of type A, an index to that array as a list of natural numbers and an expression E of type A.  The normal form of E is stored at that index and then returned.")
    (put-prop "_" "3-place function that takes a symbol S, a pointer P (a string symbol or number), and an expression E. The pointer P is set to point from S to the normal form of E which is then returned.")
    (quit "_" "0-place function that exits Qi.")
    (random "number --> number" "Given a positive number n, generates a random number between 0 and    n-1.")
    (rational? "A --> boolean" "Recognisor for rational numbers.")
    (read nil nil)
    (read-char "A --> character" "The input is discarded and the character typed by the user is returned.")
    (read-chars-as-stringlist "(list character) --> (character -->  boolean) -->  (list string)" "Returns a list of strings whose components are taken from the character list. The second input acts as a tokeniser.  Thus (read-chars-as-stringlist [#\\H #\\i #\\Space #\\P #\\a #\\t]  (/. X (= X #\\Space))) will produce [\"Hi\" \"Pat\"].")
    (read-file "string --> (list unit)" "Returns the contents of an ASCII file designated by a string.  Returns a list of units,  where unit is an unspecified type.")
    (read-file-as-charlist "string --> (list character)" "Returns the list of characters from the contents of an ASCII file designated by a string.")
    (read-file-as-string nil nil)
    (real? "A --> boolean" "Recognisor for real numbers.")
    (remove "A --> (list A) --> (list A)" "Removes all occurrences of an element from a list.")
    (return nil nil)
    (reverse "(list A)--> ?(list A)" "Reverses a list.")
    (round "number--> ?number" "Rounds a number.")
    (save "_" "0 place function. Saves a Qi image.")
    (snd "(A * B) --> B" "Returns the second element of a tuple.")
    (specialise "symbol --> symbol" "Receives the name of a function and turns it into a special form. Special forms are not curried during evaluation or compilation.")
    (speed "number --> number" "Receives a value 0 to 3 and sets the performance of the generated Lisp code, returning its input.  0 is the lowest setting.")
    (spy "symbol --> boolean" "Receives either + or - and respectively enables/disables tracing the    operation of T*.")
    (sqrt "number --> number" "Returns the square root of a number.")
    (step "symbol --> boolean" "Receives either + or - and enables/disables stepping in the trace.")
    (stinput nil nil)
    (string? "A --> boolean" "Recognisor for strings.")
    (strong-warning "symbol --> boolean" "Takes + or -; if + then warnings are treated as error messages.")
    (subst nil nil)
    (sugar "symbol --> (A --> B) --> number --> (A --> B)" "Receives either in or out as first argument, a function f and an integer    greater than 0 and returns f as a result.  The function f is placed on the    sugaring list at a position determined by the number.")
    (sugar-list "symbol --> (list symbol)" "Receives either in or out as first argument, and returns the list of sugar    functions.")
    (sum nil "sum a list of numbers")
    (symbol? "A --> boolean" "Recognisor for symbols.")
    (systemf nil nil)
    (tail "(list A) --> (list A)" "Returns all but the first element of a non-empty list.")
    (tc "symbol --> boolean" "Receives either + or - and respectively enables/disables static typing.")
    (tc? nil "return true if type checking")
    (thaw "(lazy A) --> A" "Receives a frozen input and evaluates it to get the unthawed result..")
    (time "A --> A" "Prints the run time for the evaluation of its input and returns its normal form.")
    (tlv nil nil)
    (track "symbol --> symbol" "Tracks the I/O behaviour of a function.")
    (transparent "symbol --> symbol" "Applied to a Lisp macro makes it transparent to Qi.")
    (tuple? "A --> boolean" "Recognisor for tuples.")
    (type "_" "Returns a type for its input (if any) or false if the input has no type.")
    (unassoc-type "symbol --> symbol" "Removes any associations with the Qi type in the type association table.")
    (undebug "A --> string" "The input is ignored, undebugging is returned and all terminal output is closed to the file debug.txt.")
    (unify nil nil)
    (unify! nil nil)
    (union "(list A) --> (list A) --> (list A)" "Forms the union of two lists.")
    (unprofile "(A --> B) --> (A --> B)" "Unprofiles a function.")
    (unspecialise "symbol --> symbol" "Receives the name of a function and deletes its special form status.")
    (unsugar "symbol --> (A --> B) --> (A --> B)" "Receives either out or in and the name of a function and removes its status as a sugar function.")
    (untrack "symbol --> symbol" "Untracks a function.")
    (value "_" "Applied to a symbol, returns the global value assigned to it.")
    (variable? "A --> boolean" "Applied to a variable, returns true.")
    (vector nil nil)
    (vector-> nil nil)
    (vector? nil nil)
    (version "string --> string" "Changes the version string displayed on startup.")
    (warn "string --> string" "Prints the string as a warning and returns \"done\".  See strong-warning")
    (write-to-file "string --> A --> string" "Writes the second input into a file named in the first input. If the file does not exist, it is created, else it is overwritten. If the second input is a string then it is written to the file without the enclosing quotes.  The first input is returned.")
    (y-or-n? "string --> boolean" "Prints the string as a question and returns true for y and false for n.")))

(core/doseq [[fn sig doc] shen-doc
             :let [v (core/resolve fn)]
             :when v]
            (core/alter-meta! v core/merge {:doc doc
                                            :arglists (core/list (core/read-string (core/str "[" sig "]")))}))

(ns shen.primitives
  (:require [clojure.core :as core]
            [clojure.set :as set]
            [clojure.string :as string]
            [clojure.walk :as walk]
            [clojure.java.io :as io])
  (:refer-clojure :exclude [set intern let pr type cond cons str number? string? defmacro
                            + - * / > < >= <= = and or])
  (:import [java.io Reader Writer InputStream OutputStream PrintWriter OutputStreamWriter]
           [java.util Arrays])
  (:gen-class))

(create-ns 'shen.globals)

(def string? core/string?)
(def number? core/number?)

(core/defmacro and
  ([x] `(fn [y#] (core/and ~x y#)))
  ([x & xs] `(core/and ~x ~@xs)))

(core/defmacro or
  ([x] `(fn [y#] (core/or ~x y#)))
  ([x & xs] `(core/or ~x ~@xs)))

(defn ^:private and-fn
  ([x] (and x))
  ([x y] (and x y)))

(defn ^:private or-fn
  ([x] (or x))
  ([x y] (or x y)))

(defn ^:private partials [name parameters]
  (for [p (map #(take % parameters) (range 1 (count parameters)))]
    `(~(vec p) (partial ~name ~@p))))

(core/defmacro defun [F X & Y]
  (core/let [F (if (seq? F) (eval F) F)]
            `(do
               (defn ^:dynamic ~F
                 ~@(partials F X)
                 (~(vec X) ~@Y))
               ~F)))

(def ^:private array-class (Class/forName "[Ljava.lang.Object;"))

(defn =
  ([X] (partial = X))
  ([X Y]
     (core/cond
      (and (identical? array-class (class X))
           (identical? array-class (class Y))) (Arrays/equals #^"[Ljava.lang.Object;" X
                                                              #^"[Ljava.lang.Object;" Y)
           (and (number? X) (number? Y)) (== X Y)
           :else (core/= X Y))))

(defn /
  ([X] (partial / X))
  ([X Y] (core/let [r (clojure.core// X Y)]
                   (if (ratio? r) (double r) r))))

(defn ^:private alias-op [op real-op]
  (eval `(defun ~op ~'[X Y] (~real-op ~'X ~'Y))))

(doseq [op '[+ - *]]
  (alias-op op (symbol "clojure.core" (core/str (name op) "'"))))

(doseq [op '[> < >= <=]]
  (alias-op op (symbol "clojure.core" (name op))))

(defn ^:private interned? [X]
  (and (seq? X) (= 'intern (first X))))

(def ^:private slash-dot (symbol "/."))

(defn ^:private recur?
  ([path] (partial recur? path))
  ([path fn]
     (or (= 'cond (last (drop-last path)))
         (set/superset? '#{defun cond if do let}
                        (core/set path)))))

(defn ^:private maybe-apply [kl path]
  (if (= 'cond (last path)) kl
      (list 'function kl)))

(defn shen-kl-to-clj
  ([kl] (shen-kl-to-clj kl #{} [] :unknown))
  ([kl scope] (shen-kl-to-clj kl scope [] :no-recur))
  ([kl scope path fn]
     (condp some [kl]
       scope kl
       symbol? (condp = (name kl)
                 "true" true
                 "false" false
                 (list 'quote kl))
       seq? (core/let [[fst snd trd & rst] kl
                       fn (if ('#{defun} fst) snd
                              fn)
                       scope (condp get fst
                               '#{defun} (into scope trd)
                               '#{let lambda} (conj scope snd)
                               scope)
                       fst (condp some [fst]
                             (every-pred
                              #{fn}
                              (recur? path)) 'recur
                             (some-fn
                              interned?
                              scope) (maybe-apply fst path)
                              seq? (maybe-apply (shen-kl-to-clj fst scope) path)
                              (if (= 'cond (last path))
                                (shen-kl-to-clj fst scope)
                                fst))
                       path (conj path fst)
                       snd (condp get fst
                             '#{defun let lambda} snd
                             '#{if} (shen-kl-to-clj snd scope)
                             (shen-kl-to-clj snd scope path fn))
                       trd (condp get fst
                             '#{defun} trd
                             '#{let} (shen-kl-to-clj trd scope)
                             (shen-kl-to-clj trd scope path fn))]
                      (take-while (complement nil?)
                                  (concat [fst snd trd]
                                          (map #(shen-kl-to-clj % scope path fn) rst))))
       kl)))

(defn intern [String]
  (symbol (condp = String
            "/" "/"
            "/." slash-dot
            (string/replace String "/" "-slash-"))))

(core/defmacro cond [& CS]
  `(core/cond ~@(apply concat CS)))

(defn set* [X Y ns]
  @(core/intern (the-ns ns)
                (with-meta X {:dynamic true :declared true})
                Y))

(defn set
  ([X] (partial set X))
  ([X Y] (set* X Y 'shen.globals)))

(defn ^:private value* [X ns]
  (core/let [v (and (symbol? X) (ns-resolve ns X))]
            (condp = X
              'and and-fn
              'or or-fn
              @v)))

(defn value [X] (value* X 'shen.globals))

(defn function [fn]
  (if (fn? fn) fn
      (value* fn 'shen)))

(defn simple-error [String]
  (throw (RuntimeException. ^String String)))

(core/defmacro trap-error [X F]
  `(try
     ~X
     (catch Exception e#
       (~F e#))))

(defn error-to-string [E]
  (if (instance? Throwable E)
    (or (.getMessage ^Throwable E) (core/str E))
    (throw (IllegalArgumentException. ^String (core/str E " is not an exception")))))

(defn ^:private pair [X Y] [X Y])

(defn ^:private pair? [X]
  (and (vector? X) (= 2 (count X))))

(defn cons [X Y]
  (if (and (coll? Y)
           (not (pair? Y)))
    (core/cons X Y)
    (pair X Y)))

(defn hd [X] (first X))

(defn tl [X]
  (if (pair? X)
    (second X)
    (rest X)))

(defn fail! [] (assert false))

(defn cons? [X]
  (and (coll? X) (not (empty? X))))

(defn str [X]
  (if-not (coll? X) (core/pr-str X)
          (throw (IllegalArgumentException.
                  (core/str X " is not an atom; str cannot convert it to a string.")))))

(defn ^:private vec-to-cons [[fst & rst]]
  (if fst (list 'cons fst (vec-to-cons rst))
      ()))

(defn ^:private cleanup-clj [clj]
  (condp some [clj]
    vector? (recur (vec-to-cons clj))
    coll? (if ('#{clojure.core/deref} (first clj))
            (symbol (core/str "@" (second clj)))
            clj)
    '#{λ} slash-dot
    char? (intern clj)
    clj))

(defn ^:private define* [name body]
  (core/let [kl ((function 'shen-shen->kl) name body)]
            (binding [*ns* (the-ns 'shen)]
              ((function 'eval) kl)
              name)))

(defn ^:private shen-elim-define [X]
  (if (seq? X)
    (if ('#{define} (first X)) (define* (second X) (drop 2 X))
        (map shen-elim-define X))
    X))

(defn eval-shen* [body]
  (core/let [body (walk/postwalk cleanup-clj body)]
            (binding [*ns* (the-ns 'shen)]
              (->> body
                   (map (function 'eval))
                   last))))

(core/defmacro eval-shen [& body]
  `(eval-shen* '~body))

(core/defmacro 神 [& body]
  `(eval-shen ~@body))

(core/defmacro define [name & body]
  `(core/let [fn# (eval-shen ~(concat ['define name] body))]
             (defn ~(with-meta name {:dynamic true})
               [& ~'args] (apply (function fn#) ~'args))))

(doseq [[name args] '{defmacro [name] defprolog [name] prolog? [] package [name exceptions]}]
  (eval
   `(core/defmacro ~name [~@args & ~'body]
      `(eval-shen ~(concat ['~name ~@args] ~'body)))))

(def ^:private missing-symbol-pattern #"Unable to resolve symbol: (.+) in this context")

(defn ^:private missing-symbol [s]
  (when-let [[_ sym] (re-find missing-symbol-pattern (or s ))] sym))

(defn ^:private fn-to-symbol [fn]
  (-> fn class .getName
      (string/replace "_" "-")
      (string/split #"\$")
      last symbol))

(defn ^:private cleanup-return [x]
  (or (when (fn? x)
        (core/let [name (fn-to-symbol x)]
                  (when (fn? (ns-resolve 'shen name)) name)))
      x))

(defn ^:private eval-and-declare-missing [kl]
  (binding [*ns* (the-ns 'shen)]
    (try
      (cleanup-return (eval kl))
      (catch RuntimeException e
        (if-let [s (missing-symbol (.getMessage e))]
          (do
            (set* (symbol s) nil 'shen)
            (eval-and-declare-missing kl))
          (throw e))))))

(defn eval-without-macros [X]
  (core/let [kl (shen-kl-to-clj (shen-elim-define (cleanup-clj X)))]
            (eval-and-declare-missing kl)))

(core/defmacro lambda [X Y]
  `(fn [~X & XS#] (core/let [result# ~Y]
                            (if XS# (apply result# XS#)
                                result#))))

(core/defmacro λ [X Y]
  `(lambda ~X ~Y))

(core/defmacro let [X Y Z]
  (core/let [X-safe (if (seq? X) (gensym (eval X)) X)
             Z (if (seq? X) (walk/postwalk
                             #(if (= X %) X-safe %) Z) Z)]
            `(core/let [~X-safe ~Y]
                       ~Z)))

(core/defmacro freeze [X]
 `(fn [] ~X))

(defn thaw [X] (X))

(defn absvector [N]
  (doto (object-array (int N)) (Arrays/fill 'fail!)))

(defn absvector? [X]
  (identical? array-class (core/class X)))

(defn <-address [#^"[Ljava.lang.Object;" Vector N]
  (aget Vector (int N)))

(defn address-> [#^"[Ljava.lang.Object;" Vector N Value]
  (aset Vector (int N) Value)
  Vector)

(defn n->string [N]
  (core/str (char N)))

(defn string->n [S]
  (core/int (first S)))

(def byte->string n->string)

(defmulti pr (fn [_ S] (class S)))

(defmethod pr Reader [X ^Reader S]
  (if (= *in* S)
    (pr X *out*)
    (throw (IllegalArgumentException. (str S)))))

(defmethod pr OutputStream [X ^OutputStream S]
  (pr X (OutputStreamWriter. S)))

(defmethod pr Writer [X ^Writer S]
  (binding [*out* S]
    (print X)
    (flush)
    X))

(defmulti read-byte class)

(defmethod read-byte InputStream [^InputStream S]
  (.read S))

(defmethod read-byte Reader [^Reader S]
  (.read S))

(defn open [Type String Direction]
  (condp = Type
    'file
    (core/let [Path (io/file (value '*home-directory*) String)]
              (condp = Direction
                'in (io/input-stream Path)
                'out (io/output-stream Path)
                (throw (IllegalArgumentException. "invalid direction"))))
    (throw (IllegalArgumentException. "invalid stream type"))))

(defn type [X MyType]
  (cast MyType X))

(defn close [^java.io.Closeable Stream]
  (.close Stream))

(defn pos [X N]
  (core/str (get X N)))

(defn tlstr [X]
  (subs X 1))

(defn cn
  ([Str1] (partial cn Str1))
  ([Str1 Str2]
     (core/let [strings (replace {() } [Str1 Str2])]
               (when-let [no-string (first (remove string? strings))]
                 (throw (IllegalArgumentException. (core/str no-string " is not a string"))))
               (apply core/str strings))))

(def ^:private internal-start-time (System/currentTimeMillis))

(defn get-time [Time]
  (if (= Time 'run)
    (/ (- (System/currentTimeMillis) internal-start-time) 1000)
    (throw (IllegalArgumentException.
            (core/str "get-time does not understand the parameter " Time)))))

(defmethod print-method array-class [o ^Writer w]
  (print-method (vec o) w))

(defn ^:private read-bytes [s]
  ((function (intern "@p")) (map int s) ()))

(defn parse-shen [s]
  (core/let [<st_input> (function 'shen-<st_input>)
             snd (function 'snd)]
            (-> s read-bytes <st_input> snd)))

(defn parse-and-eval-shen [s]
  (eval-shen* (parse-shen s)))

(defn reset-macros! []
  (set '*macros* (filter #(re-find #"shen-" (name %)) (value '*macros*))))

(defn exit
  ([] (exit 0))
  ([status] (System/exit status)))