diff options
Diffstat (limited to 'new-luxc')
20 files changed, 1642 insertions, 467 deletions
diff --git a/new-luxc/source/luxc/analyser.lux b/new-luxc/source/luxc/analyser.lux index 2be2b6da6..44fa96081 100644 --- a/new-luxc/source/luxc/analyser.lux +++ b/new-luxc/source/luxc/analyser.lux @@ -18,9 +18,9 @@ ["&&;" primitive] ["&&;" reference] ["&&;" type] - ["&&;" struct] + ["&&;" structure] ["&&;" case] - ["&&;" proc])) + ["&&;" procedure])) (def: (to-branches raw) (-> (List Code) (Lux (List [Code Code]))) @@ -61,14 +61,20 @@ (analyse singleton) (^ (#;Tuple elems)) - (&&struct;analyse-product analyse elems) + (&&structure;analyse-product analyse elems) (^ (#;Record pairs)) - (&&struct;analyse-record analyse pairs) + (&&structure;analyse-record analyse pairs) (#;Symbol reference) (&&reference;analyse-reference reference) + (^ (#;Form (list [_ (#;Symbol ["" "_lux_function"])] + [_ (#;Symbol ["" func-name])] + [_ (#;Symbol ["" arg-name])] + body))) + (&&function;analyse-function analyse func-name arg-name body) + (^ (#;Form (list [_ (#;Symbol ["" "_lux_check"])] type value))) @@ -79,10 +85,8 @@ value))) (&&type;analyse-coerce analyse eval type value) - (^ (#;Form (list [_ (#;Symbol ["" "_lux_proc"])] - [_ (#;Symbol proc)] - [_ (#;Tuple args)]))) - (&&proc;analyse-proc analyse proc args) + (^ (#;Form (list& [_ (#;Text proc-name)] proc-args))) + (&&procedure;analyse-procedure analyse proc-name proc-args) (^ (#;Form (list& [_ (#;Symbol ["" "_lux_case"])] input @@ -93,11 +97,11 @@ (^ (#;Form (list [_ (#;Nat tag)] value))) - (&&struct;analyse-sum analyse tag value) + (&&structure;analyse-sum analyse tag value) (^ (#;Form (list [_ (#;Tag tag)] value))) - (&&struct;analyse-tagged-sum analyse tag value) + (&&structure;analyse-tagged-sum analyse tag value) (^ (#;Form (list& func args))) (do Monad<Lux> diff --git a/new-luxc/source/luxc/analyser/case.lux b/new-luxc/source/luxc/analyser/case.lux index 239d846d1..d5c84b7bf 100644 --- a/new-luxc/source/luxc/analyser/case.lux +++ b/new-luxc/source/luxc/analyser/case.lux @@ -20,7 +20,7 @@ ["lp" pattern #+ Pattern]) ["&;" env] (analyser ["&;" common] - ["&;" struct]))) + ["&;" structure]))) (type: #rec Coverage #PartialC @@ -146,8 +146,8 @@ [cursor (#;Record pairs)] (do Monad<Lux> - [pairs (&struct;normalize-record pairs) - [members recordT] (&struct;order-record pairs) + [pairs (&structure;normalize-record pairs) + [members recordT] (&structure;order-record pairs) _ (&;within-type-env (TC;check inputT recordT))] (analyse-pattern (#;Some (list;size members)) inputT [cursor (#;Tuple members)] next)) @@ -173,12 +173,12 @@ (do Monad<Lux> [[testP nextA] (analyse-pattern #;None (type;variant (list;drop (n.dec num-cases) flat-sum)) - (' [(~@ values)]) + (` [(~@ values)]) next)] (wrap [(#lp;Variant idx num-cases testP) nextA])) (do Monad<Lux> - [[testP nextA] (analyse-pattern #;None case-type (' [(~@ values)]) next)] + [[testP nextA] (analyse-pattern #;None case-type (` [(~@ values)]) next)] (wrap [(#lp;Variant idx num-cases testP) nextA]))) @@ -195,7 +195,7 @@ [idx group variantT] (macro;resolve-tag tag) _ (&;within-type-env (TC;check inputT variantT))] - (analyse-pattern (#;Some (list;size group)) inputT (' ((~ (code;nat idx)) (~@ values))) next))) + (analyse-pattern (#;Some (list;size group)) inputT (` ((~ (code;nat idx)) (~@ values))) next))) _ (&;fail (format "Unrecognized pattern syntax: " (%code pattern))) @@ -274,7 +274,7 @@ (struct: _ (Eq Coverage) (def: (= reference sample) (case [reference sample] - (^or [#TotalC #TotalC] [#PartialC #PartialC]) + [#TotalC #TotalC] true [(#BoolC sideR) (#BoolC sideS)] @@ -339,7 +339,9 @@ #;None (wrap (D;put tagA coverageA casesSF')))) casesSF (D;entries casesA))] - (wrap (if (list;every? total? (D;values casesM)) + (wrap (if (let [case-coverages (D;values casesM)] + (and (n.= allSF (list;size case-coverages)) + (list;every? total? case-coverages))) #TotalC (#VariantC allSF casesM))))) diff --git a/new-luxc/source/luxc/analyser/function.lux b/new-luxc/source/luxc/analyser/function.lux index 838de4181..394e65c4d 100644 --- a/new-luxc/source/luxc/analyser/function.lux +++ b/new-luxc/source/luxc/analyser/function.lux @@ -17,8 +17,8 @@ (def: #export (analyse-function analyse func-name arg-name body) (-> &;Analyser Text Text Code (Lux Analysis)) (do Monad<Lux> - [original macro;expected-type] - (loop [expected original] + [functionT macro;expected-type] + (loop [expected functionT] (&;with-stacked-errors (function [_] (format "Functions require function types: " (type;to-text expected))) (case expected @@ -79,7 +79,7 @@ (#;Function inputT outputT) (<| (:: @ map (|>. #la;Function)) &;with-scope - (&env;with-local [func-name original]) + (&env;with-local [func-name functionT]) (&env;with-local [arg-name inputT]) (&;with-expected-type outputT) (analyse body)) diff --git a/new-luxc/source/luxc/analyser/proc.lux b/new-luxc/source/luxc/analyser/proc.lux deleted file mode 100644 index 56b4ba3b3..000000000 --- a/new-luxc/source/luxc/analyser/proc.lux +++ /dev/null @@ -1,19 +0,0 @@ -(;module: - lux - (lux (control monad) - (data [text] - text/format - (coll ["D" dict]) - maybe)) - (luxc ["&" base] - (lang ["la" analysis #+ Analysis])) - (. ["&&;" lux])) - -(def: #export (analyse-proc analyse [proc-category proc-name] proc-args) - (-> &;Analyser Ident (List Code) (Lux Analysis)) - (default (let [proc-description (format "[" (%t proc-category) " " (%t proc-name) "]")] - (&;fail (format "Unknown procedure: " proc-description))) - (do Monad<Maybe> - [procs (D;get proc-category &&lux;procs) - proc (D;get proc-name procs)] - (wrap (proc analyse proc-args))))) diff --git a/new-luxc/source/luxc/analyser/proc/lux.lux b/new-luxc/source/luxc/analyser/proc/lux.lux deleted file mode 100644 index 8ad88baed..000000000 --- a/new-luxc/source/luxc/analyser/proc/lux.lux +++ /dev/null @@ -1,321 +0,0 @@ -(;module: - lux - (lux (control monad) - (concurrency ["A" atom]) - (data [text] - text/format - (coll [list] - [array #+ Array] - ["D" dict])) - [macro #+ Monad<Lux>] - (type ["TC" check]) - [io]) - (luxc ["&" base] - (lang ["la" analysis #+ Analysis]) - (analyser ["&;" common]))) - -## [Utils] -(type: Proc-Analyser - (-> &;Analyser (List Code) (Lux Analysis))) - -(type: Proc-Set - (D;Dict Text Proc-Analyser)) - -(def: (wrong-amount-error proc expected actual) - (-> Ident Nat Nat Text) - (let [[proc-category proc-name] proc - proc-description (format "[" (%t proc-category) " " (%t proc-name) "]")] - (format "Wrong number of arguments for " proc-description "\n" - "Expected: " (|> expected nat-to-int %i) "\n" - " Actual: " (|> actual nat-to-int %i)))) - -(def: (simple-proc proc input-types output-type) - (-> Ident (List Type) Type Proc-Analyser) - (let [num-expected (list;size input-types)] - (function [analyse args] - (let [num-actual (list;size args)] - (if (n.= num-expected num-actual) - (do Monad<Lux> - [argsA (mapM @ - (function [[argT argC]] - (&;with-expected-type argT - (analyse argC))) - (list;zip2 input-types args)) - expected macro;expected-type - _ (&;within-type-env - (TC;check expected output-type))] - (wrap (#la;Procedure proc argsA))) - (&;fail (wrong-amount-error proc num-expected num-actual))))))) - -(def: (binary-operation proc subjectT paramT outputT) - (-> Ident Type Type Type Proc-Analyser) - (simple-proc proc (list subjectT paramT) outputT)) - -(def: (trinary-operation proc subjectT param0T param1T outputT) - (-> Ident Type Type Type Type Proc-Analyser) - (simple-proc proc (list subjectT param0T param1T) outputT)) - -(def: (unary-operation proc inputT outputT) - (-> Ident Type Type Proc-Analyser) - (simple-proc proc (list inputT) outputT)) - -(def: (special-value proc valueT) - (-> Ident Type Proc-Analyser) - (simple-proc proc (list) valueT)) - -(def: (converter proc fromT toT) - (-> Ident Type Type Proc-Analyser) - (simple-proc proc (list fromT) toT)) - -## [Analysers] -(def: (analyse-lux-is analyse args) - Proc-Analyser - (&common;with-var - (function [[var-id varT]] - ((binary-operation ["lux" "is"] varT varT Bool) - analyse args)))) - -(def: (analyse-lux-try analyse args) - Proc-Analyser - (&common;with-var - (function [[var-id varT]] - (case args - (^ (list opC)) - (do Monad<Lux> - [opA (&;with-expected-type (type (io;IO varT)) - (analyse opC)) - outputT (&;within-type-env - (TC;clean var-id (type (Either Text varT)))) - expected macro;expected-type - _ (&;within-type-env - (TC;check expected outputT))] - (wrap (#la;Procedure ["lux" "try"] (list opA)))) - - _ - (&;fail (wrong-amount-error ["lux" "try"] +1 (list;size args))))))) - -(def: lux-procs - Proc-Set - (|> (D;new text;Hash<Text>) - (D;put "is" analyse-lux-is) - (D;put "try" analyse-lux-try))) - -(def: io-procs - Proc-Set - (|> (D;new text;Hash<Text>) - (D;put "log" (converter ["io" "log"] Text Unit)) - (D;put "error" (converter ["io" "error"] Text Bottom)) - (D;put "exit" (converter ["io" "exit"] Nat Bottom)) - (D;put "current-time" (special-value ["io" "current-time"] Int)))) - -(def: bit-procs - Proc-Set - (|> (D;new text;Hash<Text>) - (D;put "count" (unary-operation ["bit" "count"] Nat Nat)) - (D;put "and" (binary-operation ["bit" "and"] Nat Nat Nat)) - (D;put "or" (binary-operation ["bit" "or"] Nat Nat Nat)) - (D;put "xor" (binary-operation ["bit" "xor"] Nat Nat Nat)) - (D;put "shift-left" (binary-operation ["bit" "shift-left"] Nat Nat Nat)) - (D;put "unsigned-shift-right" (binary-operation ["bit" "unsigned-shift-right"] Nat Nat Nat)) - (D;put "shift-right" (binary-operation ["bit" "shift-right"] Int Nat Int)) - )) - -(def: nat-procs - Proc-Set - (|> (D;new text;Hash<Text>) - (D;put "+" (binary-operation ["nat" "+"] Nat Nat Nat)) - (D;put "-" (binary-operation ["nat" "-"] Nat Nat Nat)) - (D;put "*" (binary-operation ["nat" "*"] Nat Nat Nat)) - (D;put "/" (binary-operation ["nat" "/"] Nat Nat Nat)) - (D;put "%" (binary-operation ["nat" "%"] Nat Nat Nat)) - (D;put "=" (binary-operation ["nat" "="] Nat Nat Bool)) - (D;put "<" (binary-operation ["nat" "<"] Nat Nat Bool)) - (D;put "min-value" (special-value ["nat" "min-value"] Nat)) - (D;put "max-value" (special-value ["nat" "max-value"] Nat)) - (D;put "to-int" (converter ["nat" "to-int"] Nat Int)) - (D;put "to-text" (converter ["nat" "to-text"] Nat Text)))) - -(def: int-procs - Proc-Set - (|> (D;new text;Hash<Text>) - (D;put "+" (binary-operation ["int" "+"] Int Int Int)) - (D;put "-" (binary-operation ["int" "-"] Int Int Int)) - (D;put "*" (binary-operation ["int" "*"] Int Int Int)) - (D;put "/" (binary-operation ["int" "/"] Int Int Int)) - (D;put "%" (binary-operation ["int" "%"] Int Int Int)) - (D;put "=" (binary-operation ["int" "="] Int Int Bool)) - (D;put "<" (binary-operation ["int" "<"] Int Int Bool)) - (D;put "min-value" (special-value ["int" "min-value"] Int)) - (D;put "max-value" (special-value ["int" "max-value"] Int)) - (D;put "to-nat" (converter ["int" "to-nat"] Int Nat)) - (D;put "to-real" (converter ["int" "to-real"] Int Real)))) - -(def: deg-procs - Proc-Set - (|> (D;new text;Hash<Text>) - (D;put "+" (binary-operation ["deg" "+"] Deg Deg Deg)) - (D;put "-" (binary-operation ["deg" "-"] Deg Deg Deg)) - (D;put "*" (binary-operation ["deg" "*"] Deg Deg Deg)) - (D;put "/" (binary-operation ["deg" "/"] Deg Deg Deg)) - (D;put "%" (binary-operation ["deg" "%"] Deg Deg Deg)) - (D;put "=" (binary-operation ["deg" "="] Deg Deg Bool)) - (D;put "<" (binary-operation ["deg" "<"] Deg Deg Bool)) - (D;put "scale" (binary-operation ["deg" "scale"] Deg Nat Deg)) - (D;put "reciprocal" (binary-operation ["deg" "scale"] Deg Nat Deg)) - (D;put "min-value" (special-value ["deg" "min-value"] Deg)) - (D;put "max-value" (special-value ["deg" "max-value"] Deg)) - (D;put "to-real" (converter ["deg" "to-real"] Deg Real)))) - -(def: real-procs - Proc-Set - (|> (D;new text;Hash<Text>) - (D;put "+" (binary-operation ["real" "+"] Real Real Real)) - (D;put "-" (binary-operation ["real" "-"] Real Real Real)) - (D;put "*" (binary-operation ["real" "*"] Real Real Real)) - (D;put "/" (binary-operation ["real" "/"] Real Real Real)) - (D;put "%" (binary-operation ["real" "%"] Real Real Real)) - (D;put "=" (binary-operation ["real" "="] Real Real Bool)) - (D;put "<" (binary-operation ["real" "<"] Real Real Bool)) - (D;put "smallest-value" (special-value ["real" "smallest-value"] Real)) - (D;put "min-value" (special-value ["real" "min-value"] Real)) - (D;put "max-value" (special-value ["real" "max-value"] Real)) - (D;put "not-a-number" (special-value ["real" "not-a-number"] Real)) - (D;put "positive-infinity" (special-value ["real" "positive-infinity"] Real)) - (D;put "negative-infinity" (special-value ["real" "negative-infinity"] Real)) - (D;put "to-deg" (converter ["real" "to-deg"] Real Deg)) - (D;put "to-int" (converter ["real" "to-int"] Real Int)) - (D;put "hash" (unary-operation ["real" "hash"] Real Nat)) - (D;put "encode" (converter ["real" "encode"] Real Text)) - (D;put "decode" (converter ["real" "decode"] Text (type (Maybe Real)))))) - -(def: text-procs - Proc-Set - (|> (D;new text;Hash<Text>) - (D;put "=" (binary-operation ["text" "="] Text Text Bool)) - (D;put "<" (binary-operation ["text" "<"] Text Text Bool)) - (D;put "prepend" (binary-operation ["text" "prepend"] Text Text Text)) - (D;put "index" (trinary-operation ["text" "index"] Text Text Nat (type (Maybe Nat)))) - (D;put "size" (unary-operation ["text" "size"] Text Nat)) - (D;put "hash" (unary-operation ["text" "hash"] Text Nat)) - (D;put "replace-once" (binary-operation ["text" "replace-once"] Text Text Text)) - (D;put "replace-all" (binary-operation ["text" "replace-all"] Text Text Text)) - (D;put "char" (binary-operation ["text" "char"] Text Nat Nat)) - (D;put "clip" (trinary-operation ["text" "clip"] Text Nat Nat Text)) - )) - -(def: (analyse-array-get analyse args) - Proc-Analyser - (&common;with-var - (function [[var-id varT]] - ((binary-operation ["lux" "get"] Nat (type (Array varT)) varT) - analyse args)))) - -(def: (analyse-array-put analyse args) - Proc-Analyser - (&common;with-var - (function [[var-id varT]] - ((trinary-operation ["lux" "put"] Nat varT (type (Array varT)) (type (Array varT))) - analyse args)))) - -(def: (analyse-array-remove analyse args) - Proc-Analyser - (&common;with-var - (function [[var-id varT]] - ((binary-operation ["lux" "remove"] Nat (type (Array varT)) (type (Array varT))) - analyse args)))) - -(def: array-procs - Proc-Set - (|> (D;new text;Hash<Text>) - (D;put "new" (unary-operation ["array" "hash"] Nat Array)) - (D;put "get" analyse-array-get) - (D;put "put" analyse-array-put) - (D;put "remove" analyse-array-remove) - (D;put "size" (unary-operation ["array" "size"] (type (Ex [a] (Array a))) Nat)) - )) - -(def: math-procs - Proc-Set - (|> (D;new text;Hash<Text>) - (D;put "cos" (unary-operation ["math" "cos"] Real Real)) - (D;put "sin" (unary-operation ["math" "sin"] Real Real)) - (D;put "tan" (unary-operation ["math" "tan"] Real Real)) - (D;put "acos" (unary-operation ["math" "acos"] Real Real)) - (D;put "asin" (unary-operation ["math" "asin"] Real Real)) - (D;put "atan" (unary-operation ["math" "atan"] Real Real)) - (D;put "cosh" (unary-operation ["math" "cosh"] Real Real)) - (D;put "sinh" (unary-operation ["math" "sinh"] Real Real)) - (D;put "tanh" (unary-operation ["math" "tanh"] Real Real)) - (D;put "exp" (unary-operation ["math" "exp"] Real Real)) - (D;put "log" (unary-operation ["math" "log"] Real Real)) - (D;put "root2" (unary-operation ["math" "root2"] Real Real)) - (D;put "root3" (unary-operation ["math" "root3"] Real Real)) - (D;put "ceil" (unary-operation ["math" "ceil"] Real Real)) - (D;put "floor" (unary-operation ["math" "floor"] Real Real)) - (D;put "round" (unary-operation ["math" "round"] Real Real)) - (D;put "atan2" (binary-operation ["math" "atan2"] Real Real Real)) - (D;put "pow" (binary-operation ["math" "pow"] Real Real Real)) - )) - -(def: (analyse-atom-new analyse args) - Proc-Analyser - (&common;with-var - (function [[var-id varT]] - (case args - (^ (list initC)) - (do Monad<Lux> - [initA (&;with-expected-type varT - (analyse initC)) - outputT (&;within-type-env - (TC;clean var-id (type (A;Atom varT)))) - expected macro;expected-type - _ (&;within-type-env - (TC;check expected outputT))] - (wrap (#la;Procedure ["atom" "new"] (list initA)))) - - _ - (&;fail (wrong-amount-error ["atom" "new"] +1 (list;size args))))))) - -(def: (analyse-atom-read analyse args) - (&common;with-var - (function [[var-id varT]] - ((unary-operation ["atom" "read"] (type (A;Atom varT)) varT) - analyse args)))) - -(def: (analyse-atom-compare-and-swap analyse args) - (&common;with-var - (function [[var-id varT]] - ((trinary-operation ["atom" "compare-and-swap"] varT varT (type (A;Atom varT)) Bool) - analyse args)))) - -(def: atom-procs - Proc-Set - (|> (D;new text;Hash<Text>) - (D;put "new" analyse-atom-new) - (D;put "read" analyse-atom-read) - (D;put "compare-and-swap" analyse-atom-compare-and-swap) - )) - -(def: process-procs - Proc-Set - (|> (D;new text;Hash<Text>) - (D;put "concurrency-level" (special-value ["process" "concurrency-level"] Nat)) - (D;put "future" (unary-operation ["process" "future"] (type (io;IO Top)) Unit)) - (D;put "schedule" (binary-operation ["process" "schedule"] Nat (type (io;IO Top)) Unit)) - )) - -(def: #export procs - (D;Dict Text Proc-Set) - (|> (D;new text;Hash<Text>) - (D;put "lux" lux-procs) - (D;put "bit" bit-procs) - (D;put "nat" nat-procs) - (D;put "int" int-procs) - (D;put "deg" deg-procs) - (D;put "real" real-procs) - (D;put "text" text-procs) - (D;put "array" array-procs) - (D;put "math" math-procs) - (D;put "atom" atom-procs) - (D;put "process" process-procs) - (D;put "io" io-procs))) diff --git a/new-luxc/source/luxc/analyser/procedure.lux b/new-luxc/source/luxc/analyser/procedure.lux new file mode 100644 index 000000000..d8778844f --- /dev/null +++ b/new-luxc/source/luxc/analyser/procedure.lux @@ -0,0 +1,17 @@ +(;module: + lux + (lux (control monad) + (data [text] + text/format + (coll ["D" dict]) + maybe)) + (luxc ["&" base] + (lang ["la" analysis #+ Analysis])) + (. ["&&;" common])) + +(def: #export (analyse-procedure analyse proc-name proc-args) + (-> &;Analyser Text (List Code) (Lux Analysis)) + (default (&;fail (format "Unknown procedure: " (%t proc-name))) + (do Monad<Maybe> + [proc (D;get proc-name &&common;procedures)] + (wrap (proc analyse proc-args))))) diff --git a/new-luxc/source/luxc/analyser/procedure/common.lux b/new-luxc/source/luxc/analyser/procedure/common.lux new file mode 100644 index 000000000..8a03f9cad --- /dev/null +++ b/new-luxc/source/luxc/analyser/procedure/common.lux @@ -0,0 +1,333 @@ +(;module: + lux + (lux (control monad) + (concurrency ["A" atom]) + (data [text] + text/format + (coll [list] + [array #+ Array] + ["D" dict])) + [macro #+ Monad<Lux>] + (type ["TC" check]) + [io]) + (luxc ["&" base] + (lang ["la" analysis #+ Analysis]) + (analyser ["&;" common]))) + +## [Utils] +(type: Proc-Analyser + (-> &;Analyser (List Code) (Lux Analysis))) + +(type: Proc-Set + (D;Dict Text Proc-Analyser)) + +(def: (install name unnamed) + (-> Text (-> Text Proc-Analyser) + (-> Proc-Set Proc-Set)) + (D;put name (unnamed name))) + +(def: (wrong-amount-error proc expected actual) + (-> Text Nat Nat Text) + (format "Wrong number of arguments for " (%t proc) "\n" + "Expected: " (|> expected nat-to-int %i) "\n" + " Actual: " (|> actual nat-to-int %i))) + +(def: (simple-proc proc input-types output-type) + (-> Text (List Type) Type Proc-Analyser) + (let [num-expected (list;size input-types)] + (function [analyse args] + (let [num-actual (list;size args)] + (if (n.= num-expected num-actual) + (do Monad<Lux> + [argsA (mapM @ + (function [[argT argC]] + (&;with-expected-type argT + (analyse argC))) + (list;zip2 input-types args)) + expected macro;expected-type + _ (&;within-type-env + (TC;check expected output-type))] + (wrap (#la;Procedure proc argsA))) + (&;fail (wrong-amount-error proc num-expected num-actual))))))) + +(def: (binary-operation subjectT paramT outputT proc) + (-> Type Type Type Text Proc-Analyser) + (simple-proc proc (list subjectT paramT) outputT)) + +(def: (trinary-operation subjectT param0T param1T outputT proc) + (-> Type Type Type Type Text Proc-Analyser) + (simple-proc proc (list subjectT param0T param1T) outputT)) + +(def: (unary-operation inputT outputT proc) + (-> Type Type Text Proc-Analyser) + (simple-proc proc (list inputT) outputT)) + +(def: (special-value valueT proc) + (-> Type Text Proc-Analyser) + (simple-proc proc (list) valueT)) + +(def: (converter fromT toT proc) + (-> Type Type Text Proc-Analyser) + (simple-proc proc (list fromT) toT)) + +## [Analysers] +(def: (analyse-lux-is proc) + (-> Text Proc-Analyser) + (function [analyse args] + (&common;with-var + (function [[var-id varT]] + ((binary-operation varT varT Bool proc) + analyse args))))) + +(def: (analyse-lux-try proc) + (-> Text Proc-Analyser) + (function [analyse args] + (&common;with-var + (function [[var-id varT]] + (case args + (^ (list opC)) + (do Monad<Lux> + [opA (&;with-expected-type (type (io;IO varT)) + (analyse opC)) + outputT (&;within-type-env + (TC;clean var-id (type (Either Text varT)))) + expected macro;expected-type + _ (&;within-type-env + (TC;check expected outputT))] + (wrap (#la;Procedure proc (list opA)))) + + _ + (&;fail (wrong-amount-error proc +1 (list;size args)))))))) + +(def: lux-procs + Proc-Set + (|> (D;new text;Hash<Text>) + (install "lux is" analyse-lux-is) + (install "lux try" analyse-lux-try))) + +(def: io-procs + Proc-Set + (|> (D;new text;Hash<Text>) + (install "io log" (converter Text Unit)) + (install "io error" (converter Text Bottom)) + (install "io exit" (converter Nat Bottom)) + (install "io current-time" (special-value Int)))) + +(def: bit-procs + Proc-Set + (|> (D;new text;Hash<Text>) + (install "bit count" (unary-operation Nat Nat)) + (install "bit and" (binary-operation Nat Nat Nat)) + (install "bit or" (binary-operation Nat Nat Nat)) + (install "bit xor" (binary-operation Nat Nat Nat)) + (install "bit shift-left" (binary-operation Nat Nat Nat)) + (install "bit unsigned-shift-right" (binary-operation Nat Nat Nat)) + (install "bit shift-right" (binary-operation Int Nat Int)) + )) + +(def: nat-procs + Proc-Set + (|> (D;new text;Hash<Text>) + (install "nat +" (binary-operation Nat Nat Nat)) + (install "nat -" (binary-operation Nat Nat Nat)) + (install "nat *" (binary-operation Nat Nat Nat)) + (install "nat /" (binary-operation Nat Nat Nat)) + (install "nat %" (binary-operation Nat Nat Nat)) + (install "nat =" (binary-operation Nat Nat Bool)) + (install "nat <" (binary-operation Nat Nat Bool)) + (install "nat min" (special-value Nat)) + (install "nat max" (special-value Nat)) + (install "nat to-int" (converter Nat Int)) + (install "nat to-text" (converter Nat Text)))) + +(def: int-procs + Proc-Set + (|> (D;new text;Hash<Text>) + (install "int +" (binary-operation Int Int Int)) + (install "int -" (binary-operation Int Int Int)) + (install "int *" (binary-operation Int Int Int)) + (install "int /" (binary-operation Int Int Int)) + (install "int %" (binary-operation Int Int Int)) + (install "int =" (binary-operation Int Int Bool)) + (install "int <" (binary-operation Int Int Bool)) + (install "int min" (special-value Int)) + (install "int max" (special-value Int)) + (install "int to-nat" (converter Int Nat)) + (install "int to-real" (converter Int Real)))) + +(def: deg-procs + Proc-Set + (|> (D;new text;Hash<Text>) + (install "deg +" (binary-operation Deg Deg Deg)) + (install "deg -" (binary-operation Deg Deg Deg)) + (install "deg *" (binary-operation Deg Deg Deg)) + (install "deg /" (binary-operation Deg Deg Deg)) + (install "deg %" (binary-operation Deg Deg Deg)) + (install "deg =" (binary-operation Deg Deg Bool)) + (install "deg <" (binary-operation Deg Deg Bool)) + (install "deg scale" (binary-operation Deg Nat Deg)) + (install "deg reciprocal" (unary-operation Nat Deg)) + (install "deg min" (special-value Deg)) + (install "deg max" (special-value Deg)) + (install "deg to-real" (converter Deg Real)))) + +(def: real-procs + Proc-Set + (|> (D;new text;Hash<Text>) + (install "real +" (binary-operation Real Real Real)) + (install "real -" (binary-operation Real Real Real)) + (install "real *" (binary-operation Real Real Real)) + (install "real /" (binary-operation Real Real Real)) + (install "real %" (binary-operation Real Real Real)) + (install "real =" (binary-operation Real Real Bool)) + (install "real <" (binary-operation Real Real Bool)) + (install "real smallest" (special-value Real)) + (install "real min" (special-value Real)) + (install "real max" (special-value Real)) + (install "real not-a-number" (special-value Real)) + (install "real positive-infinity" (special-value Real)) + (install "real negative-infinity" (special-value Real)) + (install "real to-deg" (converter Real Deg)) + (install "real to-int" (converter Real Int)) + (install "real to-text" (converter Real Text)) + (install "real from-text" (converter Text (type (Maybe Real)))))) + +(def: text-procs + Proc-Set + (|> (D;new text;Hash<Text>) + (install "text =" (binary-operation Text Text Bool)) + (install "text <" (binary-operation Text Text Bool)) + (install "text prepend" (binary-operation Text Text Text)) + (install "text index" (trinary-operation Text Text Nat (type (Maybe Nat)))) + (install "text size" (unary-operation Text Nat)) + (install "text hash" (unary-operation Text Nat)) + (install "text replace-once" (trinary-operation Text Text Text Text)) + (install "text replace-all" (trinary-operation Text Text Text Text)) + (install "text char" (binary-operation Text Nat Nat)) + (install "text clip" (trinary-operation Text Nat Nat Text)) + )) + +(def: (analyse-array-get proc) + (-> Text Proc-Analyser) + (function [analyse args] + (&common;with-var + (function [[var-id varT]] + ((binary-operation Nat (type (Array varT)) varT proc) + analyse args))))) + +(def: (analyse-array-put proc) + (-> Text Proc-Analyser) + (function [analyse args] + (&common;with-var + (function [[var-id varT]] + ((trinary-operation Nat varT (type (Array varT)) (type (Array varT)) proc) + analyse args))))) + +(def: (analyse-array-remove proc) + (-> Text Proc-Analyser) + (function [analyse args] + (&common;with-var + (function [[var-id varT]] + ((binary-operation Nat (type (Array varT)) (type (Array varT)) proc) + analyse args))))) + +(def: array-procs + Proc-Set + (|> (D;new text;Hash<Text>) + (install "array new" (unary-operation Nat Array)) + (install "array get" analyse-array-get) + (install "array put" analyse-array-put) + (install "array remove" analyse-array-remove) + (install "array size" (unary-operation (type (Ex [a] (Array a))) Nat)) + )) + +(def: math-procs + Proc-Set + (|> (D;new text;Hash<Text>) + (install "math cos" (unary-operation Real Real)) + (install "math sin" (unary-operation Real Real)) + (install "math tan" (unary-operation Real Real)) + (install "math acos" (unary-operation Real Real)) + (install "math asin" (unary-operation Real Real)) + (install "math atan" (unary-operation Real Real)) + (install "math cosh" (unary-operation Real Real)) + (install "math sinh" (unary-operation Real Real)) + (install "math tanh" (unary-operation Real Real)) + (install "math exp" (unary-operation Real Real)) + (install "math log" (unary-operation Real Real)) + (install "math root2" (unary-operation Real Real)) + (install "math root3" (unary-operation Real Real)) + (install "math ceil" (unary-operation Real Real)) + (install "math floor" (unary-operation Real Real)) + (install "math round" (unary-operation Real Real)) + (install "math atan2" (binary-operation Real Real Real)) + (install "math pow" (binary-operation Real Real Real)) + )) + +(def: (analyse-atom-new proc) + (-> Text Proc-Analyser) + (function [analyse args] + (&common;with-var + (function [[var-id varT]] + (case args + (^ (list initC)) + (do Monad<Lux> + [initA (&;with-expected-type varT + (analyse initC)) + outputT (&;within-type-env + (TC;clean var-id (type (A;Atom varT)))) + expected macro;expected-type + _ (&;within-type-env + (TC;check expected outputT))] + (wrap (#la;Procedure proc (list initA)))) + + _ + (&;fail (wrong-amount-error proc +1 (list;size args)))))))) + +(def: (analyse-atom-read proc) + (-> Text Proc-Analyser) + (function [analyse args] + (&common;with-var + (function [[var-id varT]] + ((unary-operation (type (A;Atom varT)) varT proc) + analyse args))))) + +(def: (analyse-atom-compare-and-swap proc) + (-> Text Proc-Analyser) + (function [analyse args] + (&common;with-var + (function [[var-id varT]] + ((trinary-operation varT varT (type (A;Atom varT)) Bool proc) + analyse args))))) + +(def: atom-procs + Proc-Set + (|> (D;new text;Hash<Text>) + (install "atom new" analyse-atom-new) + (install "atom read" analyse-atom-read) + (install "atom compare-and-swap" analyse-atom-compare-and-swap) + )) + +(def: process-procs + Proc-Set + (|> (D;new text;Hash<Text>) + (install "process concurrency-level" (special-value Nat)) + (install "process future" (unary-operation (type (io;IO Top)) Unit)) + (install "process schedule" (binary-operation Nat (type (io;IO Top)) Unit)) + )) + +(def: #export procedures + Proc-Set + (|> (D;new text;Hash<Text>) + (D;merge lux-procs) + (D;merge bit-procs) + (D;merge nat-procs) + (D;merge int-procs) + (D;merge deg-procs) + (D;merge real-procs) + (D;merge text-procs) + (D;merge array-procs) + (D;merge math-procs) + (D;merge atom-procs) + (D;merge process-procs) + (D;merge io-procs))) diff --git a/new-luxc/source/luxc/analyser/struct.lux b/new-luxc/source/luxc/analyser/structure.lux index 562e30294..ab6f6adae 100644 --- a/new-luxc/source/luxc/analyser/struct.lux +++ b/new-luxc/source/luxc/analyser/structure.lux @@ -82,7 +82,7 @@ "Expected: " (|> size-ts nat-to-int %i) "\n" " Actual: " (|> size-record nat-to-int %i) "\n" "For type: " (%type recordT)))) - #let [tuple-range (list;n.range +0 size-ts) + #let [tuple-range (list;n.range +0 (n.dec size-ts)) tag->idx (D;from-list ident;Hash<Ident> (list;zip2 tag-set tuple-range))] idx->val (foldM @ (function [[key val] idx->val] @@ -203,13 +203,13 @@ (case type (#;Named name unnamedT) (do Monad<Lux> - [unnamedT+ (record-function-type unnamedT)] + [unnamedT+ (variant-function-type tag expected-size unnamedT)] (wrap (#;Named name unnamedT+))) (^template [<tag>] (<tag> env bodyT) (do Monad<Lux> - [bodyT+ (record-function-type bodyT)] + [bodyT+ (variant-function-type tag expected-size bodyT)] (wrap (<tag> env bodyT+)))) ([#;UnivQ] [#;ExQ]) @@ -265,20 +265,21 @@ (def: (variant tag size temp value) (-> Nat Nat Nat Analysis Analysis) - (let [last-tag (n.dec size)] - (if (n.= last-tag tag) + (if (n.= (n.dec size) tag) + (if (n.= +1 tag) + (sum-right value) (L/fold (function;const sum-left) (sum-right value) - (list;n.range +0 last-tag)) - (L/fold (function;const sum-left) - (case value - (#la;Sum _) - (#la;Case value (list [(#lp;Bind temp) - (#la;Relative (#;Local temp))])) + (list;n.range +0 (n.- +2 tag)))) + (L/fold (function;const sum-left) + (case value + (#la;Sum _) + (#la;Case value (list [(#lp;Bind temp) + (#la;Relative (#;Local temp))])) - _ - value) - (list;n.range +0 tag))))) + _ + value) + (list;n.range +0 tag)))) (def: #export (analyse-tagged-sum analyse tag value) (-> &;Analyser Ident Code (Lux Analysis)) @@ -345,4 +346,6 @@ (analyse-sum analyse tag valueC)))) _ - (&;fail ""))))) + (if (n.= +0 tag) + (analyse valueC) + (&;fail "")))))) diff --git a/new-luxc/source/luxc/base.lux b/new-luxc/source/luxc/base.lux index 612ce70d2..abd154190 100644 --- a/new-luxc/source/luxc/base.lux +++ b/new-luxc/source/luxc/base.lux @@ -55,15 +55,25 @@ (#R;Success [(set@ #;type-context context' compiler) output])))) -(def: #export (pl-contains? key mappings) - (All [a] (-> Text (List [Text a]) Bool)) - (case mappings +(def: #export (pl-get key table) + (All [a] (-> Text (List [Text a]) (Maybe a))) + (case table #;Nil - false + #;None - (#;Cons [k v] mappings') - (or (T/= key k) - (pl-contains? key mappings')))) + (#;Cons [k' v'] table') + (if (T/= key k') + (#;Some v') + (pl-get key table')))) + +(def: #export (pl-contains? key table) + (All [a] (-> Text (List [Text a]) Bool)) + (case (pl-get key table) + (#;Some _) + true + + #;None + false)) (def: #export (pl-put key val table) (All [a] (-> Text a (List [Text a]) (List [Text a]))) @@ -78,16 +88,16 @@ (#;Cons [k' v'] (pl-put key val table'))))) -(def: #export (pl-get key table) - (All [a] (-> Text (List [Text a]) (Maybe a))) +(def: #export (pl-update key f table) + (All [a] (-> Text (-> a a) (List [Text a]) (List [Text a]))) (case table #;Nil - #;None + #;Nil (#;Cons [k' v'] table') (if (T/= key k') - (#;Some v') - (pl-get key table')))) + (#;Cons [k' (f v')] table') + (#;Cons [k' v'] (pl-update key f table'))))) (def: #export (with-source-code source action) (All [a] (-> [Cursor Text] (Lux a) (Lux a))) diff --git a/new-luxc/source/luxc/lang/analysis.lux b/new-luxc/source/luxc/lang/analysis.lux index 4e823276d..3cd63b65f 100644 --- a/new-luxc/source/luxc/lang/analysis.lux +++ b/new-luxc/source/luxc/lang/analysis.lux @@ -4,6 +4,7 @@ (.. ["lp" pattern])) (type: #export #rec Analysis + #Unit (#Bool Bool) (#Nat Nat) (#Int Int) @@ -11,12 +12,11 @@ (#Real Real) (#Char Char) (#Text Text) - #Unit (#Sum (Either Analysis Analysis)) (#Product Analysis Analysis) (#Case Analysis (List [lp;Pattern Analysis])) (#Function Scope Analysis) (#Apply Analysis Analysis) - (#Procedure Ident (List Analysis)) + (#Procedure Text (List Analysis)) (#Relative Ref) (#Absolute Ident)) diff --git a/new-luxc/source/luxc/lang/synthesis.lux b/new-luxc/source/luxc/lang/synthesis.lux index 1edf0f1a0..491891600 100644 --- a/new-luxc/source/luxc/lang/synthesis.lux +++ b/new-luxc/source/luxc/lang/synthesis.lux @@ -3,6 +3,7 @@ (.. ["lp" pattern])) (type: #export #rec Synthesis + #Unit (#Bool Bool) (#Nat Nat) (#Int Int) @@ -10,11 +11,12 @@ (#Real Real) (#Char Char) (#Text Text) - (#Variant Nat Nat Synthesis) + (#Variant Nat Bool Synthesis) (#Tuple (List Synthesis)) (#Case (List [lp;Pattern Synthesis])) - (#Function Scope Synthesis) + (#Function Nat Scope Synthesis) (#Call Synthesis (List Synthesis)) - (#Procedure Ident (List Synthesis)) + (#Recur Nat (List Synthesis)) + (#Procedure Text (List Synthesis)) (#Relative Ref) (#Absolute Ident)) diff --git a/new-luxc/source/luxc/module.lux b/new-luxc/source/luxc/module.lux index 237fda3b9..b53ceefed 100644 --- a/new-luxc/source/luxc/module.lux +++ b/new-luxc/source/luxc/module.lux @@ -3,8 +3,11 @@ (lux (control monad) (data [text "T/" Eq<Text>] text/format - ["R" result])) - (luxc ["&" base])) + ["R" result] + (coll [list "L/" Fold<List> Functor<List>])) + [macro #+ Monad<Lux>]) + (luxc ["&" base] + ["&;" env])) (def: (new-module hash) (-> Nat Module) @@ -49,6 +52,14 @@ compiler) module])))) +(def: #export (with-module hash name action) + (All [a] (-> Nat Text (Lux a) (Lux [Module a]))) + (do Monad<Lux> + [_ (create hash name) + output (&env;with-scope name action) + module (macro;find-module name)] + (wrap [module output]))) + (do-template [<flagger> <asker> <tag>] [(def: #export (<flagger> module-name) (-> Text (Lux Unit)) @@ -85,3 +96,65 @@ [flag-compiled! compiled? #;Compiled] [flag-cached! cached? #;Cached] ) + +(do-template [<name> <tag> <type>] + [(def: (<name> module-name) + (-> Text (Lux <type>)) + (function [compiler] + (case (|> compiler (get@ #;modules) (&;pl-get module-name)) + (#;Some module) + (#R;Success [compiler (get@ <tag> module)]) + + #;None + (macro;run compiler (&;fail (format "Unknown module: " module-name)))) + ))] + + [tags-by-module #;tags (List [Text [Nat (List Ident) Bool Type]])] + [types-by-module #;types (List [Text [(List Ident) Bool Type]])] + [module-hash #;module-hash Nat] + ) + +(def: (ensure-undeclared-tags module-name tags) + (-> Text (List Text) (Lux Unit)) + (do Monad<Lux> + [bindings (tags-by-module module-name) + _ (mapM @ + (function [tag] + (case (&;pl-get tag bindings) + #;None + (wrap []) + + (#;Some _) + (&;fail (format "Cannot re-declare tag: " tag)))) + tags)] + (wrap []))) + +(def: #export (declare-tags tags exported? type) + (-> (List Text) Bool Type (Lux Unit)) + (do Monad<Lux> + [current-module macro;current-module-name + [type-module type-name] (case type + (#;Named type-ident _) + (wrap type-ident) + + _ + (&;fail (format "Cannot define tags for an unnamed type: " (%type type)))) + _ (ensure-undeclared-tags current-module tags) + _ (macro;assert (format "Cannot define tags for a type belonging to a foreign module: " (%type type)) + (T/= current-module type-module))] + (function [compiler] + (case (|> compiler (get@ #;modules) (&;pl-get current-module)) + (#;Some module) + (let [namespaced-tags (L/map (|>. [current-module]) tags)] + (#R;Success [(update@ #;modules + (&;pl-update current-module + (|>. (update@ #;tags (function [tag-bindings] + (L/fold (function [[idx tag] table] + (&;pl-put tag [idx namespaced-tags exported? type] table)) + tag-bindings + (list;enumerate tags)))) + (update@ #;types (&;pl-put type-name [namespaced-tags exported? type])))) + compiler) + []])) + #;None + (macro;run compiler (&;fail (format "Unknown module: " current-module))))))) diff --git a/new-luxc/test/test/luxc/analyser/case.lux b/new-luxc/test/test/luxc/analyser/case.lux new file mode 100644 index 000000000..f43625825 --- /dev/null +++ b/new-luxc/test/test/luxc/analyser/case.lux @@ -0,0 +1,175 @@ +(;module: + lux + (lux [io] + (control monad + pipe) + (data [bool "B/" Eq<Bool>] + ["R" result] + [product] + [text "T/" Eq<Text>] + text/format + (coll [list "L/" Monad<List>] + ["S" set])) + ["r" math/random "r/" Monad<Random>] + [type "Type/" Eq<Type>] + (type ["TC" check]) + [macro #+ Monad<Lux>] + (macro [code]) + test) + (luxc ["&" base] + (lang ["la" analysis]) + [analyser] + (analyser ["@" case] + ["@;" common]) + ["@;" module]) + (.. common)) + +(def: (total-weaving branchings) + (-> (List (List Code)) (List (List Code))) + (case branchings + #;Nil + #;Nil + + (#;Cons head+ #;Nil) + (L/map (|>. list) head+) + + (#;Cons head+ tail++) + (do list;Monad<List> + [tail+ (total-weaving tail++) + head head+] + (wrap (#;Cons head tail+))))) + +(def: (total-branches-for variantTC inputC) + (-> (List [Code Code]) Code (r;Random (List Code))) + (case inputC + [_ (#;Bool _)] + (r/wrap (list (' true) (' false))) + + (^template [<tag> <gen> <wrapper>] + [_ (<tag> _)] + (do r;Monad<Random> + [?sample (r;maybe <gen>)] + (case ?sample + (#;Some sample) + (do @ + [else (total-branches-for variantTC inputC)] + (wrap (list& (<wrapper> sample) else))) + + #;None + (wrap (list (' _)))))) + ([#;Nat r;nat code;nat] + [#;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))]) + (r/wrap (list (' []))) + + (^ [_ (#;Record (list))]) + (r/wrap (list (' {}))) + + [_ (#;Tuple members)] + (do r;Monad<Random> + [member-wise-patterns (mapM @ (total-branches-for variantTC) members)] + (wrap (|> member-wise-patterns + total-weaving + (L/map code;tuple)))) + + [_ (#;Record kvs)] + (do r;Monad<Random> + [#let [ks (L/map product;left kvs) + vs (L/map product;right kvs)] + member-wise-patterns (mapM @ (total-branches-for variantTC) vs)] + (wrap (|> member-wise-patterns + total-weaving + (L/map (|>. (list;zip2 ks) code;record))))) + + (^ [_ (#;Form (list [_ (#;Tag _)] _))]) + (do r;Monad<Random> + [bundles (mapM @ + (function [[_tag _code]] + (do @ + [v-branches (total-branches-for variantTC _code)] + (wrap (L/map (function [pattern] (` ((~ _tag) (~ pattern)))) + v-branches)))) + variantTC)] + (wrap (L/join bundles))) + + _ + (r/wrap (list)) + )) + +(def: (gen-input variant-tags record-tags primitivesC) + (-> (List Code) (List Code) (List Code) (r;Random Code)) + (r;rec + (function [gen-input] + ($_ r;either + (r/map product;right gen-simple-primitive) + (do r;Monad<Random> + [choice (|> r;nat (:: @ map (n.% (list;size variant-tags)))) + #let [choiceT (assume (list;nth choice variant-tags)) + choiceC (assume (list;nth choice primitivesC))]] + (wrap (` ((~ choiceT) (~ choiceC))))) + (do r;Monad<Random> + [size (|> r;nat (:: @ map (n.% +3))) + elems (r;list size gen-input)] + (wrap (code;tuple elems))) + (r/wrap (code;record (list;zip2 record-tags primitivesC))) + )))) + +(test: "Pattern-matching." + #seed +9253409297339902486 + [module-name (r;text +5) + variant-name (r;text +5) + record-name (|> (r;text +5) (r;filter (|>. (T/= variant-name) not))) + size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) + variant-tags (|> (r;set text;Hash<Text> size (r;text +5)) (:: @ map S;to-list)) + record-tags (|> (r;set text;Hash<Text> size (r;text +5)) (:: @ map S;to-list)) + primitivesTC (r;list size gen-simple-primitive) + #let [primitivesT (L/map product;left primitivesTC) + primitivesC (L/map product;right primitivesTC) + 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) + [outputT outputC] gen-simple-primitive + total-patterns (total-branches-for variantTC inputC) + #let [total-branchesC (L/map (function [pattern] [pattern outputC]) + total-patterns) + non-total-branchesC (list;take (n.dec (list;size total-branchesC)) + total-branchesC)]] + ($_ seq + (assert "Will reject empty pattern-matching (no branches)." + (|> (&;with-scope + (&;with-expected-type outputT + (@;analyse-case analyse inputC (list)))) + check-failure)) + (assert "Can analyse total pattern-matching." + (|> (@module;with-module +0 module-name + (do Monad<Lux> + [_ (@module;declare-tags variant-tags false + (#;Named [module-name variant-name] + (type;variant primitivesT))) + _ (@module;declare-tags record-tags false + (#;Named [module-name record-name] + (type;tuple primitivesT)))] + (&;with-scope + (&;with-expected-type outputT + (@;analyse-case analyse inputC total-branchesC))))) + check-success)) + (assert "Will reject non-total pattern-matching." + (|> (@module;with-module +0 module-name + (do Monad<Lux> + [_ (@module;declare-tags variant-tags false + (#;Named [module-name variant-name] + (type;variant primitivesT))) + _ (@module;declare-tags record-tags false + (#;Named [module-name record-name] + (type;tuple primitivesT)))] + (&;with-scope + (&;with-expected-type outputT + (@;analyse-case analyse inputC non-total-branchesC))))) + check-failure)) + )) diff --git a/new-luxc/test/test/luxc/analyser/common.lux b/new-luxc/test/test/luxc/analyser/common.lux index 9e3db3513..5d1dcf55e 100644 --- a/new-luxc/test/test/luxc/analyser/common.lux +++ b/new-luxc/test/test/luxc/analyser/common.lux @@ -1,7 +1,12 @@ (;module: lux - (lux ["R" math/random "R/" Monad<Random>] - (macro [code]))) + (lux (control pipe) + ["r" math/random "r/" Monad<Random>] + (data ["R" result]) + [macro] + (macro [code])) + (luxc ["&" base] + [analyser])) (def: compiler-version Text "0.6.0") @@ -30,24 +35,43 @@ #;host (:! Void [])}) (def: gen-unit - (R;Random Code) - (R/wrap (' []))) + (r;Random Code) + (r/wrap (' []))) (def: #export gen-simple-primitive - (R;Random [Type Code]) + (r;Random [Type Code]) (with-expansions [<generators> (do-template [<type> <code-wrapper> <value-gen>] - [(R;seq (R/wrap <type>) (R/map <code-wrapper> <value-gen>))] - - [Unit code;tuple (R;list +0 gen-unit)] - [Bool code;bool R;bool] - [Nat code;nat R;nat] - [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;seq (r/wrap <type>) (r/map <code-wrapper> <value-gen>))] + + [Unit code;tuple (r;list +0 gen-unit)] + [Bool code;bool r;bool] + [Nat code;nat r;nat] + [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 + ($_ r;either <generators> ))) + +(def: #export analyse + &;Analyser + (analyser;analyser (:!! []))) + +(do-template [<name> <on-success> <on-failure>] + [(def: #export (<name> analysis) + (All [a] (-> (Lux a) Bool)) + (|> analysis + (macro;run init-compiler) + (case> (#R;Success _) + <on-success> + + (#R;Error error) + <on-failure>)))] + + [check-success true false] + [check-failure false true] + ) diff --git a/new-luxc/test/test/luxc/analyser/function.lux b/new-luxc/test/test/luxc/analyser/function.lux new file mode 100644 index 000000000..fc203ca2d --- /dev/null +++ b/new-luxc/test/test/luxc/analyser/function.lux @@ -0,0 +1,155 @@ +(;module: + lux + (lux [io] + (control monad + pipe) + (data ["R" result] + [product] + [text "T/" Eq<Text>] + text/format + (coll [list "L/" Functor<List>] + ["S" set])) + ["r" math/random "r/" Monad<Random>] + [type "Type/" Eq<Type>] + (type ["TC" check]) + [macro #+ Monad<Lux>] + (macro [code]) + test) + (luxc ["&" base] + (lang ["la" analysis]) + [analyser] + (analyser ["@" function] + ["@;" common]) + ["@;" module]) + (.. common)) + +(def: (check-type expectedT result) + (-> Type (R;Result [Type la;Analysis]) Bool) + (case result + (#R;Success [exprT exprA]) + (Type/= expectedT exprT) + + _ + false)) + +(def: (succeeds? result) + (All [a] (-> (R;Result a) Bool)) + (case result + (#R;Success _) + true + + (#R;Error _) + false)) + +(def: (flatten-apply analysis) + (-> la;Analysis [la;Analysis (List la;Analysis)]) + (case analysis + (#la;Apply head func) + (let [[func' tail] (flatten-apply func)] + [func' (#;Cons head tail)]) + + _ + [analysis (list)])) + +(def: (check-apply expectedT num-args analysis) + (-> Type Nat (Lux [Type la;Analysis]) Bool) + (|> analysis + (macro;run init-compiler) + (case> (#R;Success [applyT applyA]) + (let [[funcA argsA] (flatten-apply applyA)] + (and (Type/= expectedT applyT) + (n.= num-args (list;size argsA)))) + + (#R;Error error) + false))) + +(test: "Function definition." + [func-name (r;text +5) + arg-name (|> (r;text +5) (r;filter (|>. (T/= func-name) not))) + [outputT outputC] gen-simple-primitive + [inputT _] gen-simple-primitive] + ($_ seq + (assert "Can analyse function." + (|> (&;with-expected-type (type (All [a] (-> a outputT))) + (@;analyse-function analyse func-name arg-name outputC)) + (macro;run init-compiler) + succeeds?)) + (assert "Generic functions can always be specialized." + (and (|> (&;with-expected-type (-> inputT outputT) + (@;analyse-function analyse func-name arg-name outputC)) + (macro;run init-compiler) + succeeds?) + (|> (&;with-expected-type (-> inputT inputT) + (@;analyse-function analyse func-name arg-name (code;symbol ["" arg-name]))) + (macro;run init-compiler) + succeeds?))) + (assert "Can infer function (constant output and unused input)." + (|> (@common;with-unknown-type + (@;analyse-function analyse func-name arg-name outputC)) + (macro;run init-compiler) + (check-type (type (All [a] (-> a outputT)))))) + (assert "Can infer function (output = input)." + (|> (@common;with-unknown-type + (@;analyse-function analyse func-name arg-name (code;symbol ["" arg-name]))) + (macro;run init-compiler) + (check-type (type (All [a] (-> a a)))))) + (assert "The function's name is bound to the function's type." + (|> (&;with-expected-type (type (Rec self (-> inputT self))) + (@;analyse-function analyse func-name arg-name (code;symbol ["" func-name]))) + (macro;run init-compiler) + succeeds?)) + (assert "Can infer recursive types for functions." + (|> (@common;with-unknown-type + (@;analyse-function analyse func-name arg-name (code;symbol ["" func-name]))) + (macro;run init-compiler) + (check-type (type (Rec self (All [a] (-> a self))))))) + )) + +(test: "Function application." + [full-args (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) + partial-args (|> r;nat (:: @ map (n.% full-args))) + var-idx (|> r;nat (:: @ map (|>. (n.% full-args) (n.max +1)))) + inputsTC (r;list full-args gen-simple-primitive) + #let [inputsT (L/map product;left inputsTC) + inputsC (L/map product;right inputsTC)] + [outputT outputC] gen-simple-primitive + #let [funcT (type;function inputsT outputT) + partialT (type;function (list;drop partial-args inputsT) outputT) + varT (#;Bound +1) + polyT (<| (type;univ-q +1) + (type;function (list;concat (list (list;take var-idx inputsT) + (list varT) + (list;drop (n.inc var-idx) inputsT)))) + varT) + poly-inputT (assume (list;nth var-idx inputsT)) + partial-poly-inputsT (list;drop (n.inc var-idx) inputsT) + partial-polyT1 (<| (type;function partial-poly-inputsT) + poly-inputT) + partial-polyT2 (<| (type;univ-q +1) + (type;function (#;Cons varT partial-poly-inputsT)) + varT)]] + ($_ seq + (assert "Can analyse monomorphic type application." + (|> (@common;with-unknown-type + (@;analyse-apply analyse funcT (#la;Unit) inputsC)) + (check-apply outputT full-args))) + (assert "Can partially apply functions." + (|> (@common;with-unknown-type + (@;analyse-apply analyse funcT (#la;Unit) + (list;take partial-args inputsC))) + (check-apply partialT partial-args))) + (assert "Can apply polymorphic functions." + (|> (@common;with-unknown-type + (@;analyse-apply analyse polyT (#la;Unit) inputsC)) + (check-apply poly-inputT full-args))) + (assert "Polymorphic partial application propagates found type-vars." + (|> (@common;with-unknown-type + (@;analyse-apply analyse polyT (#la;Unit) + (list;take (n.inc var-idx) inputsC))) + (check-apply partial-polyT1 (n.inc var-idx)))) + (assert "Polymorphic partial application preserves quantification for type-vars." + (|> (@common;with-unknown-type + (@;analyse-apply analyse polyT (#la;Unit) + (list;take var-idx inputsC))) + (check-apply partial-polyT2 var-idx))) + )) diff --git a/new-luxc/test/test/luxc/analyser/procedure/common.lux b/new-luxc/test/test/luxc/analyser/procedure/common.lux new file mode 100644 index 000000000..14edcf516 --- /dev/null +++ b/new-luxc/test/test/luxc/analyser/procedure/common.lux @@ -0,0 +1,396 @@ +(;module: + lux + (lux [io] + (control monad + pipe) + (concurrency [atom]) + (data text/format + ["R" result] + [product] + (coll [array])) + ["r" math/random "r/" Monad<Random>] + [type "Type/" Eq<Type>] + [macro #+ Monad<Lux>] + (macro [code]) + test) + (luxc ["&" base] + ["&;" env] + ["&;" module] + (lang ["~" analysis]) + [analyser] + (analyser ["@" procedure] + ["@;" common])) + (../.. common)) + +(do-template [<name> <success> <failure>] + [(def: (<name> procedure params output-type) + (-> Text (List Code) Type Bool) + (|> (&;with-expected-type output-type + (@;analyse-procedure analyse procedure params)) + (macro;run init-compiler) + (case> (#R;Success _) + <success> + + (#R;Error _) + <failure>)))] + + [check-success+ true false] + [check-failure+ false true] + ) + +(test: "Lux procedures" + [[primT primC] gen-simple-primitive + [antiT antiC] (|> gen-simple-primitive + (r;filter (|>. product;left (Type/= primT) not)))] + ($_ seq + (assert "Can test for reference equality." + (check-success+ "lux is" (list primC primC) Bool)) + (assert "Reference equality must be done with elements of the same type." + (check-failure+ "lux is" (list primC antiC) Bool)) + (assert "Can 'try' risky IO computations." + (check-success+ "lux try" + (list (` ((~' _lux_function) (~' _) (~' _) (~ primC)))) + (type (Either Text primT)))) + )) + +(test: "Bit procedures" + [subjectC (|> r;nat (:: @ map code;nat)) + signedC (|> r;int (:: @ map code;int)) + paramC (|> r;nat (:: @ map code;nat))] + ($_ seq + (assert "Can count the number of 1 bits in a bit pattern." + (check-success+ "bit count" (list subjectC) Nat)) + (assert "Can perform bit 'and'." + (check-success+ "bit and" (list subjectC paramC) Nat)) + (assert "Can perform bit 'or'." + (check-success+ "bit or" (list subjectC paramC) Nat)) + (assert "Can perform bit 'xor'." + (check-success+ "bit xor" (list subjectC paramC) Nat)) + (assert "Can shift bit pattern to the left." + (check-success+ "bit shift-left" (list subjectC paramC) Nat)) + (assert "Can shift bit pattern to the right." + (check-success+ "bit unsigned-shift-right" (list subjectC paramC) Nat)) + (assert "Can shift signed bit pattern to the right." + (check-success+ "bit shift-right" (list signedC paramC) Int)) + )) + +(test: "Nat procedures" + [subjectC (|> r;nat (:: @ map code;nat)) + paramC (|> r;nat (:: @ map code;nat))] + ($_ seq + (assert "Can add natural numbers." + (check-success+ "nat +" (list subjectC paramC) Nat)) + (assert "Can subtract natural numbers." + (check-success+ "nat -" (list subjectC paramC) Nat)) + (assert "Can multiply natural numbers." + (check-success+ "nat *" (list subjectC paramC) Nat)) + (assert "Can divide natural numbers." + (check-success+ "nat /" (list subjectC paramC) Nat)) + (assert "Can calculate remainder of natural numbers." + (check-success+ "nat %" (list subjectC paramC) Nat)) + (assert "Can test equality of natural numbers." + (check-success+ "nat =" (list subjectC paramC) Bool)) + (assert "Can compare natural numbers." + (check-success+ "nat <" (list subjectC paramC) Bool)) + (assert "Can obtain minimum natural number." + (check-success+ "nat min" (list) Nat)) + (assert "Can obtain maximum natural number." + (check-success+ "nat max" (list) Nat)) + (assert "Can convert natural number to integer." + (check-success+ "nat to-int" (list subjectC) Int)) + (assert "Can convert natural number to text." + (check-success+ "nat to-text" (list subjectC) Text)) + )) + +(test: "Int procedures" + [subjectC (|> r;int (:: @ map code;int)) + paramC (|> r;int (:: @ map code;int))] + ($_ seq + (assert "Can add integers." + (check-success+ "int +" (list subjectC paramC) Int)) + (assert "Can subtract integers." + (check-success+ "int -" (list subjectC paramC) Int)) + (assert "Can multiply integers." + (check-success+ "int *" (list subjectC paramC) Int)) + (assert "Can divide integers." + (check-success+ "int /" (list subjectC paramC) Int)) + (assert "Can calculate remainder of integers." + (check-success+ "int %" (list subjectC paramC) Int)) + (assert "Can test equality of integers." + (check-success+ "int =" (list subjectC paramC) Bool)) + (assert "Can compare integers." + (check-success+ "int <" (list subjectC paramC) Bool)) + (assert "Can obtain minimum integer." + (check-success+ "int min" (list) Int)) + (assert "Can obtain maximum integer." + (check-success+ "int max" (list) Int)) + (assert "Can convert integer to natural number." + (check-success+ "int to-nat" (list subjectC) Nat)) + (assert "Can convert integer to real number." + (check-success+ "int to-real" (list subjectC) Real)) + )) + +(test: "Deg procedures" + [subjectC (|> r;deg (:: @ map code;deg)) + paramC (|> r;deg (:: @ map code;deg)) + natC (|> r;nat (:: @ map code;nat))] + ($_ seq + (assert "Can add degrees." + (check-success+ "deg +" (list subjectC paramC) Deg)) + (assert "Can subtract degrees." + (check-success+ "deg -" (list subjectC paramC) Deg)) + (assert "Can multiply degrees." + (check-success+ "deg *" (list subjectC paramC) Deg)) + (assert "Can divide degrees." + (check-success+ "deg /" (list subjectC paramC) Deg)) + (assert "Can calculate remainder of degrees." + (check-success+ "deg %" (list subjectC paramC) Deg)) + (assert "Can test equality of degrees." + (check-success+ "deg =" (list subjectC paramC) Bool)) + (assert "Can compare degrees." + (check-success+ "deg <" (list subjectC paramC) Bool)) + (assert "Can obtain minimum degree." + (check-success+ "deg min" (list) Deg)) + (assert "Can obtain maximum degree." + (check-success+ "deg max" (list) Deg)) + (assert "Can convert degree to real number." + (check-success+ "deg to-real" (list subjectC) Real)) + (assert "Can scale degree." + (check-success+ "deg scale" (list subjectC natC) Deg)) + (assert "Can calculate the reciprocal of a natural number." + (check-success+ "deg reciprocal" (list natC) Deg)) + )) + +(test: "Real procedures" + [subjectC (|> r;real (:: @ map code;real)) + paramC (|> r;real (:: @ map code;real)) + encodedC (|> (r;text +5) (:: @ map code;text))] + ($_ seq + (assert "Can add real numbers." + (check-success+ "real +" (list subjectC paramC) Real)) + (assert "Can subtract real numbers." + (check-success+ "real -" (list subjectC paramC) Real)) + (assert "Can multiply real numbers." + (check-success+ "real *" (list subjectC paramC) Real)) + (assert "Can divide real numbers." + (check-success+ "real /" (list subjectC paramC) Real)) + (assert "Can calculate remainder of real numbers." + (check-success+ "real %" (list subjectC paramC) Real)) + (assert "Can test equality of real numbers." + (check-success+ "real =" (list subjectC paramC) Bool)) + (assert "Can compare real numbers." + (check-success+ "real <" (list subjectC paramC) Bool)) + (assert "Can obtain minimum real number." + (check-success+ "real min" (list) Real)) + (assert "Can obtain maximum real number." + (check-success+ "real max" (list) Real)) + (assert "Can obtain smallest real number." + (check-success+ "real smallest" (list) Real)) + (assert "Can obtain not-a-number." + (check-success+ "real not-a-number" (list) Real)) + (assert "Can obtain positive infinity." + (check-success+ "real positive-infinity" (list) Real)) + (assert "Can obtain negative infinity." + (check-success+ "real negative-infinity" (list) Real)) + (assert "Can convert real number to integer." + (check-success+ "real to-int" (list subjectC) Int)) + (assert "Can convert real number to degree." + (check-success+ "real to-deg" (list subjectC) Deg)) + (assert "Can convert real number to text." + (check-success+ "real to-text" (list subjectC) Text)) + (assert "Can convert text to real number." + (check-success+ "real from-text" (list encodedC) (type (Maybe Real)))) + )) + +(test: "Text procedures" + [subjectC (|> (r;text +5) (:: @ map code;text)) + paramC (|> (r;text +5) (:: @ map code;text)) + replacementC (|> (r;text +5) (:: @ map code;text)) + fromC (|> r;nat (:: @ map code;nat)) + toC (|> r;nat (:: @ map code;nat))] + ($_ seq + (assert "Can test text equality." + (check-success+ "text =" (list subjectC paramC) Bool)) + (assert "Compare texts in lexicographical order." + (check-success+ "text <" (list subjectC paramC) Bool)) + (assert "Can prepend one text to another." + (check-success+ "text prepend" (list subjectC paramC) Text)) + (assert "Can find the index of a piece of text inside a larger one that (may) contain it." + (check-success+ "text index" (list subjectC paramC fromC) (type (Maybe Nat)))) + (assert "Can query the size/length of a text." + (check-success+ "text size" (list subjectC) Nat)) + (assert "Can calculate a hash code for text." + (check-success+ "text hash" (list subjectC) Nat)) + (assert "Can replace a text inside of a larger one (once)." + (check-success+ "text replace-once" (list subjectC paramC replacementC) Text)) + (assert "Can replace a text inside of a larger one (all times)." + (check-success+ "text replace-all" (list subjectC paramC replacementC) Text)) + (assert "Can obtain the character code of a text at a given index." + (check-success+ "text char" (list subjectC fromC) Nat)) + (assert "Can clip a piece of text between 2 indices." + (check-success+ "text clip" (list subjectC fromC toC) Text)) + )) + +(test: "Array procedures" + [[elemT elemC] gen-simple-primitive + sizeC (|> r;nat (:: @ map code;nat)) + idxC (|> r;nat (:: @ map code;nat)) + var-name (r;text +5) + #let [arrayT (type (array;Array elemT))]] + ($_ seq + (assert "Can create arrays." + (check-success+ "array new" (list sizeC) arrayT)) + (assert "Can get a value inside an array." + (|> (&env;with-scope "" + (&env;with-local [var-name arrayT] + (&;with-expected-type elemT + (@;analyse-procedure analyse "array get" + (list idxC + (code;symbol ["" var-name])))))) + (macro;run init-compiler) + (case> (#R;Success _) + true + + (#R;Error _) + false))) + (assert "Can put a value inside an array." + (|> (&env;with-scope "" + (&env;with-local [var-name arrayT] + (&;with-expected-type arrayT + (@;analyse-procedure analyse "array put" + (list idxC + elemC + (code;symbol ["" var-name])))))) + (macro;run init-compiler) + (case> (#R;Success _) + true + + (#R;Error _) + false))) + (assert "Can remove a value from an array." + (|> (&env;with-scope "" + (&env;with-local [var-name arrayT] + (&;with-expected-type arrayT + (@;analyse-procedure analyse "array remove" + (list idxC + (code;symbol ["" var-name])))))) + (macro;run init-compiler) + (case> (#R;Success _) + true + + (#R;Error _) + false))) + (assert "Can query the size of an array." + (|> (&env;with-scope "" + (&env;with-local [var-name arrayT] + (&;with-expected-type Nat + (@;analyse-procedure analyse "array size" + (list (code;symbol ["" var-name])))))) + (macro;run init-compiler) + (case> (#R;Success _) + true + + (#R;Error _) + false))) + )) + +(test: "Math procedures" + [subjectC (|> r;real (:: @ map code;real)) + paramC (|> r;real (:: @ map code;real))] + (with-expansions [<unary> (do-template [<proc> <desc>] + [(assert (format "Can calculate " <desc> ".") + (check-success+ <proc> (list subjectC) Real))] + + ["math cos" "cosine"] + ["math sin" "sine"] + ["math tan" "tangent"] + ["math acos" "inverse/arc cosine"] + ["math asin" "inverse/arc sine"] + ["math atan" "inverse/arc tangent"] + ["math cosh" "hyperbolic cosine"] + ["math sinh" "hyperbolic sine"] + ["math tanh" "hyperbolic tangent"] + ["math exp" "exponentiation"] + ["math log" "logarithm"] + ["math root2" "square root"] + ["math root3" "cubic root"] + ["math ceil" "ceiling"] + ["math floor" "floor"] + ["math round" "rounding"]) + <binary> (do-template [<proc> <desc>] + [(assert (format "Can calculate " <desc> ".") + (check-success+ <proc> (list subjectC paramC) Real))] + + ["math atan2" "inverse/arc tangent (with 2 arguments)"] + ["math pow" "power"])] + ($_ seq + <unary> + <binary>))) + +(test: "Atom procedures" + [[elemT elemC] gen-simple-primitive + sizeC (|> r;nat (:: @ map code;nat)) + idxC (|> r;nat (:: @ map code;nat)) + var-name (r;text +5) + #let [atomT (type (atom;Atom elemT))]] + ($_ seq + (assert "Can create atomic reference." + (check-success+ "atom new" (list elemC) atomT)) + (assert "Can read the value of an atomic reference." + (|> (&env;with-scope "" + (&env;with-local [var-name atomT] + (&;with-expected-type elemT + (@;analyse-procedure analyse "atom read" + (list (code;symbol ["" var-name])))))) + (macro;run init-compiler) + (case> (#R;Success _) + true + + (#R;Error _) + false))) + (assert "Can swap the value of an atomic reference." + (|> (&env;with-scope "" + (&env;with-local [var-name atomT] + (&;with-expected-type Bool + (@;analyse-procedure analyse "atom compare-and-swap" + (list elemC + elemC + (code;symbol ["" var-name])))))) + (macro;run init-compiler) + (case> (#R;Success _) + true + + (#R;Error _) + false))) + )) + +(test: "Process procedures" + [[primT primC] gen-simple-primitive + timeC (|> r;nat (:: @ map code;nat))] + ($_ seq + (assert "Can query the level of concurrency." + (check-success+ "process concurrency-level" (list) Nat)) + (assert "Can run an IO computation concurrently." + (check-success+ "process future" + (list (` ((~' _lux_function) (~' _) (~' _) (~ primC)))) + Unit)) + (assert "Can schedule an IO computation to run concurrently at some future time." + (check-success+ "process schedule" + (list timeC + (` ((~' _lux_function) (~' _) (~' _) (~ primC)))) + Unit)) + )) + +(test: "IO procedures" + [logC (|> (r;text +5) (:: @ map code;text)) + exitC (|> r;nat (:: @ map code;nat))] + ($_ seq + (assert "Can log messages to standard output." + (check-success+ "io log" (list logC) Unit)) + (assert "Can log messages to standard output." + (check-success+ "io error" (list logC) Bottom)) + (assert "Can log messages to standard output." + (check-success+ "io exit" (list exitC) Bottom)) + (assert "Can query the current time (as milliseconds since epoch)." + (check-success+ "io current-time" (list) Int)) + )) diff --git a/new-luxc/test/test/luxc/analyser/struct.lux b/new-luxc/test/test/luxc/analyser/struct.lux deleted file mode 100644 index 8bf7957b5..000000000 --- a/new-luxc/test/test/luxc/analyser/struct.lux +++ /dev/null @@ -1,48 +0,0 @@ -(;module: - lux - (lux [io] - (control monad - pipe) - (data ["R" result] - [product] - (coll [list "L/" Functor<List>])) - ["r" math/random "R/" Monad<Random>] - [type "Type/" Eq<Type>] - [macro #+ Monad<Lux>] - test) - (luxc ["&" base] - (lang ["la" analysis]) - [analyser] - (analyser ["@" struct] - ["@;" common])) - (.. common)) - -(def: analyse - &;Analyser - (analyser;analyser (:!! []))) - -(def: (flatten-tuple analysis) - (-> la;Analysis (List la;Analysis)) - (case analysis - (#la;Product left right) - (#;Cons left (flatten-tuple right)) - - _ - (list analysis))) - -(test: "Tuples" - [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) - primitives (r;list size gen-simple-primitive)] - ($_ seq - (assert "Can analyse tuple." - (|> (@common;with-unknown-type - (@;analyse-product analyse (L/map product;right primitives))) - (macro;run init-compiler) - (case> (#R;Success [_type tupleA]) - (and (Type/= (type;tuple (L/map product;left primitives)) - _type) - (n.= size (list;size (flatten-tuple tupleA)))) - - _ - false)) - ))) diff --git a/new-luxc/test/test/luxc/analyser/structure.lux b/new-luxc/test/test/luxc/analyser/structure.lux new file mode 100644 index 000000000..b38a904c3 --- /dev/null +++ b/new-luxc/test/test/luxc/analyser/structure.lux @@ -0,0 +1,365 @@ +(;module: + lux + (lux [io] + (control monad + pipe) + (data [bool "B/" Eq<Bool>] + ["R" result] + [product] + [text] + text/format + (coll [list "L/" Functor<List>] + ["S" set])) + ["r" math/random "r/" Monad<Random>] + [type "Type/" Eq<Type>] + (type ["TC" check]) + [macro #+ Monad<Lux>] + (macro [code]) + test) + (luxc ["&" base] + (lang ["la" analysis]) + [analyser] + (analyser ["@" structure] + ["@;" common]) + ["@;" module]) + (.. common)) + +(def: (flatten-tuple analysis) + (-> la;Analysis (List la;Analysis)) + (case analysis + (#la;Product left right) + (#;Cons left (flatten-tuple right)) + + _ + (list analysis))) + +(def: (flatten-variant analysis) + (-> la;Analysis (Maybe [Nat Bool la;Analysis])) + (case analysis + (#la;Sum variant) + (loop [so-far +0 + variantA variant] + (case variantA + (#;Left valueA) + (case valueA + (#la;Sum choice) + (recur (n.inc so-far) choice) + + _ + (#;Some [so-far false valueA])) + + (#;Right valueA) + (#;Some [(n.inc so-far) true valueA]))) + + _ + #;None)) + +(test: "Sums" + [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) + choice (|> r;nat (:: @ map (n.% size))) + primitives (r;list size gen-simple-primitive) + +choice (|> r;nat (:: @ map (n.% (n.inc size)))) + [_ +valueC] gen-simple-primitive + #let [variantT (type;variant (L/map product;left primitives)) + [valueT valueC] (assume (list;nth choice primitives)) + +size (n.inc size) + +primitives (list;concat (list (list;take choice primitives) + (list [(#;Bound +1) +valueC]) + (list;drop choice primitives))) + [+valueT +valueC] (assume (list;nth +choice +primitives)) + +variantT (type;variant (L/map product;left +primitives))]] + ($_ seq + (assert "Can analyse sum." + (|> (&;with-scope + (&;with-expected-type variantT + (@;analyse-sum analyse choice valueC))) + (macro;run init-compiler) + (case> (^multi (#R;Success [_ sumA]) + [(flatten-variant sumA) + (#;Some [tag last? valueA])]) + (and (n.= tag choice) + (B/= last? (n.= (n.dec size) choice))) + + _ + false))) + (assert "Can analyse pseudo-sum." + (|> (&;with-expected-type valueT + (@;analyse-sum analyse +0 valueC)) + (macro;run init-compiler) + (case> (#R;Success sumA) + true + + _ + false))) + (assert "Can analyse sum through bound type-vars." + (|> (&;with-scope + (@common;with-var + (function [[var-id varT]] + (do Monad<Lux> + [_ (&;within-type-env + (TC;check varT variantT))] + (&;with-expected-type varT + (@;analyse-sum analyse choice valueC)))))) + (macro;run init-compiler) + (case> (^multi (#R;Success [_ sumA]) + [(flatten-variant sumA) + (#;Some [tag last? valueA])]) + (and (n.= tag choice) + (B/= last? (n.= (n.dec size) choice))) + + _ + false))) + (assert "Cannot analyse sum through unbound type-vars." + (|> (&;with-scope + (@common;with-var + (function [[var-id varT]] + (&;with-expected-type varT + (@;analyse-sum analyse choice valueC))))) + (macro;run init-compiler) + (case> (#R;Success _) + false + + _ + true))) + (assert "Can analyse sum through existential quantification." + (|> (&;with-scope + (&;with-expected-type (type;ex-q +1 +variantT) + (@;analyse-sum analyse +choice +valueC))) + (macro;run init-compiler) + (case> (#R;Success _) + true + + (#R;Error error) + false))) + (assert "Can analyse sum through universal quantification." + (|> (&;with-scope + (&;with-expected-type (type;univ-q +1 +variantT) + (@;analyse-sum analyse +choice +valueC))) + (macro;run init-compiler) + (case> (#R;Success _) + (not (n.= choice +choice)) + + (#R;Error error) + (n.= choice +choice)))) + )) + +(test: "Products" + [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) + primitives (r;list size gen-simple-primitive) + choice (|> r;nat (:: @ map (n.% size))) + [_ +valueC] gen-simple-primitive + #let [[singletonT singletonC] (|> primitives (list;nth choice) assume) + +primitives (list;concat (list (list;take choice primitives) + (list [(#;Bound +1) +valueC]) + (list;drop choice primitives))) + +tupleT (type;tuple (L/map product;left +primitives))]] + ($_ seq + (assert "Can analyse product." + (|> (&;with-expected-type (type;tuple (L/map product;left primitives)) + (@;analyse-product analyse (L/map product;right primitives))) + (macro;run init-compiler) + (case> (#R;Success tupleA) + (n.= size (list;size (flatten-tuple tupleA))) + + _ + false))) + (assert "Can infer product." + (|> (@common;with-unknown-type + (@;analyse-product analyse (L/map product;right primitives))) + (macro;run init-compiler) + (case> (#R;Success [_type tupleA]) + (and (Type/= (type;tuple (L/map product;left primitives)) + _type) + (n.= size (list;size (flatten-tuple tupleA)))) + + _ + false))) + (assert "Can analyse pseudo-product (singleton tuple)" + (|> (&;with-expected-type singletonT + (analyse (` [(~ singletonC)]))) + (macro;run init-compiler) + (case> (#R;Success singletonA) + true + + (#R;Error error) + false))) + (assert "Can analyse product through bound type-vars." + (|> (&;with-scope + (@common;with-var + (function [[var-id varT]] + (do Monad<Lux> + [_ (&;within-type-env + (TC;check varT (type;tuple (L/map product;left primitives))))] + (&;with-expected-type varT + (@;analyse-product analyse (L/map product;right primitives))))))) + (macro;run init-compiler) + (case> (#R;Success [_ tupleA]) + (n.= size (list;size (flatten-tuple tupleA))) + + _ + false))) + (assert "Can analyse product through existential quantification." + (|> (&;with-scope + (&;with-expected-type (type;ex-q +1 +tupleT) + (@;analyse-product analyse (L/map product;right +primitives)))) + (macro;run init-compiler) + (case> (#R;Success _) + true + + (#R;Error error) + false))) + (assert "Cannot analyse product through universal quantification." + (|> (&;with-scope + (&;with-expected-type (type;univ-q +1 +tupleT) + (@;analyse-product analyse (L/map product;right +primitives)))) + (macro;run init-compiler) + (case> (#R;Success _) + false + + (#R;Error error) + true))) + )) + +(def: (check-variant-inference variantT choice size analysis) + (-> Type Nat Nat (Lux [Module Scope Type la;Analysis]) Bool) + (|> analysis + (macro;run init-compiler) + (case> (^multi (#R;Success [_ _ sumT sumA]) + [(flatten-variant sumA) + (#;Some [tag last? valueA])]) + (and (Type/= variantT sumT) + (n.= tag choice) + (B/= last? (n.= (n.dec size) choice))) + + _ + false))) + +(def: (check-record-inference tupleT size analysis) + (-> Type Nat (Lux [Module Scope Type la;Analysis]) Bool) + (|> analysis + (macro;run init-compiler) + (case> (^multi (#R;Success [_ _ productT productA]) + [(flatten-tuple productA) + membersA]) + (and (Type/= tupleT productT) + (n.= size (list;size membersA))) + + _ + false))) + +(test: "Tagged Sums" + [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) + tags (|> (r;set text;Hash<Text> size (r;text +5)) (:: @ map S;to-list)) + choice (|> r;nat (:: @ map (n.% size))) + other-choice (|> r;nat (:: @ map (n.% size)) (r;filter (|>. (n.= choice) not))) + primitives (r;list size gen-simple-primitive) + module-name (r;text +5) + type-name (r;text +5) + #let [varT (#;Bound +1) + primitivesT (L/map product;left primitives) + [choiceT choiceC] (assume (list;nth choice primitives)) + [other-choiceT other-choiceC] (assume (list;nth other-choice primitives)) + variantT (type;variant primitivesT) + namedT (#;Named [module-name type-name] variantT) + polyT (|> (type;variant (list;concat (list (list;take choice primitivesT) + (list varT) + (list;drop (n.inc choice) primitivesT)))) + (type;univ-q +1)) + named-polyT (#;Named [module-name type-name] polyT) + choice-tag (assume (list;nth choice tags)) + other-choice-tag (assume (list;nth other-choice tags))]] + ($_ seq + (assert "Can infer tagged sum." + (|> (@module;with-module +0 module-name + (do Monad<Lux> + [_ (@module;declare-tags tags false namedT)] + (&;with-scope + (@common;with-unknown-type + (@;analyse-tagged-sum analyse [module-name choice-tag] choiceC))))) + (check-variant-inference variantT choice size))) + (assert "Tagged sums specialize when type-vars get bound." + (|> (@module;with-module +0 module-name + (do Monad<Lux> + [_ (@module;declare-tags tags false named-polyT)] + (&;with-scope + (@common;with-unknown-type + (@;analyse-tagged-sum analyse [module-name choice-tag] choiceC))))) + (check-variant-inference variantT choice size))) + (assert "Tagged sum inference retains universal quantification when type-vars are not bound." + (|> (@module;with-module +0 module-name + (do Monad<Lux> + [_ (@module;declare-tags tags false named-polyT)] + (&;with-scope + (@common;with-unknown-type + (@;analyse-tagged-sum analyse [module-name other-choice-tag] other-choiceC))))) + (check-variant-inference polyT other-choice size))) + (assert "Can specialize generic tagged sums." + (|> (@module;with-module +0 module-name + (do Monad<Lux> + [_ (@module;declare-tags tags false named-polyT)] + (&;with-scope + (&;with-expected-type variantT + (@;analyse-tagged-sum analyse [module-name other-choice-tag] other-choiceC))))) + (macro;run init-compiler) + (case> (^multi (#R;Success [_ _ sumA]) + [(flatten-variant sumA) + (#;Some [tag last? valueA])]) + (and (n.= tag other-choice) + (B/= last? (n.= (n.dec size) other-choice))) + + _ + false))) + )) + +(test: "Records" + [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) + tags (|> (r;set text;Hash<Text> size (r;text +5)) (:: @ map S;to-list)) + primitives (r;list size gen-simple-primitive) + module-name (r;text +5) + type-name (r;text +5) + choice (|> r;nat (:: @ map (n.% size))) + #let [varT (#;Bound +1) + tagsC (L/map (|>. [module-name] code;tag) tags) + primitivesT (L/map product;left primitives) + primitivesC (L/map product;right primitives) + tupleT (type;tuple primitivesT) + namedT (#;Named [module-name type-name] tupleT) + recordC (list;zip2 tagsC primitivesC) + polyT (|> (type;tuple (list;concat (list (list;take choice primitivesT) + (list varT) + (list;drop (n.inc choice) primitivesT)))) + (type;univ-q +1)) + named-polyT (#;Named [module-name type-name] polyT)]] + ($_ seq + (assert "Can infer record." + (|> (@module;with-module +0 module-name + (do Monad<Lux> + [_ (@module;declare-tags tags false namedT)] + (&;with-scope + (@common;with-unknown-type + (@;analyse-record analyse recordC))))) + (check-record-inference tupleT size))) + (assert "Records specialize when type-vars get bound." + (|> (@module;with-module +0 module-name + (do Monad<Lux> + [_ (@module;declare-tags tags false named-polyT)] + (&;with-scope + (@common;with-unknown-type + (@;analyse-record analyse recordC))))) + (check-record-inference tupleT size))) + (assert "Can specialize generic records." + (|> (@module;with-module +0 module-name + (do Monad<Lux> + [_ (@module;declare-tags tags false named-polyT)] + (&;with-scope + (&;with-expected-type tupleT + (@;analyse-record analyse recordC))))) + (macro;run init-compiler) + (case> (^multi (#R;Success [_ _ productA]) + [(flatten-tuple productA) + membersA]) + (n.= size (list;size membersA)) + + _ + false))) + )) diff --git a/new-luxc/test/test/luxc/parser.lux b/new-luxc/test/test/luxc/parser.lux index f6ee8ea72..33b6eba36 100644 --- a/new-luxc/test/test/luxc/parser.lux +++ b/new-luxc/test/test/luxc/parser.lux @@ -38,7 +38,7 @@ (r;Random Ident) (r;seq ident-part^ ident-part^)) -(def: ast^ +(def: code^ (r;Random Code) (let [numeric^ (: (r;Random Code) ($_ r;either @@ -60,23 +60,23 @@ numeric^ textual^))] (r;rec - (function [ast^] + (function [code^] (let [multi^ (do r;Monad<Random> [size (|> r;nat (r/map (n.% +3)))] - (r;list size ast^)) + (r;list size code^)) composite^ (: (r;Random Code) ($_ r;either (|> multi^ (r/map (|>. #;Form [default-cursor]))) (|> multi^ (r/map (|>. #;Tuple [default-cursor]))) (do r;Monad<Random> [size (|> r;nat (r/map (n.% +3)))] - (|> (r;list size (r;seq ast^ ast^)) + (|> (r;list size (r;seq code^ code^)) (r/map (|>. #;Record [default-cursor]))))))] (r;either simple^ composite^)))))) (test: "Lux code parser." - [sample ast^] + [sample code^] (assert "Can parse Lux code." (case (&;parse [default-cursor (code;to-text sample)]) (#R;Error error) @@ -119,7 +119,7 @@ z char-gen offset-size (|> r;nat (r/map (|>. (n.% +10) (n.max +1)))) #let [offset (text;join-with "" (list;repeat offset-size " "))] - sample ast^ + sample code^ comment comment^ unbalanced-comment comment-text^] ($_ seq diff --git a/new-luxc/test/tests.lux b/new-luxc/test/tests.lux index a330560fc..26ec28743 100644 --- a/new-luxc/test/tests.lux +++ b/new-luxc/test/tests.lux @@ -7,8 +7,12 @@ [test]) (test (luxc ["_;" parser] (analyser ["_;" primitive] - ["_;" struct] - ["_;" reference])))) + ["_;" structure] + ["_;" reference] + ["_;" case] + ["_;" function] + (procedure ["_;" common]) + )))) ## [Program] (program: args |