content: ;;; Tests for macros.
  
  (module Main)
  
  (:eval-when-compile
    (import Prelude)
    (import Language.Finkel))
  
  (import Language.Finkel)
  
  (:eval-when-compile
    (:: define-macro Macro)
    (= define-macro
      (Macro (\form
               (case (unCode form)
                 (List (: _ (: name rest)))
                 (let ((= __name
                         (toCode (qSymbol (++ "__" (show name))
                                          "1002-macro.fnk"
                                          0 0 0 0))))
                   (return
                     `(:begin
                        (:: ,name Macro)
                        (= ,name
                          (let ((:: ,__name (-> Code (Fnk Code)))
                                (= ,__name ,@rest))
                            (Macro ,__name))))))
                 _ (finkelSrcError form "define-macro: invalid args")))))
  
    (:: let-macro Macro)
    (= let-macro
      (let ((= f form
              (case (unCode form)
                (List [name arg body])
                (let ((= __name (toCode (qSymbol (++ "__" (show name))
                                                 "1002-macro.fnk"
                                                 0 0 0 0))))
                  (return `(= ,name
                             (let ((:: ,__name (-> Code (Fnk Code)))
                                   (= ,__name ,arg ,body))
                               (Macro ,__name)))))
                _ (finkelSrcError form "let-macro: malformed macro"))))
        (Macro (\form
                 (case (unCode form)
                   (List (: _self (: (LForm (L _l (List ms))) rest)))
                   (do (<- ms' (mapM f ms))
                       (return `(:with-macro (,@ms') ,@rest)))
                   _ (finkelSrcError form "let-macro: malformed args")))))))
  
  (:eval-when-compile
    (define-macro define-macro' form
      (case (unCode form)
        (List (: _ rest)) (return
                            `(:begin
                               (:eval-when-compile
                                 (define-macro ,@rest))
                               (define-macro ,@rest)))
        _ (finkelSrcError form "error"))))
  
  ;; Simple version of `defmacro' defined with `define-macro''
  (define-macro' defmacro form
    (case form
      (LForm (L _ (List [_self name args body])))
      (case args
        (LForm (L _ (List _)))
        (return
          `(define-macro' ,name form
             (case form
               (LForm (L l1 (List [_ ,@args]))) (return ,body)
               _ (finkelSrcError ',name "error"))))
        _ (return `(define-macro ,name ,args
                     (return ,body))))
      _ (finkelSrcError form "error")))
  
  ;;; Using `defmacro' defined above.
  (defmacro m1 (x y)
    `(putStrLn (concat [,x ", " ,y])))
  
  (define-macro' m2 form
    (where (case form
             (LForm (L _ (List [_self arg1 arg2])))
             (return (mkbody arg1 arg2)))
      (= mkbody x y
        `(print (+ (:: ,x Int) (:: ,y Int))))))
  
  ;; Simple `let-macro'.
  (let-macro ((m2a form
                (case form
                  (LForm (L _ (List [_ a b c]))) (return `(,a (+ ,b ,c)))
                  _ (finkelSrcError form "m2a: error")))
              (m2b form
                (case form
                  (LForm (L _ (List [_ x y]))) (return `(+ ,x ,y))
                  _ (finkelSrcError form "m2b: error"))))
    (:: f1 (-> Int Int (IO ())))
    (= f1 x y
      (m2a print x (m2b x y))))
  
  ;;; Macro taking fractional value as argument.
  (let-macro ((m1 form
                (case form
                  (LForm (L l (List [_ x])))
                  (case (fromCode x)
                    (Just d) (if (<= 1.0 (:: d Double))
                                 (return '"more or eq to one")
                                 (return '"less than one"))
                    Nothing (return '"not a double"))
                  _ (finkelSrcError form "m1: invalid args"))))
    (:: fracmac (IO ()))
    (= fracmac
      (do (putStrLn (m1 1.1))
          (putStrLn (m1 0.9))
          (putStrLn (m1 #'x)))))
  
  ;;; Macro returning haskell list.
  (let-macro ((m2 form
                (case form
                  (LForm (L l (List [_ a b c])))
                  (let ((:: mbints (Maybe (, Int Int Int)))
                        (= mbints
                          (do (<- x (fromCode a))
                              (<- y (fromCode b))
                              (<- z (fromCode c))
                              (return (, x y z)))))
                    (case mbints
                      (Just (, x y z))
                      (return `[,(* x 100) ,(* y 100) ,(* z 100)])
                      _ (finkelSrcError form "m2: invalid args")))
                  _ (finkelSrcError form "m2: invalid form"))))
    (:: hslistmac (IO ()))
    (= hslistmac
      (print (m2 1 2 3))))
  
  (let-macro ((identity-form form
                (case (unCode form)
                  (List [_ body]) (return body))))
    (identity-form
     (define-macro' m4 _
       (return `(putStrLn "m4")))))
  
  (:: m4run (IO ()))
  (= m4run (m4))
  
  (define-macro' m5 form
    (case (unCode form)
      (List [_ arg1 body])
      (do (<- tmp gensym)
          (return `(let ((= ,tmp (* ,arg1 2)))
                     (sequence_ (replicate ,tmp ,body)))))
  
      _ (finkelSrcError form "m5-ok")))
  
  (:: m5run (IO ()))
  (= m5run
    (let ((= x 123))
      (m5 2 (print x))))
  
  ;;; XXX: Haskell source code generated from below expression does not
  ;;; compile, since the line containing `let ... in ...' get long with
  ;;; temporary name generated by gensym. The `do' block cannot understand
  ;;; the line starting with `in', because the line does not have
  ;;; indentation clue.
  
  ;; (:: m5run-v2 (IO ()))
  ;; (= m5run-v2
  ;;   (do (let ((= x 123)))
  ;;       (m5 2 (print x))))
  
  (:: main (IO ()))
  (= main
    (do (m1 "Hello" "macro")
        (m2 11 31)
        (f1 11 20)
        fracmac
        hslistmac
        m4run
        m5run))
  