aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source/test/lux/meta/compiler/language/lux/phase/analysis.lux
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source/test/lux/meta/compiler/language/lux/phase/analysis.lux')
-rw-r--r--stdlib/source/test/lux/meta/compiler/language/lux/phase/analysis.lux967
1 files changed, 967 insertions, 0 deletions
diff --git a/stdlib/source/test/lux/meta/compiler/language/lux/phase/analysis.lux b/stdlib/source/test/lux/meta/compiler/language/lux/phase/analysis.lux
new file mode 100644
index 000000000..91614f4b2
--- /dev/null
+++ b/stdlib/source/test/lux/meta/compiler/language/lux/phase/analysis.lux
@@ -0,0 +1,967 @@
+(.require
+ [library
+ [lux (.except)
+ ["_" test (.only Test)]
+ [abstract
+ [monad (.only do)]]
+ [control
+ ["[0]" try]
+ ["[0]" exception]]
+ [data
+ ["[0]" product]
+ ["[0]" text]
+ [collection
+ ["[0]" list]]]
+ [math
+ ["[0]" random]
+ [number
+ ["n" nat]]]
+ [meta
+ ["[0]" code]
+ ["[0]" macro]
+ ["[0]" type (.use "[1]#[0]" equivalence)
+ ["[0]" check]]]]]
+ [\\library
+ ["[0]" / (.only)
+ [//
+ ["[0]" extension (.only)
+ ["[1]/[0]" analysis
+ ["[1]" lux]]]
+ [//
+ ["/[1]" analysis (.only Analysis Operation)
+ [evaluation (.only Eval)]
+ ["[1][0]" macro]
+ ["[1][0]" scope]
+ ["[1][0]" module]
+ ["[1][0]" pattern]
+ ["[1][0]" type (.only)
+ ["$[1]" \\test]]]
+ [///
+ ["[0]" phase (.use "[1]#[0]" monad)]
+ [meta
+ ["[0]" archive]]]]]]]
+ ["[0]" /
+ ["[1][0]" simple]
+ ["[1][0]" complex]
+ ["[1][0]" reference]
+ ["[1][0]" function]
+ ["[1][0]" case]])
+
+(def (eval archive type term)
+ Eval
+ (phase#in []))
+
+(def (expander macro inputs state)
+ //macro.Expander
+ {try.#Success ((macro.function macro) inputs state)})
+
+(def (can_analyse_unit! lux module/0)
+ (-> Lux Text Bit)
+ (let [state [extension.#bundle (extension/analysis.bundle ..eval)
+ extension.#state lux]]
+ (|> (do phase.monad
+ [[:it: it] (|> (' [])
+ (/.phase ..expander archive.empty)
+ //type.inferring)]
+ (in (and (type#= .Any :it:)
+ (case it
+ (//.unit)
+ true
+
+ _
+ false))))
+ //scope.with
+ (//module.with 0 module/0)
+ (phase#each (|>> product.right product.right))
+ (phase.result state)
+ (try.else false))))
+
+(def (can_analyse_simple_literal_or_singleton_tuple! lux module/0 [bit/0 nat/0 int/0 rev/0 frac/0 text/0])
+ (-> Lux Text [.Bit .Nat .Int .Rev .Frac .Text] Bit)
+ (let [state [extension.#bundle (extension/analysis.bundle ..eval)
+ extension.#state lux]]
+ (`` (and (,, (with_template [<expected> <code> <type> <analysis>]
+ [(|> (do phase.monad
+ [[:it: it] (|> <expected>
+ <code>
+ (/.phase ..expander archive.empty)
+ //type.inferring)]
+ (in (and (type#= <type> :it:)
+ (case it
+ (<analysis> it)
+ (same? <expected> it)
+
+ _
+ false))))
+ //scope.with
+ (//module.with 0 module/0)
+ (phase#each (|>> product.right product.right))
+ (phase.result state)
+ (try.else false))]
+
+ [bit/0 code.bit .Bit //.bit]
+ [nat/0 code.nat .Nat //.nat]
+ [int/0 code.int .Int //.int]
+ [rev/0 code.rev .Rev //.rev]
+ [frac/0 code.frac .Frac //.frac]
+ [text/0 code.text .Text //.text]
+
+ ... Singleton tuple
+ [bit/0 (<| code.tuple list code.bit) .Bit //.bit]
+ [nat/0 (<| code.tuple list code.nat) .Nat //.nat]
+ [int/0 (<| code.tuple list code.int) .Int //.int]
+ [rev/0 (<| code.tuple list code.rev) .Rev //.rev]
+ [frac/0 (<| code.tuple list code.frac) .Frac //.frac]
+ [text/0 (<| code.tuple list code.text) .Text //.text]
+ ))
+ ))))
+
+(def (can_analyse_sum! lux module/0 [@any @bit @nat @int @rev @frac @text] [bit/0 nat/0 int/0 rev/0 frac/0 text/0] [@left @right])
+ (-> Lux Text [.Text .Text .Text .Text .Text .Text .Text] [.Bit .Nat .Int .Rev .Frac .Text] [.Text .Text] Bit)
+ (let [state [extension.#bundle (extension/analysis.bundle ..eval)
+ extension.#state lux]
+ :record: (And .Any .Bit .Nat .Int .Rev .Frac .Text)
+ :variant: (Or .Any .Bit .Nat .Int .Rev .Frac .Text)
+
+ can_analyse_unary!
+ (`` (and (|> (do phase.monad
+ [it (|> (code.variant (list (code.nat 0) (code.bit #0) (` [])))
+ (/.phase ..expander archive.empty)
+ (//type.expecting :variant:))]
+ (in (case it
+ (//.variant [0 #0 (//.unit)])
+ true
+
+ _
+ false)))
+ //scope.with
+ (//module.with 0 module/0)
+ (phase#each (|>> product.right product.right))
+ (phase.result state)
+ (try.else false))
+ (,, (with_template [<lefts> <right> <expected> <tag> <code> <analysis>]
+ [(|> (do phase.monad
+ [it (|> (code.variant (list (code.nat <lefts>) (code.bit <right>) (<code> <expected>)))
+ (/.phase ..expander archive.empty)
+ (//type.expecting :variant:))]
+ (in (case it
+ (//.variant [<lefts> <right> (<analysis> actual)])
+ (same? <expected> actual)
+
+ _
+ false)))
+ //scope.with
+ (//module.with 0 module/0)
+ (phase#each (|>> product.right product.right))
+ (phase.result state)
+ (try.else false))]
+
+ [1 #0 bit/0 @bit code.bit //.bit]
+ [2 #0 nat/0 @nat code.nat //.nat]
+ [3 #0 int/0 @int code.int //.int]
+ [4 #0 rev/0 @rev code.rev //.rev]
+ [5 #0 frac/0 @frac code.frac //.frac]
+ [5 #1 text/0 @text code.text //.text]
+ ))))
+
+ can_analyse_nullary!
+ (|> (do phase.monad
+ [.let [:either: (Or .Any :record:)]
+ it (|> (code.variant (list (code.nat 0) (code.bit #0)))
+ (/.phase ..expander archive.empty)
+ (//type.expecting :either:))]
+ (in (case it
+ (//.variant [0 #0 (//.unit)])
+ true
+
+ _
+ false)))
+ //scope.with
+ (//module.with 0 module/0)
+ (phase#each (|>> product.right product.right))
+ (phase.result state)
+ (try.else false))
+
+ can_analyse_multiary!
+ (|> (do phase.monad
+ [.let [:either: (Or .Any :record:)]
+ it (|> (code.variant (list (code.nat 0)
+ (code.bit #1)
+ (` [])
+ (code.bit bit/0)
+ (code.nat nat/0)
+ (code.int int/0)
+ (code.rev rev/0)
+ (code.frac frac/0)
+ (code.text text/0)))
+ (/.phase ..expander archive.empty)
+ (//type.expecting :either:))]
+ (in (case it
+ (//.variant [0 #1 (//.tuple (list (//.unit)
+ (//.bit bit/?)
+ (//.nat nat/?)
+ (//.int int/?)
+ (//.rev rev/?)
+ (//.frac frac/?)
+ (//.text text/?)))])
+ (and (same? bit/0 bit/?)
+ (same? nat/0 nat/?)
+ (same? int/0 int/?)
+ (same? rev/0 rev/?)
+ (same? frac/0 frac/?)
+ (same? text/0 text/?))
+
+ _
+ false)))
+ //scope.with
+ (//module.with 0 module/0)
+ (phase#each (|>> product.right product.right))
+ (phase.result state)
+ (try.else false))]
+ (and can_analyse_unary!
+ can_analyse_nullary!
+ can_analyse_multiary!
+ )))
+
+(def (can_analyse_variant! lux module/0 [@any @bit @nat @int @rev @frac @text] [bit/0 nat/0 int/0 rev/0 frac/0 text/0] [@left @right])
+ (-> Lux Text [.Text .Text .Text .Text .Text .Text .Text] [.Bit .Nat .Int .Rev .Frac .Text] [.Text .Text] Bit)
+ (let [state [extension.#bundle (extension/analysis.bundle ..eval)
+ extension.#state lux]
+ :record: {.#Named [module/0 @text]
+ (type_literal [.Any .Bit .Nat .Int .Rev .Frac .Text])}
+ slots/* (list @any @bit @nat @int @rev @frac @text)
+ :variant: {.#Named [module/0 @text]
+ (type_literal (Or .Any .Bit .Nat .Int .Rev .Frac .Text))}
+ tags/* (list @any @bit @nat @int @rev @frac @text)
+
+ can_analyse_unary!
+ (`` (and (|> (do phase.monad
+ [_ (//module.declare_labels false tags/* false :variant:)
+ [:it: it] (|> (code.variant (list (code.local @any) (` [])))
+ (/.phase ..expander archive.empty)
+ //type.inferring)]
+ (in (and (type#= :variant:
+ :it:)
+ (case it
+ (//.variant [0 #0 (//.unit)])
+ true
+
+ _
+ false))))
+ //scope.with
+ (//module.with 0 module/0)
+ (phase#each (|>> product.right product.right))
+ (phase.result state)
+ (try.else false))
+ (,, (with_template [<lefts> <right> <expected> <tag> <code> <analysis>]
+ [(|> (do phase.monad
+ [_ (//module.declare_labels false tags/* false :variant:)
+ [:it: it] (|> (code.variant (list (code.local <tag>) (<code> <expected>)))
+ (/.phase ..expander archive.empty)
+ //type.inferring)]
+ (in (and (type#= :variant:
+ :it:)
+ (case it
+ (//.variant [<lefts> <right> (<analysis> actual)])
+ (same? <expected> actual)
+
+ _
+ false))))
+ //scope.with
+ (//module.with 0 module/0)
+ (phase#each (|>> product.right product.right))
+ (phase.result state)
+ (try.else false))]
+
+ [1 #0 bit/0 @bit code.bit //.bit]
+ [2 #0 nat/0 @nat code.nat //.nat]
+ [3 #0 int/0 @int code.int //.int]
+ [4 #0 rev/0 @rev code.rev //.rev]
+ [5 #0 frac/0 @frac code.frac //.frac]
+ [5 #1 text/0 @text code.text //.text]
+ ))))
+
+ can_analyse_nullary!
+ (|> (do phase.monad
+ [_ (//module.declare_labels true slots/* false :record:)
+ .let [:either: {.#Named [module/0 module/0]
+ (type_literal (Or .Any :record:))}]
+ _ (//module.declare_labels false (list @left @right) false :either:)
+ [:it: it] (|> (code.variant (list (code.local @left)))
+ (/.phase ..expander archive.empty)
+ //type.inferring)]
+ (in (and (type#= :either:
+ :it:)
+ (case it
+ (//.variant [0 #0 (//.unit)])
+ true
+
+ _
+ false))))
+ //scope.with
+ (//module.with 0 module/0)
+ (phase#each (|>> product.right product.right))
+ (phase.result state)
+ (try.else false))
+
+ can_analyse_multiary!
+ (|> (do phase.monad
+ [_ (//module.declare_labels true slots/* false :record:)
+ .let [:either: {.#Named [module/0 module/0]
+ (type_literal (Or .Any :record:))}]
+ _ (//module.declare_labels false (list @left @right) false :either:)
+ [:it: it] (|> (code.variant (list (code.local @right)
+ (` [])
+ (code.bit bit/0)
+ (code.nat nat/0)
+ (code.int int/0)
+ (code.rev rev/0)
+ (code.frac frac/0)
+ (code.text text/0)))
+ (/.phase ..expander archive.empty)
+ //type.inferring)]
+ (in (and (type#= :either:
+ :it:)
+ (case it
+ (//.variant [0 #1 (//.tuple (list (//.unit)
+ (//.bit bit/?)
+ (//.nat nat/?)
+ (//.int int/?)
+ (//.rev rev/?)
+ (//.frac frac/?)
+ (//.text text/?)))])
+ (and (same? bit/0 bit/?)
+ (same? nat/0 nat/?)
+ (same? int/0 int/?)
+ (same? rev/0 rev/?)
+ (same? frac/0 frac/?)
+ (same? text/0 text/?))
+
+ _
+ false))))
+ //scope.with
+ (//module.with 0 module/0)
+ (phase#each (|>> product.right product.right))
+ (phase.result state)
+ (try.else false))]
+ (and can_analyse_unary!
+ can_analyse_nullary!
+ can_analyse_multiary!)))
+
+(def (can_analyse_tuple! lux module/0 [bit/0 nat/0 int/0 rev/0 frac/0 text/0])
+ (-> Lux Text [.Bit .Nat .Int .Rev .Frac .Text] Bit)
+ (let [state [extension.#bundle (extension/analysis.bundle ..eval)
+ extension.#state lux]]
+ (|> (do phase.monad
+ [[:it: it] (|> (code.tuple (list (` [])
+ (code.bit bit/0)
+ (code.nat nat/0)
+ (code.int int/0)
+ (code.rev rev/0)
+ (code.frac frac/0)
+ (code.text text/0)))
+ (/.phase ..expander archive.empty)
+ //type.inferring)]
+ (in (and (type#= (type_literal [.Any .Bit .Nat .Int .Rev .Frac .Text])
+ :it:)
+ (case it
+ (//.tuple (list (//.unit)
+ (//.bit bit/?)
+ (//.nat nat/?)
+ (//.int int/?)
+ (//.rev rev/?)
+ (//.frac frac/?)
+ (//.text text/?)))
+ (and (same? bit/0 bit/?)
+ (same? nat/0 nat/?)
+ (same? int/0 int/?)
+ (same? rev/0 rev/?)
+ (same? frac/0 frac/?)
+ (same? text/0 text/?))
+
+ _
+ false))))
+ //scope.with
+ (//module.with 0 module/0)
+ (phase#each (|>> product.right product.right))
+ (phase.result state)
+ (try.else false))))
+
+(def (can_analyse_record! lux module/0 [@any @bit @nat @int @rev @frac @text] [bit/0 nat/0 int/0 rev/0 frac/0 text/0])
+ (-> Lux Text [.Text .Text .Text .Text .Text .Text .Text] [.Bit .Nat .Int .Rev .Frac .Text] Bit)
+ (let [state [extension.#bundle (extension/analysis.bundle ..eval)
+ extension.#state lux]
+ :record: {.#Named [module/0 @text]
+ (type_literal [.Any .Bit .Nat .Int .Rev .Frac .Text])}
+ slots/* (list @any @bit @nat @int @rev @frac @text)]
+ (|> (do phase.monad
+ [_ (//module.declare_labels true slots/* false :record:)
+ [:it: it] (|> (code.tuple (list (code.local @text) (code.text text/0)
+ (code.local @bit) (code.bit bit/0)
+ (code.local @rev) (code.rev rev/0)
+ (code.local @int) (code.int int/0)
+ (code.local @nat) (code.nat nat/0)
+ (code.local @frac) (code.frac frac/0)
+ (code.local @any) (` [])))
+ (/.phase ..expander archive.empty)
+ //type.inferring)]
+ (in (and (type#= :record:
+ :it:)
+ (case it
+ (//.tuple (list (//.unit)
+ (//.bit bit/?)
+ (//.nat nat/?)
+ (//.int int/?)
+ (//.rev rev/?)
+ (//.frac frac/?)
+ (//.text text/?)))
+ (and (same? bit/0 bit/?)
+ (same? nat/0 nat/?)
+ (same? int/0 int/?)
+ (same? rev/0 rev/?)
+ (same? frac/0 frac/?)
+ (same? text/0 text/?))
+
+ _
+ false))))
+ //scope.with
+ (//module.with 0 module/0)
+ (phase#each (|>> product.right product.right))
+ (phase.result state)
+ (try.else false))))
+
+(def (can_analyse_function! lux module/0 nat/0 [$abstraction/0 $parameter/0 $abstraction/1 $parameter/1])
+ (-> Lux Text Nat [Code Code Code Code] Bit)
+ (let [state [extension.#bundle (extension/analysis.bundle ..eval)
+ extension.#state lux]
+
+ can_make_abstraction!
+ (|> (do phase.monad
+ [[:it: it] (|> (` ([(, $abstraction/0) (, $parameter/0)] (, (code.nat nat/0))))
+ (/.phase ..expander archive.empty)
+ //type.inferring)]
+ (in (and (type#= (All (_ a) (-> a .Nat))
+ :it:)
+ (case it
+ {//.#Function (list) (//.nat nat/?)}
+ (same? nat/0 nat/?)
+
+ _
+ false))))
+ //scope.with
+ (//module.with 0 module/0)
+ (phase#each (|>> product.right product.right))
+ (phase.result state)
+ (try.else false))
+
+ can_nest_abstraction!
+ (|> (do phase.monad
+ [[:it: it] (|> (` ([(, $abstraction/0) (, $parameter/0)]
+ ([(, $abstraction/1) (, $parameter/1)]
+ (, (code.nat nat/0)))))
+ (/.phase ..expander archive.empty)
+ //type.inferring)]
+ (in (and (type#= (All (_ a) (-> a (All (_ b) (-> b .Nat))))
+ :it:)
+ (case it
+ {//.#Function (list) {//.#Function (list) (//.nat nat/?)}}
+ (same? nat/0 nat/?)
+
+ _
+ false))))
+ //scope.with
+ (//module.with 0 module/0)
+ (phase#each (|>> product.right product.right))
+ (phase.result state)
+ (try.else false))
+
+ can_refer_to_parameter!
+ (|> (do phase.monad
+ [[:it: it] (|> (` ([(, $abstraction/0) (, $parameter/0)]
+ ([(, $abstraction/1) (, $parameter/1)]
+ (, $parameter/1))))
+ (/.phase ..expander archive.empty)
+ //type.inferring)]
+ (in (and (type#= (All (_ a) (-> a (All (_ b) (-> b b))))
+ :it:)
+ (case it
+ {//.#Function (list) {//.#Function (list) (//.local 1)}}
+ true
+
+ _
+ false))))
+ //scope.with
+ (//module.with 0 module/0)
+ (phase#each (|>> product.right product.right))
+ (phase.result state)
+ (try.else false))
+
+ can_refer_to_closure!
+ (|> (do phase.monad
+ [[:it: it] (|> (` ([(, $abstraction/0) (, $parameter/0)]
+ ([(, $abstraction/1) (, $parameter/1)]
+ (, $parameter/0))))
+ (/.phase ..expander archive.empty)
+ //type.inferring)]
+ (in (and (case it
+ {//.#Function (list) {//.#Function (list (//.local 1)) (//.foreign 0)}}
+ true
+
+ _
+ false)
+ ... TODO: Un-comment
+ ... (type#= (All (_ a) (-> a (All (_ b) (-> b a))))
+ ... :it:)
+ )))
+ //scope.with
+ (//module.with 0 module/0)
+ (phase#each (|>> product.right product.right))
+ (phase.result state)
+ (try.else false))]
+ (and can_make_abstraction!
+ can_nest_abstraction!
+ can_refer_to_parameter!
+ can_refer_to_closure!
+ ... TODO: Un-comment
+ ... (|> (do phase.monad
+ ... [[:it: it] (|> (` ([(, $abstraction/0) (, $parameter/0)]
+ ... ([(, $abstraction/1) (, $parameter/1)]
+ ... (, $abstraction/1))))
+ ... (/.phase ..expander archive.empty)
+ ... //type.inferring)]
+ ... (in (case it
+ ... {//.#Function (list) {//.#Function (list) (//.local 0)}}
+ ... true
+
+ ... _
+ ... false)))
+ ... //scope.with
+ ... (//module.with 0 module/0)
+ ... (phase#each (|>> product.right product.right))
+ ... (phase.result state)
+ ... (try.else false))
+ ... TODO: Un-comment
+ ... (|> (do phase.monad
+ ... [[:it: it] (|> (` ([(, $abstraction/0) (, $parameter/0)]
+ ... ([(, $abstraction/1) (, $parameter/1)]
+ ... (, $abstraction/0))))
+ ... (/.phase ..expander archive.empty)
+ ... //type.inferring)]
+ ... (in (case it
+ ... {//.#Function (list) {//.#Function (list (//.local 0)) (//.foreign 0)}}
+ ... true
+
+ ... _
+ ... false)))
+ ... //scope.with
+ ... (//module.with 0 module/0)
+ ... (phase#each (|>> product.right product.right))
+ ... (phase.result state)
+ ... (try.else false))
+ )))
+
+(def (can_analyse_apply! lux module/0 bit/0 nat/0 [$abstraction/0 $parameter/0 $abstraction/1 $parameter/1])
+ (-> Lux Text Bit Nat [Code Code Code Code] Bit)
+ (let [state [extension.#bundle (extension/analysis.bundle ..eval)
+ extension.#state lux]
+
+ constant!
+ (|> (do phase.monad
+ [[:it: it] (|> (` (([(, $abstraction/0) (, $parameter/0)] (, (code.bit bit/0)))
+ (, (code.nat nat/0))))
+ (/.phase ..expander archive.empty)
+ //type.inferring)]
+ (in (and (type#= .Bit :it:)
+ (case it
+ {//.#Apply (//.nat nat/?)
+ {//.#Function (list) (//.bit bit/?)}}
+ (and (same? bit/0 bit/?)
+ (same? nat/0 nat/?))
+
+ _
+ false))))
+ //scope.with
+ (//module.with 0 module/0)
+ (phase#each (|>> product.right product.right))
+ (phase.result state)
+ (try.else false))
+
+ variable!
+ (|> (do phase.monad
+ [[:it: it] (|> (` (([(, $abstraction/0) (, $parameter/0)] (, $parameter/0))
+ (, (code.nat nat/0))))
+ (/.phase ..expander archive.empty)
+ //type.inferring)]
+ (in (and (type#= .Nat :it:)
+ (case it
+ {//.#Apply (//.nat nat/?)
+ {//.#Function (list) (//.local 1)}}
+ (same? nat/0 nat/?)
+
+ _
+ false))))
+ //scope.with
+ (//module.with 0 module/0)
+ (phase#each (|>> product.right product.right))
+ (phase.result state)
+ (try.else false))
+
+ partial!
+ (|> (do phase.monad
+ [[:it: it] (|> (` (([(, $abstraction/0) (, $parameter/0)]
+ ([(, $abstraction/1) (, $parameter/1)]
+ (, (code.bit bit/0))))
+ (, (code.nat nat/0))))
+ (/.phase ..expander archive.empty)
+ //type.inferring)]
+ (in (and (check.subsumes? (All (_ a) (-> a Bit)) :it:)
+ (case it
+ {//.#Apply (//.nat nat/?)
+ {//.#Function (list)
+ {//.#Function (list) (//.bit bit/?)}}}
+ (and (same? bit/0 bit/?)
+ (same? nat/0 nat/?))
+
+ _
+ false))))
+ //scope.with
+ (//module.with 0 module/0)
+ (phase#each (|>> product.right product.right))
+ (phase.result state)
+ (try.else false))]
+ (and constant!
+ variable!
+ partial!)))
+
+(def (can_analyse_extension! lux module/0 text/0)
+ (-> Lux Text Text Bit)
+ (let [state [extension.#bundle (extension/analysis.bundle ..eval)
+ extension.#state lux]]
+ (|> (do phase.monad
+ [[:it: it] (|> (` ("lux text concat" (, (code.text text/0)) (, (code.text text/0))))
+ (/.phase ..expander archive.empty)
+ //type.inferring)]
+ (in (and (type#= .Text :it:)
+ (case it
+ {//.#Extension "lux text concat" (list (//.text left) (//.text right))}
+ (and (same? text/0 left)
+ (same? text/0 right))
+
+ _
+ false))))
+ //scope.with
+ (//module.with 0 module/0)
+ (phase#each (|>> product.right product.right))
+ (phase.result state)
+ (try.else false))))
+
+(def (can_analyse_pattern_matching! lux module/0 [@any @bit @nat @int @rev @frac @text] [bit/0 nat/0 int/0 rev/0 frac/0 text/0] $parameter/0)
+ (-> Lux Text [.Text .Text .Text .Text .Text .Text .Text] [.Bit .Nat .Int .Rev .Frac .Text] Code Bit)
+ (let [state [extension.#bundle (extension/analysis.bundle ..eval)
+ extension.#state lux]
+
+ :variant: {.#Named [module/0 module/0]
+ (type_literal (Or .Any .Bit .Nat .Int .Rev .Frac .Text))}
+ tags/* (list @any @bit @nat @int @rev @frac @text)
+
+ :record: {.#Named [module/0 module/0]
+ (type_literal (And .Any .Bit .Nat .Int .Rev .Frac .Text))}
+ slots/* (list @any @bit @nat @int @rev @frac @text)
+
+ simple!
+ (`` (and (,, (with_template [<input> <code> <analysis> <pattern>]
+ [(|> (do phase.monad
+ [[:it: it] (|> (` ({(, $parameter/0) (, (code.frac frac/0))} (, (<code> <input>))))
+ (/.phase ..expander archive.empty)
+ //type.inferring)]
+ (in (and (type#= .Frac :it:)
+ (case it
+ {//.#Case (<analysis> input/?)
+ [[//.#when (//pattern.bind 0)
+ //.#then (//.frac frac/?)]
+ (list)]}
+ (and (same? <input> input/?)
+ (same? frac/0 frac/?))
+
+ _
+ false))))
+ //scope.with
+ (//module.with 0 module/0)
+ (phase#each (|>> product.right product.right))
+ (phase.result state)
+ (try.else false))
+ (|> (do phase.monad
+ [[:it: it] (|> (` ({(, (<code> <input>))
+ (, (code.frac frac/0))
+
+ (, $parameter/0)
+ (, (code.frac frac/0))}
+ (, (<code> <input>))))
+ (/.phase ..expander archive.empty)
+ //type.inferring)]
+ (in (and (type#= .Frac :it:)
+ (case it
+ {//.#Case (<analysis> input/?)
+ [[//.#when (<pattern> pattern/?)
+ //.#then (//.frac frac/?)]
+ (list [//.#when (//pattern.bind 0)
+ //.#then (//.frac frac/?)])]}
+ (and (same? <input> input/?)
+ (same? <input> pattern/?)
+ (same? frac/0 frac/?))
+
+ _
+ false))))
+ //scope.with
+ (//module.with 0 module/0)
+ (phase#each (|>> product.right product.right))
+ (phase.result state)
+ (try.else false))]
+
+ [bit/0 code.bit //.bit //pattern.bit]
+ [nat/0 code.nat //.nat //pattern.nat]
+ [int/0 code.int //.int //pattern.int]
+ [rev/0 code.rev //.rev //pattern.rev]
+ [frac/0 code.frac //.frac //pattern.frac]
+ [text/0 code.text //.text //pattern.text]
+ ))))
+
+ bit!
+ (|> (do phase.monad
+ [[:it: it] (|> (` ({#0
+ (, (code.frac frac/0))
+
+ #1
+ (, (code.frac frac/0))}
+ (, (code.bit bit/0))))
+ (/.phase ..expander archive.empty)
+ //type.inferring)]
+ (in (and (type#= .Frac :it:)
+ (case it
+ {//.#Case (//.bit bit/?)
+ [[//.#when (//pattern.bit #0)
+ //.#then (//.frac false/?)]
+ (list [//.#when (//pattern.bit #1)
+ //.#then (//.frac true/?)])]}
+ (and (same? bit/0 bit/?)
+ (same? frac/0 false/?)
+ (same? frac/0 true/?))
+
+ _
+ false))))
+ //scope.with
+ (//module.with 0 module/0)
+ (phase#each (|>> product.right product.right))
+ (phase.result state)
+ (try.else false))
+
+ variant!
+ (`` (and (,, (with_template [<lefts> <right?> <expected> <tag> <code> <analysis> <pattern>]
+ [(|> (do phase.monad
+ [_ (//module.declare_labels false tags/* false :variant:)
+ [:it: it] (|> (` ({{(, (code.local <tag>)) (, (<code> <expected>))}
+ (, (code.frac frac/0))
+
+ (, $parameter/0)
+ (, (code.frac frac/0))}
+ {(, (code.local <tag>)) (, (<code> <expected>))}))
+ (/.phase ..expander archive.empty)
+ //type.inferring)]
+ (in (and (type#= .Frac :it:)
+ (case it
+ {//.#Case (//.variant [<lefts> <right?> (<analysis> analysis/?)])
+ [[//.#when (//pattern.variant [<lefts> <right?> (<pattern> pattern/?)])
+ //.#then (//.frac match/?)]
+ (list [//.#when (//pattern.bind 0)
+ //.#then (//.frac mismatch/?)])]}
+ (and (same? <expected> analysis/?)
+ (same? <expected> pattern/?)
+ (same? frac/0 match/?)
+ (same? frac/0 mismatch/?))
+
+ _
+ false))))
+ //scope.with
+ (//module.with 0 module/0)
+ (phase#each (|>> product.right product.right))
+ (phase.result state)
+ (try.else false))]
+
+ [1 #0 bit/0 @bit code.bit //.bit //pattern.bit]
+ [2 #0 nat/0 @nat code.nat //.nat //pattern.nat]
+ [3 #0 int/0 @int code.int //.int //pattern.int]
+ [4 #0 rev/0 @rev code.rev //.rev //pattern.rev]
+ [5 #0 frac/0 @frac code.frac //.frac //pattern.frac]
+ [5 #1 text/0 @text code.text //.text //pattern.text]
+ ))))
+
+ tuple!
+ (|> (do phase.monad
+ [[:it: it] (|> (` ({[#0 (, $parameter/0)]
+ (, (code.frac frac/0))
+
+ [#1 (, $parameter/0)]
+ (, (code.frac frac/0))}
+ [(, (code.bit bit/0))
+ (, (code.nat nat/0))]))
+ (/.phase ..expander archive.empty)
+ //type.inferring)]
+ (in (and (type#= .Frac :it:)
+ (case it
+ {//.#Case (//.tuple (list (//.bit bit/?) (//.nat nat/?)))
+ [[//.#when (//pattern.tuple (list (//pattern.bit #0) (//pattern.bind 0)))
+ //.#then (//.frac false/?)]
+ (list [//.#when (//pattern.tuple (list (//pattern.bit #1) (//pattern.bind 0)))
+ //.#then (//.frac true/?)])]}
+ (and (same? bit/0 bit/?)
+ (same? nat/0 nat/?)
+ (same? frac/0 false/?)
+ (same? frac/0 true/?))
+
+ _
+ false))))
+ //scope.with
+ (//module.with 0 module/0)
+ (phase#each (|>> product.right product.right))
+ (phase.result state)
+ (try.else false))
+
+ record!
+ (|> (do phase.monad
+ [_ (//module.declare_labels true slots/* false :record:)
+ [:it: it] (|> (` ({[(, (code.symbol [module/0 @any])) []
+ (, (code.symbol [module/0 @bit])) (, (code.bit bit/0))
+ (, (code.symbol [module/0 @nat])) (, (code.nat nat/0))
+ (, (code.symbol [module/0 @int])) (, (code.int int/0))
+ (, (code.symbol [module/0 @rev])) (, (code.rev rev/0))
+ (, (code.symbol [module/0 @frac])) (, (code.frac frac/0))
+ (, (code.symbol [module/0 @text])) (, (code.text text/0))]
+ (, (code.frac frac/0))
+
+ (, $parameter/0)
+ (, (code.frac frac/0))}
+ [(, (code.local @any)) []
+ (, (code.local @bit)) (, (code.bit bit/0))
+ (, (code.local @nat)) (, (code.nat nat/0))
+ (, (code.local @int)) (, (code.int int/0))
+ (, (code.local @rev)) (, (code.rev rev/0))
+ (, (code.local @frac)) (, (code.frac frac/0))
+ (, (code.local @text)) (, (code.text text/0))]))
+ (/.phase ..expander archive.empty)
+ //type.inferring)]
+ (in (and (type#= .Frac :it:)
+ (case it
+ {//.#Case (//.tuple (list (//.unit)
+ (//.bit bit/?)
+ (//.nat nat/?)
+ (//.int int/?)
+ (//.rev rev/?)
+ (//.frac frac/?)
+ (//.text text/?)))
+ [[//.#when (//pattern.tuple (list (//pattern.unit)
+ (//pattern.bit bit/?')
+ (//pattern.nat nat/?')
+ (//pattern.int int/?')
+ (//pattern.rev rev/?')
+ (//pattern.frac frac/?')
+ (//pattern.text text/?')))
+ //.#then (//.frac match/?)]
+ (list [//.#when (//pattern.bind 0)
+ //.#then (//.frac mismatch/?)])]}
+ (and (same? bit/0 bit/?) (same? bit/0 bit/?')
+ (same? nat/0 nat/?) (same? nat/0 nat/?')
+ (same? int/0 int/?) (same? int/0 int/?')
+ (same? rev/0 rev/?) (same? rev/0 rev/?')
+ (same? frac/0 frac/?) (same? frac/0 frac/?')
+ (same? text/0 text/?) (same? text/0 text/?')
+ (same? frac/0 match/?)
+ (same? frac/0 mismatch/?))
+
+ _
+ false))))
+ //scope.with
+ (//module.with 0 module/0)
+ (phase#each (|>> product.right product.right))
+ (phase.result state)
+ (try.else false))]
+ (and simple!
+ bit!
+ variant!
+ tuple!
+ record!)))
+
+(def .public test
+ Test
+ (<| (_.covering /._)
+ (do [! random.monad]
+ [lux $//type.random_state
+ .let [state [extension.#bundle (extension/analysis.bundle ..eval)
+ extension.#state lux]]
+
+ .let [[module/0 _] (symbol ._)]
+
+ bit/0 random.bit
+ nat/0 random.nat
+ int/0 random.int
+ rev/0 random.rev
+ frac/0 random.frac
+ text/0 (random.lower_case 1)
+
+ @any (random.lower_case 2)
+ @bit (random.lower_case 3)
+ @nat (random.lower_case 4)
+ @int (random.lower_case 5)
+ @rev (random.lower_case 6)
+ @frac (random.lower_case 7)
+ @text (random.lower_case 8)
+
+ @left (random.lower_case 9)
+ @right (random.lower_case 10)
+
+ $abstraction/0 (at ! each code.local (random.lower_case 11))
+ $parameter/0 (at ! each code.local (random.lower_case 12))
+ $abstraction/1 (at ! each code.local (random.lower_case 13))
+ $parameter/1 (at ! each code.local (random.lower_case 14))])
+ (all _.and
+ (_.coverage [/.phase]
+ (and (..can_analyse_unit! lux module/0)
+ (..can_analyse_simple_literal_or_singleton_tuple! lux module/0 [bit/0 nat/0 int/0 rev/0 frac/0 text/0])
+ (..can_analyse_sum! lux module/0 [@any @bit @nat @int @rev @frac @text] [bit/0 nat/0 int/0 rev/0 frac/0 text/0] [@left @right])
+ (..can_analyse_variant! lux module/0 [@any @bit @nat @int @rev @frac @text] [bit/0 nat/0 int/0 rev/0 frac/0 text/0] [@left @right])
+ (..can_analyse_tuple! lux module/0 [bit/0 nat/0 int/0 rev/0 frac/0 text/0])
+ (..can_analyse_record! lux module/0 [@any @bit @nat @int @rev @frac @text] [bit/0 nat/0 int/0 rev/0 frac/0 text/0])
+ (..can_analyse_function! lux module/0 nat/0 [$abstraction/0 $parameter/0 $abstraction/1 $parameter/1])
+ (..can_analyse_apply! lux module/0 bit/0 nat/0 [$abstraction/0 $parameter/0 $abstraction/1 $parameter/1])
+ (..can_analyse_extension! lux module/0 text/0)
+ (..can_analyse_pattern_matching! lux module/0 [@any @bit @nat @int @rev @frac @text] [bit/0 nat/0 int/0 rev/0 frac/0 text/0] $parameter/0)
+ ))
+ (_.coverage [/.invalid]
+ (`` (and (,, (with_template [<syntax>]
+ [(|> (do phase.monad
+ [_ (|> <syntax>
+ (/.phase ..expander archive.empty)
+ (//type.expecting .Any))]
+ (in false))
+ //scope.with
+ (//module.with 0 module/0)
+ (phase#each (|>> product.right product.right))
+ (phase.result state)
+ (exception.otherwise (text.contains? (the exception.#label /.invalid))))]
+
+ [(` ({#0} (, (code.bit bit/0))))]
+ [(` ({#0 [] #1} (, (code.bit bit/0))))]
+ [(` {(, (code.bit bit/0)) (, (code.nat nat/0)) (, (code.int int/0)) (, (code.rev rev/0)) (, (code.frac frac/0)) (, (code.text text/0))})]
+ [(` {(, (code.nat nat/0)) (, (code.int int/0)) (, (code.rev rev/0)) (, (code.frac frac/0)) (, (code.text text/0)) (, (code.bit bit/0))})]
+ [(` {(, (code.int int/0)) (, (code.rev rev/0)) (, (code.frac frac/0)) (, (code.text text/0)) (, (code.bit bit/0)) (, (code.nat nat/0))})]
+ [(` {(, (code.rev rev/0)) (, (code.frac frac/0)) (, (code.text text/0)) (, (code.bit bit/0)) (, (code.nat nat/0)) (, (code.int int/0))})]
+ [(` {(, (code.frac frac/0)) (, (code.text text/0)) (, (code.bit bit/0)) (, (code.nat nat/0)) (, (code.int int/0)) (, (code.rev rev/0))})]
+ [(` {(, (code.text text/0)) (, (code.bit bit/0)) (, (code.nat nat/0)) (, (code.int int/0)) (, (code.rev rev/0)) (, (code.frac frac/0))})]
+ ))
+ )))
+
+ /simple.test
+ /complex.test
+ /reference.test
+ /function.test
+ /case.test
+ )))
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-28 21:16:06 +0000