(.module:
  lux
  (lux (control [monad #+ do]
                ["ex" exception #+ exception:]
                pipe)
       (data [text "text/" Eq<Text>]
             text/format
             ["e" error]
             (coll [list "list/" Fold<List> Functor<List>]))
       [macro]
       (macro [code]))
  (luxc ["&" lang]
        (lang ["&." scope])))

(exception: #export Unknown-Module)
(exception: #export Cannot-Declare-Tag-Twice)
(exception: #export Cannot-Declare-Tags-For-Unnamed-Type)
(exception: #export Cannot-Declare-Tags-For-Foreign-Type)
(exception: #export Cannot-Define-More-Than-Once)
(exception: #export Cannot-Define-In-Unknown-Module)
(exception: #export Can-Only-Change-State-Of-Active-Module)
(exception: #export Cannot-Set-Module-Annotations-More-Than-Once)

(def: (new-module hash)
  (-> Nat Module)
  {#.module-hash        hash
   #.module-aliases     (list)
   #.defs               (list)
   #.imports            (list)
   #.tags               (list)
   #.types              (list)
   #.module-annotations #.None
   #.module-state       #.Active})

(def: #export (set-annotations annotations)
  (-> Code (Meta Unit))
  (do macro.Monad<Meta>
    [self-name macro.current-module-name
     self macro.current-module]
    (case (get@ #.module-annotations self)
      #.None
      (function [compiler]
        (#e.Success [(update@ #.modules
                              (&.pl-put self-name (set@ #.module-annotations (#.Some annotations) self))
                              compiler)
                     []]))
      
      (#.Some old)
      (macro.fail (Cannot-Set-Module-Annotations-More-Than-Once
                   (format "         Module: " self-name "\n"
                           "Old annotations: " (%code old) "\n"
                           "New annotations: " (%code annotations) "\n"))))))

(def: #export (import module)
  (-> Text (Meta Unit))
  (do macro.Monad<Meta>
    [self macro.current-module-name]
    (function [compiler]
      (#e.Success [(update@ #.modules
                            (&.pl-update self (update@ #.imports (|>> (#.Cons module))))
                            compiler)
                   []]))))

(def: #export (alias alias module)
  (-> Text Text (Meta Unit))
  (do macro.Monad<Meta>
    [self macro.current-module-name]
    (function [compiler]
      (#e.Success [(update@ #.modules
                            (&.pl-update self (update@ #.module-aliases (: (-> (List [Text Text]) (List [Text Text]))
                                                                           (|>> (#.Cons [alias module])))))
                            compiler)
                   []]))))

(def: #export (exists? module)
  (-> Text (Meta Bool))
  (function [compiler]
    (|> (get@ #.modules compiler)
        (&.pl-get module)
        (case> (#.Some _) true #.None false)
        [compiler] #e.Success)))

(def: #export (define (^@ full-name [module-name def-name])
                      definition)
  (-> Ident Def (Meta Unit))
  (function [compiler]
    (case (&.pl-get module-name (get@ #.modules compiler))
      (#.Some module)
      (case (&.pl-get def-name (get@ #.defs module))
        #.None
        (#e.Success [(update@ #.modules
                              (&.pl-put module-name
                                        (update@ #.defs
                                                 (: (-> (List [Text Def]) (List [Text Def]))
                                                    (|>> (#.Cons [def-name definition])))
                                                 module))
                              compiler)
                     []])

        (#.Some already-existing)
        ((&.throw Cannot-Define-More-Than-Once (%ident full-name)) compiler))

      #.None
      ((&.throw Cannot-Define-In-Unknown-Module (%ident full-name)) compiler))))

(def: #export (create hash name)
  (-> Nat Text (Meta Module))
  (function [compiler]
    (let [module (new-module hash)]
      (#e.Success [(update@ #.modules
                            (&.pl-put name module)
                            compiler)
                   module]))))

(def: #export (with-module hash name action)
  (All [a] (-> Nat Text (Meta a) (Meta [Module a])))
  (do macro.Monad<Meta>
    [_ (create hash name)
     output (&.with-current-module name
              action)
     module (macro.find-module name)]
    (wrap [module output])))

(do-template [<flagger> <asker> <tag> <description>]
  [(def: #export (<flagger> module-name)
     (-> Text (Meta Unit))
     (function [compiler]
       (case (|> compiler (get@ #.modules) (&.pl-get module-name))
         (#.Some module)
         (let [active? (case (get@ #.module-state module)
                         #.Active true
                         _     false)]
           (if active?
             (#e.Success [(update@ #.modules
                                   (&.pl-put module-name (set@ #.module-state <tag> module))
                                   compiler)
                          []])
             ((&.throw Can-Only-Change-State-Of-Active-Module
                       (format "       Module: " module-name "\n"
                               "Desired state: " <description>))
              compiler)))

         #.None
         ((&.throw Unknown-Module module-name) compiler))))
   (def: #export (<asker> module-name)
     (-> Text (Meta Bool))
     (function [compiler]
       (case (|> compiler (get@ #.modules) (&.pl-get module-name))
         (#.Some module)
         (#e.Success [compiler
                      (case (get@ #.module-state module)
                        <tag> true
                        _     false)])

         #.None
         ((&.throw Unknown-Module module-name) compiler))
       ))]

  [flag-active!   active?   #.Active   "Active"]
  [flag-compiled! compiled? #.Compiled "Compiled"]
  [flag-cached!   cached?   #.Cached   "Cached"]
  )

(do-template [<name> <tag> <type>]
  [(def: (<name> module-name)
     (-> Text (Meta <type>))
     (function [compiler]
       (case (|> compiler (get@ #.modules) (&.pl-get module-name))
         (#.Some module)
         (#e.Success [compiler (get@ <tag> module)])

         #.None
         ((&.throw Unknown-Module module-name) compiler))
       ))]

  [tags-by-module  #.tags        (List [Text [Nat (List Ident) Bool Type]])]
  [types-by-module #.types       (List [Text [(List Ident) Bool Type]])]
  [module-hash     #.module-hash Nat]
  )

(def: (ensure-undeclared-tags module-name tags)
  (-> Text (List Text) (Meta Unit))
  (do macro.Monad<Meta>
    [bindings (tags-by-module module-name)
     _ (monad.map @
                  (function [tag]
                    (case (&.pl-get tag bindings)
                      #.None
                      (wrap [])

                      (#.Some _)
                      (&.throw Cannot-Declare-Tag-Twice (format "Module: " module-name "\n"
                                                                "   Tag: " tag))))
                  tags)]
    (wrap [])))

(def: #export (declare-tags tags exported? type)
  (-> (List Text) Bool Type (Meta Unit))
  (do macro.Monad<Meta>
    [current-module macro.current-module-name
     [type-module type-name] (case type
                               (#.Named type-ident _)
                               (wrap type-ident)

                               _
                               (&.throw Cannot-Declare-Tags-For-Unnamed-Type
                                        (format "Tags: " (|> tags (list/map code.text) code.tuple %code) "\n"
                                                "Type: " (%type type))))
     _ (ensure-undeclared-tags current-module tags)
     _ (&.assert Cannot-Declare-Tags-For-Foreign-Type
                 (format "Tags: " (|> tags (list/map code.text) code.tuple %code) "\n"
                         "Type: " (%type type))
                 (text/= current-module type-module))]
    (function [compiler]
      (case (|> compiler (get@ #.modules) (&.pl-get current-module))
        (#.Some module)
        (let [namespaced-tags (list/map (|>> [current-module]) tags)]
          (#e.Success [(update@ #.modules
                                (&.pl-update current-module
                                             (|>> (update@ #.tags (function [tag-bindings]
                                                                    (list/fold (function [[idx tag] table]
                                                                                 (&.pl-put tag [idx namespaced-tags exported? type] table))
                                                                               tag-bindings
                                                                               (list.enumerate tags))))
                                                  (update@ #.types (&.pl-put type-name [namespaced-tags exported? type]))))
                                compiler)
                       []]))
        #.None
        ((&.throw Unknown-Module current-module) compiler)))))