From c95fa2cc7db042fdde7250479727650f43b087a1 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 17 Sep 2017 00:38:24 -0400 Subject: - Added pattern-matching compilation. --- new-luxc/test/test/luxc/analyser/case.lux | 22 +++---- new-luxc/test/test/luxc/generator/case.lux | 102 +++++++++++++++++++++++++++++ new-luxc/test/tests.lux | 1 + 3 files changed, 114 insertions(+), 11 deletions(-) create mode 100644 new-luxc/test/test/luxc/generator/case.lux (limited to 'new-luxc/test') diff --git a/new-luxc/test/test/luxc/analyser/case.lux b/new-luxc/test/test/luxc/analyser/case.lux index 3c05f5dad..983dff6f5 100644 --- a/new-luxc/test/test/luxc/analyser/case.lux +++ b/new-luxc/test/test/luxc/analyser/case.lux @@ -40,7 +40,7 @@ head head+] (wrap (#;Cons head tail+))))) -(def: (exhaustive-branches-for allow-literals? variantTC inputC) +(def: #export (exhaustive-branches allow-literals? variantTC inputC) (-> Bool (List [Code Code]) Code (r;Random (List Code))) (case inputC [_ (#;Bool _)] @@ -54,7 +54,7 @@ (case ?sample (#;Some sample) (do @ - [else (exhaustive-branches-for allow-literals? variantTC inputC)] + [else (exhaustive-branches allow-literals? variantTC inputC)] (wrap (list& ( sample) else))) #;None @@ -74,7 +74,7 @@ [_ (#;Tuple members)] (do r;Monad - [member-wise-patterns (monad;map @ (exhaustive-branches-for allow-literals? variantTC) members)] + [member-wise-patterns (monad;map @ (exhaustive-branches allow-literals? variantTC) members)] (wrap (|> member-wise-patterns exhaustive-weaving (L/map code;tuple)))) @@ -83,7 +83,7 @@ (do r;Monad [#let [ks (L/map product;left kvs) vs (L/map product;right kvs)] - member-wise-patterns (monad;map @ (exhaustive-branches-for allow-literals? variantTC) vs)] + member-wise-patterns (monad;map @ (exhaustive-branches allow-literals? variantTC) vs)] (wrap (|> member-wise-patterns exhaustive-weaving (L/map (|>. (list;zip2 ks) code;record))))) @@ -93,7 +93,7 @@ [bundles (monad;map @ (function [[_tag _code]] (do @ - [v-branches (exhaustive-branches-for allow-literals? variantTC _code)] + [v-branches (exhaustive-branches allow-literals? variantTC _code)] (wrap (L/map (function [pattern] (` ((~ _tag) (~ pattern)))) v-branches)))) variantTC)] @@ -103,10 +103,10 @@ (r/wrap (list)) )) -(def: (gen-input variant-tags record-tags primitivesC) +(def: #export (input variant-tags record-tags primitivesC) (-> (List Code) (List Code) (List Code) (r;Random Code)) (r;rec - (function [gen-input] + (function [input] ($_ r;either (r/map product;right gen-primitive) (do r;Monad @@ -116,7 +116,7 @@ (wrap (` ((~ choiceT) (~ choiceC))))) (do r;Monad [size (|> r;nat (:: @ map (n.% +3))) - elems (r;list size gen-input)] + elems (r;list size input)] (wrap (code;tuple elems))) (r/wrap (code;record (list;zip2 record-tags primitivesC))) )))) @@ -141,12 +141,12 @@ variant-tags+ (L/map (|>. [module-name] code;tag) variant-tags) record-tags+ (L/map (|>. [module-name] code;tag) record-tags) variantTC (list;zip2 variant-tags+ primitivesC)] - inputC (gen-input variant-tags+ record-tags+ primitivesC) + inputC (input variant-tags+ record-tags+ primitivesC) [outputT outputC] gen-primitive [heterogeneousT heterogeneousC] (|> gen-primitive (r;filter (|>. product;left (tc;checks? outputT) not))) - exhaustive-patterns (exhaustive-branches-for true variantTC inputC) - redundant-patterns (exhaustive-branches-for false variantTC inputC) + exhaustive-patterns (exhaustive-branches true variantTC inputC) + redundant-patterns (exhaustive-branches false variantTC inputC) redundancy-idx (|> r;nat (:: @ map (n.% (list;size redundant-patterns)))) heterogeneous-idx (|> r;nat (:: @ map (n.% (list;size exhaustive-patterns)))) #let [exhaustive-branchesC (L/map (branch outputC) diff --git a/new-luxc/test/test/luxc/generator/case.lux b/new-luxc/test/test/luxc/generator/case.lux new file mode 100644 index 000000000..9e6dbf928 --- /dev/null +++ b/new-luxc/test/test/luxc/generator/case.lux @@ -0,0 +1,102 @@ +(;module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (data text/format + [product] + ["R" result] + [bool "B/" Eq] + [text "T/" Eq] + (coll ["a" array] + [list "L/" Functor] + ["S" set])) + ["r" math/random "r/" Monad] + [macro #+ Monad] + (macro [code]) + [host] + test) + (luxc (lang ["ls" synthesis]) + [analyser] + [synthesizer] + (generator ["@" case] + ["@;" eval] + ["@;" runtime] + ["@;" common])) + (test/luxc common)) + +(def: struct-limit Nat +10) + +(def: (tail? size idx) + (-> Nat Nat Bool) + (n.= (n.dec size) idx)) + +(def: gen-case + (r;Random [ls;Synthesis ls;Path]) + (<| r;rec (function [gen-case]) + (with-expansions [ (do-template [ ] + [(do r;Monad + [value ] + (wrap [( value) ( value)]))] + + [r;bool #ls;Bool #ls;BoolP] + [r;nat #ls;Nat #ls;NatP] + [r;int #ls;Int #ls;IntP] + [r;deg #ls;Deg #ls;DegP] + [r;frac #ls;Frac #ls;FracP] + [(r;text +5) #ls;Text #ls;TextP])] + ($_ r;either + (r/wrap [#ls;Unit #ls;UnitP]) + + (do r;Monad + [size (|> r;nat (:: @ map (|>. (n.% struct-limit) (n.max +2)))) + idx (|> r;nat (:: @ map (n.% size))) + [subS subP] gen-case + #let [dummyS (list;repeat (n.dec size) #ls;Unit) + caseS (#ls;Tuple (list;concat (list (list;take idx dummyS) + (list subS) + (list;drop idx dummyS)))) + caseP (#ls;TupleP (if (tail? idx idx) + (#;Right idx) + (#;Left idx)) + subP)]] + (wrap [caseS caseP])) + (do r;Monad + [size (|> r;nat (:: @ map (|>. (n.% struct-limit) (n.max +2)))) + idx (|> r;nat (:: @ map (n.% size))) + [subS subP] gen-case + #let [caseS (#ls;Variant idx (tail? idx idx) subS) + caseP (#ls;VariantP (if (tail? idx idx) + (#;Right idx) + (#;Left idx)) + subP)]] + (wrap [caseS caseP])) + )))) + +(context: "Pattern-matching." + [[valueS path] gen-case + to-bind r;nat] + ($_ seq + (test "Can generate pattern-matching." + (|> (do Monad + [runtime-bytecode @runtime;generate] + (@eval;eval (@;generate valueS + (#ls;AltP (#ls;SeqP path (#ls;ExecP (#ls;Bool true))) + (#ls;SeqP (#ls;BindP +0) (#ls;ExecP (#ls;Bool false))))))) + (macro;run (init-compiler [])) + (case> (#R;Success valueG) + (:! Bool valueG) + + _ + false))) + (test "Can bind values." + (|> (do Monad + [runtime-bytecode @runtime;generate] + (@eval;eval (@;generate (#ls;Nat to-bind) + (#ls;SeqP (#ls;BindP +1) (#ls;ExecP (#ls;Variable 1)))))) + (macro;run (init-compiler [])) + (case> (#R;Success valueG) + (n.= to-bind (:! Nat valueG)) + + _ + false))))) diff --git a/new-luxc/test/tests.lux b/new-luxc/test/tests.lux index 06f3e940e..d07822069 100644 --- a/new-luxc/test/tests.lux +++ b/new-luxc/test/tests.lux @@ -20,6 +20,7 @@ ["_;S" loop]) (generator ["_;G" primitive] ["_;G" structure] + ["_;G" case] (procedure ["_;G" common])) )) ## (luxc (generator ["_;G" function])) -- cgit v1.2.3