ludus/janet/parser.janet

### in repl, make sure to (os/cwd) into the janet dir
(import ./clj-loop :prefix "")

(defn ? [val default] (if (nil? val) default val))

(defn ok? [{:status status}]
 	(= status :ok))

(def failing {:err true :none true})

(def passing {:ok true :group true :quiet true})

(defn pass? [{:status status}] (get passing status))

(defn fail? [{:status status}] (get failing status))

(defn data [{:data d}] d)

(defn remaining [{:remaining r}] r)

(defn pname [parser] (? (get parser :name) parser))

(defn kw+str [kw mystr] (keyword (string kw) mystr))

(defn value [token]
 	(if (= :none (get token :literal)) (get token :lexeme) (get token :literal)))

(defn rest [seq]
 (let [len (length seq)]
   (cond
     (empty? seq) []
     (tuple? seq) (tuple/slice 1 len)
     (array? seq) (array/slice 1 len))))

(defn some? [val] (not (nil? val)))

(defn apply-kw-parser [kw tokens]
 	(let [token (first tokens)]
  		#(if (= kw (get token :type)) (println "Matched " kw))
  		(if (= kw (get token :type))
   			@{:status :ok 
   				:type kw 
   				:data (if (some? (value token)) @[(value token)] @[])
   				:token token 
   				:remaining (rest tokens)}
   			@{:status :none :token token :trace [kw] :remaining (rest tokens)})))

(defn apply-fn-parser [parser tokens]
 	(let [rule (get parser :rule) name (get parser :name) result (rule tokens)]
  		#(if (pass? result) (println "Matched " (get parser :name)))
  		result))

(defn apply-parser [parser tokens]
 	#(println "Applying parser " (? (get parser :name) parser))
 	(let [result (cond 
               		(keyword? parser) (apply-kw-parser parser tokens)
               		(get parser :rule) (apply-fn-parser parser tokens)
               		(function? parser) (apply-fn-parser (parser) tokens)
               		:else (error "`apply-parser` requires a parser"))]
  		#(println "Parser result " (? (get parser :name) parser) (get result :status))
  		result
   	))


(defn choice [name parsers]
 	{:name name
 		:rule (fn choice-fn [tokens]
            (clj-loop [ps parsers]
          			(let [result (apply-parser (first ps) tokens) 
               				rem-ts (remaining result)
               				rem-ps (rest ps)]
         						(cond
          							(pass? result)
          							{:status :ok :type name :data [result] :token (first tokens) :remaining rem-ts}

          							(= :err (get result :status))
          							(update result :trace |(array/push $ name))

          							(empty? rem-ps)
          							{:status :none :token (first tokens) :trace [name] :remaining rem-ts}

          							:else (recur rem-ps)))))})

(defn order-1 [name parsers]
  {:name name
   :rule (fn order-fn [tokens]
           (let [origin (first tokens)
                 first-result (apply-parser (first parsers) tokens)]
             (case (get first-result :status)
               (:err :none)
               (put (update first-result :trace |(array/push $ name)) :status :none)

               (:ok :quiet :group)
               (do (defn recur [ps results ts]
                     (let [result (apply-parser (first ps) ts)
                           res-rem (remaining result)]
                       (if (empty? (rest ps))
                         (case (get result :status)
                           :ok @{:status :group
                                :type name
                                :data (array/push results result)
                                :token origin
                                :remaining res-rem}

                           :quiet @{:status :group
                                   :type name
                                   :data results
                                   :token origin
                                   :remaining res-rem}

                           :group @{:status :group
                                   :type name
                                   :data (array/concat results (get result :data))
                                   :token origin
                                   :remaining res-rem}

                           (:err :none)
                           (put (update result :trace |(array/push $ name)) :status :err))

                         (case (get result :status)
                           :ok (recur (rest ps) (array/push results result) res-rem)
                           :group (recur (rest ps)
                                         (array/concat results (get result :data))
                                         res-rem)
                           :quiet (recur (rest ps) results res-rem)

                           (:err :none)
                           (put (update result :trace |(array/push $ name)) :status :err)))))
                 (recur
                   (get first-result :status)
                   (case (get first-result :status) :ok [first-result] :quiet [] :group (get first-result :data))
                   (remaining first-result))))))})

(defn order-0 [name parsers]
  {:name name
   :rule (fn order-fn [tokens]
           (let [origin (first tokens)]
             (defn recur [ps results ts]
               (let [result (apply-parser (first ps) ts)
                     res-rem (remaining result)]
                 (if (empty? (rest ps))
                   ## Nothing more: return 
                   (case (get result :status)
                     :ok @{:status :group
                          :type name
                          :data (array/push results result)
                          :token origin
                          :remaining res-rem}

                     :quiet @{:status :group
                             :type name
                             :data results
                             :token origin
                             :remaining res-rem}

                     :group @{:status :group
                             :type name
                             :data (array/concat results (get result :data))
                             :token origin
                             :remaining res-rem}

                     (:err :none)
                     (put (update result :trace |(array/push $ name)) :status :err))

                   ## Still parsers left in the vector: recur
                   (case (get result :status)
                     :ok (recur (rest ps) (array/push results result) res-rem)
                     :group (recur (rest ps)
                                   (array/concat results (get result :data))
                                   res-rem)
                     :quiet (recur (rest ps) results res-rem)

                     (:err :none)
                     (put (update result :trace |(array/push $ name)) :status :err)

                     (error (string "Got bad result: " (get result :status)))))))
             (recur parsers [] tokens)))})

(defn weak-order [name parsers]
 	{:name name
 		:rule (fn order-fn [tokens]
        			(let [origin (first tokens)]
          			(clj-loop [ps parsers # now we can use my handy macro
                				results [] 
                				ts tokens]
            			(let [result (apply-parser (first ps) ts)
                 				res-rem (remaining result)]
             				(if (empty? (rest ps))
             						## Nothing more: return 
             						(case (get result :status)
              							:ok @{:status :group 
                  								:type name 
                  								:data (array/push results result) 
                  								:token origin 
                  								:remaining res-rem}
          							
              							:quiet @{:status :group
                     								:type name 
                     								:data results 
                     								:token origin 
                     								:remaining res-rem}

              							:group @{:status :group
                     								:type name
                     								:data (array/concat results (get result :data))
                     								:token origin 
                     								:remaining res-rem}
          							
              							(:err :none)
              							(update result :trace |(array/push $ name)))
             						
             						## Still parsers left in the vector: recur
              					(case (get result :status)  
                					:ok 	(recur (rest ps) (array/push results result) res-rem)
                					:group	(recur (rest ps) 
                        						(array/concat results (get result :data))
                        						res-rem)
                					:quiet 	(recur (rest ps) results res-rem)

                					(:err :none)
                					(update result :trace |(array/push $ name))))))))})

(defn quiet [parser]
 	{:name (kw+str (? (get parser :name) parser) "-quiet")
 		:rule (fn quiet-fn [tokens]
        			(let [result (apply-parser parser tokens)]
         				(if (pass? result) 
        							(put result :status :quiet)
          					result)))})

(defn zero+/2 [name parser]
  	{:name (kw+str name "-zero+")
  		:rule (fn zero+fn [tokens]
         			(clj-loop [results [] 
              					ts tokens]
          				(let [result (apply-parser parser ts)]
           					(case (get result :status)
            						:ok (recur (array/push results result) (remaining result))
            						:group (recur (array/concat results (get result :data)) (remaining result))
            						:quiet (recur results (remaining result))
            						:err (update result :trace |(array/push $ name))
            						:none @{:status :group 
                  							:type name 
                  							:data results 
                  							:token (first tokens) 
                  							:remaining ts}))))})

(defn zero+/1 [parser] (zero+/2 (pname parser) parser))

(defn zero+ [& args]
  (def arity (length args))
  (if (= 1 arity) (zero+/1 ;args) (zero+/2 ;args)))

 	# ([parser] (zero+ (pname parser) parser))
 	# ([name parser]
  # 	{:name (kw+str name "-zero+")
  # 		:rule (fn zero+fn [tokens]
  #        			(clj-loop [results [] 
  #             					ts tokens]
  #         				(let [result (apply-parser parser ts)]
  #          					(case (get result :status)
  #           						:ok (recur (array/push results result) (remaining result))
  #           						:group (recur (array/concat results (get result :data)) (remaining result))
  #           						:quiet (recur results (remaining result))
  #           						:err (update result :trace |(array/push $ name))
  #           						:none {:status :group 
  #                 							:type name 
  #                 							:data results 
  #                 							:token (first tokens) 
  #                 							:remaining ts}))))}))

(defn one+/2 [name parser]
 		{:name (kw+str name "-one+")
  		:rule (fn one+fn [tokens]
         			(let [first-result (apply-parser parser tokens)
              				rest-parser (zero+ name parser)]
          				(case (get first-result :status)
           					(:ok :group)
           					(let [rest-result (apply-parser rest-parser (remaining first-result))]
            						(case (get rest-result :status)

             							(:ok :group :quiet) 
             							{:status :group
 	            							:type name 
 	            							:data (array/concat (get first-result :data) (data rest-result))
 	            							:token (first tokens)
 	            							:remaining (remaining rest-result)}

             							:none {:status :group :type name
                   								:data first-result
                   								:token (first tokens)
                   								:remaining (remaining rest-result)}

             							:err (update rest-result :trace |(array/push % name))))
    						
          						:quiet
          						(let [rest-result (apply-parser rest-parser (remaining first-result))]
           							{:status :quiet
           								:type name
           								:data []
           								:token (first tokens)
           								:remaining (remaining rest-result)})

           					(:err :none) first-result)))})

(defn one+/1 [parser] (one+/2 (pname parser) parser))

(defn one+ [& args]
  (def arity (length args))
  (if (= 1 arity) (one+/1 ;args) (one+/2 ;args)))

# (defn one+
#  	([parser] (one+ (pname parser) parser))
#  	([name parser]
#  		{:name (kw+str name "-one+")
#   		:rule (fn one+fn [tokens]
#          			(let [first-result (apply-parser parser tokens)
#               				rest-parser (zero+ name parser)]
#           				(case (get first-result :status)
#            					(:ok :group)
#            					(let [rest-result (apply-parser rest-parser (remaining first-result))]
#             						(case (get rest-result :status)

#              							(:ok :group :quiet) 
#              							{:status :group
#  	            							:type name 
#  	            							:data (array/concat (get first-result :data) (data rest-result))
#  	            							:token (first tokens)
#  	            							:remaining (remaining rest-result)}

#              							:none {:status :group :type name
#                    								:data first-result
#                    								:token (first tokens)
#                    								:remaining (remaining rest-result)}

#              							:err (update rest-result :trace |(array/push % name))))
    						
#           						:quiet
#           						(let [rest-result (apply-parser rest-parser (remaining first-result))]
#            							{:status :quiet
#            								:type name
#            								:data []
#            								:token (first tokens)
#            								:remaining (remaining rest-result)})

#            					(:err :none) first-result)))}))

(defn maybe/2 [name parser])

(defn maybe/1 [parser] (maybe/2 (pname parser) parser))

(defn maybe [& args]
  (def arity (length args))
  (if (= 1 arity) (maybe/1 ;args) (maybe/2 ;args)))

# (defn maybe
#  	([parser] (maybe (pname parser) parser))
#  	([name parser]
#  		{:name (kw+str name "-maybe")
#  			:rule (fn maybe-fn [tokens]
#         				(let [result (apply-parser parser tokens)]
#          					(if (pass? result)
#           						result
#           						{:status :group :type name :data [] :token (first tokens) :remaining tokens}
#           						)))}))

(defn flat/2 [name parser])

(defn flat/1 [parser] (flat/2 (pname parser) parser))

(defn flat [& args]
  (def arity (length args))
  (if (= 1 arity) (flat/1 ;args) (flat/2 ;args)))

# (defn flat
#  	([parser] (flat (pname parser) parser))
#  	([name parser]
#  		{:name (kw+str name "-flat")
#   		:rule (fn flat-fn [tokens]
#          			(let [result (apply-parser parser tokens)]
#           				(if (pass? result) (first (get result :data)) result)))}))

(defn group/2 [name parser])

(defn group/1 [])

(defn group
 	([parser] (group (pname parser) parser))
 	([name parser]
 		{:name (kw+str name "-group")
  		:rule (fn group-fn [tokens]
         			(let [result (apply-parser parser tokens)]
          				(if (= :group (get result :status))
           					(put result :status :ok)
           					result)))}))

(defn err-msg [{:token token :trace trace}]
 	(print "Unexpected token " (get token :type) " on line " (get token :line))
 	(print "Expected token " (first trace)))

(defn butlast [xs] (if (empty? xs) [] (slice xs 0 -2)))

(defmacro defp [name & items]
 	(let [arg (last items)
     			fns (butlast items)]
  		~(defn ,name [] ((apply comp ,fns) (keyword ',name) ,arg))))