diff options
Diffstat (limited to 'stdlib/source/lux/compiler/default/phase/synthesis.lux')
| -rw-r--r-- | stdlib/source/lux/compiler/default/phase/synthesis.lux | 234 |
1 files changed, 192 insertions, 42 deletions
diff --git a/stdlib/source/lux/compiler/default/phase/synthesis.lux b/stdlib/source/lux/compiler/default/phase/synthesis.lux index bf60c9798..da5cad094 100644 --- a/stdlib/source/lux/compiler/default/phase/synthesis.lux +++ b/stdlib/source/lux/compiler/default/phase/synthesis.lux @@ -1,15 +1,18 @@ (.module: [lux (#- i64 Scope) - [control [monad (#+ do)]] + [control + [monad (#+ do)] + [equivalence (#+ Equivalence)] + ["ex" exception (#+ exception:)]] [data - [error (#+ Error)] - ["." text + [bit ("bit/." Equivalence<Bit>)] + ["." text ("text/." Equivalence<Text>) format] [collection [list ("list/." Functor<List>)] ["." dictionary (#+ Dictionary)]]]] ["." // - ["." analysis (#+ Environment Arity Analysis)] + ["." analysis (#+ Environment Arity Composite Analysis)] ["." extension (#+ Extension)] [// ["." reference (#+ Register Variable Reference)]]]) @@ -17,10 +20,7 @@ (type: #export Resolver (Dictionary Variable Variable)) (type: #export State - {#scope-arity Arity - #resolver Resolver - #direct? Bit - #locals Nat}) + {#locals Nat}) (def: #export fresh-resolver Resolver @@ -28,10 +28,7 @@ (def: #export init State - {#scope-arity 0 - #resolver fresh-resolver - #direct? #0 - #locals 0}) + {#locals 0}) (type: #export Primitive (#Bit Bit) @@ -39,10 +36,6 @@ (#F64 Frac) (#Text Text)) -(type: #export (Structure a) - (#Variant (analysis.Variant a)) - (#Tuple (analysis.Tuple a))) - (type: #export Side (Either Nat Nat)) @@ -96,7 +89,7 @@ (type: #export #rec Synthesis (#Primitive Primitive) - (#Structure (Structure Synthesis)) + (#Structure (Composite Synthesis)) (#Reference Reference) (#Control (Control Synthesis)) (#Extension (Extension Synthesis))) @@ -157,9 +150,15 @@ (<tag> content))] [path/bind #..Bind] + [path/then #..Then] + ) + +(do-template [<name> <tag>] + [(template: #export (<name> left right) + (<tag> [left right]))] + [path/alt #..Alt] [path/seq #..Seq] - [path/then #..Then] ) (type: #export Abstraction @@ -170,41 +169,24 @@ (def: #export unit Text "") -(do-template [<name> <value>] - [(def: #export <name> - (All [a] (-> (Operation a) (Operation a))) - (extension.temporary (set@ #direct? <value>)))] - - [indirectly #0] - [directly #1] - ) - (do-template [<name> <type> <tag>] [(def: #export (<name> value) (-> <type> (All [a] (-> (Operation a) (Operation a)))) (extension.temporary (set@ <tag> value)))] - [with-scope-arity Arity #scope-arity] - [with-resolver Resolver #resolver] [with-locals Nat #locals] ) (def: #export (with-abstraction arity resolver) (-> Arity Resolver (All [a] (-> (Operation a) (Operation a)))) - (extension.with-state {#scope-arity arity - #resolver resolver - #direct? #1 - #locals arity})) + (extension.with-state {#locals arity})) (do-template [<name> <tag> <type>] [(def: #export <name> (Operation <type>) (extension.read (get@ <tag>)))] - [scope-arity #scope-arity Arity] - [resolver #resolver Resolver] - [direct? #direct? Bit] [locals #locals Nat] ) @@ -230,8 +212,8 @@ <tag> content))] - [variant #..Variant] - [tuple #..Tuple] + [variant #analysis.Variant] + [tuple #analysis.Tuple] ) (do-template [<name> <tag>] @@ -272,6 +254,59 @@ [function/apply #..Function #..Apply] ) +(def: #export (%path' %then value) + (All [a] (-> (Format a) (Format (Path' a)))) + (case value + #Pop + "_" + + (#Test primitive) + (format "(? " + (case primitive + (#Bit value) + (%b value) + + (#I64 value) + (%i (.int value)) + + (#F64 value) + (%f value) + + (#Text value) + (%t value)) + ")") + + (#Access access) + (case access + (#Side side) + (case side + (#.Left lefts) + (format "(" (%n lefts) " #0" ")") + + (#.Right lefts) + (format "(" (%n lefts) " #1" ")")) + + (#Member member) + (case member + (#.Left lefts) + (format "[" (%n lefts) " #0" "]") + + (#.Right lefts) + (format "[" (%n lefts) " #1" "]"))) + + (#Bind register) + (format "(@ " (%n register) ")") + + (#Alt left right) + (format "(| " (%path' %then left) " " (%path' %then right) ")") + + (#Seq left right) + (format "(& " (%path' %then left) " " (%path' %then right) ")") + + (#Then then) + (|> (%then then) + (text.enclose ["(! " ")"])))) + (def: #export (%synthesis value) (Format Synthesis) (case value @@ -283,7 +318,7 @@ [..text %t]) (^ (..i64 value)) - (%n (.nat value)) + (%i (.int value)) (^ (..variant [lefts right? content])) (|> (%synthesis content) @@ -295,6 +330,121 @@ (list/map %synthesis) (text.join-with " ") (text.enclose ["[" "]"])) - - _ - "???")) + + (#Reference reference) + (reference.%reference reference) + + (#Control control) + (case control + (#Function function) + (case function + (#Abstraction [environment arity body]) + (|> (%synthesis body) + (format (%n arity) " ") + (format (|> environment + (list/map reference.%variable) + (text.join-with " ") + (text.enclose ["[" "]"])) + " ") + (text.enclose ["(" ")"])) + + (#Apply func args) + (|> (list/map %synthesis args) + (text.join-with " ") + (format (%synthesis func) " ") + (text.enclose ["(" ")"]))) + + ## (%path' %synthesis ...) + ## (#Branch branch) + ## (#Loop loop) + _ + "???") + + (#Extension [name args]) + (|> (list/map %synthesis args) + (text.join-with " ") + (format (%t name)) + (text.enclose ["(" ")"])))) + +(def: #export %path + (Format Path) + (%path' %synthesis)) + +(structure: #export _ (Equivalence Primitive) + (def: (= reference sample) + (case [reference sample] + (^template [<tag> <eq> <format>] + [(<tag> reference') (<tag> sample')] + (<eq> reference' sample')) + ([#Bit bit/= %b] + [#F64 f/= %f] + [#Text text/= %t]) + + [(#I64 reference') (#I64 sample')] + (i/= (.int reference') (.int sample')) + + _ + false))) + +(structure: #export _ (Equivalence Access) + (def: (= reference sample) + (case [reference sample] + (^template [<tag>] + [(<tag> reference') (<tag> sample')] + (case [reference' sample'] + (^template [<side>] + [(<side> reference'') (<side> sample'')] + (n/= reference'' sample'')) + ([#.Left] + [#.Right]) + + _ + false)) + ([#Side] + [#Member]) + + _ + false))) + +(structure: #export (Equivalence<Path'> Equivalence<a>) + (All [a] (-> (Equivalence a) (Equivalence (Path' a)))) + + (def: (= reference sample) + (case [reference sample] + [#Pop #Pop] + true + + (^template [<tag> <equivalence>] + [(<tag> reference') (<tag> sample')] + (:: <equivalence> = reference' sample')) + ([#Test Equivalence<Primitive>] + [#Access Equivalence<Access>] + [#Then Equivalence<a>]) + + [(#Bind reference') (#Bind sample')] + (n/= reference' sample') + + (^template [<tag>] + [(<tag> leftR rightR) (<tag> leftS rightS)] + (and (= leftR leftS) + (= rightR rightS))) + ([#Alt] + [#Seq]) + + _ + false))) + +(structure: #export _ (Equivalence Synthesis) + (def: (= reference sample) + (case [reference sample] + (^template [<tag> <equivalence>] + [(<tag> reference') (<tag> sample')] + (:: <equivalence> = reference' sample')) + ([#Primitive Equivalence<Primitive>]) + + _ + false))) + +(def: #export Equivalence<Path> + (Equivalence Path) + (Equivalence<Path'> Equivalence<Synthesis>)) |