path: root/stdlib/source/library/lux/meta.lux

(.module:
  {#.doc "Functions for extracting information from the state of the compiler."}
  [library
   [lux (#- type)
    [abstract
     [functor (#+ Functor)]
     [apply (#+ Apply)]
     ["." monad (#+ Monad do)]]
    [control
     ["." try (#+ Try)]]
    [data
     ["." product]
     ["." maybe]
     ["." text ("#\." monoid equivalence)]
     ["." name ("#\." codec equivalence)]
     [collection
      ["." list ("#\." monoid monad)]
      [dictionary
       ["." plist]]]]
    [macro
     ["." code]]
    [math
     [number
      ["n" nat]
      ["i" int]]]]]
  [/
   ["." location]])

... (type: (Meta a)
...   (-> Lux (Try [Lux a])))

(implementation: .public functor
  (Functor Meta)
  
  (def: (map f fa)
    (function (_ compiler)
      (case (fa compiler)
        (#try.Failure msg)
        (#try.Failure msg)

        (#try.Success [compiler' a])
        (#try.Success [compiler' (f a)])))))

(implementation: .public apply
  (Apply Meta)
  
  (def: &functor ..functor)

  (def: (apply ff fa)
    (function (_ compiler)
      (case (ff compiler)
        (#try.Success [compiler' f])
        (case (fa compiler')
          (#try.Success [compiler'' a])
          (#try.Success [compiler'' (f a)])

          (#try.Failure msg)
          (#try.Failure msg))

        (#try.Failure msg)
        (#try.Failure msg)))))

(implementation: .public monad
  (Monad Meta)
  
  (def: &functor ..functor)

  (def: (in x)
    (function (_ compiler)
      (#try.Success [compiler x])))
  
  (def: (join mma)
    (function (_ compiler)
      (case (mma compiler)
        (#try.Failure msg)
        (#try.Failure msg)

        (#try.Success [compiler' ma])
        (ma compiler')))))

(def: .public (run' compiler action)
  (All [a] (-> Lux (Meta a) (Try [Lux a])))
  (action compiler))

(def: .public (run compiler action)
  (All [a] (-> Lux (Meta a) (Try a)))
  (case (action compiler)
    (#try.Failure error)
    (#try.Failure error)

    (#try.Success [_ output])
    (#try.Success output)))

(def: .public (either left right)
  {#.doc "Pick whichever computation succeeds."}
  (All [a] (-> (Meta a) (Meta a) (Meta a)))
  (function (_ compiler)
    (case (left compiler)
      (#try.Failure error)
      (right compiler)

      (#try.Success [compiler' output])
      (#try.Success [compiler' output]))))

(def: .public (assertion message test)
  {#.doc "Fails with the given message if the test is #0."}
  (-> Text Bit (Meta Any))
  (function (_ compiler)
    (if test
      (#try.Success [compiler []])
      (#try.Failure message))))

(def: .public (failure error)
  {#.doc "Fails with the given error message."}
  (All [a]
    (-> Text (Meta a)))
  (function (_ state)
    (#try.Failure (location.with (get@ #.location state) error))))

(def: .public (module name)
  (-> Text (Meta Module))
  (function (_ compiler)
    (case (plist.get name (get@ #.modules compiler))
      (#.Some module)
      (#try.Success [compiler module])

      _
      (#try.Failure ($_ text\compose "Unknown module: " name)))))

(def: .public current_module_name
  (Meta Text)
  (function (_ compiler)
    (case (get@ #.current_module compiler)
      (#.Some current_module)
      (#try.Success [compiler current_module])

      _
      (#try.Failure "No current module."))))

(def: .public current_module
  (Meta Module)
  (let [(^open "\.") ..monad]
    (|> ..current_module_name
        (\map ..module)
        \join)))

(def: (macro_type? type)
  (-> Type Bit)
  (`` (case type
        (#.Named [(~~ (static .prelude_module)) "Macro"] (#.Primitive "#Macro" #.End))
        true

        _
        false)))

(def: .public (normal name)
  {#.doc (doc "If given a name without a module prefix, gives it the current module's name as prefix."
              "Otherwise, returns the name as-is.")}
  (-> Name (Meta Name))
  (case name
    ["" name]
    (do ..monad
      [module_name ..current_module_name]
      (in [module_name name]))

    _
    (\ ..monad in name)))

(def: (macro' modules this_module module name)
  (-> (List [Text Module]) Text Text Text
      (Maybe Macro))
  (do maybe.monad
    [$module (plist.get module modules)
     definition (: (Maybe Global)
                   (|> (: Module $module)
                       (get@ #.definitions)
                       (plist.get name)))]
    (case definition
      (#.Alias [r_module r_name])
      (macro' modules this_module r_module r_name)
      
      (#.Definition [exported? def_type def_anns def_value])
      (if (macro_type? def_type)
        (#.Some (:as Macro def_value))
        #.None))))

(def: .public (macro full_name)
  (-> Name (Meta (Maybe Macro)))
  (do ..monad
    [[module name] (..normal full_name)]
    (: (Meta (Maybe Macro))
       (function (_ compiler)
         (let [macro (case (..current_module_name compiler)
                       (#try.Failure error)
                       #.None

                       (#try.Success [_ this_module])
                       (macro' (get@ #.modules compiler) this_module module name))]
           (#try.Success [compiler macro]))))))

(def: .public seed
  (Meta Nat)
  (function (_ compiler)
    (#try.Success [(update@ #.seed inc compiler)
                   (get@ #.seed compiler)])))

(def: .public (module_exists? module)
  (-> Text (Meta Bit))
  (function (_ compiler)
    (#try.Success [compiler (case (plist.get module (get@ #.modules compiler))
                              (#.Some _)
                              #1
                              
                              #.None
                              #0)])))

(def: (on_either f x1 x2)
  (All [a b]
    (-> (-> a (Maybe b)) a a (Maybe b)))
  (case (f x1)
    #.None     (f x2)
    (#.Some y) (#.Some y)))

(def: (type_variable idx bindings)
  (-> Nat (List [Nat (Maybe Type)]) (Maybe Type))
  (case bindings
    #.End
    #.None
    
    (#.Item [var bound] bindings')
    (if (n.= idx var)
      bound
      (type_variable idx bindings'))))

(def: (clean_type type)
  (-> Type (Meta Type))
  (case type
    (#.Var var)
    (function (_ compiler)
      (case (|> compiler
                (get@ [#.type_context #.var_bindings])
                (type_variable var))
        (^or #.None (#.Some (#.Var _)))
        (#try.Success [compiler type])

        (#.Some type')
        (#try.Success [compiler type'])))

    _
    (\ ..monad in type)))

(def: .public (var_type name)
  {#.doc "Looks-up the type of a local variable somewhere in the environment."}
  (-> Text (Meta Type))
  (function (_ compiler)
    (let [test (: (-> [Text [Type Any]] Bit)
                  (|>> product.left (text\= name)))]
      (case (do maybe.monad
              [scope (list.find (function (_ env)
                                  (or (list.any? test (: (List [Text [Type Any]])
                                                         (get@ [#.locals #.mappings] env)))
                                      (list.any? test (: (List [Text [Type Any]])
                                                         (get@ [#.captured #.mappings] env)))))
                                (get@ #.scopes compiler))
               [_ [type _]] (on_either (list.find test)
                                       (: (List [Text [Type Any]])
                                          (get@ [#.locals #.mappings] scope))
                                       (: (List [Text [Type Any]])
                                          (get@ [#.captured #.mappings] scope)))]
              (in type))
        (#.Some var_type)
        ((clean_type var_type) compiler)

        #.None
        (#try.Failure ($_ text\compose "Unknown variable: " name))))))

(def: .public (definition name)
  {#.doc "Looks-up a definition's whole data in the available modules (including the current one)."}
  (-> Name (Meta Global))
  (do ..monad
    [name (..normal name)
     .let [[normal_module normal_short] name]]
    (function (_ compiler)
      (case (: (Maybe Global)
               (do maybe.monad
                 [(^slots [#.definitions]) (|> compiler
                                               (get@ #.modules)
                                               (plist.get normal_module))]
                 (plist.get normal_short definitions)))
        (#.Some definition)
        (#try.Success [compiler definition])

        _
        (let [current_module (|> compiler (get@ #.current_module) (maybe.else "???"))
              separator ($_ text\compose text.new_line "                    ")]
          (#try.Failure ($_ text\compose
                            "Unknown definition: " (name\encode name) text.new_line
                            "    Current module: " current_module text.new_line
                            (case (plist.get current_module (get@ #.modules compiler))
                              (#.Some this_module)
                              (let [candidates (|> compiler
                                                   (get@ #.modules)
                                                   (list\map (function (_ [module_name module])
                                                               (|> module
                                                                   (get@ #.definitions)
                                                                   (list.all (function (_ [def_name global])
                                                                               (case global
                                                                                 (#.Definition [exported? _ _ _])
                                                                                 (if (and exported?
                                                                                          (text\= normal_short def_name))
                                                                                   (#.Some (name\encode [module_name def_name]))
                                                                                   #.None)

                                                                                 (#.Alias _)
                                                                                 #.None))))))
                                                   list.concat
                                                   (text.join_with separator))
                                    imports (|> this_module
                                                (get@ #.imports)
                                                (text.join_with separator))
                                    aliases (|> this_module
                                                (get@ #.module_aliases)
                                                (list\map (function (_ [alias real]) ($_ text\compose alias " => " real)))
                                                (text.join_with separator))]
                                ($_ text\compose
                                    "        Candidates: " candidates text.new_line
                                    "           Imports: " imports text.new_line
                                    "           Aliases: " aliases text.new_line))

                              _
                              "")
                            " All known modules: " (|> compiler (get@ #.modules) (list\map product.left) (text.join_with separator)) text.new_line)))))))

(def: .public (export name)
  {#.doc "Looks-up a definition's type in the available modules (including the current one)."}
  (-> Name (Meta Definition))
  (do ..monad
    [definition (..definition name)]
    (case definition
      (#.Left de_aliased)
      (failure ($_ text\compose
                   "Aliases are not considered exports: "
                   (name\encode name)))
      
      (#.Right definition)
      (let [[exported? def_type def_data def_value] definition]
        (if exported?
          (in definition)
          (failure ($_ text\compose "Definition is not an export: " (name\encode name))))))))

(def: .public (definition_type name)
  {#.doc "Looks-up a definition's type in the available modules (including the current one)."}
  (-> Name (Meta Type))
  (do ..monad
    [definition (definition name)]
    (case definition
      (#.Left de_aliased)
      (definition_type de_aliased)
      
      (#.Right [exported? def_type def_data def_value])
      (clean_type def_type))))

(def: .public (type name)
  {#.doc "Looks-up the type of either a local variable or a definition."}
  (-> Name (Meta Type))
  (do ..monad
    [.let [[_ _name] name]]
    (case name
      ["" _name]
      (either (var_type _name)
              (definition_type name))

      _
      (definition_type name))))

(def: .public (type_definition name)
  {#.doc "Finds the value of a type definition (such as Int, Any or Lux)."}
  (-> Name (Meta Type))
  (do ..monad
    [definition (definition name)]
    (case definition
      (#.Left de_aliased)
      (type_definition de_aliased)
      
      (#.Right [exported? def_type def_data def_value])
      (let [type_code (`` ("lux in-module" (~~ (static .prelude_module)) .type_code))]
        (if (or (is? .Type def_type)
                (\ code.equivalence =
                   (type_code .Type)
                   (type_code def_type)))
          (in (:as Type def_value))
          (..failure ($_ text\compose "Definition is not a type: " (name\encode name))))))))

(def: .public (globals module)
  {#.doc "The entire list of globals in a module (including the non-exported/private ones)."}
  (-> Text (Meta (List [Text Global])))
  (function (_ compiler)
    (case (plist.get module (get@ #.modules compiler))
      #.None
      (#try.Failure ($_ text\compose "Unknown module: " module))
      
      (#.Some module)
      (#try.Success [compiler (get@ #.definitions module)]))))

(def: .public (definitions module)
  {#.doc "The entire list of definitions in a module (including the non-exported/private ones)."}
  (-> Text (Meta (List [Text Definition])))
  (\ ..monad map
     (list.all (function (_ [name global])
                 (case global
                   (#.Left de_aliased)
                   #.None
                   
                   (#.Right definition)
                   (#.Some [name definition]))))
     (..globals module)))

(def: .public (exports module_name)
  {#.doc "All the exported definitions in a module."}
  (-> Text (Meta (List [Text Definition])))
  (do ..monad
    [constants (..definitions module_name)]
    (in (do list.monad
          [[name [exported? def_type def_data def_value]] constants]
          (if exported?
            (in [name [exported? def_type def_data def_value]])
            (list))))))

(def: .public modules
  {#.doc "All the available modules (including the current one)."}
  (Meta (List [Text Module]))
  (function (_ compiler)
    (|> compiler
        (get@ #.modules)
        [compiler]
        #try.Success)))

(def: .public (tags_of type_name)
  {#.doc "All the tags associated with a type definition."}
  (-> Name (Meta (Maybe (List Name))))
  (do ..monad
    [.let [[module name] type_name]
     module (..module module)]
    (case (plist.get name (get@ #.types module))
      (#.Some [tags _])
      (in (#.Some tags))

      _
      (in #.None))))

(def: .public location
  {#.doc "The location of the current expression being analyzed."}
  (Meta Location)
  (function (_ compiler)
    (#try.Success [compiler (get@ #.location compiler)])))

(def: .public expected_type
  {#.doc "The expected type of the current expression being analyzed."}
  (Meta Type)
  (function (_ compiler)
    (case (get@ #.expected compiler)
      (#.Some type)
      (#try.Success [compiler type])

      #.None
      (#try.Failure "Not expecting any type."))))

(def: .public (imported_modules module_name)
  {#.doc "All the modules imported by a specified module."}
  (-> Text (Meta (List Text)))
  (do ..monad
    [(^slots [#.imports]) (..module module_name)]
    (in imports)))

(def: .public (imported_by? import module)
  (-> Text Text (Meta Bit))
  (do ..monad
    [(^slots [#.imports]) (..module module)]
    (in (list.any? (text\= import) imports))))

(def: .public (imported? import)
  (-> Text (Meta Bit))
  (\ ..functor map
     (|>> (get@ #.imports) (list.any? (text\= import)))
     ..current_module))

(def: .public (tag tag_name)
  {#.doc "Given a tag, finds out what is its index, its related tag-list and its associated type."}
  (-> Name (Meta [Nat (List Name) Type]))
  (do ..monad
    [.let [[module name] tag_name]
     =module (..module module)
     this_module_name ..current_module_name
     imported! (..imported? module)]
    (case (plist.get name (get@ #.tags =module))
      (#.Some [idx tag_list exported? type])
      (if (or (text\= this_module_name module)
              (and imported! exported?))
        (in [idx tag_list type])
        (..failure ($_ text\compose "Cannot access tag: " (name\encode tag_name) " from module " this_module_name)))

      _
      (..failure ($_ text\compose
                     "Unknown tag: " (name\encode tag_name) text.new_line
                     " Known tags: " (|> =module
                                         (get@ #.tags)
                                         (list\map (|>> product.left [module] name\encode (text.prefix text.new_line)))
                                         (text.join_with ""))
                     )))))

(def: .public (tag_lists module)
  {#.doc "All the tag-lists defined in a module, with their associated types."}
  (-> Text (Meta (List [(List Name) Type])))
  (do ..monad
    [=module (..module module)
     this_module_name ..current_module_name]
    (in (|> (get@ #.types =module)
            (list.only (function (_ [type_name [tag_list exported? type]])
                         (or exported?
                             (text\= this_module_name module))))
            (list\map (function (_ [type_name [tag_list exported? type]])
                        [tag_list type]))))))

(def: .public locals
  {#.doc "All the local variables currently in scope, separated in different scopes."}
  (Meta (List (List [Text Type])))
  (function (_ compiler)
    (case (list.inits (get@ #.scopes compiler))
      #.None
      (#try.Failure "No local environment")

      (#.Some scopes)
      (#try.Success [compiler
                     (list\map (|>> (get@ [#.locals #.mappings])
                                    (list\map (function (_ [name [type _]])
                                                [name type])))
                               scopes)]))))

(def: .public (de_aliased def_name)
  {#.doc "Given an aliased definition's name, returns the original definition being referenced."}
  (-> Name (Meta Name))
  (do ..monad
    [constant (..definition def_name)]
    (in (case constant
          (#.Left real_def_name)
          real_def_name

          (#.Right _)
          def_name))))

(def: .public get_compiler
  {#.doc "Obtains the current state of the compiler."}
  (Meta Lux)
  (function (_ compiler)
    (#try.Success [compiler compiler])))

(def: .public type_context
  (Meta Type_Context)
  (function (_ compiler)
    (#try.Success [compiler (get@ #.type_context compiler)])))

(def: .public (lift result)
  (All [a] (-> (Try a) (Meta a)))
  (case result
    (#try.Success output)
    (\ ..monad in output)

    (#try.Failure error)
    (..failure error)))