(.using
  [library
   [lux "*"
    ["[0]" meta]
    [abstract
     [monad {"+" Monad do}]]
    [control
     ["[0]" exception {"+" exception:}]
     ["<>" parser ("[1]#[0]" monad)
      ["<[0]>" code {"+" Parser}]]]
    [data
     ["[0]" text ("[1]#[0]" equivalence monoid)]
     [collection
      ["[0]" list ("[1]#[0]" functor monoid)]]]
    [macro
     ["[0]" code]
     [syntax {"+" syntax:}
      ["|[0]|" export]]]
    [meta
     ["[0]" symbol ("[1]#[0]" codec)]]]]
  ["[0]" //])

(type: Stack
  List)

(def: peek
  (All (_ a) (-> (Stack a) (Maybe a)))
  list.head)

(def: (push value stack)
  (All (_ a) (-> a (Stack a) (Stack a)))
  {.#Item value stack})

(def: pop
  (All (_ a) (-> (Stack a) (Maybe (Stack a))))
  list.tail)

(type: .public Frame
  (Record
   [#name Text
    #type_vars (List Code)
    #abstraction Code
    #representation Code]))

(def: frames
  (Stack Frame)
  {.#End})

(template: (!peek <source> <reference> <then>)
  [(loop [entries <source>]
     (case entries
       {.#Item [head_name head] tail}
       (if (text#= <reference> head_name)
         <then>
         (again tail))

       {.#End}
       (undefined)))])

(def: (peek_frames_definition reference source)
  (-> Text (List [Text Global]) (Stack Frame))
  (!peek source reference
         (case head
           {.#Definition [exported? frame_type frame_value]}
           (:as (Stack Frame) frame_value)

           (^or {.#Type _}
                {.#Alias _}
                {.#Tag _}
                {.#Slot _})
           (undefined))))

(def: (peek_frames reference definition_reference source)
  (-> Text Text (List [Text Module]) (Stack Frame))
  (!peek source reference
         (peek_frames_definition definition_reference (value@ .#definitions head))))

(exception: .public no_active_frames)

(def: (peek! frame)
  (-> (Maybe Text) (Meta Frame))
  (function (_ compiler)
    (let [[reference definition_reference] (symbol ..frames)
          current_frames (peek_frames reference definition_reference (value@ .#modules compiler))]
      (case (case frame
              {.#Some frame}
              (list.example (function (_ [actual _])
                              (text#= frame actual))
                            current_frames)
              
              {.#None}
              (..peek current_frames))
        {.#Some frame}
        {.#Right [compiler frame]}
        
        {.#None}
        (exception.except ..no_active_frames [])))))

(def: .public current
  (Meta Frame)
  (..peek! {.#None}))

(def: .public (specific name)
  (-> Text (Meta Frame))
  (..peek! {.#Some name}))

(template: (!push <source> <reference> <then>)
  [(loop [entries <source>]
     (case entries
       {.#Item [head_name head] tail}
       (if (text#= <reference> head_name)
         {.#Item [head_name <then>]
                 tail}
         {.#Item [head_name head]
                 (again tail)})

       {.#End}
       (undefined)))])

(def: (push_frame_definition reference frame source)
  (-> Text Frame (List [Text Global]) (List [Text Global]))
  (!push source reference
         (case head
           {.#Definition [exported? frames_type frames_value]}
           {.#Definition [exported?
                          frames_type
                          (..push frame (:as (Stack Frame) frames_value))]}

           (^or {.#Type _}
                {.#Alias _}
                {.#Tag _}
                {.#Slot _})
           (undefined))))

(def: (push_frame [module_reference definition_reference] frame source)
  (-> Symbol Frame (List [Text Module]) (List [Text Module]))
  (!push source module_reference
         (revised@ .#definitions (push_frame_definition definition_reference frame) head)))

(def: (push! frame)
  (-> Frame (Meta Any))
  (function (_ compiler)
    {.#Right [(revised@ .#modules
                        (..push_frame (symbol ..frames) frame)
                        compiler)
              []]}))

(def: (pop_frame_definition reference source)
  (-> Text (List [Text Global]) (List [Text Global]))
  (!push source reference
         (case head
           {.#Definition [exported? frames_type frames_value]}
           {.#Definition [exported?
                          frames_type
                          (let [current_frames (:as (Stack Frame) frames_value)]
                            (case (..pop current_frames)
                              {.#Some current_frames'}
                              current_frames'

                              {.#None}
                              current_frames))]}

           (^or {.#Type _}
                {.#Alias _}
                {.#Tag _}
                {.#Slot _})
           (undefined))))

(def: (pop_frame [module_reference definition_reference] source)
  (-> Symbol (List [Text Module]) (List [Text Module]))
  (!push source module_reference
         (|> head (revised@ .#definitions (pop_frame_definition definition_reference)))))

(syntax: (pop! [])
  (function (_ compiler)
    {.#Right [(revised@ .#modules
                        (..pop_frame (symbol ..frames))
                        compiler)
              (list)]}))

(def: cast
  (Parser [(Maybe Text) Code])
  (<>.either (<>.and (<>.maybe <code>.local_symbol) <code>.any)
             (<>.and (<>#in {.#None}) <code>.any)))

(template [<name> <from> <to>]
  [(syntax: .public (<name> [[frame value] ..cast])
     (do meta.monad
       [[name type_vars abstraction representation] (peek! frame)]
       (in (list (` ((~! //.:as) [(~+ type_vars)] (~ <from>) (~ <to>)
                     (~ value)))))))]

  [:abstraction representation abstraction]
  [:representation abstraction representation]
  )

(def: abstraction_type_name
  (-> Symbol Text)
  symbol#encoded)

(def: representation_definition_name
  (-> Text Text)
  (|>> ($_ text#composite
           (symbol#encoded (symbol ..#Representation))
           " ")))

(def: declaration
  (Parser [Text (List Text)])
  (<>.either (<code>.form (<>.and <code>.local_symbol (<>.some <code>.local_symbol)))
             (<>.and <code>.local_symbol (# <>.monad in (list)))))

(def: abstract
  (Parser [Code [Text (List Text)] Code (List Code)])
  (|export|.parser
   ($_ <>.and
       ..declaration
       <code>.any
       (<>.some <code>.any)
       )))

... TODO: Make sure the generated code always gets optimized away.
... (This applies to uses of ":abstraction" and ":representation")
(syntax: .public (abstract: [[export_policy [name type_vars] representation_type primitives]
                             ..abstract])
  (do meta.monad
    [current_module meta.current_module_name
     .let [type_varsC (list#each code.local_symbol type_vars)
           abstraction_declaration (` ((~ (code.local_symbol name)) (~+ type_varsC)))
           representation_declaration (` ((~ (code.local_symbol (representation_definition_name name)))
                                          (~+ type_varsC)))]
     _ (..push! [name
                 type_varsC
                 abstraction_declaration
                 representation_declaration])]
    (in (list& (` (type: (~ export_policy) (~ abstraction_declaration)
                    (Primitive (~ (code.text (abstraction_type_name [current_module name])))
                               [(~+ type_varsC)])))
               (` (type: (~ representation_declaration)
                    (~ representation_type)))
               ($_ list#composite
                   primitives
                   (list (` ((~! ..pop!)))))))))

(type: (Selection a)
  (Variant
   {#Specific Code a}
   {#Current a}))

(def: (selection parser)
  (All (_ a) (-> (Parser a) (Parser (Selection a))))
  (<>.or (<>.and <code>.any parser)
         parser))

(syntax: .public (:transmutation [selection (..selection <code>.any)])
  (case selection
    {#Specific specific value}
    (in (list (` (.|> (~ value)
                      (..:representation (~ specific))
                      (..:abstraction (~ specific))))))
    
    {#Current value}
    (in (list (` (.|> (~ value) ..:representation ..:abstraction))))))

(syntax: .public (^:representation [selection (<code>.form (..selection <code>.local_symbol))
                                    body <code>.any
                                    branches (<>.some <code>.any)])
  (case selection
    {#Specific specific name}
    (let [g!var (code.local_symbol name)]
      (in (list& g!var
                 (` (.let [(~ g!var) (..:representation (~ specific) (~ g!var))]
                      (~ body)))
                 branches)))
    
    {#Current name}
    (let [g!var (code.local_symbol name)]
      (in (list& g!var
                 (` (.let [(~ g!var) (..:representation (~ g!var))]
                      (~ body)))
                 branches)))))
