Can now define nested abstract types.

3 files changed, 169 insertions, 142 deletions

diff --git a/stdlib/source/lux/data/collection/stack.lux b/stdlib/source/lux/data/collection/stack.lux
index 6a7e5a215..2f822ecb1 100644
--- a/stdlib/source/lux/data/collection/stack.lux
+++ b/stdlib/source/lux/data/collection/stack.lux
@@ -4,11 +4,9 @@
     [collection
      ["." list]]]])
 
-## [Types]
 (type: #export (Stack a)
   (List a))
 
-## [Values]
 (def: #export empty
   Stack
   (list))
diff --git a/stdlib/source/lux/macro/syntax/common/writer.lux b/stdlib/source/lux/macro/syntax/common/writer.lux
index 9133cdfa0..fe4c961e2 100644
--- a/stdlib/source/lux/macro/syntax/common/writer.lux
+++ b/stdlib/source/lux/macro/syntax/common/writer.lux
@@ -21,10 +21,11 @@
       (~+ (list/map code.local-identifier
                     (get@ #//.declaration-args declaration))))))
 
-(def: #export (annotations anns)
+(def: #export annotations
   (-> //.Annotations Code)
-  (|> anns (list/map (product.both code.tag id)) code.record))
+  (|>> (list/map (product.both code.tag id))
+       code.record))
 
-(def: #export (type-variables vars)
+(def: #export type-variables
   (-> (List Text) (List Code))
-  (list/map code.local-identifier vars))
+  (list/map code.local-identifier))
diff --git a/stdlib/source/lux/type/abstract.lux b/stdlib/source/lux/type/abstract.lux
index 6eb16df4d..a8be42a00 100644
--- a/stdlib/source/lux/type/abstract.lux
+++ b/stdlib/source/lux/type/abstract.lux
@@ -1,17 +1,18 @@
 (.module:
-  [lux #*
+  [lux (#- Scope)
    [control
-    [monad (#+ do Monad)]
-    ["p" parser]]
+    [monad (#+ Monad do)]
+    ["p" parser ("p/." Monad<Parser>)]
+    ["ex" exception (#+ exception:)]]
    [data
     [name ("name/." Codec<Text,Name>)]
     [text ("text/." Equivalence<Text> Monoid<Text>)]
-    ["." error]
     [collection
-     [list ("list/." Functor<List> Monoid<List>)]]]
+     ["." list ("list/." Functor<List> Monoid<List>)]
+     ["." stack (#+ Stack)]]]
    ["." macro ("meta/." Monad<Meta>)
     ["." code]
-    ["s" syntax (#+ syntax:)]
+    ["s" syntax (#+ Syntax syntax:)]
     [syntax
      ["cs" common]
      [common
@@ -19,126 +20,151 @@
       ["csw" writer]]]]
    [type (#+ :cast)]])
 
-(def: (get k plist)
-  (All [a]
-    (-> Text (List [Text a]) (Maybe a)))
-  (case plist
-    #.Nil
-    #.None
-
-    (#.Cons [k' v] plist')
-    (if (text/= k k')
-      (#.Some v)
-      (get k plist'))))
-
-(def: (put k v plist)
-  (All [a]
-    (-> Text a (List [Text a]) (List [Text a])))
-  (case plist
-    #.Nil
-    (list [k v])
-
-    (#.Cons [k' v'] plist')
-    (if (text/= k k')
-      (#.Cons [k' v] plist')
-      (#.Cons [k' v'] (put k v plist')))))
-
-(def: (remove k plist)
-  (All [a]
-    (-> Text (List [Text a]) (List [Text a])))
-  (case plist
-    #.Nil
-    #.Nil
-
-    (#.Cons [k' v'] plist')
-    (if (text/= k k')
-      plist'
-      (#.Cons [k' v'] (remove k plist')))))
-
-(def: down-cast Text ":abstraction")
-(def: up-cast Text ":representation")
-(def: macro-anns Code (' {#.macro? #1}))
-
-(def: representation-name
+(type: Scope
+  {#name Text
+   #type-vars (List Code)
+   #abstraction Code
+   #representation Code})
+
+(def: scopes
+  (Stack Scope)
+  stack.empty)
+
+(template: (!peek <source> <reference> <then>)
+  (loop [entries <source>]
+    (case entries
+      (#.Cons [head-name head-content] tail)
+      (if (text/= <reference> head-name)
+        <then>
+        (recur tail))
+
+      #.Nil
+      (undefined))))
+
+(def: (peek-scopes-definition reference source)
+  (-> Text (List [Text Definition]) (Stack Scope))
+  (!peek source reference
+         (let [[scope-type scope-anns scope-value] head-content]
+           (:coerce (Stack Scope) scope-value))))
+
+(def: (peek-scopes reference definition-reference source)
+  (-> Text Text (List [Text Module]) (Stack Scope))
+  (!peek source reference
+         (peek-scopes-definition definition-reference (get@ #.definitions head-content))))
+
+(exception: #export (no-active-scopes)
+  "")
+
+(def: (peek! scope)
+  (-> (Maybe Text) (Meta Scope))
+  (function (_ compiler)
+    (let [[reference definition-reference] (name-of ..scopes)
+          current-scopes (peek-scopes reference definition-reference (get@ #.modules compiler))]
+      (case (case scope
+              (#.Some scope)
+              (list.find (function (_ [actual _])
+                           (text/= scope actual))
+                         current-scopes)
+              
+              #.None
+              (stack.peek current-scopes))
+        (#.Some scope)
+        (#.Right [compiler scope])
+        
+        #.None
+        (ex.throw no-active-scopes [])))))
+
+(template: (!push <source> <reference> <then>)
+  (loop [entries <source>]
+    (case entries
+      (#.Cons [head-name head-content] tail)
+      (if (text/= <reference> head-name)
+        (#.Cons [head-name <then>]
+                tail)
+        (#.Cons [head-name head-content]
+                (recur tail)))
+
+      #.Nil
+      (undefined))))
+
+(def: (push-scope-definition reference scope source)
+  (-> Text Scope (List [Text Definition]) (List [Text Definition]))
+  (!push source reference
+         (let [[scopes-type scopes-anns scopes-value] head-content]
+           [scopes-type
+            scopes-anns
+            (stack.push scope (:coerce (Stack Scope) scopes-value))])))
+
+(def: (push-scope [module-reference definition-reference] scope source)
+  (-> Name Scope (List [Text Module]) (List [Text Module]))
+  (!push source module-reference
+         (|> head-content (update@ #.definitions (push-scope-definition definition-reference scope)))))
+
+(def: (push! scope)
+  (-> Scope (Meta Any))
+  (function (_ compiler)
+    (#.Right [(update@ #.modules
+                       (..push-scope (name-of ..scopes) scope)
+                       compiler)
+              []])))
+
+(def: (pop-scope-definition reference source)
+  (-> Text (List [Text Definition]) (List [Text Definition]))
+  (!push source reference
+         (let [[scopes-type scopes-anns scopes-value] head-content]
+           [scopes-type
+            scopes-anns
+            (let [current-scopes (:coerce (Stack Scope) scopes-value)]
+              (case (stack.pop current-scopes)
+                (#.Some current-scopes')
+                current-scopes'
+
+                #.None
+                current-scopes))])))
+
+(def: (pop-scope [module-reference definition-reference] source)
+  (-> Name (List [Text Module]) (List [Text Module]))
+  (!push source module-reference
+         (|> head-content (update@ #.definitions (pop-scope-definition definition-reference)))))
+
+(syntax: (pop!)
+  (function (_ compiler)
+    (#.Right [(update@ #.modules
+                       (..pop-scope (name-of ..scopes))
+                       compiler)
+              (list)])))
+
+(def: cast
+  (Syntax [(Maybe Text) Code])
+  (p.either (p.and (p.maybe s.local-identifier) s.any)
+            (p.and (p/wrap #.None) s.any)))
+
+(do-template [<name> <from> <to>]
+  [(syntax: #export (<name> {[scope value] cast})
+     (do @
+       [[name type-vars abstraction representation] (peek! scope)]
+       (wrap (list (` ((~! :cast) [(~+ 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 #..Representation))
-           "} ")))
-
-(def: (cast type-vars input-declaration output-declaration)
-  (-> (List Code) Code Code Macro)
-  (function (_ tokens)
-    (case tokens
-      (^ (list value))
-      (meta/wrap (list (` ((~! :cast) [(~+ type-vars)] (~ input-declaration) (~ output-declaration)
-                           (~ value)))))
-
-      _
-      (meta/wrap (list (` ((~! :cast) [(~+ type-vars)] (~ input-declaration) (~ output-declaration))))))))
-
-(def: (install-casts' this-module-name name type-vars)
-  (-> Text Text (List Text) (Meta Any))
-  (do macro.Monad<Meta>
-    [this-module (macro.find-module this-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-name [this-module-name name])))
-                                          (~+ type-varsC)))
-           this-module (|> this-module
-                           (update@ #.definitions (put down-cast (: Definition
-                                                                    [Macro macro-anns
-                                                                     (cast type-varsC representation-declaration abstraction-declaration)])))
-                           (update@ #.definitions (put up-cast (: Definition
-                                                                  [Macro macro-anns
-                                                                   (cast type-varsC abstraction-declaration representation-declaration)]))))]]
-    (function (_ compiler)
-      (#error.Success [(update@ #.modules (put this-module-name this-module) compiler)
-                       []]))))
-
-(def: (un-install-casts' this-module-name)
-  (-> Text (Meta Any))
-  (do macro.Monad<Meta>
-    [this-module (macro.find-module this-module-name)
-     #let [this-module (|> this-module
-                           (update@ #.definitions (remove down-cast))
-                           (update@ #.definitions (remove up-cast)))]]
-    (function (_ compiler)
-      (#error.Success [(update@ #.modules (put this-module-name this-module) compiler)
-                       []]))))
-
-(syntax: (install-casts {name s.local-identifier}
-                        {type-vars (s.tuple (p.some s.local-identifier))})
-  (do @
-    [this-module-name macro.current-module-name
-     ?down-cast (macro.find-macro [this-module-name down-cast])
-     ?up-cast (macro.find-macro [this-module-name up-cast])]
-    (case [?down-cast ?up-cast]
-      [#.None #.None]
-      (do @
-        [_ (install-casts' this-module-name name type-vars)]
-        (wrap (list)))
-
-      _
-      (macro.fail ($_ text/compose "Cannot temporarily define casting functions (" down-cast " & " up-cast ") because definitions like that already exist.")))))
-
-(syntax: (un-install-casts)
-  (do macro.Monad<Meta>
-    [this-module-name macro.current-module-name
-     ?down-cast (macro.find-macro [this-module-name down-cast])
-     ?up-cast (macro.find-macro [this-module-name up-cast])]
-    (case [?down-cast ?up-cast]
-      [(#.Some _) (#.Some _)]
-      (do @
-        [_ (un-install-casts' this-module-name)]
-        (wrap (list)))
-
-      _
-      (macro.fail ($_ text/compose "Cannot un-define casting functions (" down-cast " & " up-cast ") because they do not exist.")))))
+           (name/encode (name-of #..Abstraction))
+           " ")))
+
+(def: representation-definition-name
+  (-> Text Text)
+  (|>> ($_ text/compose
+           (name/encode (name-of #Representation))
+           " ")))
 
 (def: declaration
-  (s.Syntax [Text (List Text)])
+  (Syntax [Text (List Text)])
   (p.either (s.form (p.and s.local-identifier (p.some s.local-identifier)))
             (p.and s.local-identifier (:: p.Monad<Parser> wrap (list)))))
 
@@ -152,27 +178,29 @@
                    {primitives (p.some s.any)})
   (do @
     [current-module macro.current-module-name
-     #let [hidden-name (representation-name [current-module name])
-           type-varsC (list/map code.local-identifier type-vars)
+     #let [type-varsC (list/map code.local-identifier type-vars)
            abstraction-declaration (` ((~ (code.local-identifier name)) (~+ type-varsC)))
-           representation-declaration (` ((~ (code.local-identifier hidden-name)) (~+ type-varsC)))]]
+           representation-declaration (` ((~ (code.local-identifier (representation-definition-name name)))
+                                          (~+ type-varsC)))]
+     _ (..push! [name
+                 type-varsC
+                 abstraction-declaration
+                 representation-declaration])]
     (wrap (list& (` (type: (~+ (csw.export export)) (~ abstraction-declaration)
                       (~ (csw.annotations annotations))
-                      (primitive (~ (code.text hidden-name)) [(~+ type-varsC)])))
+                      (primitive (~ (code.text (abstraction-type-name [current-module name])))
+                                 [(~+ type-varsC)])))
                  (` (type: (~+ (csw.export export)) (~ representation-declaration)
                       (~ representation-type)))
-                 (` ((~! install-casts) (~ (code.local-identifier name)) [(~+ type-varsC)]))
-                 (list/compose primitives
-                               (list (` ((~! un-install-casts)))))))))
+                 ($_ list/compose
+                     primitives
+                     (list (` ((~! ..pop!)))))))))
 
 (syntax: #export (^:representation {name (s.form s.local-identifier)}
                                    body
                                    {branches (p.some s.any)})
-  (let [g!representation (code.local-identifier name)]
-    (do @
-      [current-module macro.current-module-name
-       #let [g!:representation (code.identifier [current-module up-cast])]]
-      (wrap (list& g!representation
-                   (` (.let [(~ g!representation) ((~ g!:representation) (~ g!representation))]
-                        (~ body)))
-                   branches)))))
+  (let [g!var (code.local-identifier name)]
+    (wrap (list& g!var
+                 (` (.let [(~ g!var) (..:representation (~ g!var))]
+                      (~ body)))
+                 branches))))