aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorEduardo Julian2018-08-15 23:02:09 -0400
committerEduardo Julian2018-08-15 23:02:09 -0400
commit18bb5f90d24376d3731986bf2c16bf6b58dcd3cb (patch)
tree19833a928b8af610291f17faf82ed11a33682e67
parent70152bea7b43320cf5f7f0c4d136664245f25039 (diff)
Fixes for pattern-matching and macro-expansions.
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/compiler/default/phase/analysis.lux10
-rw-r--r--stdlib/source/lux/compiler/default/phase/analysis/case.lux24
-rw-r--r--stdlib/source/lux/compiler/default/phase/analysis/case/coverage.lux141
-rw-r--r--stdlib/source/lux/compiler/default/phase/analysis/expression.lux56
-rw-r--r--stdlib/source/lux/compiler/default/phase/analysis/macro.lux6
-rw-r--r--stdlib/source/lux/compiler/default/phase/statement/total.lux49
-rw-r--r--stdlib/source/lux/interpreter.lux2
7 files changed, 191 insertions, 97 deletions
diff --git a/stdlib/source/lux/compiler/default/phase/analysis.lux b/stdlib/source/lux/compiler/default/phase/analysis.lux
index dde9f4e9a..8ef8324ae 100644
--- a/stdlib/source/lux/compiler/default/phase/analysis.lux
+++ b/stdlib/source/lux/compiler/default/phase/analysis.lux
@@ -132,6 +132,16 @@
(do-template [<name> <tag>]
[(template: #export (<name> content)
+ (.<| #..Reference
+ <tag>
+ content))]
+
+ [variable #reference.Variable]
+ [constant #reference.Constant]
+ )
+
+(do-template [<name> <tag>]
+ [(template: #export (<name> content)
(.<| #Complex
<tag>
content))]
diff --git a/stdlib/source/lux/compiler/default/phase/analysis/case.lux b/stdlib/source/lux/compiler/default/phase/analysis/case.lux
index 0d3536db3..2081ceb61 100644
--- a/stdlib/source/lux/compiler/default/phase/analysis/case.lux
+++ b/stdlib/source/lux/compiler/default/phase/analysis/case.lux
@@ -22,7 +22,7 @@
["/." //
["." extension]]]
[/
- ["." coverage]])
+ ["." coverage (#+ Coverage)]])
(exception: #export (cannot-match-with-pattern {type Type} {pattern Code})
(ex.report ["Type" (%type type)]
@@ -32,19 +32,19 @@
(ex.report ["Case" (%n case)]
["Type" (%type type)]))
-(exception: #export (unrecognized-pattern-syntax {pattern Code})
- (%code pattern))
+(exception: #export (not-a-pattern {code Code})
+ (ex.report ["Code" (%code code)]))
(exception: #export (cannot-simplify-for-pattern-matching {type Type})
- (%type type))
+ (ex.report ["Type" (%type type)]))
-(do-template [<name>]
- [(exception: #export (<name> {message Text})
- message)]
+(exception: #export (non-exhaustive-pattern-matching {input Code} {branches (List [Code Code])} {coverage Coverage})
+ (ex.report ["Input" (%code input)]
+ ["Branches" (%code (code.record branches))]
+ ["Coverage" (coverage.%coverage coverage)]))
- [cannot-have-empty-branches]
- [non-exhaustive-pattern-matching]
- )
+(exception: #export (cannot-have-empty-branches {message Text})
+ message)
(def: (re-quantify envs baseT)
(-> (List (List Type)) Type Type)
@@ -270,7 +270,7 @@
(analyse-pattern (#.Some (list.size group)) inputT (` ((~ (code.nat idx)) (~+ values))) next)))
_
- (///.throw unrecognized-pattern-syntax pattern)
+ (///.throw not-a-pattern pattern)
))
(def: #export (case analyse inputC branches)
@@ -292,7 +292,7 @@
outputTC (monad.map @ (|>> product.left coverage.determine) outputT)
_ (.case (monad.fold error.Monad<Error> coverage.merge outputHC outputTC)
(#error.Success coverage)
- (///.assert non-exhaustive-pattern-matching ""
+ (///.assert non-exhaustive-pattern-matching [inputC branches coverage]
(coverage.exhaustive? coverage))
(#error.Error error)
diff --git a/stdlib/source/lux/compiler/default/phase/analysis/case/coverage.lux b/stdlib/source/lux/compiler/default/phase/analysis/case/coverage.lux
index 6b2f307ac..1f90bdcff 100644
--- a/stdlib/source/lux/compiler/default/phase/analysis/case/coverage.lux
+++ b/stdlib/source/lux/compiler/default/phase/analysis/case/coverage.lux
@@ -7,13 +7,13 @@
[data
[bit ("bit/." Equivalence<Bit>)]
["." number]
- ["e" error ("error/." Monad<Error>)]
+ ["." error (#+ Error) ("error/." Monad<Error>)]
["." maybe]
- [text
+ ["." text
format]
[collection
- ["." list ("list/." Fold<List>)]
- ["dict" dictionary (#+ Dictionary)]]]]
+ ["." list ("list/." Functor<List> Fold<List>)]
+ ["." dictionary (#+ Dictionary)]]]]
["." //// ("operation/." Monad<Operation>)]
["." /// (#+ Pattern Variant Operation)])
@@ -24,6 +24,10 @@
(-> (Maybe Nat) Nat)
(|>> (maybe.default 0)))
+(def: known-cases?
+ (-> Nat Bit)
+ (n/> 0))
+
## The coverage of a pattern-matching expression summarizes how well
## all the possible values of an input are being covered by the
## different patterns involved.
@@ -53,6 +57,36 @@
_
#0))
+(def: #export (%coverage value)
+ (Format Coverage)
+ (case value
+ #Partial
+ "#Partial"
+
+ (#Bit value')
+ (|> value'
+ %b
+ (text.enclose ["(#Bit " ")"]))
+
+ (#Variant ?max-cases cases)
+ (|> cases
+ dictionary.entries
+ (list/map (function (_ [idx coverage])
+ (format (%n idx) " " (%coverage coverage))))
+ (text.join-with " ")
+ (text.enclose ["{" "}"])
+ (format (%n (..cases ?max-cases)) " ")
+ (text.enclose ["(#Variant " ")"]))
+
+ (#Seq left right)
+ (format "(#Seq " (%coverage left) " " (%coverage right) ")")
+
+ (#Alt left right)
+ (format "(#Alt " (%coverage left) " " (%coverage right) ")")
+
+ #Exhaustive
+ "#Exhaustive"))
+
(def: #export (determine pattern)
(-> Pattern (Operation Coverage))
(case pattern
@@ -110,8 +144,8 @@
(wrap (#Variant (if right?
(#.Some idx)
#.None)
- (|> (dict.new number.Hash<Nat>)
- (dict.put idx value-coverage)))))))
+ (|> (dictionary.new number.Hash<Nat>)
+ (dictionary.put idx value-coverage)))))))
(def: (xor left right)
(-> Bit Bit Bit)
@@ -124,9 +158,8 @@
## always be a pattern prior to them that would match the input.
## Because of that, the presence of redundant patterns is assumed to
## be a bug, likely due to programmer carelessness.
-(def: redundant-pattern
- (e.Error Coverage)
- (e.fail "Redundant pattern."))
+(exception: #export (redundant-pattern)
+ "")
(def: (flatten-alt coverage)
(-> Coverage (List Coverage))
@@ -149,7 +182,7 @@
[(#Variant allR casesR) (#Variant allS casesS)]
(and (n/= (cases allR)
(cases allS))
- (:: (dict.Equivalence<Dictionary> =) = casesR casesS))
+ (:: (dictionary.Equivalence<Dictionary> =) = casesR casesS))
[(#Seq leftR rightR) (#Seq leftS rightS)]
(and (= leftR leftS)
@@ -168,16 +201,20 @@
(open: "coverage/." Equivalence<Coverage>)
+(exception: #export (variants-do-not-match {addition-cases Nat} {so-far-cases Nat})
+ (ex.report ["So-far Cases" (%n so-far-cases)]
+ ["Addition Cases" (%n addition-cases)]))
+
## After determining the coverage of each individual pattern, it is
## necessary to merge them all to figure out if the entire
## pattern-matching expression is exhaustive and whether it contains
## redundant patterns.
(def: #export (merge addition so-far)
- (-> Coverage Coverage (e.Error Coverage))
+ (-> Coverage Coverage (Error Coverage))
(case [addition so-far]
## The addition cannot possibly improve the coverage.
[_ #Exhaustive]
- redundant-pattern
+ (ex.throw redundant-pattern [])
## The addition completes the coverage.
[#Exhaustive _]
@@ -192,36 +229,46 @@
(error/wrap #Exhaustive)
[(#Variant allA casesA) (#Variant allSF casesSF)]
- (cond (not (n/= (cases allSF) (cases allA)))
- (e.fail "Variants do not match.")
-
- (:: (dict.Equivalence<Dictionary> Equivalence<Coverage>) = casesSF casesA)
- redundant-pattern
-
- ## else
- (do e.Monad<Error>
- [casesM (monad.fold @
- (function (_ [tagA coverageA] casesSF')
- (case (dict.get tagA casesSF')
- (#.Some coverageSF)
- (do @
- [coverageM (merge coverageA coverageSF)]
- (wrap (dict.put tagA coverageM casesSF')))
-
- #.None
- (wrap (dict.put tagA coverageA casesSF'))))
- casesSF (dict.entries casesA))]
- (wrap (if (let [case-coverages (dict.values casesM)]
- (and (n/= (cases allSF) (list.size case-coverages))
- (list.every? exhaustive? case-coverages)))
- #Exhaustive
- (#Variant allSF casesM)))))
+ (let [addition-cases (cases allSF)
+ so-far-cases (cases allA)]
+ (cond (and (known-cases? addition-cases)
+ (known-cases? so-far-cases)
+ (not (n/= addition-cases so-far-cases)))
+ (ex.throw variants-do-not-match [addition-cases so-far-cases])
+
+ (:: (dictionary.Equivalence<Dictionary> Equivalence<Coverage>) = casesSF casesA)
+ (ex.throw redundant-pattern [])
+
+ ## else
+ (do error.Monad<Error>
+ [casesM (monad.fold @
+ (function (_ [tagA coverageA] casesSF')
+ (case (dictionary.get tagA casesSF')
+ (#.Some coverageSF)
+ (do @
+ [coverageM (merge coverageA coverageSF)]
+ (wrap (dictionary.put tagA coverageM casesSF')))
+
+ #.None
+ (wrap (dictionary.put tagA coverageA casesSF'))))
+ casesSF (dictionary.entries casesA))]
+ (wrap (if (and (n/= (inc (n/max addition-cases so-far-cases))
+ (dictionary.size casesM))
+ (list.every? exhaustive? (dictionary.values casesM)))
+ #Exhaustive
+ (#Variant (case allSF
+ (#.Some _)
+ allSF
+
+ _
+ allA)
+ casesM))))))
[(#Seq leftA rightA) (#Seq leftSF rightSF)]
(case [(coverage/= leftSF leftA) (coverage/= rightSF rightA)]
## There is nothing the addition adds to the coverage.
[#1 #1]
- redundant-pattern
+ (ex.throw redundant-pattern [])
## The 2 sequences cannot possibly be merged.
[#0 #0]
@@ -229,7 +276,7 @@
## Same prefix
[#1 #0]
- (do e.Monad<Error>
+ (do error.Monad<Error>
[rightM (merge rightA rightSF)]
(if (exhaustive? rightM)
## If all that follows is exhaustive, then it can be safely dropped
@@ -240,14 +287,14 @@
## Same suffix
[#0 #1]
- (do e.Monad<Error>
+ (do error.Monad<Error>
[leftM (merge leftA leftSF)]
(wrap (#Seq leftM rightA))))
## The left part will always match, so the addition is redundant.
(^multi [(#Seq left right) single]
(coverage/= left single))
- redundant-pattern
+ (ex.throw redundant-pattern [])
## The right part is not necessary, since it can always match the left.
(^multi [single (#Seq left right)]
@@ -264,10 +311,10 @@
## This process must be repeated until no further productive
## merges can be done.
[_ (#Alt leftS rightS)]
- (do e.Monad<Error>
+ (do error.Monad<Error>
[#let [fuse-once (: (-> Coverage (List Coverage)
- (e.Error [(Maybe Coverage)
- (List Coverage)]))
+ (Error [(Maybe Coverage)
+ (List Coverage)]))
(function (_ coverage possibilities)
(loop [alts possibilities]
(case alts
@@ -276,7 +323,7 @@
(#.Cons alt alts')
(case (merge coverage alt)
- (#e.Success altM)
+ (#error.Success altM)
(case altM
(#Alt _)
(do @
@@ -286,8 +333,8 @@
_
(wrap [(#.Some altM) alts']))
- (#e.Error error)
- (e.fail error))
+ (#error.Error error)
+ (error.fail error))
))))]
[success possibilities] (fuse-once addition (flatten-alt so-far))]
(loop [success success
@@ -311,6 +358,6 @@
_
(if (coverage/= so-far addition)
## The addition cannot possibly improve the coverage.
- redundant-pattern
+ (ex.throw redundant-pattern [])
## There are now 2 alternative paths.
(error/wrap (#Alt so-far addition)))))
diff --git a/stdlib/source/lux/compiler/default/phase/analysis/expression.lux b/stdlib/source/lux/compiler/default/phase/analysis/expression.lux
index c3c3ee619..0f01b48da 100644
--- a/stdlib/source/lux/compiler/default/phase/analysis/expression.lux
+++ b/stdlib/source/lux/compiler/default/phase/analysis/expression.lux
@@ -5,8 +5,10 @@
["ex" exception (#+ exception:)]]
[data
["." error]
- [text
- format]]
+ ["." text
+ format]
+ [collection
+ [list ("list/." Functor<List>)]]]
["." macro]]
["." // (#+ Analysis Operation Phase)
["." type]
@@ -21,16 +23,32 @@
[//
["." reference]]]])
-(exception: #export (macro-expansion-failed {message Text})
- message)
-
-(do-template [<name>]
- [(exception: #export (<name> {code Code})
- (%code code))]
-
- [macro-call-must-have-single-expansion]
- [unrecognized-syntax]
- )
+(exception: #export (macro-expansion-failed {macro Name} {inputs (List Code)} {error Text})
+ (ex.report ["Macro" (%name macro)]
+ ["Inputs" (|> inputs
+ (list/map (|>> %code (format "\n\t")))
+ (text.join-with ""))]
+ ["Error" error]))
+
+(exception: #export (macro-call-must-have-single-expansion {macro Name} {inputs (List Code)})
+ (ex.report ["Macro" (%name macro)]
+ ["Inputs" (|> inputs
+ (list/map (|>> %code (format "\n\t")))
+ (text.join-with ""))]))
+
+(exception: #export (unrecognized-syntax {code Code})
+ (ex.report ["Code" (%code code)]))
+
+(def: #export (expand-macro name macro inputs)
+ (-> Name Macro (List Code) (Operation (List Code)))
+ (extension.lift
+ (function (_ state)
+ (case (//macro.expand macro inputs state)
+ (#error.Error error)
+ ((///.throw macro-expansion-failed [name inputs error]) state)
+
+ output
+ output))))
(def: #export (compile code)
Phase
@@ -103,23 +121,13 @@
(case ?macro
(#.Some macro)
(do @
- [#let [_ (log! (format (%name def-name) " @@@ "
- (%list %code argsC+)))]
- expansion (: (Operation (List Code))
- (extension.lift
- (function (_ state)
- (case (//macro.expand macro argsC+ state)
- (#error.Error error)
- ((///.throw macro-expansion-failed error) state)
-
- output
- output))))]
+ [expansion (expand-macro def-name macro argsC+)]
(case expansion
(^ (list single))
(compile single)
_
- (///.throw macro-call-must-have-single-expansion code)))
+ (///.throw macro-call-must-have-single-expansion [def-name argsC+])))
_
(function.apply compile functionT functionA argsC+)))
diff --git a/stdlib/source/lux/compiler/default/phase/analysis/macro.lux b/stdlib/source/lux/compiler/default/phase/analysis/macro.lux
index c37375805..a674dde07 100644
--- a/stdlib/source/lux/compiler/default/phase/analysis/macro.lux
+++ b/stdlib/source/lux/compiler/default/phase/analysis/macro.lux
@@ -5,7 +5,7 @@
[data
["." error (#+ Error)]
[collection
- ["." array (#+ Array)]]]
+ [array (#+ Array)]]]
["." host (#+ import:)]])
(import: java/lang/reflect/Method
@@ -29,7 +29,7 @@
(def: #export (expand macro inputs)
(-> Macro (List Code) (Meta (List Code)))
- (function (_ compiler)
+ (function (_ state)
(do error.Monad<Error>
[apply-method (|> macro
(:coerce Object)
@@ -38,7 +38,7 @@
output (Method::invoke [(:coerce Object macro)
(|> (host.array Object 2)
(host.array-write 0 (:coerce Object inputs))
- (host.array-write 1 (:coerce Object compiler)))]
+ (host.array-write 1 (:coerce Object state)))]
apply-method)]
(:coerce (Error [Lux (List Code)])
output))))
diff --git a/stdlib/source/lux/compiler/default/phase/statement/total.lux b/stdlib/source/lux/compiler/default/phase/statement/total.lux
index d2b046f5f..967f07294 100644
--- a/stdlib/source/lux/compiler/default/phase/statement/total.lux
+++ b/stdlib/source/lux/compiler/default/phase/statement/total.lux
@@ -1,27 +1,56 @@
(.module:
[lux #*
[control
- [monad (#+ do)]
+ ["." monad (#+ do)]
["ex" exception (#+ exception:)]]
[data
[text
- format]]]
+ format]]
+ ["." macro]]
["." // (#+ Phase)
["/." //
+ ["." analysis
+ ["." expression]
+ ["." type]
+ [macro (#+ expand)]]
["." extension]]])
-(do-template [<name>]
- [(exception: #export (<name> {code Code})
- (ex.report ["Statement" (%code code)]))]
+(exception: #export (not-a-statement {code Code})
+ (ex.report ["Statement" (%code code)]))
- [unrecognized-statement]
- )
+(exception: #export (not-a-macro {code Code})
+ (ex.report ["Code" (%code code)]))
+
+(exception: #export (macro-was-not-found {name Name})
+ (ex.report ["Name" (%name name)]))
(def: #export (phase code)
Phase
(case code
- (^ [_ (#.Form (list& [_ (#.Text extension-name)] extension-args))])
- (extension.apply phase [extension-name extension-args])
+ (^ [_ (#.Form (list& [_ (#.Text name)] inputs))])
+ (extension.apply phase [name inputs])
+
+ (^ [_ (#.Form (list& macro inputs))])
+ (do ///.Monad<Operation>
+ [expansion (//.lift-analysis
+ (do @
+ [macroA (type.with-type Macro
+ (expression.compile macro))]
+ (case macroA
+ (^ (analysis.constant macro-name))
+ (do @
+ [?macro (extension.lift (macro.find-macro macro-name))
+ macro (case ?macro
+ (#.Some macro)
+ (wrap macro)
+
+ #.None
+ (///.throw macro-was-not-found macro-name))]
+ (expression.expand-macro macro-name macro inputs))
+
+ _
+ (///.throw not-a-macro code))))]
+ (monad.map @ phase expansion))
_
- (///.throw unrecognized-statement code)))
+ (///.throw not-a-statement code)))
diff --git a/stdlib/source/lux/interpreter.lux b/stdlib/source/lux/interpreter.lux
index 2feb4b81c..36cef324d 100644
--- a/stdlib/source/lux/interpreter.lux
+++ b/stdlib/source/lux/interpreter.lux
@@ -131,7 +131,7 @@
(#error.Success [state' output])
(#error.Error error)
- (if (ex.match? total.unrecognized-statement error)
+ (if (ex.match? total.not-a-statement error)
(<| (phase.run' state)
(:share [anchor expression statement]
{(State+ anchor expression statement)