From c0acd75d41ed0e927ec318d4b12c0ec4f5f2e1d3 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 2 Jul 2017 15:52:36 -0400 Subject: - Adjusted compiler to the new lack of Char type. - WIP: PM/case synthesis. --- new-luxc/test/test/luxc/analyser/case.lux | 1 - new-luxc/test/test/luxc/analyser/common.lux | 1 - new-luxc/test/test/luxc/analyser/primitive.lux | 3 - new-luxc/test/test/luxc/generator/primitive.lux | 3 - new-luxc/test/test/luxc/generator/structure.lux | 5 +- new-luxc/test/test/luxc/parser.lux | 44 ++--- new-luxc/test/test/luxc/synthesizer/case.lux | 213 +++++++++++++++++++++ .../test/test/luxc/synthesizer/case/special.lux | 66 +++++++ new-luxc/test/test/luxc/synthesizer/common.lux | 5 +- new-luxc/test/test/luxc/synthesizer/primitive.lux | 2 - 10 files changed, 301 insertions(+), 42 deletions(-) create mode 100644 new-luxc/test/test/luxc/synthesizer/case.lux create mode 100644 new-luxc/test/test/luxc/synthesizer/case/special.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 037f99feb..280c52245 100644 --- a/new-luxc/test/test/luxc/analyser/case.lux +++ b/new-luxc/test/test/luxc/analyser/case.lux @@ -62,7 +62,6 @@ [#;Int r;int code;int] [#;Deg r;deg code;deg] [#;Real r;real code;real] - [#;Char r;char code;char] [#;Text (r;text +5) code;text]) (^ [_ (#;Tuple (list))]) diff --git a/new-luxc/test/test/luxc/analyser/common.lux b/new-luxc/test/test/luxc/analyser/common.lux index 9a17fbb45..683ede10f 100644 --- a/new-luxc/test/test/luxc/analyser/common.lux +++ b/new-luxc/test/test/luxc/analyser/common.lux @@ -25,7 +25,6 @@ [Int code;int r;int] [Deg code;deg r;deg] [Real code;real r;real] - [Char code;char r;char] [Text code;text (r;text +5)] )] ($_ r;either diff --git a/new-luxc/test/test/luxc/analyser/primitive.lux b/new-luxc/test/test/luxc/analyser/primitive.lux index 545b4e0fd..f291e2c7f 100644 --- a/new-luxc/test/test/luxc/analyser/primitive.lux +++ b/new-luxc/test/test/luxc/analyser/primitive.lux @@ -4,7 +4,6 @@ (control monad pipe) (data [bool "B/" Eq] - [char "C/" Eq] [text "T/" Eq] (text format ["l" lexer]) @@ -33,7 +32,6 @@ %int% r;int %deg% r;deg %real% r;real - %char% r;char %text% (r;text +5)] (with-expansions [ (do-template [ ] @@ -55,7 +53,6 @@ ["int" Int #~;Int %int% @;analyse-int] ["deg" Deg #~;Deg %deg% @;analyse-deg] ["real" Real #~;Real %real% @;analyse-real] - ["char" Char #~;Char %char% @;analyse-char] ["text" Text #~;Text %text% @;analyse-text] )] ($_ seq diff --git a/new-luxc/test/test/luxc/generator/primitive.lux b/new-luxc/test/test/luxc/generator/primitive.lux index b1ea17f95..134ff312d 100644 --- a/new-luxc/test/test/luxc/generator/primitive.lux +++ b/new-luxc/test/test/luxc/generator/primitive.lux @@ -6,7 +6,6 @@ (data text/format ["R" result] [bool "B/" Eq] - [char "C/" Eq] [text "T/" Eq]) ["r" math/random "R/" Monad] [macro] @@ -26,7 +25,6 @@ %int% r;int %deg% r;deg %real% r;real - %char% r;char %text% (r;text +5)] (with-expansions [ (do-template [ ] @@ -44,7 +42,6 @@ ["int" Int #ls;Int %int% i.=] ["deg" Deg #ls;Deg %deg% d.=] ["real" Real #ls;Real %real% r.=] - ["char" Char #ls;Char %char% C/=] ["text" Text #ls;Text %text% T/=])] ($_ seq (test "Can generate unit." diff --git a/new-luxc/test/test/luxc/generator/structure.lux b/new-luxc/test/test/luxc/generator/structure.lux index 1fcba59d4..51c6c80c7 100644 --- a/new-luxc/test/test/luxc/generator/structure.lux +++ b/new-luxc/test/test/luxc/generator/structure.lux @@ -6,7 +6,6 @@ (data text/format ["R" result] [bool "B/" Eq] - [char "C/" Eq] [text "T/" Eq] (coll ["a" array] [list])) @@ -33,8 +32,7 @@ (r/map (|>. #ls;Int) r;int))) (r;either (r;either (r/map (|>. #ls;Deg) r;deg) (r/map (|>. #ls;Real) r;real)) - (r;either (r/map (|>. #ls;Char) r;char) - (r/map (|>. #ls;Text) (r;text +5)))))) + (r/map (|>. #ls;Text) (r;text +5))))) (def: (corresponds? [prediction sample]) (-> [ls;Synthesis Top] Bool) @@ -55,7 +53,6 @@ [#ls;Int Int i.=] [#ls;Deg Deg d.=] [#ls;Real Real r.=] - [#ls;Char Char C/=] [#ls;Text Text T/=]) _ diff --git a/new-luxc/test/test/luxc/parser.lux b/new-luxc/test/test/luxc/parser.lux index 21d34f7c0..b7eaa0ea5 100644 --- a/new-luxc/test/test/luxc/parser.lux +++ b/new-luxc/test/test/luxc/parser.lux @@ -2,8 +2,7 @@ lux (lux [io] (control monad) - (data [char "C/" Eq] - [text "T/" Eq] + (data [text "T/" Eq] (text format ["l" lexer]) [number] @@ -27,9 +26,9 @@ delimiters "()[]{}#;" space "\t\v \n\r\f" invalid-range (format digits delimiters space) - char-gen (|> r;char + char-gen (|> r;nat (r;filter (function [sample] - (not (text;contains? (char;as-text sample) + (not (text;contains? (text;from-code sample) invalid-range)))))] size (|> r;nat (:: @ map (|>. (n.% +20) (n.max +1))))] (r;text' char-gen size))) @@ -49,7 +48,6 @@ (|> r;real (r/map (|>. #;Real [default-cursor]))))) textual^ (: (r;Random Code) ($_ r;either - (|> r;char (r/map (|>. #;Char [default-cursor]))) (do r;Monad [size (|> r;nat (r/map (n.% +20)))] (|> (r;text size) (r/map (|>. #;Text [default-cursor])))) @@ -89,12 +87,11 @@ (def: comment-text^ (r;Random Text) - (let [char-gen (|> r;char (r;filter (function [value] - (not (or (char;space? value) - (C/= #"\n" value) - (C/= #"#" value) - (C/= #"(" value) - (C/= #")" value))))))] + (let [char-gen (|> r;nat (r;filter (function [value] + (not (or (text;space? value) + (n.= (char "#") value) + (n.= (char "(") value) + (n.= (char ")") value))))))] (do r;Monad [size (|> r;nat (r/map (n.% +20)))] (r;text' char-gen size)))) @@ -112,10 +109,9 @@ (context: "Multi-line text & comments." #seed +13835085537605735783 - [#let [char-gen (|> r;char (r;filter (function [value] - (not (or (char;space? value) - (C/= #"\"" value) - (C/= #"\n" value))))))] + [#let [char-gen (|> r;nat (r;filter (function [value] + (not (or (text;space? value) + (n.= (char "\"") value))))))] x char-gen y char-gen z char-gen @@ -126,9 +122,9 @@ unbalanced-comment comment-text^] ($_ seq (test "Will reject invalid multi-line text." - (let [bad-match (format (char;as-text x) "\n" - (char;as-text y) "\n" - (char;as-text z))] + (let [bad-match (format (text;from-code x) "\n" + (text;from-code y) "\n" + (text;from-code z))] (case (&;parse [default-cursor (format "\"" bad-match "\"")]) (#R;Error error) @@ -137,12 +133,12 @@ (#R;Success [_ parsed]) false))) (test "Will accept valid multi-line text" - (let [good-input (format (char;as-text x) "\n" - offset (char;as-text y) "\n" - offset (char;as-text z)) - good-output (format (char;as-text x) "\n" - (char;as-text y) "\n" - (char;as-text z))] + (let [good-input (format (text;from-code x) "\n" + offset (text;from-code y) "\n" + offset (text;from-code z)) + good-output (format (text;from-code x) "\n" + (text;from-code y) "\n" + (text;from-code z))] (case (&;parse [(|> default-cursor (update@ #;column (n.+ (n.dec offset-size)))) (format "\"" good-input "\"")]) diff --git a/new-luxc/test/test/luxc/synthesizer/case.lux b/new-luxc/test/test/luxc/synthesizer/case.lux new file mode 100644 index 000000000..5e1cf2a32 --- /dev/null +++ b/new-luxc/test/test/luxc/synthesizer/case.lux @@ -0,0 +1,213 @@ +(;module: + lux + (lux [io] + (control monad + pipe + eq) + (data [bool "B/" Eq] + [text "T/" Eq] + [product] + [number] + text/format + (coll [list "L/" Functor Fold Monoid] + ["s" set])) + ["r" math/random "r/" Monad] + test) + (luxc (lang ["la" analysis] + ["ls" synthesis]) + [synthesizer] + (synthesizer ["@" case])) + (.. common)) + +(struct: _ (Eq ls;Synthesis) + (def: (= reference sample) + (case [reference sample] + (^template [ ] + [( reference') ( sample')] + ( reference' sample')) + ([#ls;Unit is] + [#ls;Bool B/=] + [#ls;Nat n.=] + [#ls;Int i.=] + [#ls;Deg d.=] + [#ls;Real r.=] + [#ls;Text T/=]) + + _ + false))) + +(struct: _ (Eq ls;Path) + (def: (= reference sample) + (case [reference sample] + (^or [#ls;UnitP #ls;UnitP] + [(#ls;ExecP _) (#ls;ExecP _)]) + true + + (^template [ ] + [( reference') ( sample')] + ( reference' sample')) + ([#ls;BindP n.=] + [#ls;BoolP B/=] + [#ls;NatP n.=] + [#ls;IntP i.=] + [#ls;DegP d.=] + [#ls;RealP r.=] + [#ls;TextP T/=]) + + (^template [ ] + [( ( reference') reference-then) + ( ( sample') sample-then)] + (and (n.= reference' sample') + (= reference-then sample-then))) + ([#ls;VariantP #;Left] + [#ls;VariantP #;Right] + [#ls;TupleP #;Left] + [#ls;TupleP #;Right]) + + (^template [] + [( referenceL referenceR) ( sampleL sampleR)] + (and (= referenceL sampleL) + (= referenceR sampleR))) + ([#ls;AltP] + [#ls;SeqP]) + + _ + false))) + +(do-template [ ] + [(def: + (r;Random ls;Path) + (do r;Monad + [num-alts (|> r;nat (:: @ map (|>. (n.% ) (n.max +1)))) + samples (|> (r;set num-alts ) + (:: @ map s;to-list))] + (case (|> samples + (L/map (|>. )) + list;reverse) + (#;Cons last prevs) + (wrap (L/fold (function [left right] + (#ls;AltP left right)) + last + prevs)) + + #;Nil + (undefined))))] + + [gen-bool #ls;BoolP r;bool bool;Hash +2] + [gen-nat #ls;NatP r;nat number;Hash +5] + [gen-int #ls;IntP r;int number;Hash +5] + [gen-deg #ls;DegP r;deg number;Hash +5] + [gen-real #ls;RealP r;real number;Hash +5] + [gen-text #ls;TextP (r;text +5) text;Hash +5] + ) + +(def: gen-primitive-path + (r;Random ls;Path) + (r;either (r;either (r;either (r/wrap #ls;UnitP) + gen-bool) + (r;either gen-nat + gen-int)) + (r;either (r;either gen-deg + gen-real) + gen-text))) + +(do-template [ ] + [(def: ( gen-path) + (-> (-> (Maybe ls;Synthesis) (r;Random ls;Path)) + (r;Random ls;Path)) + (do r;Monad + [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) + members (r;list size (gen-path #;None))] + (case (list;reverse (list;enumerate members)) + (#;Cons [last-idx last-path] prevs) + (wrap (L/fold (function [[left-idx left-path] right-path] + ( ( (#;Right left-idx) left-path) + right-path)) + ( (#;Right last-idx) last-path) + prevs)) + + #;Nil + (undefined))))] + + [gen-tuple-path #ls;TupleP #ls;SeqP] + [gen-variant-path #ls;VariantP #ls;AltP] + ) + +(def: (gen-path ?body) + (-> (Maybe ls;Synthesis) (r;Random ls;Path)) + (do r;Monad + [pattern (r;either (r;either (r/wrap (#ls;BindP +0)) + gen-primitive-path) + (r;either (gen-tuple-path gen-path) + (gen-variant-path gen-path)))] + (case ?body + #;None + (wrap pattern) + + (#;Some body) + (wrap (#ls;SeqP pattern (#ls;ExecP body)))))) + +(def: (to-branches path) + (-> ls;Path (List la;Pattern)) + (case path + (^template [ ] + ( value) + (list ( value))) + ([#ls;UnitP #la;UnitP] + [#ls;BoolP #la;BoolP] + [#ls;NatP #la;NatP] + [#ls;IntP #la;IntP] + [#ls;DegP #la;DegP] + [#ls;RealP #la;RealP] + [#ls;TextP #la;TextP] + [#ls;BindP #la;BindP]) + + (#ls;AltP left right) + (L/append (to-branches left) + (to-branches right)) + + (#ls;SeqP (#ls;TupleP (#;Left +0) head) + tail) + (loop [head head + tail tail] + (case [(path-to-pattern head) tail] + [(#;Some =head) (#ls;SeqP (#ls;TupleP (#;Left idx) head') + tail')] + (list& =head (recur head' tail')) + + [(#;Some =head) (#ls;SeqP (#ls;TupleP (#;Left idx) head') + tail')] + (list& =head (recur head' tail')) + + [(#;Some =head) (#ls;SeqP (#ls;TupleP (#;Right last-idx)) + tail')] + (do list;Monad + [=tail' (to-branches tail') + =right (to-branches right)] + ))) + + (#ls;SeqP left right) + (do list;Monad + [=left (to-branches left) + =right (to-branches right)] + ) + + #PopP + (#VariantP (Either Nat Nat)) + (#TupleP (Either Nat Nat)) + + + (#ExecP s) + )) + +(context: "Pattern-matching." + [outputA gen-primitive + prediction (gen-path (#;Some (synthesizer;synthesize outputA))) + #let [branches (to-branches outputA prediction)]] + (test "Can efficiently synthesize pattern-matching trees." + (|> (synthesizer;synthesize (#la;Case #la;Unit branches)) + (case> (#la;Case #ls;Unit pathS) + (:: Eq prediction pathS) + + _ + false)))) diff --git a/new-luxc/test/test/luxc/synthesizer/case/special.lux b/new-luxc/test/test/luxc/synthesizer/case/special.lux new file mode 100644 index 000000000..fe5ad20ac --- /dev/null +++ b/new-luxc/test/test/luxc/synthesizer/case/special.lux @@ -0,0 +1,66 @@ +(;module: + lux + (lux [io] + (control monad + pipe) + (data [product] + [number] + text/format + (coll [list "L/" Functor Fold] + ["D" dict] + ["s" set])) + ["r" math/random "r/" Monad] + test) + (luxc (lang ["la" analysis] + ["ls" synthesis]) + [synthesizer]) + (../.. common)) + +(context: "Dummy variables." + [maskedA gen-primitive + temp r;nat + #let [maskA (#la;Case maskedA + (list [(#la;BindP temp) + (#la;Relative (#;Local temp))]))]] + (test "Dummy variables created to mask expressions get eliminated during synthesis." + (|> (synthesizer;synthesize maskA) + (corresponds? maskedA)))) + +(context: "Let expressions." + [registerA r;nat + inputA gen-primitive + outputA gen-primitive + #let [letA (#la;Case inputA + (list [(#la;BindP registerA) + outputA]))]] + (test "Can detect and reify simple 'let' expressions." + (|> (synthesizer;synthesize letA) + (case> (#ls;Let registerS inputS outputS) + (and (n.= registerA registerS) + (corresponds? inputA inputS) + (corresponds? outputA outputS)) + + _ + false)))) + +(context: "If expressions." + [then|else r;bool + inputA gen-primitive + thenA gen-primitive + elseA gen-primitive + #let [ifA (if then|else + (#la;Case inputA + (list [(#la;BoolP true) thenA] + [(#la;BoolP false) elseA])) + (#la;Case inputA + (list [(#la;BoolP false) elseA] + [(#la;BoolP true) thenA])))]] + (test "Can detect and reify simple 'if' expressions." + (|> (synthesizer;synthesize ifA) + (case> (#ls;If inputS thenS elseS) + (and (corresponds? inputA inputS) + (corresponds? thenA thenS) + (corresponds? elseA elseS)) + + _ + false)))) diff --git a/new-luxc/test/test/luxc/synthesizer/common.lux b/new-luxc/test/test/luxc/synthesizer/common.lux index c02e23c7c..88eeaea7c 100644 --- a/new-luxc/test/test/luxc/synthesizer/common.lux +++ b/new-luxc/test/test/luxc/synthesizer/common.lux @@ -1,7 +1,6 @@ (;module: lux (lux (data [bool "B/" Eq] - [char "C/" Eq] [text "T/" Eq]) ["r" math/random "r/" Monad]) (luxc (lang ["la" analysis] @@ -15,8 +14,7 @@ (r/map (|>. #la;Int) r;int))) (r;either (r;either (r/map (|>. #la;Deg) r;deg) (r/map (|>. #la;Real) r;real)) - (r;either (r/map (|>. #la;Char) r;char) - (r/map (|>. #la;Text) (r;text +5)))))) + (r/map (|>. #la;Text) (r;text +5))))) (def: #export (corresponds? analysis synthesis) (-> la;Analysis ls;Synthesis Bool) @@ -30,7 +28,6 @@ [#la;Int #ls;Int i.=] [#la;Deg #ls;Deg d.=] [#la;Real #ls;Real r.=] - [#la;Char #ls;Char C/=] [#la;Text #ls;Text T/=]) _ diff --git a/new-luxc/test/test/luxc/synthesizer/primitive.lux b/new-luxc/test/test/luxc/synthesizer/primitive.lux index c17d41a78..e1e37e469 100644 --- a/new-luxc/test/test/luxc/synthesizer/primitive.lux +++ b/new-luxc/test/test/luxc/synthesizer/primitive.lux @@ -17,7 +17,6 @@ %int% r;int %deg% r;deg %real% r;real - %char% r;char %text% (r;text +5)] (with-expansions [ (do-template [ ] @@ -35,7 +34,6 @@ ["int" #la;Int #ls;Int %int%] ["deg" #la;Deg #ls;Deg %deg%] ["real" #la;Real #ls;Real %real%] - ["char" #la;Char #ls;Char %char%] ["text" #la;Text #ls;Text %text%])] ($_ seq ))) -- cgit v1.2.3