aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source')
-rw-r--r--stdlib/source/lux.lux69
-rw-r--r--stdlib/source/lux/control/state.lux10
-rw-r--r--stdlib/source/lux/data/coll/list.lux6
-rw-r--r--stdlib/source/lux/data/text.lux2
-rw-r--r--stdlib/source/lux/lang/analysis.lux30
-rw-r--r--stdlib/source/lux/lang/analysis/case/coverage.lux2
-rw-r--r--stdlib/source/lux/lang/extension.lux22
-rw-r--r--stdlib/source/lux/lang/synthesis.lux152
-rw-r--r--stdlib/source/lux/lang/synthesis/expression.lux210
-rw-r--r--stdlib/source/lux/lang/synthesis/function.lux49
-rw-r--r--stdlib/source/lux/lang/synthesis/loop.lux277
-rw-r--r--stdlib/source/lux/lang/type/check.lux14
-rw-r--r--stdlib/source/lux/world/console.lux2
13 files changed, 784 insertions, 61 deletions
diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux
index b84b0d096..157208071 100644
--- a/stdlib/source/lux.lux
+++ b/stdlib/source/lux.lux
@@ -4757,41 +4757,59 @@
(return (list (` ("lux def" (~ (symbol$ ["" (text/compose prefix name)])) (~ source+)
[(~ cursor-code) (#.Record #Nil)])))))))
-(macro: #export (open tokens)
+(macro: #export (open: tokens)
{#.doc "## Opens a structure and generates a definition for each of its members (including nested members).
## For example:
- (open Number<Int> \"i:\")
+ (open: \"i:\" Number<Int>)
## Will generate:
(def: i:+ (:: Number<Int> +))
(def: i:- (:: Number<Int> -))
(def: i:* (:: Number<Int> *))
+ ...
+
+ ## However, the prefix is optional.
+ ## For example:
+ (open: Number<Int>)
+ ## Will generate:
+ (def: + (:: Number<Int> +))
+ (def: - (:: Number<Int> -))
+ (def: * (:: Number<Int> *))
..."}
- (case tokens
- (^ (list& [_ (#Symbol struct-name)] tokens'))
- (do Monad<Meta>
- [@module current-module-name
- #let [prefix (case tokens'
- (^ (list [_ (#Text prefix)]))
- prefix
-
- _
- "")]
- struct-type (find-type struct-name)
- output (resolve-type-tags struct-type)
- #let [source (symbol$ struct-name)]]
- (case output
- (#Some [tags members])
+ (let [[prefix tokens'] (case tokens
+ (^ (list& [_ (#Text prefix)] tokens'))
+ [prefix tokens']
+
+ tokens'
+ ["" tokens'])]
+ (case tokens'
+ (^ (list struct))
+ (case struct
+ [_ (#Symbol struct-name)]
(do Monad<Meta>
- [decls' (monad/map Monad<Meta> (: (-> [Ident Type] (Meta (List Code)))
- (function (_ [sname stype]) (open-field prefix sname source stype)))
- (zip2 tags members))]
- (return (list/join decls')))
+ [struct-type (find-type struct-name)
+ output (resolve-type-tags struct-type)
+ #let [source (symbol$ struct-name)]]
+ (case output
+ (#Some [tags members])
+ (do Monad<Meta>
+ [decls' (monad/map Monad<Meta> (: (-> [Ident Type] (Meta (List Code)))
+ (function (_ [sname stype])
+ (open-field prefix sname source stype)))
+ (zip2 tags members))]
+ (return (list/join decls')))
+
+ _
+ (fail (text/compose "Can only \"open:\" structs: " (type/show struct-type)))))
_
- (fail (text/compose "Can only \"open\" structs: " (type/show struct-type)))))
+ (do Monad<Meta>
+ [g!struct (gensym "struct")]
+ (return (list (` ("lux def" (~ g!struct) (~ struct)
+ [(~ cursor-code) (#.Record #Nil)]))
+ (` (..open: (~ (text$ prefix)) (~ g!struct)))))))
- _
- (fail "Wrong syntax for open")))
+ _
+ (fail "Wrong syntax for open:"))))
(macro: #export (|>> tokens)
{#.doc "## Similar to the piping macro, but rather than taking an initial object to work on, creates a function for taking it.
@@ -4897,7 +4915,8 @@
defs')
openings (join-map (: (-> Openings (List Code))
(function (_ [prefix structs])
- (list/map (function (_ [_ name]) (` (open (~ (symbol$ [module-name name])) (~ (text$ prefix)))))
+ (list/map (function (_ [_ name])
+ (` (open: (~ (text$ prefix)) (~ (symbol$ [module-name name])))))
structs)))
r-opens)]]
(wrap (list/compose defs openings))
diff --git a/stdlib/source/lux/control/state.lux b/stdlib/source/lux/control/state.lux
index 296147e6b..be8844a0c 100644
--- a/stdlib/source/lux/control/state.lux
+++ b/stdlib/source/lux/control/state.lux
@@ -80,7 +80,7 @@
(All [s a] (-> s (State s a) [s a]))
(action state))
-(struct: (Functor<StateT> Functor<M>)
+(struct: (Functor<State'> Functor<M>)
(All [M s] (-> (F.Functor M) (F.Functor (All [a] (-> s (M [s a]))))))
(def: (map f sfa)
@@ -88,10 +88,10 @@
(:: Functor<M> map (function (_ [s a]) [s (f a)])
(sfa state)))))
-(struct: (Apply<StateT> Monad<M>)
+(struct: (Apply<State'> Monad<M>)
(All [M s] (-> (Monad M) (A.Apply (All [a] (-> s (M [s a]))))))
- (def: functor (Functor<StateT> (:: Monad<M> functor)))
+ (def: functor (Functor<State'> (:: Monad<M> functor)))
(def: (apply sFf sFa)
(function (_ state)
@@ -109,11 +109,11 @@
(All [M s a] (-> s (State' M s a) (M [s a])))
(action state))
-(struct: #export (StateT Monad<M>)
+(struct: #export (Monad<State'> Monad<M>)
{#.doc "A monad transformer to create composite stateful computations."}
(All [M s] (-> (Monad M) (Monad (State' M s))))
- (def: functor (Functor<StateT> (:: Monad<M> functor)))
+ (def: functor (Functor<State'> (:: Monad<M> functor)))
(def: (wrap a)
(function (_ state)
diff --git a/stdlib/source/lux/data/coll/list.lux b/stdlib/source/lux/data/coll/list.lux
index 063e9648c..5f41b4381 100644
--- a/stdlib/source/lux/data/coll/list.lux
+++ b/stdlib/source/lux/data/coll/list.lux
@@ -25,7 +25,7 @@
(#.Cons [x xs'])
(fold f (f x init) xs'))))
-(open Fold<List>)
+(open: Fold<List>)
(def: #export (reverse xs)
(All [a]
@@ -258,7 +258,7 @@
#.Nil ys
(#.Cons x xs') (#.Cons x (compose xs' ys)))))
-(open Monoid<List>)
+(open: Monoid<List>)
(struct: #export _ (Functor List)
(def: (map f ma)
@@ -266,7 +266,7 @@
#.Nil #.Nil
(#.Cons a ma') (#.Cons (f a) (map f ma')))))
-(open Functor<List>)
+(open: Functor<List>)
(struct: #export _ (Apply List)
(def: functor Functor<List>)
diff --git a/stdlib/source/lux/data/text.lux b/stdlib/source/lux/data/text.lux
index 6b259b49f..6d11bb9b0 100644
--- a/stdlib/source/lux/data/text.lux
+++ b/stdlib/source/lux/data/text.lux
@@ -150,7 +150,7 @@
(def: (compose left right)
("lux text concat" left right)))
-(open Monoid<Text> "text/")
+(open: "text/" Monoid<Text>)
(def: #export (encode original)
(-> Text Text)
diff --git a/stdlib/source/lux/lang/analysis.lux b/stdlib/source/lux/lang/analysis.lux
index 324f12b3e..3cac8d7b2 100644
--- a/stdlib/source/lux/lang/analysis.lux
+++ b/stdlib/source/lux/lang/analysis.lux
@@ -1,6 +1,7 @@
(.module:
[lux #- nat int deg]
- (lux [function]
+ (lux (control [equality #+ Eq])
+ [function]
(data (coll [list "list/" Fold<List>]))))
(type: #export #rec Primitive
@@ -29,6 +30,17 @@
(#Local Register)
(#Foreign Register))
+(struct: #export _ (Eq Variable)
+ (def: (= reference sample)
+ (case [reference sample]
+ (^template [<tag>]
+ [(<tag> reference') (<tag> sample')]
+ (n/= reference' sample'))
+ ([#Local] [#Foreign])
+
+ _
+ false)))
+
(type: #export (Match p e)
[[p e] (List [p e])])
@@ -36,16 +48,17 @@
(List Variable))
(type: #export (Special e)
- [Text (List e)])
+ {#extension Text
+ #parameters (List e)})
(type: #export #rec Analysis
(#Primitive Primitive)
(#Structure (Composite Analysis))
+ (#Variable Variable)
+ (#Constant Ident)
(#Case Analysis (Match Pattern Analysis))
(#Function Environment Analysis)
(#Apply Analysis Analysis)
- (#Variable Variable)
- (#Constant Ident)
(#Special (Special Analysis)))
(do-template [<name> <type> <tag>]
@@ -169,3 +182,12 @@
_
[analysis (list)]))
+
+(def: #export (self? var)
+ (-> Variable Bool)
+ (case var
+ (#Local +0)
+ true
+
+ _
+ false))
diff --git a/stdlib/source/lux/lang/analysis/case/coverage.lux b/stdlib/source/lux/lang/analysis/case/coverage.lux
index da256206f..a5958001f 100644
--- a/stdlib/source/lux/lang/analysis/case/coverage.lux
+++ b/stdlib/source/lux/lang/analysis/case/coverage.lux
@@ -172,7 +172,7 @@
_
false)))
-(open Eq<Coverage> "C/")
+(open: "C/" Eq<Coverage>)
## After determining the coverage of each individual pattern, it is
## necessary to merge them all to figure out if the entire
diff --git a/stdlib/source/lux/lang/extension.lux b/stdlib/source/lux/lang/extension.lux
index 03fd81d71..6da453148 100644
--- a/stdlib/source/lux/lang/extension.lux
+++ b/stdlib/source/lux/lang/extension.lux
@@ -8,7 +8,7 @@
[macro])
[// #+ Eval]
(// [".L" analysis #+ Analyser]
- [".L" synthesis]))
+ [".L" synthesis #+ Synthesizer]))
(do-template [<name>]
[(exception: #export (<name> {message Text})
@@ -29,7 +29,8 @@
(-> Analyser Eval (List Code) (Meta analysisL.Analysis)))
(type: #export Synthesis
- (-> (-> analysisL.Analysis synthesisL.Synthesis) (List Code) Code))
+ (-> Synthesizer (List analysisL.Analysis)
+ (synthesisL.Operation synthesisL.Synthesis)))
(type: #export Translation
(-> (List Code) (Meta Code)))
@@ -83,17 +84,20 @@
[find-statement Statement #statement unknown-statement]
)
-(do-template [<no> <all> <type> <category> <empty>]
- [(def: #export <no>
- <type>
- <empty>)
+(def: #export empty
+ (All [e] (Extension e))
+ (dict.new text.Hash<Text>))
- (def: #export <all>
- (Meta <type>)
+(do-template [<all> <type> <category>]
+ [(def: #export <all>
+ (Meta (Extension <type>))
(|> ..get
(:: macro.Monad<Meta> map (get@ <category>))))]
- [no-syntheses all-syntheses (Extension Synthesis) #synthesis (dict.new text.Hash<Text>)]
+ [all-analyses Analysis #analysis]
+ [all-syntheses Synthesis #synthesis]
+ [all-translations Translation #translation]
+ [all-statements Statement #statement]
)
(do-template [<name> <type> <category> <exception>]
diff --git a/stdlib/source/lux/lang/synthesis.lux b/stdlib/source/lux/lang/synthesis.lux
index 33c8aa063..4bb83ac5e 100644
--- a/stdlib/source/lux/lang/synthesis.lux
+++ b/stdlib/source/lux/lang/synthesis.lux
@@ -1,8 +1,152 @@
(.module:
- lux)
+ [lux #- Scope]
+ (lux (control [state]
+ ["ex" exception #+ Exception exception:])
+ (data [product]
+ [error #+ Error]
+ [number]
+ (coll (dictionary ["dict" unordered #+ Dict]))))
+ [//analysis #+ Register Variable Environment Special Analysis])
-(def: #export Arity Nat)
+(type: #export Arity Nat)
-(type: #export Synthesis Code)
+(type: #export Resolver (Dict Register Variable))
-(type: #export Path Code)
+(type: #export State
+ {#scope-arity Arity
+ #resolver Resolver
+ #direct? Bool
+ #locals Nat})
+
+(def: #export init
+ State
+ {#scope-arity +0
+ #resolver (dict.new number.Hash<Nat>)
+ #direct? false
+ #locals +0})
+
+(type: (Operation' s o)
+ (state.State' Error s o))
+
+(type: #export (Compiler s i o)
+ (-> i (Operation' ..State o)))
+
+(type: #export Primitive
+ (#Bool Bool)
+ (#I64 I64)
+ (#F64 Frac)
+ (#Text Text))
+
+(type: #export (Structure a)
+ (#Variant (//analysis.Variant a))
+ (#Tuple (//analysis.Tuple a)))
+
+(type: #export (Path' s)
+ (#Bind Register)
+ (#Alt (Path' s) (Path' s))
+ (#Seq (Path' s) (Path' s))
+ (#Exec s))
+
+(type: #export (Abstraction' s)
+ {#environment Environment
+ #arity Arity
+ #body s})
+
+(type: #export (Branch s)
+ (#Case s (Path' s))
+ (#Let s Register s)
+ (#If s s s))
+
+(type: #export (Scope s)
+ {#start Register
+ #inits (List s)
+ #iteration s})
+
+(type: #export (Loop s)
+ (#Scope (Scope s))
+ (#Recur (List s)))
+
+(type: #export (Function s)
+ (#Abstraction (Abstraction' s))
+ (#Apply s (List s)))
+
+(type: #export (Control s)
+ (#Branch (Branch s))
+ (#Loop (Loop s))
+ (#Function (Function s)))
+
+(type: #export #rec Synthesis
+ (#Primitive Primitive)
+ (#Structure (Structure Synthesis))
+ (#Variable Variable)
+ (#Control (Control Synthesis))
+ (#Special (Special Synthesis)))
+
+(type: #export Path
+ (Path' Synthesis))
+
+(type: #export Abstraction
+ (Abstraction' Synthesis))
+
+(type: #export (Operation a)
+ (Operation' ..State a))
+
+(def: #export unit Text "")
+
+(type: #export Synthesizer
+ (Compiler ..State Analysis Synthesis))
+
+(def: #export (throw exception parameters)
+ (All [e] (-> (Exception e) e Operation'))
+ (state.lift error.Monad<Error>
+ (ex.throw exception parameters)))
+
+(def: #export (run synthesizer analysis)
+ (-> Synthesizer Analysis (Error Synthesis))
+ (:: error.Monad<Error> map product.right
+ (synthesizer analysis ..init)))
+
+(def: (localized transform)
+ (-> (-> State State)
+ (-> Synthesizer Synthesizer))
+ (function (scope synthesizer)
+ (function (synthesize analysis state)
+ (case (synthesize analysis (transform state))
+ (#error.Error error)
+ (#error.Error error)
+
+ (#error.Success [state' output])
+ (#error.Success [state output])))))
+
+(def: #export indirectly
+ (-> Synthesizer Synthesizer)
+ (localized (set@ #direct? false)))
+
+(do-template [<name> <tag> <type>]
+ [(def: #export <name>
+ (Operation <type>)
+ (function (_ state)
+ (#error.Success [state (get@ <tag> state)])))]
+
+ [scope-arity #scope-arity Arity]
+ [direct? #direct? Bool]
+ [locals #locals Nat]
+ )
+
+(do-template [<name> <family> <tag>]
+ [(template: #export (<name> content)
+ (<| #..Control
+ <family>
+ <tag>
+ content))]
+
+ [branch/case #..Branch #..Case]
+ [branch/let #..Branch #..Let]
+ [branch/if #..Branch #..If]
+
+ [loop/scope #..Loop #..Scope]
+ [loop/recur #..Loop #..Recur]
+
+ [function/abstraction #..Function #..Abstraction]
+ [function/apply #..Function #..Apply]
+ )
diff --git a/stdlib/source/lux/lang/synthesis/expression.lux b/stdlib/source/lux/lang/synthesis/expression.lux
new file mode 100644
index 000000000..1167e975a
--- /dev/null
+++ b/stdlib/source/lux/lang/synthesis/expression.lux
@@ -0,0 +1,210 @@
+(.module:
+ [lux #- primitive]
+ (lux (control [monad #+ do]
+ ["ex" exception #+ exception:]
+ [state])
+ (data [maybe]
+ [error]
+ [number]
+ [product]
+ text/format
+ (coll [list "list/" Functor<List> Fold<List> Monoid<List>]
+ (dictionary ["dict" unordered #+ Dict])))
+ (macro [code]
+ ["s" syntax])
+ [lang]
+ (lang [".L" analysis #+ Analysis]
+ [".L" extension #+ Extension]))
+ [// #+ Synthesis]
+ [//function]
+ ## (luxc (lang (synthesis [".S" case]
+ ## [".S" loop])
+ ## [".L" variable #+ Variable])
+ ## )
+ )
+
+(exception: #export (unknown-synthesis-extension {name Text})
+ name)
+
+## (def: init-env (List Variable) (list))
+## (def: init-resolver (Dict Int Int) (dict.new number.Hash<Int>))
+
+## (def: (prepare-body inner-arity arity body)
+## (-> ls.Arity ls.Arity Synthesis Synthesis)
+## (if (//function.nested? inner-arity)
+## body
+## (loopS.reify-recursion arity body)))
+
+## (def: (let$ register inputS bodyS)
+## (-> Nat Synthesis Synthesis Synthesis)
+## (` ("lux let" (~ (code.nat register)) (~ inputS) (~ bodyS))))
+
+## (def: (if$ testS thenS elseS)
+## (-> Synthesis Synthesis Synthesis Synthesis)
+## (` ("lux if" (~ testS)
+## (~ thenS)
+## (~ elseS))))
+
+## (def: (variant$ tag last? valueS)
+## (-> Nat Bool Synthesis Synthesis)
+## (` ((~ (code.nat tag)) (~ (code.bool last?)) (~ valueS))))
+
+## (def: (var$ var)
+## (-> Variable Synthesis)
+## (` ((~ (code.int var)))))
+
+## (def: (procedure$ name argsS)
+## (-> Text (List Synthesis) Synthesis)
+## (` ((~ (code.text name)) (~+ argsS))))
+
+## (def: (call$ funcS argsS)
+## (-> Synthesis (List Synthesis) Synthesis)
+## (` ("lux call" (~ funcS) (~+ argsS))))
+
+## (def: (synthesize-case arity num-locals synthesize inputA branchesA)
+## (-> ls.Arity Nat (-> Nat Analysis Synthesis)
+## Analysis (List [la.Pattern Analysis])
+## Synthesis)
+## (let [inputS (synthesize num-locals inputA)]
+## (case (list.reverse branchesA)
+## (^multi (^ (list [(^code ("lux case bind" (~ [_ (#.Nat input-register)])))
+## (^code ((~ [_ (#.Int var)])))]))
+## (not (variableL.captured? var))
+## (n/= input-register (variableL.local-register var)))
+## inputS
+
+## (^ (list [(^code ("lux case bind" (~ [_ (#.Nat register)]))) bodyA]))
+## (let$ (if (//function.nested? arity)
+## (n/+ (dec arity) register)
+## register)
+## inputS
+## (synthesize (inc num-locals) bodyA))
+
+## (^or (^ (list [(^code true) thenA] [(^code false) elseA]))
+## (^ (list [(^code false) elseA] [(^code true) thenA])))
+## (if$ inputS (synthesize num-locals thenA) (synthesize num-locals elseA))
+
+## (#.Cons [lastP lastA] prevsPA)
+## (let [transform-branch (: (-> la.Pattern Analysis ls.Path)
+## (caseS.path arity num-locals synthesize))
+## pathS (list/fold caseS.weave
+## (transform-branch lastP lastA)
+## (list/map (product.uncurry transform-branch) prevsPA))]
+## (` ("lux case" (~ inputS) (~ pathS))))
+
+## _
+## (undefined)
+## )))
+
+(def: (primitive analysis)
+ (-> analysisL.Primitive //.Primitive)
+ (case analysis
+ #analysisL.Unit
+ (#//.Text //.unit)
+
+ (^template [<analysis> <synthesis>]
+ (<analysis> value)
+ (<synthesis> value))
+ ([#analysisL.Bool #//.Bool]
+ [#analysisL.Frac #//.F64]
+ [#analysisL.Text #//.Text])
+
+ (^template [<analysis> <synthesis>]
+ (<analysis> value)
+ (<synthesis> (.i64 value)))
+ ([#analysisL.Nat #//.I64]
+ [#analysisL.Int #//.I64]
+ [#analysisL.Deg #//.I64])))
+
+(def: Compiler@Monad (state.Monad<State'> error.Monad<Error>))
+(open: "compiler/" Compiler@Monad)
+
+(def: #export (synthesizer extensions)
+ (-> (Extension extensionL.Synthesis) //.Synthesizer)
+ (function (synthesize analysis)
+ (case analysis
+ (#analysisL.Primitive analysis')
+ (compiler/wrap (#//.Primitive (..primitive analysis')))
+
+ (#analysisL.Structure composite)
+ (case (analysisL.variant analysis)
+ (#.Some variant)
+ (do Compiler@Monad
+ [valueS (synthesize (get@ #analysisL.value variant))]
+ (wrap (#//.Structure (#//.Variant (set@ #analysisL.value valueS variant)))))
+
+ _
+ (do Compiler@Monad
+ [tupleS (monad.map @ synthesize (analysisL.tuple analysis))]
+ (wrap (#//.Structure (#//.Tuple tupleS)))))
+
+ (#analysisL.Apply _)
+ (//function.apply (//.indirectly synthesize) analysis)
+
+ (#analysisL.Special name args)
+ (case (dict.get name extensions)
+ #.None
+ (//.throw unknown-synthesis-extension name)
+
+ (#.Some extension)
+ (extension (//.indirectly synthesize) args))
+
+ _
+ (undefined)
+
+ ## (^code ((~ [_ (#.Int var)])))
+ ## (if (variableL.local? var)
+ ## (if (//function.nested? arity)
+ ## (if (variableL.self? var)
+ ## (call$ (var$ 0) (|> (list.n/range +1 (dec arity))
+ ## (list/map (|>> variableL.local code.int (~) () (`)))))
+ ## (var$ (//function.adjust-var arity var)))
+ ## (var$ var))
+ ## (var$ (maybe.default var (dict.get var resolver))))
+
+ ## (^code ("lux case" (~ inputA) (~ [_ (#.Record branchesA)])))
+ ## (synthesize-case arity num-locals (//.indirectly synthesize) inputA branchesA)
+
+ ## (^multi (^code ("lux function" [(~+ scope)] (~ bodyA)))
+ ## [(s.run scope (p.some s.int)) (#error.Success raw-env)])
+ ## (let [function-arity (if direct?
+ ## (inc arity)
+ ## +1)
+ ## env (list/map (function (_ closure)
+ ## (case (dict.get closure resolver)
+ ## (#.Some resolved)
+ ## (if (and (variableL.local? resolved)
+ ## (//function.nested? arity)
+ ## (|> resolved variableL.local-register (n/>= arity)))
+ ## (//function.adjust-var arity resolved)
+ ## resolved)
+
+ ## #.None
+ ## (if (and (variableL.local? closure)
+ ## (//function.nested? arity))
+ ## (//function.adjust-var arity closure)
+ ## closure)))
+ ## raw-env)
+ ## env-vars (: (List Variable)
+ ## (case raw-env
+ ## #.Nil (list)
+ ## _ (|> (list.size raw-env) dec (list.n/range +0) (list/map variableL.captured))))
+ ## resolver' (if (and (//function.nested? function-arity)
+ ## direct?)
+ ## (list/fold (function (_ [from to] resolver')
+ ## (dict.put from to resolver'))
+ ## init-resolver
+ ## (list.zip2 env-vars env))
+ ## (list/fold (function (_ var resolver')
+ ## (dict.put var var resolver'))
+ ## init-resolver
+ ## env-vars))]
+ ## (case (recur function-arity resolver' true function-arity bodyA)
+ ## (^ [_ (#.Form (list [_ (#.Text "lux function")] [_ (#.Nat unmerged-arity)] env' bodyS'))])
+ ## (let [merged-arity (inc unmerged-arity)]
+ ## (function$ merged-arity env
+ ## (prepare-body function-arity merged-arity bodyS')))
+
+ ## bodyS
+ ## (function$ +1 env (prepare-body function-arity +1 bodyS))))
+ )))
diff --git a/stdlib/source/lux/lang/synthesis/function.lux b/stdlib/source/lux/lang/synthesis/function.lux
new file mode 100644
index 000000000..7b989d975
--- /dev/null
+++ b/stdlib/source/lux/lang/synthesis/function.lux
@@ -0,0 +1,49 @@
+(.module:
+ lux
+ (lux (control [monad #+ do]
+ [state])
+ (data [maybe]
+ [error]
+ (coll [list "list/" Monoid<List>]))
+ (lang [".L" analysis #+ Variable Analysis]))
+ [// #+ Arity Synthesizer]
+ [//loop])
+
+(def: nested?
+ (-> Arity Bool)
+ (n/> +1))
+
+## (def: (adjust-var outer var)
+## (-> Arity Variable Variable)
+## (|> outer dec .int (i/+ var)))
+
+(def: (unfold apply)
+ (-> Analysis [Analysis (List Analysis)])
+ (loop [apply apply
+ args (list)]
+ (case apply
+ (#analysisL.Apply arg func)
+ (recur func (#.Cons arg args))
+
+ _
+ [apply args])))
+
+(def: #export (apply synthesize)
+ (-> Synthesizer Synthesizer)
+ (function (_ exprA)
+ (let [[funcA argsA] (unfold exprA)]
+ (do (state.Monad<State'> error.Monad<Error>)
+ [funcS (synthesize funcA)
+ argsS (monad.map @ synthesize argsA)
+ locals //.locals]
+ (case funcS
+ (^ (//.function/abstraction functionS))
+ (wrap (|> functionS
+ (//loop.loop (get@ #//.environment functionS) locals argsS)
+ (maybe.default (//.function/apply [funcS argsS]))))
+
+ (^ (//.function/apply [funcS' argsS']))
+ (wrap (//.function/apply [funcS' (list/compose argsS' argsS)]))
+
+ _
+ (wrap (//.function/apply [funcS argsS])))))))
diff --git a/stdlib/source/lux/lang/synthesis/loop.lux b/stdlib/source/lux/lang/synthesis/loop.lux
new file mode 100644
index 000000000..476cf27b4
--- /dev/null
+++ b/stdlib/source/lux/lang/synthesis/loop.lux
@@ -0,0 +1,277 @@
+(.module:
+ [lux #- loop]
+ (lux (control [monad #+ do]
+ ["p" parser])
+ (data [maybe "maybe/" Monad<Maybe>]
+ (coll [list "list/" Functor<List>]))
+ (macro [code]
+ [syntax]))
+ [///analysis #+ Register Variable Environment]
+ [// #+ Path Abstraction Synthesis])
+
+(type: (Transform a)
+ (-> a (Maybe a)))
+
+(def: (some? maybe)
+ (All [a] (-> (Maybe a) Bool))
+ (case maybe
+ (#.Some _) true
+ #.None false))
+
+(def: proper Bool true)
+
+(def: (proper? exprS)
+ (-> Synthesis Bool)
+ (case exprS
+ (#//.Structure structure)
+ (case structure
+ (#//.Variant variantS)
+ (proper? (get@ #///analysis.value variantS))
+
+ (#//.Tuple membersS+)
+ (list.every? proper? membersS+))
+
+ (#//.Variable var)
+ (not (///analysis.self? var))
+
+ (#//.Control controlS)
+ (case controlS
+ (#//.Branch branchS)
+ (case branchS
+ (#//.Case inputS pathS)
+ (and (proper? inputS)
+ (.loop [pathS pathS]
+ (case pathS
+ (^or (#//.Alt leftS rightS) (#//.Seq leftS rightS))
+ (and (recur leftS) (recur rightS))
+
+ (#//.Exec bodyS)
+ (proper? bodyS)
+
+ _
+ proper)))
+
+ (#//.Let inputS register bodyS)
+ (and (proper? inputS)
+ (proper? bodyS))
+
+ (#//.If inputS thenS elseS)
+ (and (proper? inputS)
+ (proper? thenS)
+ (proper? elseS)))
+
+ (#//.Loop loopS)
+ (case loopS
+ (#//.Scope scopeS)
+ (and (list.every? proper? (get@ #//.inits scopeS))
+ (proper? (get@ #//.iteration scopeS)))
+
+ (#//.Recur argsS)
+ (list.every? proper? argsS))
+
+ (#//.Function functionS)
+ (case functionS
+ (#//.Abstraction environment arity bodyS)
+ (list.every? ///analysis.self? environment)
+
+ (#//.Apply funcS argsS)
+ (and (proper? funcS)
+ (list.every? proper? argsS))))
+
+ (#//.Special [special argsS])
+ (list.every? proper? argsS)
+
+ _
+ proper))
+
+(def: (path-recursion synthesis-recursion)
+ (-> (Transform Synthesis) (Transform Path))
+ (function (recur pathS)
+ (case pathS
+ (#//.Alt leftS rightS)
+ (let [leftS' (recur leftS)
+ rightS' (recur rightS)]
+ (if (or (some? leftS')
+ (some? rightS'))
+ (#.Some (#//.Alt (maybe.default leftS leftS')
+ (maybe.default rightS rightS')))
+ #.None))
+
+ (#//.Seq leftS rightS)
+ (maybe/map (|>> (#//.Seq leftS)) (recur rightS))
+
+ (#//.Exec bodyS)
+ (maybe/map (|>> #//.Exec) (synthesis-recursion bodyS))
+
+ _
+ #.None)))
+
+(template: (recursive-apply args)
+ (#//.Apply (#//.Variable (#///analysis.Local +0))
+ args))
+
+(def: #export (recursion arity)
+ (-> Nat (Transform Synthesis))
+ (function (recur exprS)
+ (case exprS
+ (#//.Control controlS)
+ (case controlS
+ (#//.Branch branchS)
+ (case branchS
+ (#//.Case inputS pathS)
+ (|> pathS
+ (path-recursion recur)
+ (maybe/map (|>> (#//.Case inputS) #//.Branch #//.Control)))
+
+ (#//.Let inputS register bodyS)
+ (maybe/map (|>> (#//.Let inputS register) #//.Branch #//.Control)
+ (recur bodyS))
+
+ (#//.If inputS thenS elseS)
+ (let [thenS' (recur thenS)
+ elseS' (recur elseS)]
+ (if (or (some? thenS')
+ (some? elseS'))
+ (#.Some (|> (#//.If inputS
+ (maybe.default thenS thenS')
+ (maybe.default elseS elseS'))
+ #//.Branch #//.Control))
+ #.None)))
+
+ (^ (#//.Function (recursive-apply argsS)))
+ (if (n/= arity (list.size argsS))
+ (#.Some (|> argsS #//.Recur #//.Loop #//.Control))
+ #.None)
+
+ _
+ #.None)
+
+ _
+ #.None)))
+
+(def: (resolve environment)
+ (-> Environment (Transform Variable))
+ (function (_ variable)
+ (case variable
+ (#///analysis.Foreign register)
+ (list.nth register environment)
+
+ _
+ (#.Some variable))))
+
+(def: (adjust-path adjust-synthesis offset)
+ (-> (Transform Synthesis) Register (Transform Path))
+ (function (recur pathS)
+ (case pathS
+ (#//.Bind register)
+ (#.Some (#//.Bind (n/+ offset register)))
+
+ (^template [<tag>]
+ (<tag> leftS rightS)
+ (do maybe.Monad<Maybe>
+ [leftS' (recur leftS)
+ rightS' (recur rightS)]
+ (wrap (<tag> leftS' rightS'))))
+ ([#//.Alt] [#//.Seq])
+
+ (#//.Exec bodyS)
+ (|> bodyS adjust-synthesis (maybe/map (|>> #//.Exec)))
+
+ _
+ (#.Some pathS))))
+
+(def: (adjust scope-environment offset)
+ (-> Environment Register (Transform Synthesis))
+ (function (recur exprS)
+ (case exprS
+ (#//.Structure structureS)
+ (case structureS
+ (#//.Variant variantS)
+ (do maybe.Monad<Maybe>
+ [valueS' (|> variantS (get@ #///analysis.value) recur)]
+ (wrap (|> variantS
+ (set@ #///analysis.value valueS')
+ #//.Variant
+ #//.Structure)))
+
+ (#//.Tuple membersS+)
+ (|> membersS+
+ (monad.map maybe.Monad<Maybe> recur)
+ (maybe/map (|>> #//.Tuple #//.Structure))))
+
+ (#//.Variable variable)
+ (case variable
+ (#///analysis.Local register)
+ (#.Some (#//.Variable (#///analysis.Local (n/+ offset register))))
+
+ (#///analysis.Foreign register)
+ (|> scope-environment
+ (list.nth register)
+ (maybe/map (|>> #//.Variable))))
+
+ (^ (//.branch/case [inputS pathS]))
+ (do maybe.Monad<Maybe>
+ [inputS' (recur inputS)
+ pathS' (adjust-path recur offset pathS)]
+ (wrap (|> pathS' [inputS'] //.branch/case)))
+
+ (^ (//.branch/let [inputS register bodyS]))
+ (do maybe.Monad<Maybe>
+ [inputS' (recur inputS)
+ bodyS' (recur bodyS)]
+ (wrap (//.branch/let [inputS' register bodyS'])))
+
+ (^ (//.branch/if [inputS thenS elseS]))
+ (do maybe.Monad<Maybe>
+ [inputS' (recur inputS)
+ thenS' (recur thenS)
+ elseS' (recur elseS)]
+ (wrap (//.branch/if [inputS' thenS' elseS'])))
+
+ (^ (//.loop/scope scopeS))
+ (do maybe.Monad<Maybe>
+ [inits' (|> scopeS
+ (get@ #//.inits)
+ (monad.map maybe.Monad<Maybe> recur))
+ iteration' (recur (get@ #//.iteration scopeS))]
+ (wrap (//.loop/scope {#//.start (|> scopeS (get@ #//.start) (n/+ offset))
+ #//.inits inits'
+ #//.iteration iteration'})))
+
+ (^ (//.loop/recur argsS))
+ (|> argsS
+ (monad.map maybe.Monad<Maybe> recur)
+ (maybe/map (|>> //.loop/recur)))
+
+
+ (^ (//.function/abstraction [environment arity bodyS]))
+ (do maybe.Monad<Maybe>
+ [environment' (monad.map maybe.Monad<Maybe>
+ (resolve scope-environment)
+ environment)]
+ (wrap (//.function/abstraction [environment' arity bodyS])))
+
+ (^ (//.function/apply [function arguments]))
+ (do maybe.Monad<Maybe>
+ [function' (recur function)
+ arguments' (monad.map maybe.Monad<Maybe> recur arguments)]
+ (wrap (//.function/apply [function' arguments'])))
+
+ (#//.Special [procedure argsS])
+ (|> argsS
+ (monad.map maybe.Monad<Maybe> recur)
+ (maybe/map (|>> [procedure] #//.Special)))
+
+ _
+ (#.Some exprS))))
+
+(def: #export (loop environment num-locals inits functionS)
+ (-> Environment Nat (List Synthesis) Abstraction (Maybe Synthesis))
+ (let [bodyS (get@ #//.body functionS)]
+ (if (and (n/= (list.size inits)
+ (get@ #//.arity functionS))
+ (proper? bodyS))
+ (|> bodyS
+ (adjust environment num-locals)
+ (maybe/map (|>> [(inc num-locals) inits] //.loop/scope)))
+ #.None)))
diff --git a/stdlib/source/lux/lang/type/check.lux b/stdlib/source/lux/lang/type/check.lux
index 61001d8be..2e255d47c 100644
--- a/stdlib/source/lux/lang/type/check.lux
+++ b/stdlib/source/lux/lang/type/check.lux
@@ -24,15 +24,13 @@
(type.to-text (#.Apply argT funcT)))
(exception: #export (cannot-rebind-var {id Nat} {type Type} {bound Type})
- ($_ text/compose
- " Var: " (nat/encode id) "\n"
- " Wanted Type: " (type.to-text type) "\n"
- "Current Type: " (type.to-text bound)))
+ (ex.report ["Var" (nat/encode id)]
+ ["Wanted Type" (type.to-text type)]
+ ["Current Type" (type.to-text bound)]))
(exception: #export (type-check-failed {expected Type} {actual Type})
- ($_ text/compose
- "Expected: " (type.to-text expected) "\n\n"
- " Actual: " (type.to-text actual)))
+ (ex.report ["Expected" (type.to-text expected)]
+ ["Actual" (type.to-text actual)]))
(type: #export Var Nat)
@@ -99,7 +97,7 @@
)))
)
-(open Monad<Check> "check/")
+(open: "check/" Monad<Check>)
(def: (var::get id plist)
(-> Var Type-Vars (Maybe (Maybe Type)))
diff --git a/stdlib/source/lux/world/console.lux b/stdlib/source/lux/world/console.lux
index 7bd7cfaca..b66dce4da 100644
--- a/stdlib/source/lux/world/console.lux
+++ b/stdlib/source/lux/world/console.lux
@@ -1,5 +1,5 @@
(.module:
- [lux #- open]
+ lux
(lux (control [monad #+ do])
(data ["e" error]
[text])
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-05 14:29:46 +0000