path: root/source/lux/meta/lux.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/.

(;import lux
         (.. ast)
         (lux/control (monoid #as m)
                      (functor #as F)
                      (monad #as M #refer (#only do))
                      (show #as S))
         (lux/data (list #refer #all #open ("list:" List/Monoid List/Functor))
                   (text #as T #open ("text:" Text/Monoid Text/Eq))
                   (number/int #as I #open ("i" Int/Number))
                   (tuple #as t)
                   ident))

## [Types]
## (deftype (Lux a)
##   (-> Compiler (Either Text (, Compiler a))))

## [Utils]
(def (ident->text ident)
  (-> Ident Text)
  (let [[pre post] ident]
    ($ text:++ pre ";" post)))

## [Structures]
(defstruct #export Lux/Functor (F;Functor Lux)
  (def (map f fa)
    (lambda [state]
      (case (fa state)
        (#;Left msg)
        (#;Left msg)

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

(defstruct #export Lux/Monad (M;Monad Lux)
  (def _functor Lux/Functor)
  (def (wrap x)
    (lambda [state]
      (#;Right [state x])))
  (def (join mma)
    (lambda [state]
      (case (mma state)
        (#;Left msg)
        (#;Left msg)

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

## Functions
(def #export (get-module-name state)
  (Lux Text)
  (case (reverse (get@ #;envs state))
    #;Nil
    (#;Left "Can't get the module name without a module!")

    (#;Cons [env _])
    (#;Right [state (get@ #;name env)])))

(def (get k plist)
  (All [a]
    (-> Text (List (, Text a)) (Maybe a)))
  (case plist
    #;Nil
    #;None

    (#;Cons [k' v] plist')
    (if (text:= k k')
      (#;Some v)
      (get k plist'))))

(def (find-macro' modules current-module module name)
  (-> (List (, Text (Module Compiler))) Text Text Text
      (Maybe Macro))
  (case (get module modules)
    (#;Some $module)
    (case (|> (: (Module Compiler) $module) (get@ #;defs) (get name))
      (#;Some gdef)
      (case (: Definition gdef)
        [exported? (#;MacroD macro')]
        (if (or exported? (text:= module current-module))
          (#;Some macro')
          #;None)

        [_ (#;AliasD [r-module r-name])]
        (find-macro' modules current-module r-module r-name)
        
        _
        #;None)
      
      _
      #;None)
    
    _
    #;None))

(def #export (find-macro ident)
  (-> Ident (Lux (Maybe Macro)))
  (do Lux/Monad
    [current-module get-module-name]
    (let [[module name] ident]
      (: (Lux (Maybe Macro))
         (lambda [state]
           (#;Right [state (find-macro' (get@ #;modules state) current-module module name)]))))))

(def #export (normalize ident)
  (-> Ident (Lux Ident))
  (case ident
    ["" name]
    (do Lux/Monad
      [module-name get-module-name]
      (wrap [module-name name]))

    _
    (:: Lux/Monad (wrap ident))))

(def #export (macro-expand syntax)
  (-> AST (Lux (List AST)))
  (case syntax
    [_ (#;FormS (#;Cons [[_ (#;SymbolS macro-name)] args]))]
    (do Lux/Monad
      [macro-name' (normalize macro-name)
       ?macro (find-macro macro-name')]
      (case ?macro
        (#;Some macro)
        (do Lux/Monad
          [expansion (macro args)
           expansion' (M;map% Lux/Monad macro-expand expansion)]
          (wrap (:: List/Monad (join expansion'))))
        
        #;None
        (:: Lux/Monad (wrap (@list syntax)))))

    _
    (:: Lux/Monad (wrap (@list syntax)))))

(def #export (macro-expand-all syntax)
  (-> AST (Lux (List AST)))
  (case syntax
    [_ (#;FormS (#;Cons [[_ (#;SymbolS macro-name)] args]))]
    (do Lux/Monad
      [macro-name' (normalize macro-name)
       ?macro (find-macro macro-name')]
      (case ?macro
        (#;Some macro)
        (do Lux/Monad
          [expansion (macro args)
           expansion' (M;map% Lux/Monad macro-expand-all expansion)]
          (wrap (:: List/Monad (join expansion'))))
        
        #;None
        (do Lux/Monad
          [parts' (M;map% Lux/Monad macro-expand-all (@list& (symbol$ macro-name) args))]
          (wrap (@list (form$ (:: List/Monad (join parts'))))))))

    [_ (#;FormS (#;Cons [harg targs]))]
    (do Lux/Monad
      [harg+ (macro-expand-all harg)
       targs+ (M;map% Lux/Monad macro-expand-all targs)]
      (wrap (@list (form$ (list:++ harg+ (:: List/Monad (join (: (List (List AST)) targs+))))))))

    [_ (#;TupleS members)]
    (do Lux/Monad
      [members' (M;map% Lux/Monad macro-expand-all members)]
      (wrap (@list (tuple$ (:: List/Monad (join members'))))))

    _
    (:: Lux/Monad (wrap (@list syntax)))))

(def #export (gensym prefix state)
  (-> Text (Lux AST))
  (#;Right [(update@ #;seed (i+ 1) state)
            (symbol$ ["" ($ text:++ "__gensym__" prefix (:: I;Int/Show (show (get@ #;seed state))))])]))

(def #export (emit datum)
  (All [a]
    (-> a (Lux a)))
  (lambda [state]
    (#;Right [state datum])))

(def #export (fail msg)
  (All [a]
    (-> Text (Lux a)))
  (lambda [_]
    (#;Left msg)))

(def #export (macro-expand-1 token)
  (-> AST (Lux AST))
  (do Lux/Monad
    [token+ (macro-expand token)]
    (case token+
      (\ (@list token'))
      (wrap token')

      _
      (fail "Macro expanded to more than 1 element."))))

(def #export (module-exists? module state)
  (-> Text (Lux Bool))
  (#;Right [state (case (get module (get@ #;modules state))
                    (#;Some _)
                    true
                    
                    #;None
                    false)]))

(def #export (exported-defs module state)
  (-> Text (Lux (List Text)))
  (case (get module (get@ #;modules state))
    (#;Some =module)
    (using List/Monad
      (#;Right [state (join (map (: (-> (, Text Definition)
                                        (List Text))
                                    (lambda [gdef]
                                      (let [[name [export? _]] gdef]
                                        (if export?
                                          (@list name)
                                          (@list)))))
                                 (get@ #;defs =module)))]))
    
    #;None
    (#;Left ($ text:++ "Unknown module: " module))))

(def (try-both f x1 x2)
  (All [a b]
    (-> (-> a (Maybe b)) a a (Maybe b)))
  (case (f x1)
    #;None     (f x2)
    (#;Some y) (#;Some y)))

(def #export (find-in-env name state)
  (-> Text Compiler (Maybe Type))
  (case state
    {#;source source #;modules modules
     #;envs   envs   #;type-vars   types             #;host  host
     #;seed   seed   #;eval? eval? #;expected expected
     #;cursor cursor}
    (some (: (-> (Env Text (Meta (, Type Cursor) Analysis)) (Maybe Type))
             (lambda [env]
               (case env
                 {#;name _ #;inner-closures _ #;locals {#;counter _ #;mappings locals} #;closure {#;counter _ #;mappings closure}}
                 (try-both (some (: (-> (, Text (Meta (, Type Cursor) Analysis)) (Maybe Type))
                                    (lambda [binding]
                                      (let [[bname [[type _] _]] binding]
                                        (if (text:= name bname)
                                          (#;Some type)
                                          #;None)))))
                           locals
                           closure))))
          envs)))

(def (find-in-defs' name state)
  (-> Ident Compiler (Maybe Definition))
  (let [[v-prefix v-name] name
        {#;source source #;modules modules
         #;envs   envs   #;type-vars   types   #;host           host
         #;seed   seed   #;eval? eval? #;expected expected
         #;cursor cursor} state]
    (case (get v-prefix modules)
      #;None
      #;None

      (#;Some {#;defs defs #;module-aliases _ #;imports _ #;tags _ #;types _})
      (case (get v-name defs)
        #;None
        #;None

        (#;Some def)
        (case def
          [_ (#;AliasD name')]  (find-in-defs' name' state)
          _                     (#;Some def)
          )))
    ))

(def #export (find-in-defs name state)
  (-> Ident Compiler (Maybe Type))
  (case (find-in-defs' name state)
    (#;Some [_ def-data])
    (case def-data
      (#;ValueD [type value]) (#;Some type)
      (#;MacroD _)            (#;Some Macro)
      (#;TypeD _)             (#;Some Type)
      _                       #;None)
    
    #;None
    #;None))

(def #export (find-var-type name)
  (-> Ident (Lux Type))
  (do Lux/Monad
    [#let [[_ _name] name]
     name' (normalize name)]
    (: (Lux Type)
       (lambda [state]
         (case (find-in-env _name state)
           (#;Some struct-type)
           (#;Right [state struct-type])

           _
           (case (find-in-defs name' state)
             (#;Some struct-type)
             (#;Right [state struct-type])

             _
             (#;Left ($ text:++ "Unknown var: " (ident->text name)))))))
    ))

(def #export (find-type name)
  (-> Ident (Lux Type))
  (do Lux/Monad
    [name' (normalize name)]
    (: (Lux Type)
       (lambda [state]
         (case (find-in-defs' name' state)
           (#;Some def-data)
           (case def-data
             [_ (#;TypeD type)] (#;Right [state type])
             _                  (#;Left ($ text:++ "Definition is not a type: " (ident->text name))))

           _
           (#;Left ($ text:++ "Unknown var: " (ident->text name))))))
    ))

(def #export (defs module-name state)
  (-> Text (Lux (List (, Text Definition))))
  (case (get module-name (get@ #;modules state))
    #;None          (#;Left ($ text:++ "Unknown module: " module-name))
    (#;Some module) (#;Right [state (get@ #;defs module)])
    ))

(def #export (exports module-name)
  (-> Text (Lux (List (, Text Definition))))
  (do Lux/Monad
    [defs (defs module-name)]
    (wrap (filter (lambda [[name [exported? data]]] exported?)
                  defs))))

(def #export (modules state)
  (Lux (List Text))
  (|> state
      (get@ #;modules)
      (list:map t;first)
      (#;Right state)))

(def #export (find-module name state)
  (-> Text (Lux (Module Compiler)))
  (case (get name (get@ #;modules state))
    (#;Some module)
    (#;Right state module)

    _
    (#;Left ($ text:++ "Unknown module: " name))))

(def #export (tags-for [module name])
  (-> Ident (Lux (Maybe (List Ident))))
  (do Lux/Monad
    [module (find-module module)]
    (case (get name (get@ #;types module))
      (#;Some [tags _])
      (wrap (#;Some tags))

      _
      (wrap #;None))))