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

(.require
 [library
  [lux (.except try macro type local alias)
   [abstract
    [functor (.only Functor)]
    [apply (.only Apply)]
    ["[0]" monad (.only Monad do)]]
   [control
    ["[0]" maybe]
    ["[0]" try (.only Try)]]
   [data
    ["[0]" product]
    ["[0]" text (.use "[1]#[0]" monoid order)]
    [collection
     ["[0]" list (.use "[1]#[0]" monoid monad mix)
      ["[0]" property]]]]
   [math
    [number
     ["n" nat]
     ["i" int]]]]]
 [/
  ["[0]" location]
  ["[0]" symbol (.use "[1]#[0]" codec equivalence)]
  ["[0]" code]])

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

(def .public functor
  (Functor Meta)
  (implementation
   (def (each f fa)
     (function (_ lux)
       (when (fa lux)
         {try.#Success [lux' a]}
         {try.#Success [lux' (f a)]}

         {try.#Failure msg}
         {try.#Failure msg})))))

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

   (def (on fa ff)
     (function (_ lux)
       (when (ff lux)
         {try.#Success [lux' f]}
         (when (fa lux')
           {try.#Success [lux'' a]}
           {try.#Success [lux'' (f a)]}

           {try.#Failure msg}
           {try.#Failure msg})

         {try.#Failure msg}
         {try.#Failure msg})))))

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

   (def (in x)
     (function (_ lux)
       {try.#Success [lux x]}))
   
   (def (conjoint mma)
     (function (_ lux)
       (when (mma lux)
         {try.#Success [lux' ma]}
         (ma lux')

         {try.#Failure msg}
         {try.#Failure msg})))))

(def .public (result' lux action)
  (All (_ a) (-> Lux (Meta a) (Try [Lux a])))
  (action lux))

(def .public (result lux action)
  (All (_ a) (-> Lux (Meta a) (Try a)))
  (when (action lux)
    {try.#Success [_ output]}
    {try.#Success output}

    {try.#Failure error}
    {try.#Failure error}))

(def .public (either left right)
  (All (_ a) (-> (Meta a) (Meta a) (Meta a)))
  (function (_ lux)
    (when (left lux)
      {try.#Success [lux' output]}
      {try.#Success [lux' output]}

      {try.#Failure error}
      (right lux))))

(def .public (assertion message test)
  (-> Text Bit (Meta Any))
  (function (_ lux)
    (if test
      {try.#Success [lux []]}
      {try.#Failure message})))

(def .public (failure error)
  (All (_ a)
    (-> Text (Meta a)))
  (function (_ state)
    {try.#Failure (location.with (the .#location state) error)}))

(def .public (module name)
  (-> Text (Meta Module))
  (function (_ lux)
    (when (property.value name (the .#modules lux))
      {.#Some module}
      {try.#Success [lux module]}

      _
      {try.#Failure (all text#composite "Unknown module: " name)})))

(def .public current_module_name
  (Meta Text)
  (function (_ lux)
    (when (the .#current_module lux)
      {.#Some current_module}
      {try.#Success [lux current_module]}

      _
      {try.#Failure "No current module."})))

(def .public current_module
  (Meta Module)
  (let [(open "#[0]") ..monad]
    (|> ..current_module_name
        (#each ..module)
        #conjoint)))

(def (macro_type? type)
  (-> Type Bit)
  (when type
    {.#Named [.prelude "Macro"]
             {.#Nominal "#Macro" {.#End}}}
    true

    _
    false))

(def .public (normal name)
  (-> Symbol (Meta Symbol))
  (when name
    ["" name]
    (do ..monad
      [module_name ..current_module_name]
      (in [module_name name]))

    _
    (of ..monad in name)))

(def .public (macro full_name)
  (-> Symbol (Meta (Maybe Macro)))
  (do ..monad
    [[module name] (..normal full_name)]
    (is (Meta (Maybe Macro))
        (function (_ lux)
          {try.#Success [lux
                         (when (..current_module_name lux)
                           {try.#Success [_ this_module]}
                           (let [modules (the .#modules lux)]
                             (loop (again [module module
                                           name name])
                               (do maybe.monad
                                 [$module (property.value module modules)
                                  [exported? definition] (is (Maybe [Bit Global])
                                                             (|> $module
                                                                 (is Module)
                                                                 (the .#definitions)
                                                                 (property.value name)))]
                                 (when definition
                                   {.#Alias [r_module r_name]}
                                   (again r_module r_name)
                                   
                                   {.#Definition [def_type def_value]}
                                   (if (macro_type? def_type)
                                     {.#Some (as Macro def_value)}
                                     {.#None})

                                   {.#Default _}
                                   {.#None}))))

                           {try.#Failure error}
                           {.#None})]}))))

(def .public seed
  (Meta Nat)
  (function (_ lux)
    {try.#Success [(revised .#seed ++ lux)
                   (the .#seed lux)]}))

(def .public (module_exists? module)
  (-> Text (Meta Bit))
  (function (_ lux)
    {try.#Success [lux (when (property.value module (the .#modules lux))
                         {.#Some _}
                         true
                         
                         {.#None}
                         false)]}))

(def (on_either f x1 x2)
  (All (_ a b)
    (-> (-> a (Maybe b)) a a (Maybe b)))
  (when (f x1)
    {.#None}   (f x2)
    {.#Some y} {.#Some y}))

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

(`` (def (clean_type type)
      (-> Type (Meta Type))
      (when type
        {.#Var var}
        (function (_ lux)
          (when (|> lux
                    (the [.#type_context .#var_bindings])
                    (type_variable var))
            (,, (with_template [<pattern>]
                  [<pattern>
                   {try.#Success [lux type]}]

                  [{.#None}]
                  [{.#Some {.#Var _}}]))
            

            {.#Some type'}
            {try.#Success [lux type']}))

        _
        (of ..monad in type))))

(def .public (var_type name)
  (-> Text (Meta Type))
  (function (_ lux)
    (let [test (is (-> [Text [Type Any]] Bit)
                   (|>> product.left (text#= name)))]
      (when (do maybe.monad
              [scope (list.example (function (_ env)
                                     (or (list.any? test (is (List [Text [Type Any]])
                                                             (the [.#locals .#mappings] env)))
                                         (list.any? test (is (List [Text [Type Any]])
                                                             (the [.#captured .#mappings] env)))))
                                   (the .#scopes lux))
               [_ [type _]] (on_either (list.example test)
                                       (is (List [Text [Type Any]])
                                           (the [.#locals .#mappings] scope))
                                       (is (List [Text [Type Any]])
                                           (the [.#captured .#mappings] scope)))]
              (in type))
        {.#Some var_type}
        ((clean_type var_type) lux)

        {.#None}
        {try.#Failure (all text#composite "Unknown variable: " name)}))))

(def without_lux_runtime
  (-> (List Text) (List Text))
  ... The Lux runtime shows up as ""
  ... so I'm excluding it.
  (list.only (|>> text.empty? not)))

(def listing_separator
  Text
  (all text#composite text.new_line "                    "))

(def module_listing
  (-> (List Text) Text)
  (|>> ..without_lux_runtime
       (list.sorted text#<)
       (text.interposed ..listing_separator)))

(with_template [<name> <yes>]
  [(def .public (<name> name)
     (-> Symbol (Meta [Bit Global]))
     (do ..monad
       [name (..normal name)
        .let [[normal_module normal_short] name]]
       (function (_ lux)
         (when (is (Maybe [Bit Global])
                   (do maybe.monad
                     [(open "[0]") (|> lux
                                       (the .#modules)
                                       (property.value normal_module))]
                     (property.value normal_short #definitions)))
           {.#Some exported?,definition}
           {try.#Success [lux exported?,definition]}

           _
           (let [current_module (|> lux (the .#current_module) (maybe.else "???"))
                 all_known_modules (|> lux
                                       (the .#modules)
                                       (list#each product.left)
                                       ..module_listing)]
             {try.#Failure (all text#composite
                                "Unknown definition: " (symbol#encoded name) text.new_line
                                "    Current module: " current_module text.new_line
                                (when (property.value current_module (the .#modules lux))
                                  {.#Some this_module}
                                  (let [candidates (|> lux
                                                       (the .#modules)
                                                       (list#each (function (_ [module_name module])
                                                                    (|> module
                                                                        (the .#definitions)
                                                                        (list.all (function (_ [def_name [exported? global]])
                                                                                    (`` (when global
                                                                                          {<yes> _}
                                                                                          (if (and exported?
                                                                                                   (text#= normal_short def_name))
                                                                                            {.#Some (symbol#encoded [module_name def_name])}
                                                                                            {.#None})

                                                                                          _
                                                                                          {.#None})))))))
                                                       list.together
                                                       (list.sorted text#<)
                                                       (text.interposed ..listing_separator))
                                        imports (|> this_module
                                                    (the .#imports)
                                                    ..module_listing)
                                        aliases (|> this_module
                                                    (the .#module_aliases)
                                                    (list#each (function (_ [alias real]) (all text#composite alias " => " real)))
                                                    (list.sorted text#<)
                                                    (text.interposed ..listing_separator))]
                                    (all text#composite
                                         "        Candidates: " candidates text.new_line
                                         "           Imports: " imports text.new_line
                                         "           Aliases: " aliases text.new_line))

                                  _
                                  "")
                                " All known modules: " all_known_modules text.new_line)})))))]

  [definition .#Definition]
  [default' .#Default]
  [alias' .#Alias]
  )

(def .public (export name)
  (-> Symbol (Meta Definition))
  (do [! ..monad]
    [name (..normal name)
     .let [[expected _] name]
     [exported? definition] (..definition name)
     actual ..current_module_name]
    (when definition
      {.#Definition it}
      (if (or exported?
              (text#= expected actual))
        (in it)
        (failure (all text#composite "Definition is not an export: " (symbol#encoded name))))

      {.#Alias it}
      (if (or exported?
              (text#= expected actual))
        (export it)
        (failure (all text#composite "Alias is not an export: " (symbol#encoded name))))

      {.#Default _}
      (failure (all text#composite
                    "Defaults are not considered exports: "
                    (symbol#encoded name))))))

(def .public (default name)
  (-> Symbol (Meta Default))
  (do [! ..monad]
    [name (..normal name)
     [exported? definition] (..default' name)]
    (when definition
      {.#Definition _}
      (failure (all text#composite
                    "Definitions are not considered defaults: "
                    (symbol#encoded name)))

      {.#Alias de_aliased}
      (failure (all text#composite
                    "Aliases are not considered defaults: "
                    (symbol#encoded name)))

      {.#Default it}
      (if exported?
        (in it)
        (do !
          [.let [[expected _] name]
           actual ..current_module_name]
          (if (text#= expected actual)
            (in it)
            (failure (all text#composite "Default is not an export: " (symbol#encoded name)))))))))

(def .public (alias name)
  (-> Symbol
      (Meta Symbol))
  (do [! ..monad]
    [name (..normal name)
     [exported? it] (..alias' name)]
    (when it
      {.#Alias it}
      (in it)

      _
      (undefined))))

(with_template [<name> <slot> <type>]
  [(def .public <name>
     (Meta <type>)
     (function (_ lux)
       {try.#Success [lux (the <slot> lux)]}))]

  [compiler_state [] Lux]
  
  [type_context .#type_context Type_Context]
  
  [target [.#info .#target] Text]
  [version [.#info .#version] Text]
  [configuration [.#info .#configuration] (List [Text Text])]
  )

(def .public (definition_type name)
  (-> Symbol (Meta Type))
  (do ..monad
    [[exported? definition] (definition name)]
    (when definition
      {.#Alias de_aliased}
      (definition_type de_aliased)
      
      {.#Definition [def_type def_value]}
      (clean_type def_type)

      {.#Default _}
      (failure (all text#composite
                    "Defaults are not considered definitions: "
                    (symbol#encoded name))))))

(def .public (type name)
  (-> Symbol (Meta Type))
  (when name
    ["" _name]
    (either (var_type _name)
            (definition_type name))

    _
    (definition_type name)))

(def .public (type_definition name)
  (-> Symbol (Meta Type))
  (do ..monad
    [[exported? definition] (definition name)]
    (when definition
      {.#Alias de_aliased}
      (type_definition de_aliased)
      
      {.#Definition [def_type def_value]}
      (let [type_code (`` (.in_module# (,, (static .prelude)) .type_code))]
        (if (or (same? .Type def_type)
                (of code.equivalence =
                    (type_code .Type)
                    (type_code def_type)))
          (in (as Type def_value))
          (..failure (all text#composite "Definition is not a type: " (symbol#encoded name)))))

      {.#Default _}
      (..failure (all text#composite "Default is not a type: " (symbol#encoded name))))))

(def .public (globals module)
  (-> Text (Meta (List [Text [Bit Global]])))
  (function (_ lux)
    (when (property.value module (the .#modules lux))
      {.#Some module}
      {try.#Success [lux (the .#definitions module)]}

      {.#None}
      {try.#Failure (all text#composite "Unknown module: " module)})))

(def .public (definitions module)
  (-> Text (Meta (List [Text [Bit Definition]])))
  (of ..monad each
      (list.all (function (_ [name [exported? global]])
                  (when global
                    {.#Alias de_aliased}
                    {.#None}
                    
                    {.#Definition definition}
                    {.#Some [name [exported? definition]]}

                    {.#Default _}
                    {.#None})))
      (..globals module)))

(def .public (resolved_globals module)
  (-> Text (Meta (List [Text [Bit Definition]])))
  (do [! ..monad]
    [it (..globals module)
     .let [input (is (List [Text Bit (Either Symbol Definition)])
                     (list.all (function (_ [name [exported? global]])
                                 (when global
                                   {.#Alias de_aliased}
                                   {.#Some [name exported? {.#Left de_aliased}]}
                                   
                                   {.#Definition definition}
                                   {.#Some [name exported? {.#Right definition}]}

                                   {.#Default _}
                                   {.#None}))
                               it))]]
    (function (_ lux)
      (loop (next [input input
                   output (is (List [Text [Bit Definition]])
                              (list))])
        (when input
          (list)
          {try.#Success [lux output]}

          (list.partial [name exported? it] input)
          (let [real_definition (is (Try Definition)
                                    (loop (again [it it])
                                      (when it
                                        {.#Left de_aliased}
                                        (when (..definition de_aliased lux)
                                          {try.#Success [_ [_ definition]]}
                                          (when definition
                                            {.#Alias de_aliased}
                                            (again {.#Left de_aliased})
                                            
                                            {.#Definition definition}
                                            {try.#Success definition}

                                            {.#Default _}
                                            {try.#Failure "Cannot de-alias a default global."})
                                          
                                          {try.#Failure error}
                                          {try.#Failure error})
                                        
                                        {.#Right definition}
                                        {try.#Success definition})))]
            (when real_definition
              {try.#Success it}
              (next input (list.partial [name [exported? it]] output))
              
              {try.#Failure error}
              {try.#Failure error})))))))

(def .public (exports module_name)
  (-> Text (Meta (List [Text Definition])))
  (do ..monad
    [constants (..definitions module_name)]
    (in (do list.monad
          [[name [exported? [def_type def_value]]] constants]
          (if exported?
            (in [name [def_type def_value]])
            (list))))))

(def .public modules
  (Meta (List [Text Module]))
  (function (_ lux)
    (|> lux
        (the .#modules)
        [lux]
        {try.#Success})))

(def type#=
  (`` (.in_module# (,, (static .prelude)) .type#=)))

(def type#encoded
  (`` (.in_module# (,, (static .prelude)) .type#encoded)))

(def .public (tags_of type_name)
  (-> Symbol (Meta (Maybe (List Symbol))))
  (do ..monad
    [.let [[module_name name] type_name]
     module (..module module_name)]
    (in (list.one (function (_ [short [exported? global]])
                    (when global
                      {.#Definition [type value]}
                      (if (type#= Slot type)
                        (let [[label type] (as Label value)]
                          (when type
                            {.#Named actual_name anonymous}
                            (if (symbol#= type_name actual_name)
                              {.#Some (when label
                                        {.#Some [lefts right? family]}
                                        family
                                        
                                        {.#None}
                                        (list [module_name short]))}
                              {.#None})

                            _
                            {.#None}))
                        {.#None})

                      _
                      {.#None}))
                  (the .#definitions module)))))

(def .public location
  (Meta Location)
  (function (_ lux)
    {try.#Success [lux (the .#location lux)]}))

(def .public expected_type
  (Meta Type)
  (function (_ lux)
    (when (the .#expected lux)
      {.#Some type}
      {try.#Success [lux type]}

      {.#None}
      {try.#Failure "Not expecting any type."})))

(def .public (imported_modules module_name)
  (-> Text (Meta (List Text)))
  (do ..monad
    [(open "_[0]") (..module module_name)]
    (in _#imports)))

(def .public (imported_by? import module)
  (-> Text Text (Meta Bit))
  (do ..monad
    [(open "_[0]") (..module module)]
    (in (list.any? (text#= import) _#imports))))

(def .public (imported? import)
  (-> Text (Meta Bit))
  (of ..functor each
      (|>> (the .#imports) (list.any? (text#= import)))
      ..current_module))

(with_template [<name> <description> <type>]
  [(def .public (<name> label_name)
     (-> Symbol (Meta Label))
     (do ..monad
       [.let [[module name] label_name]
        =module (..module module)
        this_module_name ..current_module_name]
       (when (property.value name (the .#definitions =module))
         {.#Some [exported? {.#Definition [def_type def_value]}]}
         (if (or (text#= this_module_name module)
                 exported?)
           (if (type#= <type> def_type)
             (in (as Label def_value))
             (..failure (all text#composite "Invalid type for " <description> " " (symbol#encoded label_name) " : " (type#encoded def_type))))
           (..failure (all text#composite "Cannot access " <description>  ": " (symbol#encoded label_name) " from module " this_module_name)))

         _
         (..failure (all text#composite
                         "Unknown " <description>  ": " (symbol#encoded label_name))))))]

  [tag "tag" .Tag]
  [slot "slot" .Slot]
  )

(def .public (tag_lists module)
  (-> Text (Meta (List [(List Symbol) Type])))
  (do ..monad
    [=module (..module module)
     this_module_name ..current_module_name]
    (in (property.values
         (list#mix (function (_ [short [exported? global]] output)
                     (when global
                       {.#Definition [type value]}
                       (if (and (type#= Slot type)
                                (or exported?
                                    (text#= this_module_name module)))
                         (let [[label type] (as Label value)]
                           (when label
                             {.#Some [lefts right? family]}
                             (when family
                               (list.partial [_ short] _)
                               (property.has short [family type] output)

                               (list)
                               (property.has short [(list [module short]) type] output))
                             
                             {.#None}
                             (property.has short [(list [module short]) type] output)))
                         output)

                       _
                       output))
                   (is (property.List [(List Symbol) Type])
                       (list))
                   (the .#definitions =module))))))

(def .public locals
  (Meta (List (List [Text Type])))
  (function (_ lux)
    (when (list.inits (the .#scopes lux))
      {.#Some scopes}
      {try.#Success [lux
                     (list#each (|>> (the [.#locals .#mappings])
                                     (list#each (function (_ [name [type _]])
                                                  [name type])))
                                scopes)]}

      {.#None}
      {try.#Failure "No local environment"})))

(def .public (de_aliased def_name)
  (-> Symbol (Meta Symbol))
  (do ..monad
    [[exported? constant] (..definition def_name)]
    (in (when constant
          {.#Alias real_def_name}
          real_def_name

          {.#Definition _}
          def_name

          {.#Default _}
          def_name))))

(def .public (of_try result)
  (All (_ of)
    (-> (Try of)
        (Meta of)))
  (when result
    {try.#Success output}
    (of ..monad in output)

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

(def .public (eval type code)
  (-> Type Code (Meta Any))
  (do [! ..monad]
    [eval (of ! each (the .#eval)
              ..compiler_state)]
    (eval type code)))

(def .public (try computation)
  (All (_ it) (-> (Meta it) (Meta (Try it))))
  (function (_ lux)
    {try.#Success (when (computation lux)
                    {try.#Success [lux' output]}
                    [lux' {try.#Success output}]

                    {try.#Failure error}
                    [lux {try.#Failure error}])}))