aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorEduardo Julian2019-01-06 21:37:20 -0400
committerEduardo Julian2019-01-06 21:37:20 -0400
commit3673048937dce9366e138b2e273027442bf00957 (patch)
tree284e42b4bb71393ed3e5f38ba75cb6d142e1626a
parent3a8d595605ee1bb9348b97cedf6901ca2a811425 (diff)
Can now define nested abstract types.
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/data/collection/stack.lux2
-rw-r--r--stdlib/source/lux/macro/syntax/common/writer.lux9
-rw-r--r--stdlib/source/lux/type/abstract.lux300
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))))