diff options
Diffstat (limited to 'new-luxc/source/luxc/analyser')
| -rw-r--r-- | new-luxc/source/luxc/analyser/case.lux | 20 | ||||
| -rw-r--r-- | new-luxc/source/luxc/analyser/case/coverage.lux | 26 | ||||
| -rw-r--r-- | new-luxc/source/luxc/analyser/primitive.lux | 2 | ||||
| -rw-r--r-- | new-luxc/source/luxc/analyser/procedure.lux | 6 | ||||
| -rw-r--r-- | new-luxc/source/luxc/analyser/procedure/common.lux | 90 | ||||
| -rw-r--r-- | new-luxc/source/luxc/analyser/structure.lux | 56 |
6 files changed, 100 insertions, 100 deletions
diff --git a/new-luxc/source/luxc/analyser/case.lux b/new-luxc/source/luxc/analyser/case.lux index 30d0a2b7a..0f5b4da4e 100644 --- a/new-luxc/source/luxc/analyser/case.lux +++ b/new-luxc/source/luxc/analyser/case.lux @@ -1,6 +1,6 @@ (;module: lux - (lux (control monad + (lux (control [monad #+ do] eq) (data [bool "B/" Eq<Bool>] [number] @@ -102,7 +102,7 @@ [Nat #;Nat #la;NatP] [Int #;Int #la;IntP] [Deg #;Deg #la;DegP] - [Real #;Real #la;RealP] + [Frac #;Frac #la;FracP] [Text #;Text #la;TextP]) (^ [cursor (#;Tuple (list))]) @@ -225,14 +225,14 @@ [[inputT inputA] (&common;with-unknown-type (analyse input)) outputH (analyse-pattern #;None inputT patternH (analyse bodyH)) - outputT (mapM @ - (function [[patternT bodyT]] - (analyse-pattern #;None inputT patternT (analyse bodyT))) - branchesT) - _ (case (foldM R;Monad<Result> - &&coverage;merge - (|> outputH product;left &&coverage;determine) - (L/map (|>. product;left &&coverage;determine) outputT)) + outputT (monad;map @ + (function [[patternT bodyT]] + (analyse-pattern #;None inputT patternT (analyse bodyT))) + branchesT) + _ (case (monad;fold R;Monad<Result> + &&coverage;merge + (|> outputH product;left &&coverage;determine) + (L/map (|>. product;left &&coverage;determine) outputT)) (#R;Success coverage) (if (&&coverage;total? coverage) (wrap []) diff --git a/new-luxc/source/luxc/analyser/case/coverage.lux b/new-luxc/source/luxc/analyser/case/coverage.lux index 88e40ac0f..cb7341d7a 100644 --- a/new-luxc/source/luxc/analyser/case/coverage.lux +++ b/new-luxc/source/luxc/analyser/case/coverage.lux @@ -1,6 +1,6 @@ (;module: lux - (lux (control monad + (lux (control [monad #+ do] eq) (data [bool "B/" Eq<Bool>] [number] @@ -54,7 +54,7 @@ ## Primitive patterns always have partial coverage because there ## are too many possibilities as far as values go. (^or (#la;NatP _) (#la;IntP _) (#la;DegP _) - (#la;RealP _) (#la;TextP _)) + (#la;FracP _) (#la;TextP _)) #Partial ## Bools are the exception, since there is only "true" and @@ -171,17 +171,17 @@ ## else (do R;Monad<Result> - [casesM (foldM @ - (function [[tagA coverageA] casesSF'] - (case (D;get tagA casesSF') - (#;Some coverageSF) - (do @ - [coverageM (merge coverageA coverageSF)] - (wrap (D;put tagA coverageM casesSF'))) - - #;None - (wrap (D;put tagA coverageA casesSF')))) - casesSF (D;entries casesA))] + [casesM (monad;fold @ + (function [[tagA coverageA] casesSF'] + (case (D;get tagA casesSF') + (#;Some coverageSF) + (do @ + [coverageM (merge coverageA coverageSF)] + (wrap (D;put tagA coverageM casesSF'))) + + #;None + (wrap (D;put tagA coverageA casesSF')))) + casesSF (D;entries casesA))] (wrap (if (let [case-coverages (D;values casesM)] (and (n.= allSF (list;size case-coverages)) (list;every? total? case-coverages))) diff --git a/new-luxc/source/luxc/analyser/primitive.lux b/new-luxc/source/luxc/analyser/primitive.lux index 9102acda5..69e4f2b07 100644 --- a/new-luxc/source/luxc/analyser/primitive.lux +++ b/new-luxc/source/luxc/analyser/primitive.lux @@ -20,7 +20,7 @@ [analyse-nat Nat #la;Nat] [analyse-int Int #la;Int] [analyse-deg Deg #la;Deg] - [analyse-real Real #la;Real] + [analyse-frac Frac #la;Frac] [analyse-text Text #la;Text] ) diff --git a/new-luxc/source/luxc/analyser/procedure.lux b/new-luxc/source/luxc/analyser/procedure.lux index d8778844f..06ea7c324 100644 --- a/new-luxc/source/luxc/analyser/procedure.lux +++ b/new-luxc/source/luxc/analyser/procedure.lux @@ -1,10 +1,10 @@ (;module: lux - (lux (control monad) + (lux (control [monad #+ do]) (data [text] text/format (coll ["D" dict]) - maybe)) + [maybe])) (luxc ["&" base] (lang ["la" analysis #+ Analysis])) (. ["&&;" common])) @@ -12,6 +12,6 @@ (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> + (do maybe;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 index 1976d266d..0ba35a82e 100644 --- a/new-luxc/source/luxc/analyser/procedure/common.lux +++ b/new-luxc/source/luxc/analyser/procedure/common.lux @@ -1,6 +1,6 @@ (;module: lux - (lux (control monad) + (lux (control [monad #+ do]) (concurrency ["A" atom]) (data [text] text/format @@ -39,11 +39,11 @@ (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)) + [argsA (monad;map @ + (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))] @@ -156,7 +156,7 @@ (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)))) + (install "int to-frac" (converter Int Frac)))) (def: deg-procs Bundle @@ -172,28 +172,28 @@ (install "deg reciprocal" (binary-operation Deg Nat Deg)) (install "deg min" (special-value Deg)) (install "deg max" (special-value Deg)) - (install "deg to-real" (converter Deg Real)))) + (install "deg to-frac" (converter Deg Frac)))) -(def: real-procs +(def: frac-procs Bundle (|> (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)))))) + (install "frac +" (binary-operation Frac Frac Frac)) + (install "frac -" (binary-operation Frac Frac Frac)) + (install "frac *" (binary-operation Frac Frac Frac)) + (install "frac /" (binary-operation Frac Frac Frac)) + (install "frac %" (binary-operation Frac Frac Frac)) + (install "frac =" (binary-operation Frac Frac Bool)) + (install "frac <" (binary-operation Frac Frac Bool)) + (install "frac smallest" (special-value Frac)) + (install "frac min" (special-value Frac)) + (install "frac max" (special-value Frac)) + (install "frac not-a-number" (special-value Frac)) + (install "frac positive-infinity" (special-value Frac)) + (install "frac negative-infinity" (special-value Frac)) + (install "frac to-deg" (converter Frac Deg)) + (install "frac to-int" (converter Frac Int)) + (install "frac encode" (converter Frac Text)) + (install "frac decode" (converter Text (type (Maybe Frac)))))) (def: text-procs Bundle @@ -246,24 +246,24 @@ (def: math-procs Bundle (|> (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)) + (install "math cos" (unary-operation Frac Frac)) + (install "math sin" (unary-operation Frac Frac)) + (install "math tan" (unary-operation Frac Frac)) + (install "math acos" (unary-operation Frac Frac)) + (install "math asin" (unary-operation Frac Frac)) + (install "math atan" (unary-operation Frac Frac)) + (install "math cosh" (unary-operation Frac Frac)) + (install "math sinh" (unary-operation Frac Frac)) + (install "math tanh" (unary-operation Frac Frac)) + (install "math exp" (unary-operation Frac Frac)) + (install "math log" (unary-operation Frac Frac)) + (install "math root2" (unary-operation Frac Frac)) + (install "math root3" (unary-operation Frac Frac)) + (install "math ceil" (unary-operation Frac Frac)) + (install "math floor" (unary-operation Frac Frac)) + (install "math round" (unary-operation Frac Frac)) + (install "math atan2" (binary-operation Frac Frac Frac)) + (install "math pow" (binary-operation Frac Frac Frac)) )) (def: (analyse-atom-new proc) @@ -326,7 +326,7 @@ (D;merge nat-procs) (D;merge int-procs) (D;merge deg-procs) - (D;merge real-procs) + (D;merge frac-procs) (D;merge text-procs) (D;merge array-procs) (D;merge math-procs) diff --git a/new-luxc/source/luxc/analyser/structure.lux b/new-luxc/source/luxc/analyser/structure.lux index 267dfec84..ad7ad2a7a 100644 --- a/new-luxc/source/luxc/analyser/structure.lux +++ b/new-luxc/source/luxc/analyser/structure.lux @@ -1,6 +1,6 @@ (;module: lux - (lux (control monad + (lux (control [monad #+ do] pipe) [io #- run] [function] @@ -154,8 +154,8 @@ (analyse-product analyse membersC))) ## Must do inference... (do @ - [membersTA (mapM @ (|>. analyse &common;with-unknown-type) - membersC) + [membersTA (monad;map @ (|>. analyse &common;with-unknown-type) + membersC) _ (&;within-type-env (TC;check expected (type;tuple (L/map product;left membersTA))))] @@ -198,17 +198,17 @@ ## canonical form (with their corresponding module identified). (def: #export (normalize record) (-> (List [Code Code]) (Lux (List [Ident Code]))) - (mapM Monad<Lux> - (function [[key val]] - (case key - [_ (#;Tag key)] - (do Monad<Lux> - [key (macro;normalize key)] - (wrap [key val])) + (monad;map Monad<Lux> + (function [[key val]] + (case key + [_ (#;Tag key)] + (do Monad<Lux> + [key (macro;normalize key)] + (wrap [key val])) - _ - (&;fail (format "Cannot use non-tag tokens in key positions in records: " (%code key))))) - record)) + _ + (&;fail (format "Cannot use non-tag tokens in key positions in records: " (%code key))))) + record)) ## Lux already possesses the means to analyse tuples, so ## re-implementing the same functionality for records makes no sense. @@ -234,22 +234,22 @@ "For type: " (%type recordT)))) #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] - (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))) + idx->val (monad;fold @ + (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<Nat>)) - record) + (#;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<Nat>)) + record) #let [ordered-tuple (L/map (function [idx] (assume (D;get idx idx->val))) tuple-range)]] (wrap [ordered-tuple recordT])) |