path: root/stdlib/source/lux/macro/syntax.lux

##  Copyright (c) Eduardo Julian. All rights reserved.
##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
##  If a copy of the MPL was not distributed with this file,
##  You can obtain one at http://mozilla.org/MPL/2.0/.

(;module:
  [lux #- not default]
  (lux [compiler #+ Monad<Lux> with-gensyms]
       (control functor
                applicative
                monad
                eq)
       (data [bool]
             [char]
             [number]
             [text "Text/" Monoid<Text>]
             [ident]
             (struct [list #* "" Functor<List> Fold<List> "List/" Monoid<List>])
             [product]
             error))
  (.. [ast]))

## [Utils]
(def: (join-pairs pairs)
  (All [a] (-> (List [a a]) (List a)))
  (case pairs
    #;Nil                   #;Nil
    (#;Cons [[x y] pairs']) (list& x y (join-pairs pairs'))))

## [Types]
(type: #export (Syntax a)
  (-> (List AST) (Error [(List AST) a])))

## [Structures]
(struct: #export _ (Functor Syntax)
  (def: (map f ma)
    (lambda [tokens]
      (case (ma tokens)
        (#;Left msg)
        (#;Left msg)

        (#;Right [tokens' a])
        (#;Right [tokens' (f a)])))))

(struct: #export _ (Applicative Syntax)
  (def: functor Functor<Syntax>)

  (def: (wrap x tokens)
    (#;Right [tokens x]))

  (def: (apply ff fa)
    (lambda [tokens]
      (case (ff tokens)
        (#;Right [tokens' f])
        (case (fa tokens')
          (#;Right [tokens'' a])
          (#;Right [tokens'' (f a)])

          (#;Left msg)
          (#;Left msg))

        (#;Left msg)
        (#;Left msg)))))

(struct: #export _ (Monad Syntax)
  (def: applicative Applicative<Syntax>)

  (def: (join mma)
    (lambda [tokens]
      (case (mma tokens)
        (#;Left msg)
        (#;Left msg)

        (#;Right [tokens' ma])
        (ma tokens')))))

## [Utils]
(def: (remaining-inputs asts)
  (-> (List AST) Text)
  ($_ Text/append " | Remaining input: "
      (|> asts (map ast;ast-to-text) (interpose " ") (text;join-with ""))))

## [Syntaxs]
(def: #export any
  {#;doc "Just returns the next input without applying any logic."}
  (Syntax AST)
  (lambda [tokens]
    (case tokens
      #;Nil                (#;Left "There are no tokens to parse!")
      (#;Cons [t tokens']) (#;Right [tokens' t]))))

(do-template [<get-name> <ask-name> <demand-name> <type> <tag> <eq> <desc>]
  [(def: #export <get-name>
     (Syntax <type>)
     (lambda [tokens]
       (case tokens
         (#;Cons [[_ (<tag> x)] tokens'])
         (#;Right [tokens' x])

         _
         (#;Left ($_ Text/append "Can't parse " <desc> (remaining-inputs tokens))))))

   (def: #export (<ask-name> v)
     (-> <type> (Syntax Bool))
     (lambda [tokens]
       (case tokens
         (#;Cons [[_ (<tag> x)] tokens'])
         (let [is-it? (:: <eq> = v x)
               remaining (if is-it?
                           tokens'
                           tokens)]
           (#;Right [remaining is-it?]))

         _
         (#;Right [tokens false]))))

   (def: #export (<demand-name> v)
     (-> <type> (Syntax Unit))
     (lambda [tokens]
       (case tokens
         (#;Cons [[_ (<tag> x)] tokens'])
         (if (:: <eq> = v x)
           (#;Right [tokens' []])
           (#;Left ($_ Text/append "Expected a " <desc> " but instead got " (ast;ast-to-text [_ (<tag> x)]) (remaining-inputs tokens))))

         _
         (#;Left ($_ Text/append "Can't parse " <desc> (remaining-inputs tokens))))))]

  [  bool   bool?   bool!  Bool   #;BoolS   bool;Eq<Bool> "bool"]
  [   nat    nat?    nat!   Nat    #;NatS  number;Eq<Nat> "nat"]
  [   int    int?    int!   Int    #;IntS  number;Eq<Int> "int"]
  [  real   real?   real!  Real   #;RealS number;Eq<Real> "real"]
  [  char   char?   char!  Char   #;CharS   char;Eq<Char> "char"]
  [  text   text?   text!  Text   #;TextS   text;Eq<Text> "text"]
  [symbol symbol? symbol! Ident #;SymbolS ident;Eq<Ident> "symbol"]
  [   tag    tag?    tag! Ident    #;TagS ident;Eq<Ident> "tag"]
  )

(def: #export (assert v message)
  (-> Bool Text (Syntax Unit))
  (lambda [tokens]
    (if v
      (#;Right [tokens []])
      (#;Left ($_ Text/append message (remaining-inputs tokens))))))

(do-template [<name> <comp> <error>]
  [(def: #export <name>
     (Syntax Int)
     (do Monad<Syntax>
       [n int
        _ (assert (<comp> 0 n) <error>)]
       (wrap n)))]

  [pos-int i.> "Expected a positive integer: N > 0"]
  [neg-int i.< "Expected a negative integer: N < 0"]
  )

(do-template [<name> <tag> <desc>]
  [(def: #export <name>
     (Syntax Text)
     (lambda [tokens]
       (case tokens
         (#;Cons [[_ (<tag> ["" x])] tokens'])
         (#;Right [tokens' x])

         _
         (#;Left ($_ Text/append "Can't parse " <desc> (remaining-inputs tokens))))))]

  [local-symbol #;SymbolS "local symbol"]
  [   local-tag #;TagS    "local tag"]
  )

(do-template [<name> <tag> <desc>]
  [(def: #export (<name> p)
     (All [a]
       (-> (Syntax a) (Syntax a)))
     (lambda [tokens]
       (case tokens
         (#;Cons [[_ (<tag> members)] tokens'])
         (case (p members)
           (#;Right [#;Nil x]) (#;Right [tokens' x])
           _                   (#;Left ($_ Text/append "Syntax was expected to fully consume " <desc> (remaining-inputs tokens))))

         _
         (#;Left ($_ Text/append "Can't parse " <desc> (remaining-inputs tokens))))))]

  [ form  #;FormS "form"]
  [tuple #;TupleS "tuple"]
  )

(def: #export (record p)
  (All [a]
    (-> (Syntax a) (Syntax a)))
  (lambda [tokens]
    (case tokens
      (#;Cons [[_ (#;RecordS pairs)] tokens'])
      (case (p (join-pairs pairs))
        (#;Right [#;Nil x]) (#;Right [tokens' x])
        _                   (#;Left ($_ Text/append "Syntax was expected to fully consume record" (remaining-inputs tokens))))

      _
      (#;Left ($_ Text/append "Can't parse record" (remaining-inputs tokens))))))

(def: #export (opt p)
  {#;doc "Optionality combinator."}
  (All [a]
    (-> (Syntax a) (Syntax (Maybe a))))
  (lambda [tokens]
    (case (p tokens)
      (#;Left _)            (#;Right [tokens #;None])
      (#;Right [tokens' x]) (#;Right [tokens' (#;Some x)]))))

(def: #export (run tokens p)
  (All [a]
    (-> (List AST) (Syntax a) (Error [(List AST) a])))
  (p tokens))

(def: #export (some p)
  {#;doc "0-or-more combinator."}
  (All [a]
    (-> (Syntax a) (Syntax (List a))))
  (lambda [tokens]
    (case (p tokens)
      (#;Left _)            (#;Right [tokens (list)])
      (#;Right [tokens' x]) (run tokens'
                                 (do Monad<Syntax>
                                   [xs (some p)]
                                   (wrap (list& x xs)))
                                 ))))

(def: #export (many p)
  {#;doc "1-or-more combinator."}
  (All [a]
    (-> (Syntax a) (Syntax (List a))))
  (do Monad<Syntax>
    [x p
     xs (some p)]
    (wrap (list& x xs))))

(def: #export (seq p1 p2)
  {#;doc "Sequencing combinator."}
  (All [a b]
    (-> (Syntax a) (Syntax b) (Syntax [a b])))
  (do Monad<Syntax>
    [x1 p1
     x2 p2]
    (wrap [x1 x2])))

(def: #export (alt p1 p2)
  {#;doc "Heterogeneous alternative combinator."}
  (All [a b]
    (-> (Syntax a) (Syntax b) (Syntax (| a b))))
  (lambda [tokens]
    (case (p1 tokens)
      (#;Right [tokens' x1]) (#;Right [tokens' (+0 x1)])
      (#;Left _)             (run tokens
                                  (do Monad<Syntax>
                                    [x2 p2]
                                    (wrap (+1 x2))))
      )))

(def: #export (either pl pr)
  {#;doc "Homogeneous alternative combinator."}
  (All [a]
    (-> (Syntax a) (Syntax a) (Syntax a)))
  (lambda [tokens]
    (case (pl tokens)
      (#;Left _) (pr tokens)
      output     output
      )))

(def: #export end
  {#;doc "Ensures there are no more inputs."}
  (Syntax Unit)
  (lambda [tokens]
    (case tokens
      #;Nil (#;Right [tokens []])
      _     (#;Left ($_ Text/append "Expected list of tokens to be empty!" (remaining-inputs tokens))))))

(def: #export end?
  {#;doc "Checks whether there are no more inputs."}
  (Syntax Bool)
  (lambda [tokens]
    (case tokens
      #;Nil (#;Right [tokens true])
      _     (#;Right [tokens false]))))

(def: #export (exactly n p)
  (All [a] (-> Nat (Syntax a) (Syntax (List a))))
  (if (n.> +0 n)
    (do Monad<Syntax>
      [x p
       xs (exactly (n.dec n) p)]
      (wrap (#;Cons x xs)))
    (:: Monad<Syntax> wrap (list))))

(def: #export (at-least n p)
  (All [a] (-> Nat (Syntax a) (Syntax (List a))))
  (do Monad<Syntax>
    [min (exactly n p)
     extra (some p)]
    (wrap (List/append min extra))))

(def: #export (at-most n p)
  (All [a] (-> Nat (Syntax a) (Syntax (List a))))
  (if (n.> +0 n)
    (lambda [input]
      (case (p input)
        (#;Left msg)
        (#;Right [input (list)])

        (#;Right [input' x])
        (run input'
             (do Monad<Syntax>
               [xs (at-most (n.dec n) p)]
               (wrap (#;Cons x xs))))
        ))
    (:: Monad<Syntax> wrap (list))))

(def: #export (between from to p)
  (All [a] (-> Nat Nat (Syntax a) (Syntax (List a))))
  (do Monad<Syntax>
    [min-xs (exactly from p)
     max-xs (at-most (n.- from to) p)]
    (wrap (:: Monad<List> join (list min-xs max-xs)))))

(def: #export (sep-by sep p)
  {#;doc "Parsers instances of 'p' that are separated by instances of 'sep'."}
  (All [a b] (-> (Syntax b) (Syntax a) (Syntax (List a))))
  (do Monad<Syntax>
    [?x (opt p)]
    (case ?x
      #;None
      (wrap #;Nil)
      
      (#;Some x)
      (do @
        [xs' (some (seq sep p))]
        (wrap (#;Cons x (map product;right xs'))))
      )))

(def: #export (not p)
  (All [a] (-> (Syntax a) (Syntax Unit)))
  (lambda [input]
    (case (p input)
      (#;Left msg)
      (#;Right [input []])
      
      _
      (#;Left "Expected to fail; yet succeeded."))))

(def: #export (fail message)
  (All [a] (-> Text (Syntax a)))
  (lambda [input]
    (#;Left message)))

(def: #export (default value parser)
  {#;doc "If the given parser fails, returns the default value."}
  (All [a] (-> a (Syntax a) (Syntax a)))
  (lambda [input]
    (case (parser input)
      (#;Left error)
      (#;Right [input value])

      (#;Right [input' output])
      (#;Right [input' output]))))

(def: #export (on compiler meta)
  (All [a] (-> Compiler (Lux a) (Syntax a)))
  (lambda [input]
    (case (meta compiler)
      (#;Left error)
      (#;Left error)

      (#;Right [_ value])
      (#;Right [input value])
      )))

(def: #export (local local-inputs syntax)
  (All [a] (-> (List AST) (Syntax a) (Syntax a)))
  (lambda [real-inputs]
    (case (syntax local-inputs)
      (#;Left error)
      (#;Left error)

      (#;Right [unconsume-inputs value])
      (case unconsume-inputs
        #;Nil
        (#;Right [real-inputs value])

        _
        (#;Left "Unconsumed inputs.")))))

## [Syntax]
(def: #hidden text.join-with text;join-with)

(macro: #export (syntax: tokens)
  {#;doc (doc "A more advanced way to define macros than macro:."
              "The inputs to the macro can be parsed in complex ways through the use of syntax parsers."
              "The macro body is also (implicitly) run in the Monad<Lux>, to save some typing."
              "Also, the compiler state can be accessed through the *compiler* binding."
              (syntax: #export (object [#let [imports (class-imports *compiler*)]]
                                 [#let [class-vars (list)]]
                                 [super (opt (super-class-decl^ imports class-vars))]
                                 [interfaces (tuple (some (super-class-decl^ imports class-vars)))]
                                 [constructor-args (constructor-args^ imports class-vars)]
                                 [methods (some (overriden-method-def^ imports))])
                (let [def-code ($_ Text/append "anon-class:"
                                   (spaced (list (super-class-decl$ (;default object-super-class super))
                                                 (with-brackets (spaced (map super-class-decl$ interfaces)))
                                                 (with-brackets (spaced (map constructor-arg$ constructor-args)))
                                                 (with-brackets (spaced (map (method-def$ id) methods))))))]
                  (wrap (list (` (;_lux_proc ["jvm" (~ (ast;text def-code))] [])))))))}
  (let [[exported? tokens] (case tokens
                             (^ (list& [_ (#;TagS ["" "export"])] tokens'))
                             [true tokens']

                             _
                             [false tokens])
        ?parts (: (Maybe [Text (List AST) AST AST])
                  (case tokens
                    (^ (list [_ (#;FormS (list& [_ (#;SymbolS ["" name])] args))]
                             body))
                    (#;Some name args (` {}) body)

                    (^ (list [_ (#;FormS (list& [_ (#;SymbolS ["" name])] args))]
                             meta-data
                             body))
                    (#;Some name args meta-data body)

                    _
                    #;None))]
    (case ?parts
      (#;Some [name args meta body])
      (with-gensyms [g!tokens g!body g!msg]
        (do Monad<Lux>
          [vars+parsers (mapM Monad<Lux>
                              (: (-> AST (Lux [AST AST]))
                                 (lambda [arg]
                                   (case arg
                                     (^ [_ (#;RecordS (list [var parser]))])
                                     (wrap [var parser])

                                     [_ (#;SymbolS var-name)]
                                     (wrap [(ast;symbol var-name) (` any)])

                                     _
                                     (compiler;fail "Syntax pattern expects records or symbols."))))
                              args)
           #let [g!state (ast;symbol ["" "*compiler*"])
                 g!end (ast;symbol ["" ""])
                 error-msg (ast;text (Text/append "Wrong syntax for " name))
                 export-ast (: (List AST) (if exported? (list (' #export)) (list)))]]
          (wrap (list (` (macro: (~@ export-ast) ((~ (ast;symbol ["" name])) (~ g!tokens))
                           (~ meta)
                           (lambda [(~ g!state)]
                             (;_lux_case (run (~ g!tokens)
                                              (: (Syntax (Lux (List AST)))
                                                 (do Monad<Syntax>
                                                   [(~@ (join-pairs vars+parsers))
                                                    (~ g!end) end]
                                                   ((~' wrap) (do Monad<Lux>
                                                                []
                                                                (~ body))))))
                               (#;Right [(~ g!tokens) (~ g!body)])
                               ((~ g!body) (~ g!state))

                               (#;Left (~ g!msg))
                               (#;Left (text.join-with ": " (list (~ error-msg) (~ g!msg))))))))))))
      
      _
      (compiler;fail "Wrong syntax for syntax:"))))