path: root/stdlib/source/library/lux/type/abstract.lux

(.module:
  [library
   [lux #*
    ["." meta]
    [abstract
     [monad (#+ Monad do)]]
    [control
     ["." exception (#+ exception:)]
     ["<>" parser ("#\." monad)
      ["<.>" code (#+ Parser)]]]
    [data
     ["." name ("#\." codec)]
     ["." text ("#\." equivalence monoid)]
     [collection
      ["." list ("#\." functor monoid)]]]
    [macro
     ["." code]
     [syntax (#+ syntax:)
      ["|.|" annotations]]]]]
  ["." //])

(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
  {#.doc (example "Meta-data about an abstract/nominal type in a stack of them.")}
  {#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>
         (recur tail))

       #.End
       (undefined)))])

(def: (peek_frames_definition reference source)
  (-> Text (List [Text Global]) (Stack Frame))
  (!peek source reference
         (case head
           (#.Left _)
           (undefined)

           (#.Right [exported? frame_type frame_anns frame_value])
           (:as (Stack Frame) frame_value))))

(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] (name_of ..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
  {#.doc (example "The currently-being-defined abstract/nominal type.")}
  (Meta Frame)
  (..peek! #.None))

(def: .public (specific name)
  {#.doc (example "A specific abstract/nominal type still being defined somewhere in the scope.")}
  (-> 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]
                 (recur tail)))

       #.End
       (undefined)))])

(def: (push_frame_definition reference frame source)
  (-> Text Frame (List [Text Global]) (List [Text Global]))
  (!push source reference
         (case head
           (#.Left _)
           (undefined)

           (#.Right [exported? frames_type frames_anns frames_value])
           (#.Right [exported?
                     frames_type
                     frames_anns
                     (..push frame (:as (Stack Frame) frames_value))]))))

(def: (push_frame [module_reference definition_reference] frame source)
  (-> Name 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 (name_of ..frames) frame)
                        compiler)
              []])))

(def: (pop_frame_definition reference source)
  (-> Text (List [Text Global]) (List [Text Global]))
  (!push source reference
         (case head
           (#.Left _)
           (undefined)

           (#.Right [exported? frames_type frames_anns frames_value])
           (#.Right [exported?
                     frames_type
                     frames_anns
                     (let [current_frames (:as (Stack Frame) frames_value)]
                       (case (..pop current_frames)
                         (#.Some current_frames')
                         current_frames'

                         #.None
                         current_frames))]))))

(def: (pop_frame [module_reference definition_reference] source)
  (-> Name (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 (name_of ..frames))
                        compiler)
              (list)])))

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

(template [<name> <from> <to>]
  [(syntax: .public (<name> [[frame value] ..cast])
     {#.doc (example "Type-casting macro for abstract/nominal types."
                     (: <to>
                        (<name> (: <from>
                                   value))))}
     (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
  (-> Name Text)
  (|>> name\encode
       ($_ text\compose
           (name\encode (name_of #..Abstraction))
           " ")))

(def: representation_definition_name
  (-> Text Text)
  (|>> ($_ text\compose
           (name\encode (name_of #..Representation))
           " ")))

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

(def: abstract
  (Parser [Code [Text (List Text)] |annotations|.Annotations Code (List Code)])
  (let [private (: (Parser [[Text (List Text)] |annotations|.Annotations Code (List Code)])
                   ($_ <>.and
                       ..declaration
                       |annotations|.parser
                       <code>.any
                       (<>.some <code>.any)
                       ))]
    ($_ <>.either
        (<>.and <code>.any private)
        (<>.and (<>\in (` .private)) private)
        )))

... 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] annotations representation_type primitives]
                             ..abstract])
  {#.doc (example "Define abstract/nominal types which hide their representation details."
                  "You can convert between the abstraction and its representation selectively to access the value, while hiding it from others."
                  (abstract: String
                    {#.doc "An opaque text."}

                    Text

                    (def: (string value)
                      (-> Text String)
                      (:abstraction value))

                    (def: (text value)
                      (-> String Text)
                      (:representation value)))

                  "Type-parameters are optional."
                  (abstract: (Duplicate a)
                    {}

                    [a a]

                    (def: (duplicate value)
                      (All [a] (-> a (Duplicate a)))
                      (:abstraction [value value])))

                  "Definitions can be nested."
                  (abstract: (Single a)
                    {}

                    a

                    (def: (single value)
                      (All [a] (-> a (Single a)))
                      (:abstraction value))

                    (abstract: (Double a)
                      {}

                      [a a]

                      (def: (double value)
                        (All [a] (-> a (Double a)))
                        (:abstraction [value value]))

                      (def: (single' value)
                        (All [a] (-> a (Single a)))
                        (:abstraction Single [value value]))

                      (let [value 0123]
                        (same? value
                               (|> value
                                   single'
                                   (:representation Single)
                                   double
                                   :representation)))))

                  "Type-parameters do not necessarily have to be used in the representation type."
                  "If they are not used, they become phantom types and can be used to customize types without changing the representation."
                  (abstract: (JavaScript a)
                    {}

                    Text

                    (abstract: Expression {} Any)
                    (abstract: Statement {} Any)

                    (def: (+ x y)
                      (-> (JavaScript Expression) (JavaScript Expression) (JavaScript Expression))
                      (:abstraction
                       (format "(" (:representation x) "+" (:representation y) ")")))

                    (def: (while test body)
                      (-> (JavaScript Expression) (JavaScript Statement) (JavaScript Statement))
                      (:abstraction
                       (format "while(" (:representation test) ") {"
                               (:representation body)
                               "}"))))
                  )}
  (do meta.monad
    [current_module meta.current_module_name
     .let [type_varsC (list\map code.local_identifier type_vars)
           abstraction_declaration (` ((~ (code.local_identifier name)) (~+ type_varsC)))
           representation_declaration (` ((~ (code.local_identifier (representation_definition_name name)))
                                          (~+ type_varsC)))]
     _ (..push! [name
                 type_varsC
                 abstraction_declaration
                 representation_declaration])]
    (in (list& (` (type: (~ export_policy) (~ abstraction_declaration)
                    (~ (|annotations|.format annotations))
                    (primitive (~ (code.text (abstraction_type_name [current_module name])))
                               [(~+ type_varsC)])))
               (` (type: (~ representation_declaration)
                    (~ representation_type)))
               ($_ list\compose
                   primitives
                   (list (` ((~! ..pop!)))))))))

(type: (Selection a)
  (#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)])
  {#.doc (example "Transmutes an abstract/nominal type's phantom types."
                  (abstract: (JavaScript a)
                    {}

                    Text

                    (abstract: Expression {} Any)
                    (abstract: Statement {} Any)

                    (def: (statement expression)
                      (-> (JavaScript Expression) (JavaScript Statement))
                      (:transmutation expression))

                    (def: (statement' expression)
                      (-> (JavaScript Expression) (JavaScript Statement))
                      (:transmutation JavaScript expression))))}
  (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_identifier))
                                    body <code>.any
                                    branches (<>.some <code>.any)])
  {#.doc (example "Pattern-matching macro to easily extract a representation."
                  (def: (computation abstraction)
                    (All [a] (-> (Abstract a) ???))
                    (let [(^:representation value) abstraction]
                      (foo (bar (baz value))))))}
  (case selection
    (#Specific specific name)
    (let [g!var (code.local_identifier name)]
      (in (list& g!var
                 (` (.let [(~ g!var) (..:representation (~ specific) (~ g!var))]
                      (~ body)))
                 branches)))
    
    (#Current name)
    (let [g!var (code.local_identifier name)]
      (in (list& g!var
                 (` (.let [(~ g!var) (..:representation (~ g!var))]
                      (~ body)))
                 branches)))))