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

(;module:
  [lux #- not default]
  (lux [macro #+ Monad<Lux> with-gensyms]
       (control functor
                applicative
                monad
                eq)
       (data [bool]
             [char]
             [number]
             [text "Text/" Monoid<Text>]
             [ident]
             (coll [list #* "" Functor<List> Fold<List> "List/" Monoid<List>])
             [product]
             ["R" result]))
  (.. [code "Code/" Eq<Code>]))

## [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)
  {#;doc "A Lux syntax parser."}
  (-> (List Code) (R;Result [(List Code) a])))

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

        (#R;Success [tokens' a])
        (#R;Success [tokens' (f a)])))))

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

  (def: (wrap x tokens)
    (#R;Success [tokens x]))

  (def: (apply ff fa)
    (function [tokens]
      (case (ff tokens)
        (#R;Success [tokens' f])
        (case (fa tokens')
          (#R;Success [tokens'' a])
          (#R;Success [tokens'' (f a)])

          (#R;Error msg)
          (#R;Error msg))

        (#R;Error msg)
        (#R;Error msg)))))

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

  (def: (join mma)
    (function [tokens]
      (case (mma tokens)
        (#R;Error msg)
        (#R;Error msg)

        (#R;Success [tokens' ma])
        (ma tokens')))))

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

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

(do-template [<get-name> <type> <tag> <eq> <desc>]
  [(def: #export <get-name>
     {#;doc (#;TextA ($_ Text/append "Parses the next " <desc> " input Code."))}
     (Syntax <type>)
     (function [tokens]
       (case tokens
         (#;Cons [[_ (<tag> x)] tokens'])
         (#R;Success [tokens' x])

         _
         (#R;Error ($_ Text/append "Cannot parse " <desc> (remaining-inputs tokens))))))]

  [  bool  Bool   #;Bool   bool;Eq<Bool> "bool"]
  [   nat   Nat    #;Nat  number;Eq<Nat> "nat"]
  [   int   Int    #;Int  number;Eq<Int> "int"]
  [  deg    Deg    #;Deg  number;Eq<Deg> "deg"]
  [  real  Real   #;Real number;Eq<Real> "real"]
  [  char  Char   #;Char   char;Eq<Char> "char"]
  [  text  Text   #;Text   text;Eq<Text> "text"]
  [symbol Ident #;Symbol ident;Eq<Ident> "symbol"]
  [   tag Ident    #;Tag ident;Eq<Ident> "tag"]
  )

(def: #export (this? ast)
  {#;doc "Asks if the given Code is the next input."}
  (-> Code (Syntax Bool))
  (function [tokens]
    (case tokens
      (#;Cons [token tokens'])
      (let [is-it? (Code/= ast token)
            remaining (if is-it?
                        tokens'
                        tokens)]
        (#R;Success [remaining is-it?]))

      _
      (#R;Success [tokens false]))))

(def: #export (this ast)
  {#;doc "Ensures the given Code is the next input."}
  (-> Code (Syntax Unit))
  (function [tokens]
    (case tokens
      (#;Cons [token tokens'])
      (if (Code/= ast token)
        (#R;Success [tokens' []])
        (#R;Error ($_ Text/append "Expected a " (code;to-text ast) " but instead got " (code;to-text token)
                      (remaining-inputs tokens))))

      _
      (#R;Error "There are no tokens to parse!"))))

(def: #export (assert message test)
  {#;doc "Fails with the given message if the test is false."}
  (-> Text Bool (Syntax Unit))
  (function [tokens]
    (if test
      (#R;Success [tokens []])
      (#R;Error ($_ Text/append message (remaining-inputs tokens))))))

(do-template [<name> <comp> <error>]
  [(def: #export <name>
     (Syntax Int)
     (do Monad<Syntax>
       [n int
        _ (assert <error> (<comp> 0 n))]
       (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>
     {#;doc (#;TextA ($_ Text/append "Parse a local " <desc> " (a " <desc> " that has no module prefix)."))}
     (Syntax Text)
     (function [tokens]
       (case tokens
         (#;Cons [[_ (<tag> ["" x])] tokens'])
         (#R;Success [tokens' x])

         _
         (#R;Error ($_ Text/append "Cannot parse local " <desc> (remaining-inputs tokens))))))]

  [local-symbol #;Symbol "symbol"]
  [   local-tag #;Tag    "tag"]
  )

(do-template [<name> <tag> <desc>]
  [(def: #export (<name> p)
     {#;doc (#;TextA ($_ Text/append "Parse inside the contents of a " <desc> " as if they were the input Codes."))}
     (All [a]
       (-> (Syntax a) (Syntax a)))
     (function [tokens]
       (case tokens
         (#;Cons [[_ (<tag> members)] tokens'])
         (case (p members)
           (#R;Success [#;Nil x]) (#R;Success [tokens' x])
           _                   (#R;Error ($_ Text/append "Syntax was expected to fully consume " <desc> (remaining-inputs tokens))))

         _
         (#R;Error ($_ Text/append "Cannot parse " <desc> (remaining-inputs tokens))))))]

  [ form  #;Form "form"]
  [tuple #;Tuple "tuple"]
  )

(def: #export (record p)
  {#;doc (#;TextA ($_ Text/append "Parse inside the contents of a record as if they were the input Codes."))}
  (All [a]
    (-> (Syntax a) (Syntax a)))
  (function [tokens]
    (case tokens
      (#;Cons [[_ (#;Record pairs)] tokens'])
      (case (p (join-pairs pairs))
        (#R;Success [#;Nil x]) (#R;Success [tokens' x])
        _                   (#R;Error ($_ Text/append "Syntax was expected to fully consume record" (remaining-inputs tokens))))

      _
      (#R;Error ($_ Text/append "Cannot parse record" (remaining-inputs tokens))))))

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

(def: #export (run tokens p)
  (All [a]
    (-> (List Code) (Syntax a) (R;Result [(List Code) a])))
  (p tokens))

(def: #export (some p)
  {#;doc "0-or-more combinator."}
  (All [a]
    (-> (Syntax a) (Syntax (List a))))
  (function [tokens]
    (case (p tokens)
      (#R;Error _)            (#R;Success [tokens (list)])
      (#R;Success [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))))
  (function [tokens]
    (case (p1 tokens)
      (#R;Success [tokens' x1]) (#R;Success [tokens' (+0 x1)])
      (#R;Error _)             (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)))
  (function [tokens]
    (case (pl tokens)
      (#R;Error _) (pr tokens)
      output     output
      )))

(def: #export end!
  {#;doc "Ensures there are no more inputs."}
  (Syntax Unit)
  (function [tokens]
    (case tokens
      #;Nil (#R;Success [tokens []])
      _     (#R;Error ($_ 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)
  (function [tokens]
    (case tokens
      #;Nil (#R;Success [tokens true])
      _     (#R;Success [tokens false]))))

(def: #export (exactly n p)
  {#;doc "Parse exactly N times."}
  (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)
  {#;doc "Parse at least N times."}
  (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)
  {#;doc "Parse at most N times."}
  (All [a] (-> Nat (Syntax a) (Syntax (List a))))
  (if (n.> +0 n)
    (function [input]
      (case (p input)
        (#R;Error msg)
        (#R;Success [input (list)])

        (#R;Success [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)
  {#;doc "Parse between N and M times."}
  (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)))
  (function [input]
    (case (p input)
      (#R;Error msg)
      (#R;Success [input []])
      
      _
      (#R;Error "Expected to fail; yet succeeded."))))

(def: #export (fail message)
  (All [a] (-> Text (Syntax a)))
  (function [input]
    (#R;Error message)))

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

      (#R;Success [input' output])
      (#R;Success [input' output]))))

(def: #export (on compiler action)
  {#;doc "Run a Lux operation as if it was a Syntax parser."}
  (All [a] (-> Compiler (Lux a) (Syntax a)))
  (function [input]
    (case (macro;run compiler action)
      (#R;Error error)
      (#R;Error error)

      (#R;Success value)
      (#R;Success [input value])
      )))

(def: #export (local local-inputs syntax)
  {#;doc "Run a syntax parser with the given list of inputs, instead of the real ones."}
  (All [a] (-> (List Code) (Syntax a) (Syntax a)))
  (function [real-inputs]
    (case (syntax local-inputs)
      (#R;Error error)
      (#R;Error error)

      (#R;Success [unconsumed-inputs value])
      (case unconsumed-inputs
        #;Nil
        (#R;Success [real-inputs value])

        _
        (#R;Error (Text/append "Unconsumed inputs: "
                               (|> (map code;to-text unconsumed-inputs)
                                   (text;join-with ", "))))))))

(def: #export (rec syntax)
  {#;doc "Combinator for recursive syntax."}
  (All [a] (-> (-> (Syntax a) (Syntax a)) (Syntax a)))
  (function [inputs]
    (run inputs (syntax (rec syntax)))))

(def: #export (after param subject)
  (All [p s] (-> (Syntax p) (Syntax s) (Syntax s)))
  (do Monad<Syntax>
    [_ param]
    subject))

(def: #export (before param subject)
  (All [p s] (-> (Syntax p) (Syntax s) (Syntax s)))
  (do Monad<Syntax>
    [output subject
     _ param]
    (wrap output)))

## [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" (~ (code;text def-code))] [])))))))}
  (let [[exported? tokens] (case tokens
                             (^ (list& [_ (#;Tag ["" "hidden"])] tokens'))
                             [(#;Some #;Left) tokens']

                             (^ (list& [_ (#;Tag ["" "export"])] tokens'))
                             [(#;Some #;Right) tokens']

                             _
                             [#;None tokens])
        ?parts (: (Maybe [Text (List Code) Code Code])
                  (case tokens
                    (^ (list [_ (#;Form (list& [_ (#;Symbol ["" name])] args))]
                             body))
                    (#;Some name args (` {}) body)

                    (^ (list [_ (#;Form (list& [_ (#;Symbol ["" 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>
                              (: (-> Code (Lux [Code Code]))
                                 (function [arg]
                                   (case arg
                                     (^ [_ (#;Tuple (list var parser))])
                                     (wrap [var parser])

                                     [_ (#;Symbol var-name)]
                                     (wrap [(code;symbol var-name) (` any)])

                                     _
                                     (macro;fail "Syntax pattern expects tuples or symbols."))))
                              args)
           #let [g!state (code;symbol ["" "*compiler*"])
                 g!end (code;symbol ["" ""])
                 error-msg (code;text (Text/append "Wrong syntax for " name))
                 export-ast (: (List Code) (case exported?
                                             (#;Some #R;Error)
                                             (list (' #hidden))

                                             (#;Some #R;Success)
                                             (list (' #export))

                                             _
                                             (list)))]]
          (wrap (list (` (macro: (~@ export-ast) ((~ (code;symbol ["" name])) (~ g!tokens))
                           (~ meta)
                           (function [(~ g!state)]
                             (;_lux_case (run (~ g!tokens)
                                              (: (Syntax (Lux (List Code)))
                                                 (do Monad<Syntax>
                                                   [(~@ (join-pairs vars+parsers))
                                                    (~ g!end) end!]
                                                   ((~' wrap) (do Monad<Lux>
                                                                []
                                                                (~ body))))))
                               (#R;Success [(~ g!tokens) (~ g!body)])
                               ((~ g!body) (~ g!state))

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