From 953f49d5a46209f2d75e67b50edea378261108cd Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 29 May 2017 22:05:57 -0400 Subject: - Fixes for pattern-matching (case) analysis. - Small refactorings. - Improved common procedures analysis. - Can now handle tagged structures (variants & records). - Tests for pattern-matching, functions (definition & application), and common procedures. --- new-luxc/source/luxc/analyser/case.lux | 18 +- new-luxc/source/luxc/analyser/function.lux | 6 +- new-luxc/source/luxc/analyser/proc.lux | 19 -- new-luxc/source/luxc/analyser/proc/lux.lux | 321 ------------------- new-luxc/source/luxc/analyser/procedure.lux | 17 + new-luxc/source/luxc/analyser/procedure/common.lux | 333 +++++++++++++++++++ new-luxc/source/luxc/analyser/struct.lux | 348 -------------------- new-luxc/source/luxc/analyser/structure.lux | 351 +++++++++++++++++++++ 8 files changed, 714 insertions(+), 699 deletions(-) delete mode 100644 new-luxc/source/luxc/analyser/proc.lux delete mode 100644 new-luxc/source/luxc/analyser/proc/lux.lux create mode 100644 new-luxc/source/luxc/analyser/procedure.lux create mode 100644 new-luxc/source/luxc/analyser/procedure/common.lux delete mode 100644 new-luxc/source/luxc/analyser/struct.lux create mode 100644 new-luxc/source/luxc/analyser/structure.lux (limited to 'new-luxc/source/luxc/analyser') 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 - [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 [[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 - [[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 - [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 - [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] - (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 - [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 - [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) - (D;put "is" analyse-lux-is) - (D;put "try" analyse-lux-try))) - -(def: io-procs - Proc-Set - (|> (D;new text;Hash) - (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) - (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) - (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) - (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) - (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) - (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) - (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) - (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) - (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 - [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) - (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) - (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) - (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 + [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] + (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 + [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 + [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) + (install "lux is" analyse-lux-is) + (install "lux try" analyse-lux-try))) + +(def: io-procs + Proc-Set + (|> (D;new text;Hash) + (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) + (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) + (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) + (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) + (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) + (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) + (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) + (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) + (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 + [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) + (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) + (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) + (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/struct.lux deleted file mode 100644 index 562e30294..000000000 --- a/new-luxc/source/luxc/analyser/struct.lux +++ /dev/null @@ -1,348 +0,0 @@ -(;module: - lux - (lux (control monad - pipe) - [io #- run] - [function] - (concurrency ["A" atom]) - (data [text "T/" Eq] - text/format - [ident] - (coll [list "L/" Fold Monoid Monad] - ["D" dict] - ["S" set]) - [number] - [product]) - [macro #+ Monad] - (macro [code]) - [type] - (type ["TC" check])) - (luxc ["&" base] - (lang ["la" analysis #+ Analysis] - ["lp" pattern]) - ["&;" module] - ["&;" env] - (analyser ["&;" common] - ["&;" inference]))) - -## [Analysers] -(def: (analyse-typed-product analyse members) - (-> &;Analyser (List Code) (Lux Analysis)) - (do Monad - [expected macro;expected-type] - (loop [expected expected - members members] - (case [expected members] - [(#;Product leftT rightT) (#;Cons leftC rightC)] - (do @ - [leftA (&;with-expected-type leftT - (analyse leftC)) - rightA (recur rightT rightC)] - (wrap (#la;Product leftA rightA))) - - [tailT (#;Cons tailC #;Nil)] - (&;with-expected-type tailT - (analyse tailC)) - - [tailT tailC] - (do @ - [g!tail (macro;gensym "tail")] - (&;with-expected-type tailT - (analyse (` ((~' _lux_case) [(~@ tailC)] - (~ g!tail) - (~ g!tail)))))) - )))) - -(def: #export (normalize-record pairs) - (-> (List [Code Code]) (Lux (List [Ident Code]))) - (mapM Monad - (function [[key val]] - (case key - [_ (#;Tag key)] - (do Monad - [key (macro;normalize key)] - (wrap [key val])) - - _ - (&;fail (format "Cannot use non-tag tokens in key positions in records: " (%code key))))) - pairs)) - -(def: #export (order-record pairs) - (-> (List [Ident Code]) (Lux [(List Code) Type])) - (case pairs - (#;Cons [head-k head-v] _) - (do Monad - [head-k (macro;normalize head-k) - [_ tag-set recordT] (macro;resolve-tag head-k) - #let [size-record (list;size pairs) - size-ts (list;size tag-set)] - _ (if (n.= size-ts size-record) - (wrap []) - (&;fail (format "Record size does not match tag-set size." "\n" - "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) - tag->idx (D;from-list ident;Hash (list;zip2 tag-set tuple-range))] - idx->val (foldM @ - (function [[key val] idx->val] - (do @ - [key (macro;normalize key)] - (case (D;get key tag->idx) - #;None - (&;fail (format "Tag " (%code (code;tag key)) - " does not belong to tag-set for type " (%type recordT))) - - (#;Some idx) - (if (D;contains? idx idx->val) - (&;fail (format "Cannot repeat tag inside record: " (%code (code;tag key)))) - (wrap (D;put idx val idx->val)))))) - (: (D;Dict Nat Code) - (D;new number;Hash)) - pairs) - #let [ordered-tuple (L/map (function [idx] - (assume (D;get idx idx->val))) - tuple-range)]] - (wrap [ordered-tuple recordT])) - - _ - (:: Monad wrap [(list) Unit]))) - -(def: (tuple members) - (-> (List Analysis) Analysis) - (case members - #;Nil - #la;Unit - - (#;Cons singleton #;Nil) - singleton - - (#;Cons left right) - (#la;Product left (tuple right)))) - -(def: #export (analyse-product analyse membersC) - (-> &;Analyser (List Code) (Lux Analysis)) - (do Monad - [expected macro;expected-type] - (&;with-stacked-errors - (function [_] (format "Invalid type for tuple: " (%type expected))) - (case expected - (#;Product _) - (analyse-typed-product analyse membersC) - - (#;Named name unnamedT) - (&;with-expected-type unnamedT - (analyse-product analyse membersC)) - - (#;Var id) - (do @ - [bound? (&;within-type-env - (TC;bound? id))] - (if bound? - (do @ - [expected' (&;within-type-env - (TC;read-var id))] - (&;with-expected-type expected' - (analyse-product analyse membersC))) - (do @ - [membersTA (mapM @ (|>. analyse &common;with-unknown-type) - membersC) - _ (&;within-type-env - (TC;check expected - (type;tuple (L/map product;left membersTA))))] - (wrap (tuple (L/map product;right membersTA)))))) - - (#;UnivQ _) - (do @ - [[var-id var] (&;within-type-env - TC;existential)] - (&;with-expected-type (assume (type;apply-type expected var)) - (analyse-product analyse membersC))) - - (#;ExQ _) - (&common;with-var - (function [[var-id var]] - (&;with-expected-type (assume (type;apply-type expected var)) - (analyse-product analyse membersC)))) - - _ - (&;fail "") - )))) - -(def: (record-function-type type) - (-> Type (Lux Type)) - (case type - (#;Named name unnamedT) - (do Monad - [unnamedT+ (record-function-type unnamedT)] - (wrap (#;Named name unnamedT+))) - - (^template [] - ( env bodyT) - (do Monad - [bodyT+ (record-function-type bodyT)] - (wrap ( env bodyT+)))) - ([#;UnivQ] - [#;ExQ]) - - (#;Product _) - (:: Monad wrap (type;function (type;flatten-tuple type) type)) - - _ - (&;fail (format "Not a record type: " (%type type))))) - -(def: (out-of-bounds-error type size tag) - (All [a] (-> Type Nat Nat (Lux a))) - (&;fail (format "Trying to create variant with tag beyond type's limitations." "\n" - " Tag: " (%i (nat-to-int tag)) "\n" - "Size: " (%i (nat-to-int size)) "\n" - "Type: " (%type type)))) - -(def: (variant-function-type tag expected-size type) - (-> Nat Nat Type (Lux Type)) - (case type - (#;Named name unnamedT) - (do Monad - [unnamedT+ (record-function-type unnamedT)] - (wrap (#;Named name unnamedT+))) - - (^template [] - ( env bodyT) - (do Monad - [bodyT+ (record-function-type bodyT)] - (wrap ( env bodyT+)))) - ([#;UnivQ] - [#;ExQ]) - - (#;Sum _) - (let [cases (type;flatten-variant type) - actual-size (list;size cases) - boundary (n.dec expected-size)] - (cond (or (n.= expected-size actual-size) - (and (n.> expected-size actual-size) - (n.< boundary tag))) - (case (list;nth tag cases) - (#;Some caseT) - (:: Monad wrap (type;function (list caseT) type)) - - #;None - (out-of-bounds-error type expected-size tag)) - - (n.< expected-size actual-size) - (&;fail (format "Variant type is smaller than expected." "\n" - "Expected: " (%i (nat-to-int expected-size)) "\n" - " Actual: " (%i (nat-to-int actual-size)))) - - (n.= boundary tag) - (let [caseT (type;variant (list;drop boundary cases))] - (:: Monad wrap (type;function (list caseT) type))) - - ## else - (out-of-bounds-error type expected-size tag))) - - _ - (&;fail (format "Not a variant type: " (%type type))))) - -(def: #export (analyse-record analyse members) - (-> &;Analyser (List [Code Code]) (Lux Analysis)) - (do Monad - [members (normalize-record members) - [members recordT] (order-record members) - expectedT macro;expected-type - functionT (record-function-type recordT) - [inferredT membersA] (&inference;apply-function analyse functionT members) - _ (&;within-type-env - (TC;check expectedT inferredT))] - (wrap (tuple membersA)))) - -(do-template [ ] - [(def: ( inner) - (-> Analysis Analysis) - (#la;Sum ( inner)))] - - [sum-left #;Left] - [sum-right #;Right]) - -(def: (variant tag size temp value) - (-> Nat Nat Nat Analysis Analysis) - (let [last-tag (n.dec size)] - (if (n.= last-tag tag) - (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))])) - - _ - value) - (list;n.range +0 tag))))) - -(def: #export (analyse-tagged-sum analyse tag value) - (-> &;Analyser Ident Code (Lux Analysis)) - (do Monad - [tag (macro;normalize tag) - [idx group variantT] (macro;resolve-tag tag) - #let [case-size (list;size group)] - functionT (variant-function-type idx case-size variantT) - [inferredT valueA+] (&inference;apply-function analyse functionT (list value)) - expectedT macro;expected-type - _ (&;within-type-env - (TC;check expectedT inferredT)) - temp &env;next-local] - (wrap (variant idx case-size temp (|> valueA+ list;head assume))))) - -(def: #export (analyse-sum analyse tag valueC) - (-> &;Analyser Nat Code (Lux Analysis)) - (do Monad - [expected macro;expected-type] - (&;with-stacked-errors - (function [_] (format "Invalid type for variant: " (%type expected))) - (case expected - (#;Sum _) - (let [flat (type;flatten-variant expected) - type-size (list;size flat)] - (case (list;nth tag flat) - (#;Some variant-type) - (do @ - [valueA (&;with-expected-type variant-type - (analyse valueC)) - temp &env;next-local] - (wrap (variant tag type-size temp valueA))) - - #;None - (out-of-bounds-error expected type-size tag))) - - (#;Named name unnamedT) - (&;with-expected-type unnamedT - (analyse-sum analyse tag valueC)) - - (#;Var id) - (do @ - [bound? (&;within-type-env - (TC;bound? id))] - (if bound? - (do @ - [expected' (&;within-type-env - (TC;read-var id))] - (&;with-expected-type expected' - (analyse-sum analyse tag valueC))) - (&;fail (format "Invalid type for variant: " (%type expected))))) - - (#;UnivQ _) - (do @ - [[var-id var] (&;within-type-env - TC;existential)] - (&;with-expected-type (assume (type;apply-type expected var)) - (analyse-sum analyse tag valueC))) - - (#;ExQ _) - (&common;with-var - (function [[var-id var]] - (&;with-expected-type (assume (type;apply-type expected var)) - (analyse-sum analyse tag valueC)))) - - _ - (&;fail ""))))) diff --git a/new-luxc/source/luxc/analyser/structure.lux b/new-luxc/source/luxc/analyser/structure.lux new file mode 100644 index 000000000..ab6f6adae --- /dev/null +++ b/new-luxc/source/luxc/analyser/structure.lux @@ -0,0 +1,351 @@ +(;module: + lux + (lux (control monad + pipe) + [io #- run] + [function] + (concurrency ["A" atom]) + (data [text "T/" Eq] + text/format + [ident] + (coll [list "L/" Fold Monoid Monad] + ["D" dict] + ["S" set]) + [number] + [product]) + [macro #+ Monad] + (macro [code]) + [type] + (type ["TC" check])) + (luxc ["&" base] + (lang ["la" analysis #+ Analysis] + ["lp" pattern]) + ["&;" module] + ["&;" env] + (analyser ["&;" common] + ["&;" inference]))) + +## [Analysers] +(def: (analyse-typed-product analyse members) + (-> &;Analyser (List Code) (Lux Analysis)) + (do Monad + [expected macro;expected-type] + (loop [expected expected + members members] + (case [expected members] + [(#;Product leftT rightT) (#;Cons leftC rightC)] + (do @ + [leftA (&;with-expected-type leftT + (analyse leftC)) + rightA (recur rightT rightC)] + (wrap (#la;Product leftA rightA))) + + [tailT (#;Cons tailC #;Nil)] + (&;with-expected-type tailT + (analyse tailC)) + + [tailT tailC] + (do @ + [g!tail (macro;gensym "tail")] + (&;with-expected-type tailT + (analyse (` ((~' _lux_case) [(~@ tailC)] + (~ g!tail) + (~ g!tail)))))) + )))) + +(def: #export (normalize-record pairs) + (-> (List [Code Code]) (Lux (List [Ident Code]))) + (mapM Monad + (function [[key val]] + (case key + [_ (#;Tag key)] + (do Monad + [key (macro;normalize key)] + (wrap [key val])) + + _ + (&;fail (format "Cannot use non-tag tokens in key positions in records: " (%code key))))) + pairs)) + +(def: #export (order-record pairs) + (-> (List [Ident Code]) (Lux [(List Code) Type])) + (case pairs + (#;Cons [head-k head-v] _) + (do Monad + [head-k (macro;normalize head-k) + [_ tag-set recordT] (macro;resolve-tag head-k) + #let [size-record (list;size pairs) + size-ts (list;size tag-set)] + _ (if (n.= size-ts size-record) + (wrap []) + (&;fail (format "Record size does not match tag-set size." "\n" + "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 (n.dec size-ts)) + tag->idx (D;from-list ident;Hash (list;zip2 tag-set tuple-range))] + idx->val (foldM @ + (function [[key val] idx->val] + (do @ + [key (macro;normalize key)] + (case (D;get key tag->idx) + #;None + (&;fail (format "Tag " (%code (code;tag key)) + " does not belong to tag-set for type " (%type recordT))) + + (#;Some idx) + (if (D;contains? idx idx->val) + (&;fail (format "Cannot repeat tag inside record: " (%code (code;tag key)))) + (wrap (D;put idx val idx->val)))))) + (: (D;Dict Nat Code) + (D;new number;Hash)) + pairs) + #let [ordered-tuple (L/map (function [idx] + (assume (D;get idx idx->val))) + tuple-range)]] + (wrap [ordered-tuple recordT])) + + _ + (:: Monad wrap [(list) Unit]))) + +(def: (tuple members) + (-> (List Analysis) Analysis) + (case members + #;Nil + #la;Unit + + (#;Cons singleton #;Nil) + singleton + + (#;Cons left right) + (#la;Product left (tuple right)))) + +(def: #export (analyse-product analyse membersC) + (-> &;Analyser (List Code) (Lux Analysis)) + (do Monad + [expected macro;expected-type] + (&;with-stacked-errors + (function [_] (format "Invalid type for tuple: " (%type expected))) + (case expected + (#;Product _) + (analyse-typed-product analyse membersC) + + (#;Named name unnamedT) + (&;with-expected-type unnamedT + (analyse-product analyse membersC)) + + (#;Var id) + (do @ + [bound? (&;within-type-env + (TC;bound? id))] + (if bound? + (do @ + [expected' (&;within-type-env + (TC;read-var id))] + (&;with-expected-type expected' + (analyse-product analyse membersC))) + (do @ + [membersTA (mapM @ (|>. analyse &common;with-unknown-type) + membersC) + _ (&;within-type-env + (TC;check expected + (type;tuple (L/map product;left membersTA))))] + (wrap (tuple (L/map product;right membersTA)))))) + + (#;UnivQ _) + (do @ + [[var-id var] (&;within-type-env + TC;existential)] + (&;with-expected-type (assume (type;apply-type expected var)) + (analyse-product analyse membersC))) + + (#;ExQ _) + (&common;with-var + (function [[var-id var]] + (&;with-expected-type (assume (type;apply-type expected var)) + (analyse-product analyse membersC)))) + + _ + (&;fail "") + )))) + +(def: (record-function-type type) + (-> Type (Lux Type)) + (case type + (#;Named name unnamedT) + (do Monad + [unnamedT+ (record-function-type unnamedT)] + (wrap (#;Named name unnamedT+))) + + (^template [] + ( env bodyT) + (do Monad + [bodyT+ (record-function-type bodyT)] + (wrap ( env bodyT+)))) + ([#;UnivQ] + [#;ExQ]) + + (#;Product _) + (:: Monad wrap (type;function (type;flatten-tuple type) type)) + + _ + (&;fail (format "Not a record type: " (%type type))))) + +(def: (out-of-bounds-error type size tag) + (All [a] (-> Type Nat Nat (Lux a))) + (&;fail (format "Trying to create variant with tag beyond type's limitations." "\n" + " Tag: " (%i (nat-to-int tag)) "\n" + "Size: " (%i (nat-to-int size)) "\n" + "Type: " (%type type)))) + +(def: (variant-function-type tag expected-size type) + (-> Nat Nat Type (Lux Type)) + (case type + (#;Named name unnamedT) + (do Monad + [unnamedT+ (variant-function-type tag expected-size unnamedT)] + (wrap (#;Named name unnamedT+))) + + (^template [] + ( env bodyT) + (do Monad + [bodyT+ (variant-function-type tag expected-size bodyT)] + (wrap ( env bodyT+)))) + ([#;UnivQ] + [#;ExQ]) + + (#;Sum _) + (let [cases (type;flatten-variant type) + actual-size (list;size cases) + boundary (n.dec expected-size)] + (cond (or (n.= expected-size actual-size) + (and (n.> expected-size actual-size) + (n.< boundary tag))) + (case (list;nth tag cases) + (#;Some caseT) + (:: Monad wrap (type;function (list caseT) type)) + + #;None + (out-of-bounds-error type expected-size tag)) + + (n.< expected-size actual-size) + (&;fail (format "Variant type is smaller than expected." "\n" + "Expected: " (%i (nat-to-int expected-size)) "\n" + " Actual: " (%i (nat-to-int actual-size)))) + + (n.= boundary tag) + (let [caseT (type;variant (list;drop boundary cases))] + (:: Monad wrap (type;function (list caseT) type))) + + ## else + (out-of-bounds-error type expected-size tag))) + + _ + (&;fail (format "Not a variant type: " (%type type))))) + +(def: #export (analyse-record analyse members) + (-> &;Analyser (List [Code Code]) (Lux Analysis)) + (do Monad + [members (normalize-record members) + [members recordT] (order-record members) + expectedT macro;expected-type + functionT (record-function-type recordT) + [inferredT membersA] (&inference;apply-function analyse functionT members) + _ (&;within-type-env + (TC;check expectedT inferredT))] + (wrap (tuple membersA)))) + +(do-template [ ] + [(def: ( inner) + (-> Analysis Analysis) + (#la;Sum ( inner)))] + + [sum-left #;Left] + [sum-right #;Right]) + +(def: (variant tag size temp value) + (-> Nat Nat Nat Analysis Analysis) + (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 (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)))) + +(def: #export (analyse-tagged-sum analyse tag value) + (-> &;Analyser Ident Code (Lux Analysis)) + (do Monad + [tag (macro;normalize tag) + [idx group variantT] (macro;resolve-tag tag) + #let [case-size (list;size group)] + functionT (variant-function-type idx case-size variantT) + [inferredT valueA+] (&inference;apply-function analyse functionT (list value)) + expectedT macro;expected-type + _ (&;within-type-env + (TC;check expectedT inferredT)) + temp &env;next-local] + (wrap (variant idx case-size temp (|> valueA+ list;head assume))))) + +(def: #export (analyse-sum analyse tag valueC) + (-> &;Analyser Nat Code (Lux Analysis)) + (do Monad + [expected macro;expected-type] + (&;with-stacked-errors + (function [_] (format "Invalid type for variant: " (%type expected))) + (case expected + (#;Sum _) + (let [flat (type;flatten-variant expected) + type-size (list;size flat)] + (case (list;nth tag flat) + (#;Some variant-type) + (do @ + [valueA (&;with-expected-type variant-type + (analyse valueC)) + temp &env;next-local] + (wrap (variant tag type-size temp valueA))) + + #;None + (out-of-bounds-error expected type-size tag))) + + (#;Named name unnamedT) + (&;with-expected-type unnamedT + (analyse-sum analyse tag valueC)) + + (#;Var id) + (do @ + [bound? (&;within-type-env + (TC;bound? id))] + (if bound? + (do @ + [expected' (&;within-type-env + (TC;read-var id))] + (&;with-expected-type expected' + (analyse-sum analyse tag valueC))) + (&;fail (format "Invalid type for variant: " (%type expected))))) + + (#;UnivQ _) + (do @ + [[var-id var] (&;within-type-env + TC;existential)] + (&;with-expected-type (assume (type;apply-type expected var)) + (analyse-sum analyse tag valueC))) + + (#;ExQ _) + (&common;with-var + (function [[var-id var]] + (&;with-expected-type (assume (type;apply-type expected var)) + (analyse-sum analyse tag valueC)))) + + _ + (if (n.= +0 tag) + (analyse valueC) + (&;fail "")))))) -- cgit v1.2.3