diff options
| -rw-r--r-- | commands.md | 4 | ||||
| -rw-r--r-- | documentation/research/Optimization.md | 4 | ||||
| -rw-r--r-- | documentation/research/distributed_programming.md | 1 | ||||
| -rw-r--r-- | documentation/research/math.md | 5 | ||||
| -rw-r--r-- | documentation/research/paradigm/probabilistic_programming.md | 1 | ||||
| -rw-r--r-- | lux-jvm/source/luxc/lang/translation/jvm/case.lux | 54 | ||||
| -rw-r--r-- | stdlib/source/lux/control/parser/code.lux | 58 | ||||
| -rw-r--r-- | stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/case.lux | 83 | ||||
| -rw-r--r-- | stdlib/source/test/lux/control.lux | 4 | ||||
| -rw-r--r-- | stdlib/source/test/lux/control/parser/code.lux | 135 | ||||
| -rw-r--r-- | stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/case.lux | 255 |
11 files changed, 476 insertions, 128 deletions
diff --git a/commands.md b/commands.md index 2108bb873..acb180eef 100644 --- a/commands.md +++ b/commands.md @@ -26,7 +26,7 @@ cd ~/lux/lux-scheme/ && lein clean # Read generated bytecode ``` -cd ~/lux/luxc/jbe/ && ./jbe.sh +cd ~/lux/jbe/ && ./jbe.sh ``` --- @@ -42,7 +42,7 @@ cd ~/lux/luxc/ && lein clean && lein install ## Run JBE ``` -cd ~/lux/luxc/jbe/ && ./jbe.sh +cd ~/lux/jbe/ && ./jbe.sh ``` --- diff --git a/documentation/research/Optimization.md b/documentation/research/Optimization.md index b0a7861a7..e31686963 100644 --- a/documentation/research/Optimization.md +++ b/documentation/research/Optimization.md @@ -1,3 +1,7 @@ +# Pre-fetching + +1. [Prefetching in Functional Languages](https://www.cl.cam.ac.uk/~tmj32/papers/docs/ainsworth20-ismm.pdf) + # Partial evaluation 1. [AnyDSL - A Partial Evaluation Framework for Programming High-Performance Libraries](https://anydsl.github.io/) diff --git a/documentation/research/distributed_programming.md b/documentation/research/distributed_programming.md index ef4003e18..49ff324fe 100644 --- a/documentation/research/distributed_programming.md +++ b/documentation/research/distributed_programming.md @@ -5,6 +5,7 @@ # Reference +1. [Ambients: Peer-to-Peer Programs and Data](https://ipfs.io/ipfs/QmPhPJE55GvqSz7Pwvkc8n9dbKmqGw6tUGTE1MgfNQvzsf) 1. [Bastion: Highly-available Distributed Fault-tolerant Runtime](https://bastion.rs/) 1. [DDD and Messaging Architectures: An overview of my different series on patterns in distributed systems.](http://verraes.net/2019/05/ddd-msg-arch/) 1. https://replicated.cc/ diff --git a/documentation/research/math.md b/documentation/research/math.md index 5c4363680..21916064d 100644 --- a/documentation/research/math.md +++ b/documentation/research/math.md @@ -1,3 +1,7 @@ +# Tensor calculus + +1. [Introduction to Tensor Calculus](http://www.ita.uni-heidelberg.de/~dullemond/lectures/tensor/tensor.pdf) + # Geometry 1. [Perspectives on Projective Geometry: A Guided Tour through Real and Complex Geometry](https://www-m10.ma.tum.de/foswiki/pub/Lehre/WS0910/ProjektiveGeometrieWS0910/GeomBook.pdf) @@ -145,6 +149,7 @@ # Category Theory +1. [Programming with Categories](https://www.youtube.com/watch?v=Y5YCE_mVjvg&list=PLhgq-BqyZ7i7MTGhUROZy3BOICnVixETS&index=1) 1. [Awesome Applied Category Theory](https://github.com/statebox/awesome-applied-ct) 1. [Categorical Query Language](https://www.categoricaldata.net/) 1. [Abstract and Concrete Categories: The Joy of Cats](http://katmat.math.uni-bremen.de/acc/acc.pdf) diff --git a/documentation/research/paradigm/probabilistic_programming.md b/documentation/research/paradigm/probabilistic_programming.md index aeb4bf827..d1450f794 100644 --- a/documentation/research/paradigm/probabilistic_programming.md +++ b/documentation/research/paradigm/probabilistic_programming.md @@ -15,6 +15,7 @@ # Reference +1. [The Distribution Monad](http://blog.russelldmatt.com/2018/10/15/the-distribution-monad.html) 1. ["New programming constructs for probabilistic AI" by Marco Cusumano-Towner](https://www.youtube.com/watch?v=xNutxms6SH4) 1. [A tour of probabilistic programming language APIs](https://colcarroll.github.io/ppl-api/) 1. [Paradigms of Probabilistic Programming](https://www.youtube.com/watch?v=CmH1xxKRbiE) diff --git a/lux-jvm/source/luxc/lang/translation/jvm/case.lux b/lux-jvm/source/luxc/lang/translation/jvm/case.lux index 421f413a0..e21cf9aec 100644 --- a/lux-jvm/source/luxc/lang/translation/jvm/case.lux +++ b/lux-jvm/source/luxc/lang/translation/jvm/case.lux @@ -57,22 +57,35 @@ _.AALOAD (_.CHECKCAST runtime.$Stack))) +(def: (leftsI value) + (-> Nat Inst) + (.case value + 0 _.ICONST_0 + 1 _.ICONST_1 + 2 _.ICONST_2 + 3 _.ICONST_3 + 4 _.ICONST_4 + 5 _.ICONST_5 + _ (_.int (.int value)))) + (def: (left-projection lefts) (-> Nat Inst) - (.let [accessI (.case lefts - 0 - _.AALOAD - - lefts - (_.INVOKESTATIC //.$Runtime "tuple_left" (type.method [(list //.$Tuple runtime.$Index) //.$Value (list)])))] + (.let [[indexI accessI] (.case lefts + 0 + [_.ICONST_0 + _.AALOAD] + + lefts + [(leftsI lefts) + (_.INVOKESTATIC //.$Runtime "tuple_left" (type.method [(list //.$Tuple runtime.$Index) //.$Value (list)]))])] (|>> (_.CHECKCAST //.$Tuple) - (_.int (.int lefts)) + indexI accessI))) (def: (right-projection lefts) (-> Nat Inst) (|>> (_.CHECKCAST //.$Tuple) - (_.int (.int lefts)) + (leftsI lefts) (_.INVOKESTATIC //.$Runtime "tuple_right" (type.method [(list //.$Tuple runtime.$Index) //.$Value (list)])))) (def: (path' stack-depth @else @end phase archive path) @@ -151,33 +164,18 @@ pushI)) ## Extra optimization - (^ (synthesis.path/seq - (synthesis.member/left 0) - (synthesis.!bind-top register thenP))) - (do phase.monad - [then! (path' stack-depth @else @end phase archive thenP)] - (wrap (|>> peekI - (_.CHECKCAST //.$Tuple) - (_.int +0) - _.AALOAD - (_.ASTORE register) - then!))) - - ## Extra optimization - (^template [<pm> <getter>] + (^template [<path> <projection>] (^ (synthesis.path/seq - (<pm> lefts) + (<path> lefts) (synthesis.!bind-top register thenP))) (do phase.monad [then! (path' stack-depth @else @end phase archive thenP)] (wrap (|>> peekI - (_.CHECKCAST //.$Tuple) - (_.int (.int lefts)) - (_.INVOKESTATIC //.$Runtime <getter> (type.method [(list //.$Tuple runtime.$Index) //.$Value (list)])) + (<projection> lefts) (_.ASTORE register) then!)))) - ([synthesis.member/left "tuple_left"] - [synthesis.member/right "tuple_right"]) + ([synthesis.member/left ..left-projection] + [synthesis.member/right ..right-projection]) (#synthesis.Alt leftP rightP) (do phase.monad diff --git a/stdlib/source/lux/control/parser/code.lux b/stdlib/source/lux/control/parser/code.lux index 30344aaa0..ca0df7c9f 100644 --- a/stdlib/source/lux/control/parser/code.lux +++ b/stdlib/source/lux/control/parser/code.lux @@ -39,11 +39,14 @@ (Parser Code) (function (_ tokens) (case tokens - #.Nil (#try.Failure "There are no tokens to parse!") - (#.Cons [t tokens']) (#try.Success [tokens' t])))) + #.Nil + (#try.Failure "There are no tokens to parse!") + + (#.Cons [t tokens']) + (#try.Success [tokens' t])))) -(template [<query> <assertion> <type> <tag> <eq> <desc>] - [(with-expansions [<error> (as-is (#try.Failure ($_ text@compose "Cannot parse " <desc> (remaining-inputs tokens))))] +(template [<query> <check> <type> <tag> <eq> <desc>] + [(with-expansions [<failure> (as-is (#try.Failure ($_ text@compose "Cannot parse " <desc> (remaining-inputs tokens))))] (def: #export <query> {#.doc (code.text ($_ text@compose "Parses the next " <desc> " input."))} (Parser <type>) @@ -53,19 +56,19 @@ (#try.Success [tokens' x]) _ - <error>))) + <failure>))) - (def: #export (<assertion> expected) + (def: #export (<check> expected) (-> <type> (Parser Any)) (function (_ tokens) (case tokens (#.Cons [[_ (<tag> actual)] tokens']) (if (:: <eq> = expected actual) (#try.Success [tokens' []]) - <error>) + <failure>) _ - <error>))))] + <failure>))))] [bit bit! Bit #.Bit bit.equivalence "bit"] [nat nat! Nat #.Nat nat.equivalence "nat"] @@ -91,20 +94,33 @@ _ (#try.Failure "There are no tokens to parse!")))) -(template [<name> <tag> <desc>] - [(def: #export <name> - {#.doc (code.text ($_ text@compose "Parse a local " <desc> " (a " <desc> " that has no module prefix)."))} - (Parser Text) - (function (_ tokens) - (case tokens - (#.Cons [[_ (<tag> ["" x])] tokens']) - (#try.Success [tokens' x]) +(template [<query> <check> <tag> <eq> <desc>] + [(with-expansions [<failure> (as-is (#try.Failure ($_ text@compose "Cannot parse " <desc> (remaining-inputs tokens))))] + (def: #export <query> + {#.doc (code.text ($_ text@compose "Parse a local " <desc> " (a " <desc> " that has no module prefix)."))} + (Parser Text) + (function (_ tokens) + (case tokens + (#.Cons [[_ (<tag> ["" x])] tokens']) + (#try.Success [tokens' x]) - _ - (#try.Failure ($_ text@compose "Cannot parse local " <desc> (remaining-inputs tokens))))))] + _ + <failure>))) + + (def: #export (<check> expected) + (-> Text (Parser Any)) + (function (_ tokens) + (case tokens + (#.Cons [[_ (<tag> ["" actual])] tokens']) + (if (:: <eq> = expected actual) + (#try.Success [tokens' []]) + <failure>) + + _ + <failure>))))] - [local-identifier #.Identifier "identifier"] - [ local-tag #.Tag "tag"] + [local-identifier local-identifier! #.Identifier text.equivalence "local identifier"] + [ local-tag local-tag! #.Tag text.equivalence "local tag"] ) (template [<name> <tag> <desc>] @@ -177,5 +193,5 @@ (All [a] (-> (List Code) (Parser a) (Parser a))) (function (_ real) (do try.monad - [value (run syntax inputs)] + [value (..run syntax inputs)] (wrap [real value])))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/case.lux index 8d3b7b2d5..3e2bbd321 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/case.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/case.lux @@ -65,14 +65,19 @@ (#///analysis.Complex (#///analysis.Tuple tuple)) (let [tuple::last (dec (list.size tuple))] (list@fold (function (_ [tuple::lefts tuple::member] nextC) - (let [right? (n.= tuple::last tuple::lefts) - end?' (and end? right?)] - (<| (///@map (|>> (#/.Seq (#/.Access (#/.Member (if right? - (#.Right (dec tuple::lefts)) - (#.Left tuple::lefts))))))) - (path' tuple::member end?') - (when> [(new> (not end?') [])] [(///@map ..clean-up)]) - nextC))) + (.case tuple::member + (#///analysis.Simple #///analysis.Unit) + nextC + + _ + (let [right? (n.= tuple::last tuple::lefts) + end?' (and end? right?)] + (<| (///@map (|>> (#/.Seq (#/.Access (#/.Member (if right? + (#.Right (dec tuple::lefts)) + (#.Left tuple::lefts))))))) + (path' tuple::member end?') + (when> [(new> (not end?') [])] [(///@map ..clean-up)]) + nextC)))) thenC (list.reverse (list.enumerate tuple)))) )) @@ -81,27 +86,32 @@ (-> Archive Phase Pattern Analysis (Operation Path)) (path' pattern true (///@map (|>> #/.Then) (synthesize archive bodyA)))) -(def: (weave leftP rightP) +(def: (weave new old) (-> Path Path Path) - (with-expansions [<default> (as-is (#/.Alt leftP rightP))] - (case [leftP rightP] - [(#/.Seq preL postL) - (#/.Seq preR postR)] - (case (weave preL preR) + (with-expansions [<default> (as-is (#/.Alt old new))] + (case [new old] + [_ + (#/.Alt old-left old-right)] + (#/.Alt old-left + (weave new old-right)) + + [(#/.Seq preN postN) + (#/.Seq preO postO)] + (case (weave preN preO) (#/.Alt _) <default> - weavedP - (#/.Seq weavedP (weave postL postR))) + woven + (#/.Seq woven (weave postN postO))) [#/.Pop #/.Pop] - rightP + old (^template [<tag> <eq>] - [(#/.Test (<tag> leftV)) - (#/.Test (<tag> rightV))] - (if (<eq> leftV rightV) - rightP + [(#/.Test (<tag> newV)) + (#/.Test (<tag> oldV))] + (if (<eq> newV oldV) + old <default>)) ([#/.Bit bit@=] [#/.I64 "lux i64 ="] @@ -109,19 +119,19 @@ [#/.Text text@=]) (^template [<access> <side>] - [(#/.Access (<access> (<side> leftL))) - (#/.Access (<access> (<side> rightL)))] - (if (n.= leftL rightL) - rightP + [(#/.Access (<access> (<side> newL))) + (#/.Access (<access> (<side> oldL)))] + (if (n.= newL oldL) + old <default>)) ([#/.Side #.Left] [#/.Side #.Right] [#/.Member #.Left] [#/.Member #.Right]) - [(#/.Bind leftR) (#/.Bind rightR)] - (if (n.= leftR rightR) - rightP + [(#/.Bind newR) (#/.Bind oldR)] + (if (n.= newR oldR) + old <default>) _ @@ -162,19 +172,12 @@ _ <failure>))))) -(def: #export (synthesize-case synthesize archive input [headB tailB+]) +(def: #export (synthesize-case synthesize archive input [[headP headA] tailPA+]) (-> Phase Archive Synthesis Match (Operation Synthesis)) - (let [[[lastP lastA] prevsPA] (|> (#.Cons headB tailB+) - list.reverse - (case> (#.Cons [lastP lastA] prevsPA) - [[lastP lastA] prevsPA] - - _ - (undefined)))] - (do {@ ///.monad} - [lastSP (path archive synthesize lastP lastA) - prevsSP+ (monad.map @ (product.uncurry (path archive synthesize)) prevsPA)] - (wrap (/.branch/case [input (list@fold weave lastSP prevsSP+)]))))) + (do {@ ///.monad} + [headSP (path archive synthesize headP headA) + tailSP+ (monad.map @ (product.uncurry (path archive synthesize)) tailPA+)] + (wrap (/.branch/case [input (list@fold weave headSP tailSP+)])))) (template: (!masking <variable> <output>) [[(#///analysis.Bind <variable>) diff --git a/stdlib/source/test/lux/control.lux b/stdlib/source/test/lux/control.lux index 29c34b430..bad67d90a 100644 --- a/stdlib/source/test/lux/control.lux +++ b/stdlib/source/test/lux/control.lux @@ -23,7 +23,8 @@ ["#/." analysis] ["#/." binary] ["#/." text] - ["#/." cli]] + ["#/." cli] + ["#/." code]] ["#." pipe] ["#." reader] ["#." region] @@ -63,6 +64,7 @@ /parser/binary.test /parser/text.test /parser/cli.test + /parser/code.test )) (def: security diff --git a/stdlib/source/test/lux/control/parser/code.lux b/stdlib/source/test/lux/control/parser/code.lux new file mode 100644 index 000000000..696f70265 --- /dev/null +++ b/stdlib/source/test/lux/control/parser/code.lux @@ -0,0 +1,135 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)]] + [control + ["." function] + ["." try] + ["<>" parser]] + [data + ["." bit] + ["." name] + ["." text ("#@." equivalence)] + [number + ["." nat] + ["." int] + ["." rev] + ["." frac]] + [collection + ["." list]]] + [macro + ["." code ("#@." equivalence)]] + [math + ["." random (#+ Random)]]] + {1 + ["." /]}) + +(template: (!expect <pattern> <value>) + (case <value> + <pattern> + true + + _ + false)) + +(def: random-name + (Random Name) + (random.and (random.unicode 1) + (random.unicode 1))) + +(def: #export test + Test + (<| (_.covering /._) + (_.with-cover [/.Parser]) + (`` ($_ _.and + (do {@ random.monad} + [expected (:: @ map code.bit random.bit)] + (_.cover [/.run] + (and (|> (/.run /.any (list expected)) + (!expect (#try.Success _))) + (|> (/.run /.any (list)) + (!expect (#try.Failure _)))))) + (~~ (template [<query> <check> <random> <code> <equivalence>] + [(do {@ random.monad} + [expected <random> + dummy (|> <random> (random.filter (|>> (:: <equivalence> = expected) not)))] + ($_ _.and + (_.cover [<query>] + (|> (/.run <query> (list (<code> expected))) + (!expect (^multi (#try.Success actual) + (:: <equivalence> = expected actual))))) + (_.cover [<check>] + (and (|> (/.run (<check> expected) (list (<code> expected))) + (!expect (#try.Success []))) + (|> (/.run (<check> expected) (list (<code> dummy))) + (!expect (#try.Failure _))))) + ))] + + [/.any /.this! (:: @ map code.bit random.bit) function.identity code.equivalence] + [/.bit /.bit! random.bit code.bit bit.equivalence] + [/.nat /.nat! random.nat code.nat nat.equivalence] + [/.int /.int! random.int code.int int.equivalence] + [/.rev /.rev! random.rev code.rev rev.equivalence] + [/.frac /.frac! random.frac code.frac frac.equivalence] + [/.text /.text! (random.unicode 1) code.text text.equivalence] + [/.identifier /.identifier! ..random-name code.identifier name.equivalence] + [/.tag /.tag! ..random-name code.tag name.equivalence] + [/.local-identifier /.local-identifier! (random.unicode 1) code.local-identifier text.equivalence] + [/.local-tag /.local-tag! (random.unicode 1) code.local-tag text.equivalence] + )) + (~~ (template [<query> <code>] + [(do {@ random.monad} + [expected-left random.nat + expected-right random.int] + (_.cover [<query>] + (|> (/.run (<query> (<>.and /.nat /.int)) + (list (<code> (list (code.nat expected-left) + (code.int expected-right))))) + (!expect (^multi (#try.Success [actual-left actual-right]) + (and (:: nat.equivalence = expected-left actual-left) + (:: int.equivalence = expected-right actual-right)))))))] + + [/.form code.form] + [/.tuple code.tuple] + )) + (do {@ random.monad} + [expected-left random.nat + expected-right random.int] + (_.cover [/.record] + (|> (/.run (/.record (<>.and /.nat /.int)) + (list (code.record (list [(code.nat expected-left) + (code.int expected-right)])))) + (!expect (^multi (#try.Success [actual-left actual-right]) + (and (:: nat.equivalence = expected-left actual-left) + (:: int.equivalence = expected-right actual-right))))))) + (do {@ random.monad} + [expected-local random.nat + expected-global random.int] + (_.cover [/.local] + (|> (/.run (<>.and (/.local (list (code.nat expected-local)) /.nat) + /.int) + (list (code.int expected-global))) + (!expect (^multi (#try.Success [actual-local actual-global]) + (and (:: nat.equivalence = expected-local actual-local) + (:: int.equivalence = expected-global actual-global))))))) + (do {@ random.monad} + [dummy (:: @ map code.bit random.bit)] + (_.cover [/.end?] + (|> (/.run (do <>.monad + [pre /.end? + _ /.any + post /.end?] + (wrap (and (not pre) + post))) + (list dummy)) + (!expect (^multi (#try.Success verdict) + verdict))))) + (do {@ random.monad} + [dummy (:: @ map code.bit random.bit)] + (_.cover [/.end!] + (and (|> (/.run /.end! (list)) + (!expect (#try.Success []))) + (|> (/.run /.end! (list dummy)) + (!expect (#try.Failure _)))))) + )))) diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/case.lux b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/case.lux index d084e0210..2209bf366 100644 --- a/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/case.lux +++ b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/case.lux @@ -2,16 +2,23 @@ [lux #* ["_" test (#+ Test)] [abstract + [hash (#+ Hash)] ["." monad (#+ do)]] [control - pipe + [pipe (#+ case>)] ["." try ("#@." functor)]] [data ["." sum] + ["." text + ["%" format (#+ format)]] [number - ["n" nat]] + ["n" nat] + ["." int] + ["." rev] + ["." frac]] [collection - ["." list ("#@." fold monoid)]]] + ["." list ("#@." functor fold monoid)] + ["." set]]] [math ["." random (#+ Random) ("#@." monad)]]] ["." // #_ @@ -23,8 +30,8 @@ [extension ["#." bundle]] ["/#" // - ["#." analysis (#+ Branch Analysis)] - ["#." synthesis (#+ Synthesis)] + ["." analysis (#+ Branch Match Analysis)] + ["." synthesis (#+ Path Synthesis)] [/// ["#." reference [variable (#+ Register)]] @@ -37,15 +44,15 @@ (do {@ random.monad} [maskedA //primitive.primitive temp (|> random.nat (:: @ map (n.% 100))) - #let [maskA (////analysis.control/case + #let [maskA (analysis.control/case [maskedA - [[(#////analysis.Bind temp) - (#////analysis.Reference (////reference.local temp))] + [[(#analysis.Bind temp) + (#analysis.Reference (////reference.local temp))] (list)]])]] (_.cover [/.synthesize-masking] (|> maskA (//.phase archive.empty) - (phase.run [///bundle.empty ////synthesis.init]) + (phase.run [///bundle.empty synthesis.init]) (try@map (//primitive.corresponds? maskedA)) (try.default false))))) @@ -55,16 +62,16 @@ [registerA random.nat inputA //primitive.primitive outputA //primitive.primitive - #let [letA (////analysis.control/case + #let [letA (analysis.control/case [inputA - [[(#////analysis.Bind registerA) + [[(#analysis.Bind registerA) outputA] (list)]])]] (_.cover [/.synthesize-let] (|> letA (//.phase archive.empty) - (phase.run [///bundle.empty ////synthesis.init]) - (case> (^ (#try.Success (////synthesis.branch/let [inputS registerS outputS]))) + (phase.run [///bundle.empty synthesis.init]) + (case> (^ (#try.Success (synthesis.branch/let [inputS registerS outputS]))) (and (n.= registerA registerS) (//primitive.corresponds? inputA inputS) (//primitive.corresponds? outputA outputS)) @@ -80,19 +87,19 @@ thenA //primitive.primitive elseA //primitive.primitive #let [thenB (: Branch - [(#////analysis.Simple (#////analysis.Bit true)) + [(#analysis.Simple (#analysis.Bit true)) thenA]) elseB (: Branch - [(#////analysis.Simple (#////analysis.Bit false)) + [(#analysis.Simple (#analysis.Bit false)) elseA]) ifA (if then|else - (////analysis.control/case [inputA [thenB (list elseB)]]) - (////analysis.control/case [inputA [elseB (list thenB)]]))]] + (analysis.control/case [inputA [thenB (list elseB)]]) + (analysis.control/case [inputA [elseB (list thenB)]]))]] (_.cover [/.synthesize-if] (|> ifA (//.phase archive.empty) - (phase.run [///bundle.empty ////synthesis.init]) - (case> (^ (#try.Success (////synthesis.branch/if [inputS thenS elseS]))) + (phase.run [///bundle.empty synthesis.init]) + (case> (^ (#try.Success (synthesis.branch/if [inputS thenS elseS]))) (and (//primitive.corresponds? inputA inputS) (//primitive.corresponds? thenA thenS) (//primitive.corresponds? elseA elseS)) @@ -101,7 +108,7 @@ false))))) (def: random-member - (Random ////synthesis.Member) + (Random synthesis.Member) (do {@ random.monad} [lefts (|> random.nat (:: @ map (n.% 10))) right? random.bit] @@ -110,28 +117,28 @@ (#.Left lefts))))) (def: random-path - (Random (////analysis.Tuple ////synthesis.Member)) + (Random (analysis.Tuple synthesis.Member)) (do {@ random.monad} [size-1 (|> random.nat (:: @ map (|>> (n.% 10) inc)))] (random.list size-1 ..random-member))) (def: (get-pattern path) - (-> (////analysis.Tuple ////synthesis.Member) - (Random [////analysis.Pattern Register])) + (-> (analysis.Tuple synthesis.Member) + (Random [analysis.Pattern Register])) (do random.monad [@member random.nat] (wrap [(list@fold (function (_ member inner) (case member (#.Left lefts) - (////analysis.pattern/tuple - (list@compose (list.repeat lefts (////analysis.pattern/unit)) - (list inner (////analysis.pattern/unit)))) + (analysis.pattern/tuple + (list@compose (list.repeat lefts (analysis.pattern/unit)) + (list inner (analysis.pattern/unit)))) (#.Right lefts) - (////analysis.pattern/tuple - (list@compose (list.repeat (inc lefts) (////analysis.pattern/unit)) + (analysis.pattern/tuple + (list@compose (list.repeat (inc lefts) (analysis.pattern/unit)) (list inner))))) - (#////analysis.Bind @member) + (#analysis.Bind @member) (list.reverse path)) @member]))) @@ -139,25 +146,200 @@ Test (do {@ random.monad} [recordA (|> random.nat - (:: @ map (|>> ////analysis.nat)) + (:: @ map (|>> analysis.nat)) (random.list 10) - (:: @ map (|>> ////analysis.tuple))) + (:: @ map (|>> analysis.tuple))) pathA ..random-path [pattern @member] (get-pattern pathA) - #let [getA (////analysis.control/case [recordA [[pattern - (#////analysis.Reference (////reference.local @member))] - (list)]])]] + #let [getA (analysis.control/case [recordA [[pattern + (#analysis.Reference (////reference.local @member))] + (list)]])]] (_.cover [/.synthesize-get] (|> getA (//.phase archive.empty) - (phase.run [///bundle.empty ////synthesis.init]) - (case> (^ (#try.Success (////synthesis.branch/get [pathS recordS]))) + (phase.run [///bundle.empty synthesis.init]) + (case> (^ (#try.Success (synthesis.branch/get [pathS recordS]))) (and (:: (list.equivalence (sum.equivalence n.= n.=)) = pathA pathS) (//primitive.corresponds? recordA recordS)) _ false))))) +(def: random-bit + (Random [Path Match]) + (do {@ random.monad} + [test random.bit + then random.nat + else random.nat] + (wrap [(#synthesis.Alt (#synthesis.Seq (synthesis.path/bit test) + (#synthesis.Then (synthesis.i64 (.i64 then)))) + (#synthesis.Seq (synthesis.path/bit (not test)) + (#synthesis.Then (synthesis.i64 (.i64 else))))) + [{#analysis.when (analysis.pattern/bit test) + #analysis.then (analysis.nat then)} + (list {#analysis.when (analysis.pattern/bit (not test)) + #analysis.then (analysis.nat else)})]]))) + +(def: (random-five hash random-element) + (All [a] (-> (Hash a) (Random a) (Random [a a a a a]))) + (|> random-element + (random.set hash 5) + (:: random.monad map (|>> set.to-list + (case> (^ (list s0 s1 s2 s3 s4)) + [s0 s1 s2 s3 s4] + + _ + (undefined)))))) + +(template [<name> <hash> <random> <path> <synthesis> <pattern> <analysis>] + [(def: <name> + (Random [Path Match]) + (do {@ random.monad} + [[test/0 test/1 test/2 test/3 test/4] (random-five <hash> <random>) + [body/0 body/1 body/2 body/3 body/4] (random-five <hash> <random>)] + (wrap [($_ #synthesis.Alt + (#synthesis.Seq (<path> test/0) (#synthesis.Then (<synthesis> body/0))) + (#synthesis.Seq (<path> test/1) (#synthesis.Then (<synthesis> body/1))) + (#synthesis.Seq (<path> test/2) (#synthesis.Then (<synthesis> body/2))) + (#synthesis.Seq (<path> test/3) (#synthesis.Then (<synthesis> body/3))) + (#synthesis.Seq (<path> test/4) (#synthesis.Then (<synthesis> body/4)))) + [{#analysis.when (<pattern> test/0) #analysis.then (<analysis> body/0)} + (list {#analysis.when (<pattern> test/1) #analysis.then (<analysis> body/1)} + {#analysis.when (<pattern> test/2) #analysis.then (<analysis> body/2)} + {#analysis.when (<pattern> test/3) #analysis.then (<analysis> body/3)} + {#analysis.when (<pattern> test/4) #analysis.then (<analysis> body/4)})]])))] + + [random-nat n.hash random.nat (|>> .i64 synthesis.path/i64) (|>> .i64 synthesis.i64) analysis.pattern/nat analysis.nat] + [random-int int.hash random.int (|>> .i64 synthesis.path/i64) (|>> .i64 synthesis.i64) analysis.pattern/int analysis.int] + [random-rev rev.hash random.rev (|>> .i64 synthesis.path/i64) (|>> .i64 synthesis.i64) analysis.pattern/rev analysis.rev] + [random-frac frac.hash random.frac synthesis.path/f64 synthesis.f64 analysis.pattern/frac analysis.frac] + [random-text text.hash (random.unicode 1) synthesis.path/text synthesis.text analysis.pattern/text analysis.text] + ) + +(def: random-simple + ($_ random.either + ..random-bit + ..random-nat + ..random-int + ..random-rev + ..random-frac + ..random-text + )) + +(def: random-variant + (Random [Path Match]) + (do {@ random.monad} + [[lefts/0 lefts/1 lefts/2 lefts/3 lefts/4] (random-five n.hash random.nat) + [value/0 value/1 value/2 value/3 value/4] (random-five text.hash (random.unicode 1)) + last-is-right? random.bit + [body/0 body/1 body/2 body/3 body/4] (random-five frac.hash random.frac) + #let [path (: (-> Nat Bit Text Frac Path) + (function (_ lefts right? value body) + ($_ #synthesis.Seq + (synthesis.path/side (if right? + (#.Right lefts) + (#.Left lefts))) + (synthesis.path/text value) + (#synthesis.Then (synthesis.f64 body))))) + branch (: (-> Nat Bit Text Frac Branch) + (function (_ lefts right? value body) + {#analysis.when (analysis.pattern/variant {#analysis.lefts lefts + #analysis.right? right? + #analysis.value (analysis.pattern/text value)}) + #analysis.then (analysis.frac body)}))]] + (wrap [($_ #synthesis.Alt + (path lefts/0 false value/0 body/0) + (path lefts/1 false value/1 body/1) + (path lefts/2 false value/2 body/2) + (path lefts/3 false value/3 body/3) + (path lefts/4 last-is-right? value/4 body/4)) + [(branch lefts/0 false value/0 body/0) + (list (branch lefts/1 false value/1 body/1) + (branch lefts/2 false value/2 body/2) + (branch lefts/3 false value/3 body/3) + (branch lefts/4 last-is-right? value/4 body/4))]]))) + +(def: random-tuple + (Random [Path Match]) + (do {@ random.monad} + [mid-size (:: @ map (n.% 4) random.nat) + + value/first (random.unicode 1) + value/mid (random.list mid-size (random.unicode 1)) + value/last (random.unicode 1) + + body/first random.frac + body/mid (random.list mid-size random.frac) + body/last random.frac + #let [path (: (-> Nat Bit Text Frac Path) + (function (_ lefts right? value body) + (if right? + ($_ #synthesis.Seq + (synthesis.path/member (if right? + (#.Right lefts) + (#.Left lefts))) + (synthesis.path/text value) + (#synthesis.Then (synthesis.f64 body))) + ($_ #synthesis.Seq + (synthesis.path/member (if right? + (#.Right lefts) + (#.Left lefts))) + (synthesis.path/text value) + #synthesis.Pop + (#synthesis.Then (synthesis.f64 body)))))) + branch (: (-> Nat Bit Text Frac Branch) + (function (_ lefts right? value body) + {#analysis.when (if right? + (analysis.pattern/tuple (list@compose (list.repeat (inc lefts) (analysis.pattern/unit)) + (list (analysis.pattern/text value)))) + (analysis.pattern/tuple ($_ list@compose + (list.repeat lefts (analysis.pattern/unit)) + (list (analysis.pattern/text value) + (analysis.pattern/unit))))) + #analysis.then (analysis.frac body)}))]] + (wrap [(list@fold (function (_ left right) + (#synthesis.Alt left right)) + (path (inc mid-size) true value/last body/last) + (|> (list.zip2 value/mid body/mid) + (#.Cons [value/first body/first]) + list.enumerate + (list@map (function (_ [lefts' [value body]]) + (path lefts' false value body))) + list.reverse)) + [(branch 0 false value/first body/first) + (list@compose (|> (list.zip2 value/mid body/mid) + list.enumerate + (list@map (function (_ [lefts' [value body]]) + (branch (inc lefts') false value body)))) + (list (branch (inc mid-size) true value/last body/last)))]]))) + +(def: random-complex + ($_ random.either + ..random-variant + ..random-tuple + )) + +(def: random-case + ($_ random.either + ..random-simple + ..random-complex + )) + +(def: case-test + Test + (do {@ random.monad} + [expected-input (:: @ map (|>> .i64 synthesis.i64) random.nat) + [expected-path match] ..random-case] + (_.cover [/.synthesize-case] + (|> (/.synthesize-case //.phase archive.empty expected-input match) + (phase.run [///bundle.empty synthesis.init]) + (case> (^ (#try.Success (synthesis.branch/case [actual-input actual-path]))) + (and (:: synthesis.equivalence = expected-input actual-input) + (:: synthesis.path-equivalence = expected-path actual-path)) + + _ + false))))) + (def: #export test Test (<| (_.covering /._) @@ -167,4 +349,5 @@ ..let-test ..if-test ..get-test + ..case-test ))) |