path: root/stdlib/source/lux/type/object.lux

(;module:
  lux
  (lux (control ["M" monad #+ do Monad]
                ["p" parser "p/" Monad<Parser>])
       (data [text]
             text/format
             [product]
             [maybe]
             [ident #+ "Ident/" Eq<Ident>]
             (coll [list "L/" Functor<List> Fold<List> Monoid<List>]
                   [set #+ Set]))
       [meta #+ Monad<Meta> "Meta/" Monad<Meta>]
       (meta [code]
             ["s" syntax #+ syntax:]
             (syntax ["cs" common]
                     (common ["csr" reader]
                             ["csw" writer])))
       (lang [type])))

## [Common]
(type: Declaration
  [Text (List Text)])

(type: Alias Text)

(def: default-alias Alias "@")

(def: (var-set vars)
  (-> (List Text) (Set Text))
  (set;from-list text;Hash<Text> vars))

(def: (unique-type-vars parser)
  (-> (s;Syntax (List Text)) (s;Syntax (List Text)))
  (do p;Monad<Parser>
    [raw parser
     _ (p;assert "Cannot repeat the names of type variables/parameters."
                 (n.= (set;size (var-set raw))
                      (list;size raw)))]
    (wrap raw)))

(def: (safe-type-vars exclusions)
  (-> (Set Text) (s;Syntax Text))
  (do p;Monad<Parser>
    [raw s;local-symbol
     _ (p;assert "Cannot re-use names between method type-variables and interface type-parameters."
                 (|> raw (set;member? exclusions) not))]
    (wrap raw)))

(def: declarationS
  (s;Syntax Declaration)
  (p;either (s;form (p;seq s;local-symbol
                           (unique-type-vars (p;some s;local-symbol))))
            (p;seq s;local-symbol
                   (p/wrap (list)))))

(def: aliasS
  (s;Syntax Alias)
  (|> s;local-symbol
      (p;after (s;this (' #as)))
      (p;default default-alias)))

(def: (ancestor-inputs ancestors)
  (-> (List Ident) (List Code))
  (if (list;empty? ancestors)
    (list)
    (|> (list;size ancestors)
        n.dec
        (list;n.range +0)
        (L/map (|>. %n (format "ancestor") code;local-symbol)))))

## [Methods]
(type: Method
  {#type-vars (List Text)
   #name Text
   #inputs (List Code)
   #output Code})

(def: (method exclusions)
  (-> (Set Text) (s;Syntax Method))
  (s;form ($_ p;seq
              (p;either (unique-type-vars (s;tuple (p;some (safe-type-vars exclusions))))
                        (p/wrap (list)))
              s;local-symbol
              (s;tuple (p;some s;any))
              s;any)))

(def: (declarationM g!self (^open))
  (-> Code Method Code)
  (let [g!type-vars (L/map code;local-symbol type-vars)
        g!method (code;local-symbol name)]
    (` (: (All [(~@ g!type-vars)]
            (-> (~@ inputs) (~ g!self) (~ output)))
          (~ g!method)))))

(def: (definition export [interface parameters] g!self-object g!ext g!states (^open))
  (-> (Maybe cs;Export) Declaration Code Code (List Code) Method Code)
  (let [g!method (code;local-symbol name)
        g!parameters (L/map code;local-symbol parameters)
        g!type-vars (L/map code;local-symbol type-vars)
        g!_temp (code;symbol ["" "_temp"])
        g!_object (code;symbol ["" "_object"])
        g!_behavior (code;symbol ["" "_behavior"])
        g!_state (code;symbol ["" "_state"])
        g!_extension (code;symbol ["" "_extension"])
        g!_args (L/map (|>. product;left nat-to-int %i (format "_") code;local-symbol)
                       (list;enumerate inputs))
        g!destructuring (L/fold (function [_ g!bottom] (` [(~ g!_temp) (~ g!_temp) (~ g!bottom)]))
                                (` [(~ g!_behavior) (~ g!_state) (~ g!_extension)])
                                (maybe;default g!states (list;tail g!states)))]
    (` (def: (~@ (csw;export export)) ((~ g!method) (~@ g!_args) (~ g!_object))
         (All [(~@ g!parameters) (~ g!ext) (~@ g!states) (~@ g!type-vars)]
           (-> (~@ inputs) (~ g!self-object) (~ output)))
         (let [(~ g!destructuring) (~ g!_object)]
           (:: (~ g!_behavior) (~ g!method) (~@ g!_args) (~ g!_object)))))))

## [Inheritance]
(type: Reference
  [Ident (List Code)])

(def: no-parent Ident ["" ""])

(def: (no-parent? parent)
  (-> Ident Bool)
  (Ident/= no-parent parent))

(def: (with-interface parent interface)
  (-> Ident Ident cs;Annotations cs;Annotations)
  (|>. (#;Cons [(ident-for #;;interface-name)
                (code;tag interface)])
       (#;Cons [(ident-for #;;interface-parent)
                (code;tag parent)])))

(def: (with-class interface parent class)
  (-> Ident Ident Ident cs;Annotations cs;Annotations)
  (|>. (#;Cons [(ident-for #;;class-interface)
                (code;tag interface)])
       (#;Cons [(ident-for #;;class-parent)
                (code;tag parent)])
       (#;Cons [(ident-for #;;class-name)
                (code;tag class)])))

(do-template [<name> <name-tag> <parent-tag> <desc>]
  [(def: (<name> name)
     (-> Ident (Meta [Ident (List Ident)]))
     (do Monad<Meta>
       [name (meta;normalize name)
        [_ annotations _] (meta;find-def name)]
       (case [(meta;get-tag-ann (ident-for <name-tag>) annotations)
              (meta;get-tag-ann (ident-for <parent-tag>) annotations)]
         [(#;Some real-name) (#;Some parent)]
         (if (Ident/= no-parent parent)
           (wrap [real-name (list)])
           (do @
             [[_ ancestors] (<name> parent)]
             (wrap [real-name (#;Cons parent ancestors)])))

         _
         (meta;fail (format "Wrong format for " <desc> " lineage.")))))]

  [interfaceN #;;interface-name #;;interface-parent "interface"]
  [classN     #;;class-name     #;;class-parent     "class"]
  )

(def: (extract newT)
  (-> Type (Meta [Nat (List Type)]))
  (loop [depth +0
         currentT newT]
    (case currentT
      (#;UnivQ _ bodyT)
      (recur (n.inc depth) bodyT)

      (#;Function inputT outputT)
      (let [[stateT+ objectT] (type;flatten-function currentT)]
        (Meta/wrap [depth stateT+]))

      _
      (meta;fail (format "Cannot extract inheritance from type: " (type;to-text newT))))))

(def: (specialize mappings typeC)
  (-> (List Code) Code Code)
  (case (list;size mappings)
    +0
    typeC
    
    size
    (|> (n.dec size)
        (list;n.range +0)
        (L/map (|>. (n.* +2) n.inc code;nat (~) #;Bound (`)))
        (list;zip2 (list;reverse mappings))
        (L/fold (function [[mappingC boundC] genericC]
                  (code;replace boundC mappingC genericC))
                typeC))))

(def: referenceS
  (s;Syntax Reference)
  (p;either (s;form (p;seq s;symbol
                           (p;some s;any)))
            (p;seq s;symbol
                   (p/wrap (list)))))

(do-template [<name> <keyword>]
  [(def: <name>
     (s;Syntax Reference)
     (|> referenceS
         (p;after (s;this (' <keyword>)))))]

  [extension   #super]
  [inheritance #super]
  )

## [Notation]
## Utils
(def: (nest ancestors bottom)
  (-> (List Code) Code Code)
  (L/fold (function [[level _] g!bottom]
            (let [g!_behavior' (code;local-symbol (format "_behavior" (%n level)))
                  g!_state' (code;local-symbol (format "_state" (%n level)))]
              (` [(~ g!_behavior') (~ g!_state') (~ g!bottom)])))
          bottom
          (list;enumerate ancestors)))

## Names
(do-template [<name> <category>]
  [(def: (<name> base)
     (-> Text Text)
     (|> base (format <category> "@")))]
  
  [newN    "new"]
  [getN    "get"]
  [setN    "set"]
  [updateN "update"]
  )

(do-template [<name> <category>]
  [(def: (<name> raw)
     (-> Text Text)
     (let [[module kind] (ident-for <category>)]
       (format "{" kind "@" module "}" raw)))]

  [signatureN #;;Signature]
  [stateN     #;;State]
  [structN    #;;Struct]
  )

(def: (getterN export interface g!parameters g!ext g!child ancestors)
  (-> (Maybe cs;Export) Text (List Code) Code Code (List Ident)
      Code)
  (let [g!get (code;local-symbol (getN interface))
        g!interface (code;local-symbol interface)
        g!_object (' _object)
        g!_behavior (' _behavior)
        g!_state (' _state)
        g!_extension (' _extension)
        g!ancestors (ancestor-inputs ancestors)
        g!object (` ((~ g!interface) (~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child)))
        g!tear-down (nest g!ancestors
                          (` [(~ g!_behavior) (~ g!_state) (~ g!_extension)]))]
    (` (def: (~@ (csw;export export)) ((~ g!get) (~ g!_object))
         (All [(~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child)]
           (-> (~ g!object) (~ g!child)))
         (let [(~ g!tear-down) (~ g!_object)]
           (~ g!_state))))))

(def: (setterN export interface g!parameters g!ext g!child ancestors)
  (-> (Maybe cs;Export) Text (List Code) Code Code (List Ident)
      Code)
  (let [g!set (code;local-symbol (setN interface))
        g!interface (code;local-symbol interface)
        g!_object (' _object)
        g!_behavior (' _behavior)
        g!_state (' _state)
        g!_extension (' _extension)
        g!_input (' _input)
        g!ancestors (ancestor-inputs ancestors)
        g!object (` ((~ g!interface) (~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child)))
        g!tear-down (nest g!ancestors
                          (` [(~ g!_behavior) (~ g!_state) (~ g!_extension)]))
        g!build-up (nest g!ancestors
                         (` [(~ g!_behavior) (~ g!_input) (~ g!_extension)]))]
    (` (def: (~@ (csw;export export))
         ((~ g!set) (~ g!_input) (~ g!_object))
         (All [(~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child)]
           (-> (~ g!child) (~ g!object) (~ g!object)))
         (let [(~ g!tear-down) (~ g!_object)]
           (~ g!build-up))))))

(def: (updaterN export interface g!parameters g!ext g!child ancestors)
  (-> (Maybe cs;Export) Text (List Code) Code Code (List Ident)
      Code)
  (let [g!update (code;local-symbol (updateN interface))
        g!interface (code;local-symbol interface)
        g!_object (' _object)
        g!_behavior (' _behavior)
        g!_state (' _state)
        g!_extension (' _extension)
        g!_change (' _change)
        g!ancestors (ancestor-inputs ancestors)
        g!object (` ((~ g!interface) (~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child)))
        g!tear-down (nest g!ancestors
                          (` [(~ g!_behavior) (~ g!_state) (~ g!_extension)]))
        g!build-up (nest g!ancestors
                         (` [(~ g!_behavior) ((~ g!_change) (~ g!_state)) (~ g!_extension)]))]
    (` (def: (~@ (csw;export export))
         ((~ g!update) (~ g!_change) (~ g!_object))
         (All [(~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child)]
           (-> (-> (~ g!child) (~ g!child))
               (-> (~ g!object) (~ g!object))))
         (let [(~ g!tear-down) (~ g!_object)]
           (~ g!build-up))))))

## [Macros]
(def: (type-to-code type)
  (-> Type (Meta Code))
  (case type
    (#;Primitive name params)
    (do Monad<Meta>
      [paramsC+ (M;map @ type-to-code params)]
      (wrap (` (;primitive (~ (code;symbol ["" name]))
                           (~@ paramsC+)))))

    #;Void
    (Meta/wrap (` (;|)))
    
    #;Unit
    (Meta/wrap (` (;&)))

    (^template [<tag> <macro> <flatten>]
      (<tag> _)
      (do Monad<Meta>
        [partsC+ (M;map @ type-to-code (<flatten> type))]
        (wrap (` (<macro> (~@ partsC+))))))
    ([#;Sum     ;| type;flatten-variant]
     [#;Product ;& type;flatten-tuple])

    (#;Function input output)
    (do Monad<Meta>
      [#let [[insT+ outT] (type;flatten-function type)]
       insC+ (M;map @ type-to-code insT+)
       outC (type-to-code outT)]
      (wrap (` (;-> (~@ insC+) (~ outC)))))

    (^template [<tag>]
      (<tag> idx)
      (Meta/wrap (` (<tag> (~ (code;nat idx))))))
    ([#;Bound]
     [#;Var]
     [#;Ex])

    (#;Apply param fun)
    (do Monad<Meta>
      [#let [[funcT argsT+] (type;flatten-application type)]
       funcC (type-to-code funcT)
       argsC+ (M;map @ type-to-code argsT+)]
      (wrap (` ((~ funcC) (~@ argsC+)))))

    (#;Named name unnamedT)
    (Meta/wrap (code;symbol name))

    _
    (meta;fail (format "Cannot convert type to code: " (type;to-text type)))))

(syntax: #export (interface: [export csr;export]
                   [(^@ decl [interface parameters]) declarationS]
                   [?extends (p;maybe extension)]
                   [alias aliasS]
                   [annotations (p;default cs;empty-annotations csr;annotations)]
                   [methods (p;many (method (var-set parameters)))])
  (meta;with-gensyms [g!self-class g!child g!ext]
    (do @
      [module meta;current-module-name
       [parent ancestors mappings] (: (Meta [Ident (List Ident) (List Code)])
                                      (case ?extends
                                        #;None
                                        (wrap [no-parent (list) (list)])

                                        (#;Some [super mappings])
                                        (do @
                                          [[parent ancestors] (interfaceN super)]
                                          (wrap [parent (list& parent ancestors) mappings]))))
       #let [g!signature (code;local-symbol (signatureN interface))
             g!interface (code;local-symbol interface)
             g!parameters (L/map code;local-symbol parameters)
             g!self-ref (if (list;empty? g!parameters)
                          (list g!interface)
                          (list))
             g!interface-def (if (no-parent? parent)
                               (let [g!recur (` ((~ g!interface) (~@ g!parameters) (~ g!ext) (~ g!child)))]
                                 (` (Ex (~@ g!self-ref) [(~ g!ext) (~ g!child)]
                                      [((~ g!signature) (~@ g!parameters) (~ g!recur))
                                       (~ g!child)
                                       (~ g!ext)])))
                               (let [g!parent (code;symbol parent)
                                     g!ancestors (ancestor-inputs ancestors)
                                     g!recur (` ((~ g!interface) (~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child)))]
                                 (` (Ex (~@ g!self-ref) [(~ g!ext) (~@ g!ancestors) (~ g!child)]
                                      ((~ g!parent) (~@ mappings)
                                       [((~ g!signature) (~@ g!parameters) (~ g!recur))
                                        (~ g!child)
                                        (~ g!ext)]
                                       (~@ g!ancestors))))))]]
      (wrap (list& (` (sig: (~@ (csw;export export))
                        ((~ g!signature) (~@ g!parameters) (~ g!self-class))
                        (~@ (let [de-alias (code;replace (code;local-symbol alias) g!self-class)]
                              (L/map (|>. (update@ #inputs (L/map de-alias))
                                          (update@ #output de-alias)
                                          (declarationM g!self-class))
                                     methods)))))
                   
                   (` (type: (~@ (csw;export export)) ((~ g!interface) (~@ g!parameters))
                        (~ (|> annotations
                               (with-interface parent [module interface])
                               csw;annotations))
                        (~ g!interface-def)))
                   
                   (getterN export interface g!parameters g!ext g!child ancestors)
                   (setterN export interface g!parameters g!ext g!child ancestors)
                   (updaterN export interface g!parameters g!ext g!child ancestors)

                   (let [g!ancestors (ancestor-inputs ancestors)
                         g!states (L/compose g!ancestors (list g!child))
                         g!self-object (` ((~ g!interface) (~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child)))
                         de-alias (code;replace (code;symbol ["" alias]) g!self-object)]
                     (L/map (|>. (update@ #inputs (L/map de-alias))
                                 (update@ #output de-alias)
                                 (definition export decl g!self-object g!ext g!states))
                            methods))))
      )))

(syntax: #export (class: [export csr;export]
                   [[instance parameters] declarationS]
                   [annotations (p;default cs;empty-annotations csr;annotations)]
                   [[interface interface-mappings] referenceS]
                   [super (p;maybe inheritance)]
                   state-type
                   [impls (p;many s;any)])
  (meta;with-gensyms [g!init g!extension]
    (do @
      [module meta;current-module-name
       [interface _] (interfaceN interface)
       [parent ancestors parent-mappings] (: (Meta [Ident (List Ident) (List Code)])
                                             (case super
                                               (#;Some [super-class super-mappings])
                                               (do @
                                                 [[parent ancestors] (classN super-class)]
                                                 (wrap [parent ancestors super-mappings]))

                                               #;None
                                               (wrap [no-parent (list) (list)])))
       g!inheritance (: (Meta (List Code))
                        (if (no-parent? parent)
                          (wrap (list))
                          (do @
                            [newT (meta;find-def-type (product;both id newN parent))
                             [depth rawT+] (extract newT)
                             codeT+ (M;map @ type-to-code rawT+)]
                            (wrap (L/map (specialize parent-mappings) codeT+)))))
       #let [g!parameters (L/map code;local-symbol parameters)

             g!state (code;local-symbol (stateN instance))
             g!struct (code;local-symbol (structN instance))
             g!class (code;local-symbol instance)

             g!signature (code;symbol (product;both id signatureN interface))
             g!interface (code;symbol interface)

             g!parent-structs (if (no-parent? parent)
                                (list)
                                (L/map (|>. (product;both id structN) code;symbol) (list& parent ancestors)))]
       g!parent-inits (M;map @ (function [_] (meta;gensym "parent-init"))
                             g!parent-structs)
       #let [g!full-init (L/fold (function [[parent-struct parent-state] child]
                                   (` [(~ parent-struct) (~ parent-state) (~ child)]))
                                 (` [(~ g!struct) (~ g!init) []])
                                 (list;zip2 g!parent-structs g!parent-inits))
             g!new (code;local-symbol (newN instance))
             g!recur (` ((~ g!class) (~@ g!parameters) (~ g!extension)))
             g!rec (if (list;empty? g!parameters)
                     (list (' #rec))
                     (list))]]
      (wrap (list (` (type: (~@ (csw;export export))
                       ((~ g!state) (~@ g!parameters))
                       (~ state-type)))

                  (` (type: (~@ (csw;export export)) (~@ g!rec) ((~ g!class) (~@ g!parameters))
                       (~ (|> annotations
                              (with-class interface parent [module instance])
                              csw;annotations))
                       (Ex [(~ g!extension)]
                         (~ (if (no-parent? parent)
                              (` ((~ g!interface) (~@ interface-mappings)
                                  (~ g!extension)
                                  ((~ g!state) (~@ g!parameters))))
                              (let [g!parent (code;symbol parent)]
                                (` ((~ g!parent) (~@ parent-mappings)
                                    [((~ g!signature) (~@ interface-mappings) (~ g!recur))
                                     ((~ g!state) (~@ g!parameters))
                                     (~ g!extension)]))))))))

                  (` (struct: (~@ (csw;export export)) (~ g!struct)
                       (All [(~@ g!parameters) (~ g!extension)]
                         ((~ g!signature) (~@ interface-mappings)
                          ((~ g!interface) (~@ interface-mappings)
                           (~ g!extension)
                           (~@ g!inheritance)
                           ((~ g!state) (~@ g!parameters)))))
                       (~@ impls)))

                  (` (def: (~@ (csw;export export)) ((~ g!new) (~@ g!parent-inits) (~ g!init))
                       (All [(~@ g!parameters)]
                         (-> (~@ g!inheritance)
                             ((~ g!state) (~@ g!parameters))
                             ((~ g!class) (~@ g!parameters))))
                       (~ g!full-init)))
                  ))
      )))