diff options
| author | Eduardo Julian | 2018-06-17 22:27:40 -0400 | 
|---|---|---|
| committer | Eduardo Julian | 2018-06-17 22:27:40 -0400 | 
| commit | b7b0dd9bd952ede4710da157b40304d714229e04 (patch) | |
| tree | 26362697e783723fc5da52dad5369b714d6579fe /stdlib/source/lux/lang | |
| parent | b6ccfc87c52e1a98ead3b04b45bccc119418a4dc (diff) | |
- Heavy refactoring to integrate extensions better with the rest of the compiler.
Diffstat (limited to '')
| -rw-r--r-- | stdlib/source/lux/lang.lux | 112 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/analysis/expression.lux | 122 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/compiler.lux | 57 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/compiler/analysis.lux (renamed from stdlib/source/lux/lang/analysis.lux) | 92 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/compiler/analysis/case.lux (renamed from stdlib/source/lux/lang/analysis/case.lux) | 159 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/compiler/analysis/case/coverage.lux (renamed from stdlib/source/lux/lang/analysis/case/coverage.lux) | 55 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/compiler/analysis/expression.lux | 121 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/compiler/analysis/function.lux (renamed from stdlib/source/lux/lang/analysis/function.lux) | 45 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/compiler/analysis/inference.lux (renamed from stdlib/source/lux/lang/analysis/inference.lux) | 126 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/compiler/analysis/primitive.lux (renamed from stdlib/source/lux/lang/analysis/primitive.lux) | 0 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/compiler/analysis/reference.lux (renamed from stdlib/source/lux/lang/analysis/reference.lux) | 25 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/compiler/analysis/structure.lux (renamed from stdlib/source/lux/lang/analysis/structure.lux) | 148 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/compiler/analysis/type.lux (renamed from stdlib/source/lux/lang/analysis/type.lux) | 47 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/compiler/extension.lux | 68 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/compiler/extension/analysis.lux (renamed from stdlib/source/lux/lang/extension/analysis.lux) | 4 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/compiler/extension/analysis/common.lux | 396 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/compiler/extension/analysis/host.jvm.lux (renamed from stdlib/source/lux/lang/extension/analysis/host.jvm.lux) | 0 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/compiler/extension/bundle.lux | 31 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/compiler/extension/synthesis.lux (renamed from stdlib/source/lux/lang/extension/synthesis.lux) | 0 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/compiler/extension/translation.lux (renamed from stdlib/source/lux/lang/extension/translation.lux) | 0 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/compiler/init.lux | 51 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/compiler/synthesis.lux (renamed from stdlib/source/lux/lang/synthesis.lux) | 30 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/compiler/synthesis/case.lux (renamed from stdlib/source/lux/lang/synthesis/case.lux) | 0 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/compiler/synthesis/expression.lux (renamed from stdlib/source/lux/lang/synthesis/expression.lux) | 0 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/compiler/synthesis/function.lux (renamed from stdlib/source/lux/lang/synthesis/function.lux) | 0 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/compiler/synthesis/loop.lux (renamed from stdlib/source/lux/lang/synthesis/loop.lux) | 0 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/compiler/translation.lux (renamed from stdlib/source/lux/lang/translation.lux) | 0 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/compiler/translation/scheme/case.jvm.lux (renamed from stdlib/source/lux/lang/translation/scheme/case.jvm.lux) | 0 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/compiler/translation/scheme/expression.jvm.lux (renamed from stdlib/source/lux/lang/translation/scheme/expression.jvm.lux) | 0 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/compiler/translation/scheme/extension.jvm.lux (renamed from stdlib/source/lux/lang/translation/scheme/extension.jvm.lux) | 0 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/compiler/translation/scheme/extension/common.jvm.lux (renamed from stdlib/source/lux/lang/translation/scheme/extension/common.jvm.lux) | 0 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/compiler/translation/scheme/function.jvm.lux (renamed from stdlib/source/lux/lang/translation/scheme/function.jvm.lux) | 0 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/compiler/translation/scheme/loop.jvm.lux (renamed from stdlib/source/lux/lang/translation/scheme/loop.jvm.lux) | 0 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/compiler/translation/scheme/primitive.jvm.lux (renamed from stdlib/source/lux/lang/translation/scheme/primitive.jvm.lux) | 0 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/compiler/translation/scheme/reference.jvm.lux (renamed from stdlib/source/lux/lang/translation/scheme/reference.jvm.lux) | 0 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/compiler/translation/scheme/runtime.jvm.lux (renamed from stdlib/source/lux/lang/translation/scheme/runtime.jvm.lux) | 0 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/compiler/translation/scheme/structure.jvm.lux (renamed from stdlib/source/lux/lang/translation/scheme/structure.jvm.lux) | 0 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/extension.lux | 131 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/extension/analysis/common.lux | 444 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/host.lux (renamed from stdlib/source/lux/lang/target.lux) | 4 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/init.lux | 61 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/module.lux | 51 | 
42 files changed, 1146 insertions, 1234 deletions
| diff --git a/stdlib/source/lux/lang.lux b/stdlib/source/lux/lang.lux index 322b9f655..bc6e2c9ec 100644 --- a/stdlib/source/lux/lang.lux +++ b/stdlib/source/lux/lang.lux @@ -1,17 +1,5 @@  (.module: -  lux -  (lux (control [monad #+ do] -                ["ex" exception #+ exception:]) -       (data [product] -             ["e" error] -             [text "text/" Eq<Text>] -             text/format) -       [macro] -       (macro ["s" syntax #+ syntax:]))) - -(type: #export (Extension e) -  {#name Text -   #parameters (List e)}) +  lux)  (type: #export Eval    (-> Type Code (Meta Any))) @@ -19,101 +7,3 @@  (type: #export Version Text)  (def: #export version Version "0.6.0") - -(def: #export (fail message) -  (All [a] (-> Text (Meta a))) -  (do macro.Monad<Meta> -    [[file line col] macro.cursor -     #let [location (format file -                            "," (|> line .int %i) -                            "," (|> col .int %i))]] -    (macro.fail (format message "\n\n" -                        "@ " location)))) - -(def: #export (throw exception message) -  (All [e a] (-> (ex.Exception e) e (Meta a))) -  (fail (ex.construct exception message))) - -(syntax: #export (assert exception message test) -  (wrap (list (` (if (~ test) -                   (:: macro.Monad<Meta> (~' wrap) []) -                   (..throw (~ exception) (~ message))))))) - -(def: #export (with-source-code source action) -  (All [a] (-> Source (Meta a) (Meta a))) -  (function (_ compiler) -    (let [old-source (get@ #.source compiler)] -      (case (action (set@ #.source source compiler)) -        (#e.Error error) -        (#e.Error error) - -        (#e.Success [compiler' output]) -        (#e.Success [(set@ #.source old-source compiler') -                     output]))))) - -(def: #export (with-stacked-errors handler action) -  (All [a] (-> (-> [] Text) (Meta a) (Meta a))) -  (function (_ compiler) -    (case (action compiler) -      (#e.Success [compiler' output]) -      (#e.Success [compiler' output]) - -      (#e.Error error) -      (#e.Error (if (text/= "" error) -                  (handler []) -                  (format (handler []) "\n\n-----------------------------------------\n\n" error)))))) - -(def: fresh-bindings -  (All [k v] (Bindings k v)) -  {#.counter +0 -   #.mappings (list)}) - -(def: fresh-scope -  Scope -  {#.name     (list) -   #.inner    +0 -   #.locals   fresh-bindings -   #.captured fresh-bindings}) - -(def: #export (with-scope action) -  (All [a] (-> (Meta a) (Meta [Scope a]))) -  (function (_ compiler) -    (case (action (update@ #.scopes (|>> (#.Cons fresh-scope)) compiler)) -      (#e.Success [compiler' output]) -      (case (get@ #.scopes compiler') -        #.Nil -        (#e.Error "Impossible error: Drained scopes!") - -        (#.Cons head tail) -        (#e.Success [(set@ #.scopes tail compiler') -                     [head output]])) - -      (#e.Error error) -      (#e.Error error)))) - -(def: #export (with-current-module name action) -  (All [a] (-> Text (Meta a) (Meta a))) -  (function (_ compiler) -    (case (action (set@ #.current-module (#.Some name) compiler)) -      (#e.Success [compiler' output]) -      (#e.Success [(set@ #.current-module -                         (get@ #.current-module compiler) -                         compiler') -                   output]) - -      (#e.Error error) -      (#e.Error error)))) - -(def: #export (with-cursor cursor action) -  (All [a] (-> Cursor (Meta a) (Meta a))) -  (if (text/= "" (product.left cursor)) -    action -    (function (_ compiler) -      (let [old-cursor (get@ #.cursor compiler)] -        (case (action (set@ #.cursor cursor compiler)) -          (#e.Success [compiler' output]) -          (#e.Success [(set@ #.cursor old-cursor compiler') -                       output]) - -          (#e.Error error) -          (#e.Error error)))))) diff --git a/stdlib/source/lux/lang/analysis/expression.lux b/stdlib/source/lux/lang/analysis/expression.lux deleted file mode 100644 index 325394e73..000000000 --- a/stdlib/source/lux/lang/analysis/expression.lux +++ /dev/null @@ -1,122 +0,0 @@ -(.module: -  lux -  (lux (control [monad #+ do] -                ["ex" exception #+ exception:]) -       (data ["e" error] -             [product] -             text/format) -       [macro] -       [lang #+ Eval] -       (lang [type] -             (type ["tc" check]) -             [".L" analysis #+ Analysis Analyser] -             (analysis [".A" type] -                       [".A" primitive] -                       [".A" structure] -                       [".A" reference]) -             ## [".L" macro] -             [".L" extension]))) - -(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] -  ) - -(def: #export (analyser eval) -  (-> Eval Analyser) -  (: (-> Code (Meta Analysis)) -     (function (analyse code) -       (do macro.Monad<Meta> -         [expectedT macro.expected-type] -         (let [[cursor code'] code] -           ## The cursor must be set in the compiler for the sake -           ## of having useful error messages. -           (lang.with-cursor cursor -             (case code' -               (^template [<tag> <analyser>] -                 (<tag> value) -                 (<analyser> value)) -               ([#.Bool primitiveA.bool] -                [#.Nat  primitiveA.nat] -                [#.Int  primitiveA.int] -                [#.Deg  primitiveA.deg] -                [#.Frac primitiveA.frac] -                [#.Text primitiveA.text]) - -               (^template [<tag> <analyser>] -                 (^ (#.Form (list& [_ (<tag> tag)] -                                   values))) -                 (case values -                   (#.Cons value #.Nil) -                   (<analyser> analyse tag value) - -                   _ -                   (<analyser> analyse tag (` [(~+ values)])))) -               ([#.Nat structureA.sum] -                [#.Tag structureA.tagged-sum]) - -               (#.Tag tag) -               (structureA.tagged-sum analyse tag (' [])) - -               (^ (#.Tuple (list))) -               primitiveA.unit - -               (^ (#.Tuple (list singleton))) -               (analyse singleton) - -               (^ (#.Tuple elems)) -               (structureA.product analyse elems) - -               (^ (#.Record pairs)) -               (structureA.record analyse pairs) - -               (#.Symbol reference) -               (referenceA.reference reference) - -               (^ (#.Form (list& [_ (#.Text proc-name)] proc-args))) -               (do macro.Monad<Meta> -                 [procedure (extensionL.find-analysis proc-name)] -                 (procedure analyse eval proc-args)) - -               ## (^ (#.Form (list& func args))) -               ## (do macro.Monad<Meta> -               ##   [[funcT funcA] (typeA.with-inference -               ##                    (analyse func))] -               ##   (case funcA -               ##     [_ (#.Symbol def-name)] -               ##     (do @ -               ##       [?macro (lang.with-error-tracking -               ##                 (macro.find-macro def-name))] -               ##       (case ?macro -               ##         (#.Some macro) -               ##         (do @ -               ##           [expansion (: (Meta (List Code)) -               ##                         (function (_ compiler) -               ##                           (case (macroL.expand macro args compiler) -               ##                             (#e.Error error) -               ##                             ((lang.throw macro-expansion-failed error) compiler) - -               ##                             output -               ##                             output)))] -               ##           (case expansion -               ##             (^ (list single)) -               ##             (analyse single) - -               ##             _ -               ##             (lang.throw macro-call-must-have-single-expansion code))) - -               ##         _ -               ##         (functionA.analyse-apply analyse funcT funcA args))) - -               ##     _ -               ##     (functionA.analyse-apply analyse funcT funcA args))) - -               _ -               (lang.throw unrecognized-syntax code) -               ))))))) diff --git a/stdlib/source/lux/lang/compiler.lux b/stdlib/source/lux/lang/compiler.lux index c2f9af1e2..20278a6cd 100644 --- a/stdlib/source/lux/lang/compiler.lux +++ b/stdlib/source/lux/lang/compiler.lux @@ -4,12 +4,21 @@                  ["ex" exception #+ Exception exception:]                  [monad #+ do])         (data [product] -             [error #+ Error]) -       [function])) +             [error #+ Error] +             [text] +             text/format) +       [function] +       (macro ["s" syntax #+ syntax:])))  (type: #export (Operation s o)    (state.State' Error s o)) +(def: #export Monad<Operation> +  (state.Monad<State'> error.Monad<Error>)) + +(type: #export (Compiler s i o) +  (-> i (Operation s o))) +  (def: #export (run state operation)    (All [s o]      (-> s (Operation s o) (Error o))) @@ -17,11 +26,20 @@        operation        (:: error.Monad<Error> map product.right))) +(def: #export fail +  (-> Text Operation) +  (|>> error.fail (state.lift error.Monad<Error>))) +  (def: #export (throw exception parameters)    (All [e] (-> (Exception e) e Operation))    (state.lift error.Monad<Error>                (ex.throw exception parameters))) +(syntax: #export (assert exception message test) +  (wrap (list (` (if (~ test) +                   (:: ..Monad<Operation> (~' wrap) []) +                   (..throw (~ exception) (~ message))))))) +  (def: #export (localized transform)    (All [s o]      (-> (-> s s) @@ -39,8 +57,35 @@    (All [s o] (-> s (-> (Operation s o) (Operation s o))))    (localized (function.constant state))) -(def: #export Monad<Operation> -  (state.Monad<State'> error.Monad<Error>)) +(def: error-separator +  (format "\n\n" +          "-----------------------------------------" +          "\n\n")) -(type: #export (Compiler s i o) -  (-> i (Operation s o))) +(def: #export (with-stacked-errors handler action) +  (All [s o] (-> (-> [] Text) (Operation s o) (Operation s o))) +  (function (_ state) +    (case (action state) +      (#error.Error error) +      (#error.Error (if (text.empty? error) +                      (handler []) +                      (format (handler []) error-separator error))) + +      success +      success))) + +(def: #export identity +  (All [s a] (Compiler s a a)) +  (function (_ input state) +    (#error.Success [state input]))) + +(def: #export (compose pre post) +  (All [s0 s1 i t o] +    (-> (Compiler s0 i t) +        (Compiler s1 t o) +        (Compiler [s0 s1] i o))) +  (function (_ input [pre/state post/state]) +    (do error.Monad<Error> +      [[pre/state' temp] (pre input pre/state) +       [post/state' output] (post temp post/state)] +      (wrap [[pre/state' post/state'] output])))) diff --git a/stdlib/source/lux/lang/analysis.lux b/stdlib/source/lux/lang/compiler/analysis.lux index 6efa934d8..235e399fb 100644 --- a/stdlib/source/lux/lang/analysis.lux +++ b/stdlib/source/lux/lang/compiler/analysis.lux @@ -1,9 +1,12 @@  (.module:    [lux #- nat int deg] -  (lux [function] -       (data (coll [list "list/" Fold<List>]))) -  [// #+ Extension] -  [//reference #+ Register Variable Reference]) +  (lux (data [product] +             [error] +             [text "text/" Eq<Text>] +             (coll [list "list/" Fold<List>])) +       [function]) +  [///reference #+ Register Variable Reference] +  [//])  (type: #export #rec Primitive    #Unit @@ -41,8 +44,13 @@    (#Reference Reference)    (#Case Analysis (Match' Analysis))    (#Function Environment Analysis) -  (#Apply Analysis Analysis) -  (#Extension (Extension Analysis))) +  (#Apply Analysis Analysis)) + +(type: #export Operation +  (//.Operation .Lux)) + +(type: #export Compiler +  (//.Compiler .Lux Code Analysis))  (type: #export Branch    (Branch' Analysis)) @@ -88,7 +96,7 @@    (n/= (dec size) tag))  (template: #export (no-op value) -  (|> +1 #//reference.Local #//reference.Variable #..Reference +  (|> +1 #///reference.Local #///reference.Variable #..Reference        (#..Function (list))        (#..Apply value))) @@ -138,9 +146,6 @@    (-> (Application Analysis) Analysis)    (list/fold (function (_ arg func) (#Apply arg func)) func args)) -(type: #export Analyser -  (-> Code (Meta Analysis))) -  (do-template [<name> <type> <tag>]    [(def: #export (<name> value)       (-> <type> (Tuple <type>)) @@ -207,3 +212,70 @@    [pattern/frac #..Frac]    [pattern/text #..Text]    ) + +(def: #export (with-source-code source action) +  (All [a] (-> Source (Operation a) (Operation a))) +  (function (_ compiler) +    (let [old-source (get@ #.source compiler)] +      (case (action (set@ #.source source compiler)) +        (#error.Error error) +        (#error.Error error) + +        (#error.Success [compiler' output]) +        (#error.Success [(set@ #.source old-source compiler') +                         output]))))) + +(def: fresh-bindings +  (All [k v] (Bindings k v)) +  {#.counter +0 +   #.mappings (list)}) + +(def: fresh-scope +  Scope +  {#.name     (list) +   #.inner    +0 +   #.locals   fresh-bindings +   #.captured fresh-bindings}) + +(def: #export (with-scope action) +  (All [a] (-> (Operation a) (Operation [Scope a]))) +  (function (_ compiler) +    (case (action (update@ #.scopes (|>> (#.Cons fresh-scope)) compiler)) +      (#error.Success [compiler' output]) +      (case (get@ #.scopes compiler') +        #.Nil +        (#error.Error "Impossible error: Drained scopes!") + +        (#.Cons head tail) +        (#error.Success [(set@ #.scopes tail compiler') +                         [head output]])) + +      (#error.Error error) +      (#error.Error error)))) + +(def: #export (with-current-module name action) +  (All [a] (-> Text (Operation a) (Operation a))) +  (function (_ compiler) +    (case (action (set@ #.current-module (#.Some name) compiler)) +      (#error.Success [compiler' output]) +      (#error.Success [(set@ #.current-module +                             (get@ #.current-module compiler) +                             compiler') +                       output]) + +      (#error.Error error) +      (#error.Error error)))) + +(def: #export (with-cursor cursor action) +  (All [a] (-> Cursor (Operation a) (Operation a))) +  (if (text/= "" (product.left cursor)) +    action +    (function (_ compiler) +      (let [old-cursor (get@ #.cursor compiler)] +        (case (action (set@ #.cursor cursor compiler)) +          (#error.Success [compiler' output]) +          (#error.Success [(set@ #.cursor old-cursor compiler') +                           output]) + +          (#error.Error error) +          (#error.Error error)))))) diff --git a/stdlib/source/lux/lang/analysis/case.lux b/stdlib/source/lux/lang/compiler/analysis/case.lux index 744d3cf24..9e67a24f9 100644 --- a/stdlib/source/lux/lang/analysis/case.lux +++ b/stdlib/source/lux/lang/compiler/analysis/case.lux @@ -1,27 +1,22 @@  (.module:    [lux #- case]    (lux (control [monad #+ do] -                ["ex" exception #+ exception:] -                [equality #+ Eq]) -       (data [bool] -             [number] -             [product] -             ["e" error] +                ["ex" exception #+ exception:]) +       (data [product] +             [error]               [maybe] -             [text]               text/format               (coll [list "list/" Fold<List> Monoid<List> Functor<List>])) -       [function]         [macro] -       (macro [code]) -       [lang] -       (lang [type] -             (type ["tc" check]) -             [".L" scope] -             [".L" analysis #+ Pattern Analysis Analyser] -             (analysis [".A" type] -                       [".A" structure] -                       (case [".A" coverage]))))) +       (macro [code])) +  (//// [type] +        (type ["tc" check]) +        [scope]) +  [///] +  [// #+ Pattern Analysis Operation Compiler] +  [//type] +  [//structure] +  [/coverage])  (exception: #export (cannot-match-type-with-pattern {type Type} {pattern Code})    (ex.report ["Type" (%type type)] @@ -62,21 +57,21 @@  ## This function makes it easier for "case" analysis to properly  ## type-check the input with respect to the patterns.  (def: (simplify-case-type caseT) -  (-> Type (Meta Type)) +  (-> Type (Operation Type))    (loop [envs (: (List (List Type))                   (list))           caseT caseT]      (.case caseT        (#.Var id) -      (do macro.Monad<Meta> -        [?caseT' (typeA.with-env +      (do ///.Monad<Operation> +        [?caseT' (//type.with-env                     (tc.read id))]          (.case ?caseT'            (#.Some caseT')            (recur envs caseT')            _ -          (lang.throw cannot-simplify-type-for-pattern-matching caseT))) +          (///.throw cannot-simplify-type-for-pattern-matching caseT)))        (#.Named name unnamedT)        (recur envs unnamedT) @@ -85,16 +80,16 @@        (recur (#.Cons env envs) unquantifiedT)        (#.ExQ _) -      (do macro.Monad<Meta> -        [[ex-id exT] (typeA.with-env +      (do ///.Monad<Operation> +        [[ex-id exT] (//type.with-env                         tc.existential)]          (recur envs (maybe.assume (type.apply (list exT) caseT))))        (#.Apply inputT funcT)        (.case funcT          (#.Var funcT-id) -        (do macro.Monad<Meta> -          [funcT' (typeA.with-env +        (do ///.Monad<Operation> +          [funcT' (//type.with-env                      (do tc.Monad<Check>                        [?funct' (tc.read funcT-id)]                        (.case ?funct' @@ -111,23 +106,23 @@            (recur envs outputT)            #.None -          (lang.throw cannot-simplify-type-for-pattern-matching caseT))) +          (///.throw cannot-simplify-type-for-pattern-matching caseT)))        (#.Product _)        (|> caseT            type.flatten-tuple            (list/map (re-quantify envs))            type.tuple -          (:: macro.Monad<Meta> wrap)) +          (:: ///.Monad<Operation> wrap))        _ -      (:: macro.Monad<Meta> wrap (re-quantify envs caseT))))) +      (:: ///.Monad<Operation> wrap (re-quantify envs caseT)))))  (def: (analyse-primitive type inputT cursor output next) -  (All [a] (-> Type Type Cursor Pattern (Meta a) (Meta [Pattern a]))) -  (lang.with-cursor cursor -    (do macro.Monad<Meta> -      [_ (typeA.with-env +  (All [a] (-> Type Type Cursor Pattern (Operation a) (Operation [Pattern a]))) +  (//.with-cursor cursor +    (do ///.Monad<Operation> +      [_ (//type.with-env             (tc.check inputT type))         outputA next]        (wrap [output outputA])))) @@ -149,33 +144,33 @@  ## That is why the body must be analysed in the context of the  ## pattern, and not separately.  (def: (analyse-pattern num-tags inputT pattern next) -  (All [a] (-> (Maybe Nat) Type Code (Meta a) (Meta [Pattern a]))) +  (All [a] (-> (Maybe Nat) Type Code (Operation a) (Operation [Pattern a])))    (.case pattern      [cursor (#.Symbol ["" name])] -    (lang.with-cursor cursor -      (do macro.Monad<Meta> -        [outputA (scopeL.with-local [name inputT] +    (//.with-cursor cursor +      (do ///.Monad<Operation> +        [outputA (scope.with-local [name inputT]                     next) -         idx scopeL.next-local] -        (wrap [(#analysisL.Bind idx) outputA]))) +         idx scope.next-local] +        (wrap [(#//.Bind idx) outputA])))      (^template [<type> <input> <output>]        [cursor <input>] -      (analyse-primitive <type> inputT cursor (#analysisL.Simple <output>) next)) -    ([Bool (#.Bool pattern-value) (#analysisL.Bool pattern-value)] -     [Nat  (#.Nat pattern-value)  (#analysisL.Nat pattern-value)] -     [Int  (#.Int pattern-value)  (#analysisL.Int pattern-value)] -     [Deg  (#.Deg pattern-value)  (#analysisL.Deg pattern-value)] -     [Frac (#.Frac pattern-value) (#analysisL.Frac pattern-value)] -     [Text (#.Text pattern-value) (#analysisL.Text pattern-value)] -     [Any  (#.Tuple #.Nil)        #analysisL.Unit]) +      (analyse-primitive <type> inputT cursor (#//.Simple <output>) next)) +    ([Bool (#.Bool pattern-value) (#//.Bool pattern-value)] +     [Nat  (#.Nat pattern-value)  (#//.Nat pattern-value)] +     [Int  (#.Int pattern-value)  (#//.Int pattern-value)] +     [Deg  (#.Deg pattern-value)  (#//.Deg pattern-value)] +     [Frac (#.Frac pattern-value) (#//.Frac pattern-value)] +     [Text (#.Text pattern-value) (#//.Text pattern-value)] +     [Any  (#.Tuple #.Nil)        #//.Unit])      (^ [cursor (#.Tuple (list singleton))])      (analyse-pattern #.None inputT singleton next)      [cursor (#.Tuple sub-patterns)] -    (lang.with-cursor cursor -      (do macro.Monad<Meta> +    (//.with-cursor cursor +      (do ///.Monad<Operation>          [inputT' (simplify-case-type inputT)]          (.case inputT'            (#.Product _) @@ -195,11 +190,11 @@                                (list.zip2 sub-types sub-patterns))]              (do @                [[memberP+ thenA] (list/fold (: (All [a] -                                                (-> [Type Code] (Meta [(List Pattern) a]) -                                                    (Meta [(List Pattern) a]))) +                                                (-> [Type Code] (Operation [(List Pattern) a]) +                                                    (Operation [(List Pattern) a])))                                                (function (_ [memberT memberC] then)                                                  (do @ -                                                  [[memberP [memberP+ thenA]] ((:! (All [a] (-> (Maybe Nat) Type Code (Meta a) (Meta [Pattern a]))) +                                                  [[memberP [memberP+ thenA]] ((:! (All [a] (-> (Maybe Nat) Type Code (Operation a) (Operation [Pattern a])))                                                                                     analyse-pattern)                                                                                 #.None memberT memberC then)]                                                    (wrap [(list& memberP memberP+) thenA])))) @@ -207,28 +202,28 @@                                               [nextA next]                                               (wrap [(list) nextA]))                                             (list.reverse matches))] -              (wrap [(analysisL.product-pattern memberP+) +              (wrap [(//.product-pattern memberP+)                       thenA])))            _ -          (lang.throw cannot-match-type-with-pattern [inputT pattern]) +          (///.throw cannot-match-type-with-pattern [inputT pattern])            )))      [cursor (#.Record record)] -    (do macro.Monad<Meta> -      [record (structureA.normalize record) -       [members recordT] (structureA.order record) -       _ (typeA.with-env +    (do ///.Monad<Operation> +      [record (//structure.normalize record) +       [members recordT] (//structure.order record) +       _ (//type.with-env             (tc.check inputT recordT))]        (analyse-pattern (#.Some (list.size members)) inputT [cursor (#.Tuple members)] next))      [cursor (#.Tag tag)] -    (lang.with-cursor cursor +    (//.with-cursor cursor        (analyse-pattern #.None inputT (` ((~ pattern))) next))      (^ [cursor (#.Form (list& [_ (#.Nat idx)] values))]) -    (lang.with-cursor cursor -      (do macro.Monad<Meta> +    (//.with-cursor cursor +      (do ///.Monad<Operation>          [inputT' (simplify-case-type inputT)]          (.case inputT'            (#.Sum _) @@ -238,7 +233,7 @@              (.case (list.nth idx flat-sum)                (^multi (#.Some case-type)                        (n/< num-cases idx)) -              (do macro.Monad<Meta> +              (do ///.Monad<Operation>                  [[testP nextA] (if (and (n/> num-cases size-sum)                                          (n/= (dec num-cases) idx))                                   (analyse-pattern #.None @@ -246,50 +241,50 @@                                                    (` [(~+ values)])                                                    next)                                   (analyse-pattern #.None case-type (` [(~+ values)]) next))] -                (wrap [(analysisL.sum-pattern num-cases idx testP) +                (wrap [(//.sum-pattern num-cases idx testP)                         nextA]))                _ -              (lang.throw sum-type-has-no-case [idx inputT]))) +              (///.throw sum-type-has-no-case [idx inputT])))            _ -          (lang.throw cannot-match-type-with-pattern [inputT pattern])))) +          (///.throw cannot-match-type-with-pattern [inputT pattern]))))      (^ [cursor (#.Form (list& [_ (#.Tag tag)] values))]) -    (lang.with-cursor cursor -      (do macro.Monad<Meta> +    (//.with-cursor cursor +      (do ///.Monad<Operation>          [tag (macro.normalize tag)           [idx group variantT] (macro.resolve-tag tag) -         _ (typeA.with-env +         _ (//type.with-env               (tc.check inputT variantT))]          (analyse-pattern (#.Some (list.size group)) inputT (` ((~ (code.nat idx)) (~+ values))) next)))      _ -    (lang.throw unrecognized-pattern-syntax pattern) +    (///.throw unrecognized-pattern-syntax pattern)      ))  (def: #export (case analyse inputC branches) -  (-> Analyser Code (List [Code Code]) (Meta Analysis)) +  (-> Compiler Code (List [Code Code]) (Operation Analysis))    (.case branches      #.Nil -    (lang.throw cannot-have-empty-branches "") +    (///.throw cannot-have-empty-branches "")      (#.Cons [patternH bodyH] branchesT) -    (do macro.Monad<Meta> -      [[inputT inputA] (typeA.with-inference +    (do ///.Monad<Operation> +      [[inputT inputA] (//type.with-inference                           (analyse inputC))         outputH (analyse-pattern #.None inputT patternH (analyse bodyH))         outputT (monad.map @                            (function (_ [patternT bodyT])                              (analyse-pattern #.None inputT patternT (analyse bodyT)))                            branchesT) -       outputHC (|> outputH product.left coverageA.determine) -       outputTC (monad.map @ (|>> product.left coverageA.determine) outputT) -       _ (.case (monad.fold e.Monad<Error> coverageA.merge outputHC outputTC) -           (#e.Success coverage) -           (lang.assert non-exhaustive-pattern-matching "" -                        (coverageA.exhaustive? coverage)) - -           (#e.Error error) -           (lang.fail error))] -      (wrap (#analysisL.Case inputA [outputH outputT]))))) +       outputHC (|> outputH product.left /coverage.determine) +       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 "" +                       (/coverage.exhaustive? coverage)) + +           (#error.Error error) +           (///.fail error))] +      (wrap (#//.Case inputA [outputH outputT]))))) diff --git a/stdlib/source/lux/lang/analysis/case/coverage.lux b/stdlib/source/lux/lang/compiler/analysis/case/coverage.lux index a5958001f..6a965742a 100644 --- a/stdlib/source/lux/lang/analysis/case/coverage.lux +++ b/stdlib/source/lux/lang/compiler/analysis/case/coverage.lux @@ -9,10 +9,9 @@               [maybe]               text/format               (coll [list "list/" Fold<List>] -                   (dictionary ["dict" unordered #+ Dict]))) -       [macro "macro/" Monad<Meta>] -       [lang] -       (lang [".L" analysis #+ Pattern Variant]))) +                   (dictionary ["dict" unordered #+ Dict])))) +  [//// "operation/" Monad<Operation>] +  [/// #+ Pattern Variant Operation])  (def: cases    (-> (Maybe Nat) Nat) @@ -25,18 +24,18 @@      (case variantP        (#.Left valueP)        (case valueP -        (#analysisL.Complex (#analysisL.Sum value-side)) +        (#///.Complex (#///.Sum value-side))          (recur (inc lefts) value-side)          _ -        {#analysisL.lefts lefts -         #analysisL.right? false -         #analysisL.value valueP}) +        {#///.lefts lefts +         #///.right? false +         #///.value valueP})        (#.Right valueP) -      {#analysisL.lefts lefts -       #analysisL.right? true -       #analysisL.value valueP}))) +      {#///.lefts lefts +       #///.right? true +       #///.value valueP})))  ## The coverage of a pattern-matching expression summarizes how well  ## all the possible values of an input are being covered by the @@ -68,33 +67,33 @@      false))  (def: #export (determine pattern) -  (-> Pattern (Meta Coverage)) +  (-> Pattern (Operation Coverage))    (case pattern -    (^or (#analysisL.Simple #analysisL.Unit) -         (#analysisL.Bind _)) -    (macro/wrap #Exhaustive) +    (^or (#///.Simple #///.Unit) +         (#///.Bind _)) +    (operation/wrap #Exhaustive)      ## Primitive patterns always have partial coverage because there      ## are too many possibilities as far as values go.      (^template [<tag>] -      (#analysisL.Simple (<tag> _)) -      (macro/wrap #Partial)) -    ([#analysisL.Nat] -     [#analysisL.Int] -     [#analysisL.Deg] -     [#analysisL.Frac] -     [#analysisL.Text]) +      (#///.Simple (<tag> _)) +      (operation/wrap #Partial)) +    ([#///.Nat] +     [#///.Int] +     [#///.Deg] +     [#///.Frac] +     [#///.Text])      ## Bools are the exception, since there is only "true" and      ## "false", which means it is possible for boolean      ## pattern-matching to become exhaustive if complementary parts meet. -    (#analysisL.Simple (#analysisL.Bool value)) -    (macro/wrap (#Bool value)) +    (#///.Simple (#///.Bool value)) +    (operation/wrap (#Bool value))      ## Tuple patterns can be exhaustive if there is exhaustiveness for all of      ## their sub-patterns. -    (#analysisL.Complex (#analysisL.Product [left right])) -    (do macro.Monad<Meta> +    (#///.Complex (#///.Product [left right])) +    (do ////.Monad<Operation>        [left (determine left)         right (determine right)]        (case right @@ -104,11 +103,11 @@          _          (wrap (#Seq left right)))) -    (#analysisL.Complex (#analysisL.Sum sum-side)) +    (#///.Complex (#///.Sum sum-side))      (let [[variant-lefts variant-right? variant-value] (variant sum-side)]        ## Variant patterns can be shown to be exhaustive if all the possible        ## cases are handled exhaustively. -      (do macro.Monad<Meta> +      (do ////.Monad<Operation>          [value-coverage (determine variant-value)           #let [variant-idx (if variant-right?                               (inc variant-lefts) diff --git a/stdlib/source/lux/lang/compiler/analysis/expression.lux b/stdlib/source/lux/lang/compiler/analysis/expression.lux new file mode 100644 index 000000000..879f383e8 --- /dev/null +++ b/stdlib/source/lux/lang/compiler/analysis/expression.lux @@ -0,0 +1,121 @@ +(.module: +  lux +  (lux (control [monad #+ do] +                ["ex" exception #+ exception:]) +       (data ["e" error] +             [product] +             text/format) +       [macro]) +  [//// #+ Eval] +  ## (//// [".L" macro] +  ##       [".L" extension]) +  [///] +  [// #+ Analysis Operation Compiler] +  [//type] +  [//primitive] +  [//structure] +  [//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] +  ) + +(def: #export (analyser eval) +  (-> Eval Compiler) +  (function (compile code) +    (do ///.Monad<Operation> +      [expectedT macro.expected-type] +      (let [[cursor code'] code] +        ## The cursor must be set in the compiler for the sake +        ## of having useful error messages. +        (//.with-cursor cursor +          (case code' +            (^template [<tag> <analyser>] +              (<tag> value) +              (<analyser> value)) +            ([#.Bool //primitive.bool] +             [#.Nat  //primitive.nat] +             [#.Int  //primitive.int] +             [#.Deg  //primitive.deg] +             [#.Frac //primitive.frac] +             [#.Text //primitive.text]) + +            (^template [<tag> <analyser>] +              (^ (#.Form (list& [_ (<tag> tag)] +                                values))) +              (case values +                (#.Cons value #.Nil) +                (<analyser> compile tag value) + +                _ +                (<analyser> compile tag (` [(~+ values)])))) +            ([#.Nat //structure.sum] +             [#.Tag //structure.tagged-sum]) + +            (#.Tag tag) +            (//structure.tagged-sum compile tag (' [])) + +            (^ (#.Tuple (list))) +            //primitive.unit + +            (^ (#.Tuple (list singleton))) +            (compile singleton) + +            (^ (#.Tuple elems)) +            (//structure.product compile elems) + +            (^ (#.Record pairs)) +            (//structure.record compile pairs) + +            (#.Symbol reference) +            (//reference.reference reference) + +            (^ (#.Form (list& [_ (#.Text extension-name)] extension-args))) +            (undefined) +            ## (do ///.Monad<Operation> +            ##   [extension (extensionL.find-analysis extension-name)] +            ##   (extension compile eval extension-args)) + +            ## (^ (#.Form (list& func args))) +            ## (do ///.Monad<Operation> +            ##   [[funcT funcA] (//type.with-inference +            ##                    (compile func))] +            ##   (case funcA +            ##     [_ (#.Symbol def-name)] +            ##     (do @ +            ##       [?macro (///.with-error-tracking +            ##                 (macro.find-macro def-name))] +            ##       (case ?macro +            ##         (#.Some macro) +            ##         (do @ +            ##           [expansion (: (Operation (List Code)) +            ##                         (function (_ compiler) +            ##                           (case (macroL.expand macro args compiler) +            ##                             (#e.Error error) +            ##                             ((///.throw macro-expansion-failed error) compiler) + +            ##                             output +            ##                             output)))] +            ##           (case expansion +            ##             (^ (list single)) +            ##             (compile single) + +            ##             _ +            ##             (///.throw macro-call-must-have-single-expansion code))) + +            ##         _ +            ##         (functionA.apply compile funcT funcA args))) + +            ##     _ +            ##     (functionA.apply compile funcT funcA args))) + +            _ +            (///.throw unrecognized-syntax code) +            )))))) diff --git a/stdlib/source/lux/lang/analysis/function.lux b/stdlib/source/lux/lang/compiler/analysis/function.lux index f6fea9bb0..b6e09f11a 100644 --- a/stdlib/source/lux/lang/analysis/function.lux +++ b/stdlib/source/lux/lang/compiler/analysis/function.lux @@ -8,13 +8,13 @@               (coll [list "list/" Fold<List> Monoid<List> Monad<List>]))         [macro]         (macro [code]) -       [lang]         (lang [type]               (type ["tc" check]) -             [".L" scope] -             [".L" analysis #+ Analysis Analyser] -             (analysis [".A" type] -                       [".A" inference])))) +             [".L" scope])) +  [///] +  [// #+ Analysis Compiler] +  [//type] +  [//inference])  (exception: #export (cannot-analyse {expected Type} {function Text} {argument Text} {body Code})    (ex.report ["Type" (%type expected)] @@ -30,13 +30,12 @@                                            (format "\n  " (%n idx) " " (%code argC))))                                (text.join-with ""))])) -## [Analysers]  (def: #export (function analyse function-name arg-name body) -  (-> Analyser Text Text Code (Meta Analysis)) +  (-> Compiler Text Text Code (Meta Analysis))    (do macro.Monad<Meta>      [functionT macro.expected-type]      (loop [expectedT functionT] -      (lang.with-stacked-errors +      (///.with-stacked-errors          (.function (_ _)            (ex.construct cannot-analyse [expectedT function-name arg-name body]))          (case expectedT @@ -49,56 +48,56 @@              (recur value)              #.None -            (lang.fail (ex.construct cannot-analyse [expectedT function-name arg-name body]))) +            (///.fail (ex.construct cannot-analyse [expectedT function-name arg-name body])))            (^template [<tag> <instancer>]              (<tag> _)              (do @ -              [[_ instanceT] (typeA.with-env <instancer>)] +              [[_ instanceT] (//type.with-env <instancer>)]                (recur (maybe.assume (type.apply (list instanceT) expectedT)))))            ([#.UnivQ tc.existential]             [#.ExQ tc.var])            (#.Var id)            (do @ -            [?expectedT' (typeA.with-env +            [?expectedT' (//type.with-env                             (tc.read id))]              (case ?expectedT'                (#.Some expectedT')                (recur expectedT') -              _                ## Inference +              _                (do @ -                [[input-id inputT] (typeA.with-env tc.var) -                 [output-id outputT] (typeA.with-env tc.var) +                [[input-id inputT] (//type.with-env tc.var) +                 [output-id outputT] (//type.with-env tc.var)                   #let [functionT (#.Function inputT outputT)]                   functionA (recur functionT) -                 _ (typeA.with-env +                 _ (//type.with-env                       (tc.check expectedT functionT))]                  (wrap functionA))                ))            (#.Function inputT outputT)            (<| (:: @ map (.function (_ [scope bodyA]) -                          (#analysisL.Function (scopeL.environment scope) bodyA))) -              lang.with-scope +                          (#//.Function (scopeL.environment scope) bodyA))) +              //.with-scope                ## Functions have access not only to their argument, but                ## also to themselves, through a local variable.                (scopeL.with-local [function-name expectedT])                (scopeL.with-local [arg-name inputT]) -              (typeA.with-type outputT) +              (//type.with-type outputT)                (analyse body))            _ -          (lang.fail "") +          (///.fail "")            )))))  (def: #export (apply analyse functionT functionA args) -  (-> Analyser Type Analysis (List Code) (Meta Analysis)) -  (lang.with-stacked-errors +  (-> Compiler Type Analysis (List Code) (Meta Analysis)) +  (///.with-stacked-errors      (.function (_ _)        (ex.construct cannot-apply [functionT args]))      (do macro.Monad<Meta> -      [[applyT argsA] (inferenceA.general analyse functionT args)] -      (wrap (analysisL.apply [functionA argsA]))))) +      [[applyT argsA] (//inference.general analyse functionT args)] +      (wrap (//.apply [functionA argsA]))))) diff --git a/stdlib/source/lux/lang/analysis/inference.lux b/stdlib/source/lux/lang/compiler/analysis/inference.lux index 732a8e6e3..abf1529d6 100644 --- a/stdlib/source/lux/lang/analysis/inference.lux +++ b/stdlib/source/lux/lang/compiler/analysis/inference.lux @@ -6,16 +6,16 @@               [text]               text/format               (coll [list "list/" Functor<List>])) -       [macro "macro/" Monad<Meta>] -       [lang] -       (lang [type] -             (type ["tc" check]) -             [analysis #+ Analysis Analyser] -             (analysis [".A" type])))) - -(exception: #export (variant-tag-out-of-bounds {size Nat} {tag analysis.Tag} {type Type}) +       [macro]) +  (//// [type] +        (type ["tc" check])) +  [/// #+ "operation/" Monad<Operation>] +  [// #+ Tag Analysis Operation Compiler] +  [//type]) + +(exception: #export (variant-tag-out-of-bounds {size Nat} {tag Tag} {type Type})    (ex.report ["Tag" (%n tag)] -             ["Variant size" (%n size)] +             ["Variant size" (%i (.int size))]               ["Variant type" (%type type)]))  (exception: #export (cannot-infer {type Type} {args (List Code)}) @@ -43,16 +43,16 @@    [invalid-type-application]    ) -(def: (replace-bound bound-idx replacementT type) +(def: (replace bound-idx replacement type)    (-> Nat Type Type Type)    (case type      (#.Primitive name params) -    (#.Primitive name (list/map (replace-bound bound-idx replacementT) params)) +    (#.Primitive name (list/map (replace bound-idx replacement) params))      (^template [<tag>]        (<tag> left right) -      (<tag> (replace-bound bound-idx replacementT left) -             (replace-bound bound-idx replacementT right))) +      (<tag> (replace bound-idx replacement left) +             (replace bound-idx replacement right)))      ([#.Sum]       [#.Product]       [#.Function] @@ -60,13 +60,13 @@      (#.Bound idx)      (if (n/= bound-idx idx) -      replacementT +      replacement        type)      (^template [<tag>]        (<tag> env quantified) -      (<tag> (list/map (replace-bound bound-idx replacementT) env) -             (replace-bound (n/+ +2 bound-idx) replacementT quantified))) +      (<tag> (list/map (replace bound-idx replacement) env) +             (replace (n/+ +2 bound-idx) replacement quantified)))      ([#.UnivQ]       [#.ExQ]) @@ -74,13 +74,13 @@      type))  (def: new-named-type -  (Meta Type) -  (do macro.Monad<Meta> -    [[_module _line _column] macro.cursor -     [ex-id exT] (typeA.with-env tc.existential)] -    (wrap (#.Primitive (format "{New Type @ " (%t _module) -                               "," (%n _line) -                               "," (%n _column) +  (Operation Type) +  (do ///.Monad<Operation> +    [[module line column] macro.cursor +     [ex-id _] (//type.with-env tc.existential)] +    (wrap (#.Primitive (format "{New Type @ " (%t module) +                               "," (%n line) +                               "," (%n column)                                 "} " (%n ex-id))                         (list))))) @@ -92,11 +92,11 @@  ## But, so long as the type being used for the inference can be treated  ## as a function type, this method of inference should work.  (def: #export (general analyse inferT args) -  (-> Analyser Type (List Code) (Meta [Type (List Analysis)])) +  (-> Compiler Type (List Code) (Operation [Type (List Analysis)]))    (case args      #.Nil -    (do macro.Monad<Meta> -      [_ (typeA.infer inferT)] +    (do ///.Monad<Operation> +      [_ (//type.infer inferT)]        (wrap [inferT (list)]))      (#.Cons argC args') @@ -105,23 +105,23 @@        (general analyse unnamedT args)        (#.UnivQ _) -      (do macro.Monad<Meta> -        [[var-id varT] (typeA.with-env tc.var)] +      (do ///.Monad<Operation> +        [[var-id varT] (//type.with-env tc.var)]          (general analyse (maybe.assume (type.apply (list varT) inferT)) args))        (#.ExQ _) -      (do macro.Monad<Meta> -        [[var-id varT] (typeA.with-env tc.var) +      (do ///.Monad<Operation> +        [[var-id varT] (//type.with-env tc.var)           output (general analyse                           (maybe.assume (type.apply (list varT) inferT))                           args) -         bound? (typeA.with-env +         bound? (//type.with-env                    (tc.bound? var-id))           _ (if bound?               (wrap [])               (do @                 [newT new-named-type] -               (typeA.with-env +               (//type.with-env                   (tc.check varT newT))))]          (wrap output)) @@ -131,7 +131,7 @@          (general analyse outputT args)          #.None -        (lang.throw invalid-type-application inferT)) +        (///.throw invalid-type-application inferT))        ## Arguments are inferred back-to-front because, by convention,        ## Lux functions take the most important arguments *last*, which @@ -141,39 +141,39 @@        ## avoided in Lux code, since the inference algorithm can piece        ## things together more easily.        (#.Function inputT outputT) -      (do macro.Monad<Meta> +      (do ///.Monad<Operation>          [[outputT' args'A] (general analyse outputT args') -         argA (lang.with-stacked-errors +         argA (///.with-stacked-errors                  (function (_ _)                    (ex.construct cannot-infer-argument [inputT argC])) -                (typeA.with-type inputT +                (//type.with-type inputT                    (analyse argC)))]          (wrap [outputT' (list& argA args'A)]))        (#.Var infer-id) -      (do macro.Monad<Meta> -        [?inferT' (typeA.with-env (tc.read infer-id))] +      (do ///.Monad<Operation> +        [?inferT' (//type.with-env (tc.read infer-id))]          (case ?inferT'            (#.Some inferT')            (general analyse inferT' args)            _ -          (lang.throw cannot-infer [inferT args]))) +          (///.throw cannot-infer [inferT args])))        _ -      (lang.throw cannot-infer [inferT args])) +      (///.throw cannot-infer [inferT args]))      ))  ## Turns a record type into the kind of function type suitable for inference.  (def: #export (record inferT) -  (-> Type (Meta Type)) +  (-> Type (Operation Type))    (case inferT      (#.Named name unnamedT)      (record unnamedT)      (^template [<tag>]        (<tag> env bodyT) -      (do macro.Monad<Meta> +      (do ///.Monad<Operation>          [bodyT+ (record bodyT)]          (wrap (<tag> env bodyT+))))      ([#.UnivQ] @@ -185,28 +185,28 @@        (record outputT)        #.None -      (lang.throw invalid-type-application inferT)) +      (///.throw invalid-type-application inferT))      (#.Product _) -    (macro/wrap (type.function (type.flatten-tuple inferT) inferT)) +    (operation/wrap (type.function (type.flatten-tuple inferT) inferT))      _ -    (lang.throw not-a-record-type inferT))) +    (///.throw not-a-record-type inferT)))  ## Turns a variant type into the kind of function type suitable for inference.  (def: #export (variant tag expected-size inferT) -  (-> Nat Nat Type (Meta Type)) +  (-> Nat Nat Type (Operation Type))    (loop [depth +0           currentT inferT]      (case currentT        (#.Named name unnamedT) -      (do macro.Monad<Meta> +      (do ///.Monad<Operation>          [unnamedT+ (recur depth unnamedT)]          (wrap unnamedT+))        (^template [<tag>]          (<tag> env bodyT) -        (do macro.Monad<Meta> +        (do ///.Monad<Operation>            [bodyT+ (recur (inc depth) bodyT)]            (wrap (<tag> env bodyT+))))        ([#.UnivQ] @@ -221,28 +221,28 @@                         (n/< boundary tag)))                (case (list.nth tag cases)                  (#.Some caseT) -                (macro/wrap (if (n/= +0 depth) -                              (type.function (list caseT) currentT) -                              (let [replace! (replace-bound (|> depth dec (n/* +2)) inferT)] -                                (type.function (list (replace! caseT)) -                                  (replace! currentT))))) +                (operation/wrap (if (n/= +0 depth) +                                  (type.function (list caseT) currentT) +                                  (let [replace' (replace (|> depth dec (n/* +2)) inferT)] +                                    (type.function (list (replace' caseT)) +                                      (replace' currentT)))))                  #.None -                (lang.throw variant-tag-out-of-bounds [expected-size tag inferT])) +                (///.throw variant-tag-out-of-bounds [expected-size tag inferT]))                (n/< expected-size actual-size) -              (lang.throw smaller-variant-than-expected [expected-size actual-size]) +              (///.throw smaller-variant-than-expected [expected-size actual-size])                (n/= boundary tag)                (let [caseT (type.variant (list.drop boundary cases))] -                (macro/wrap (if (n/= +0 depth) -                              (type.function (list caseT) currentT) -                              (let [replace! (replace-bound (|> depth dec (n/* +2)) inferT)] -                                (type.function (list (replace! caseT)) -                                  (replace! currentT)))))) +                (operation/wrap (if (n/= +0 depth) +                                  (type.function (list caseT) currentT) +                                  (let [replace' (replace (|> depth dec (n/* +2)) inferT)] +                                    (type.function (list (replace' caseT)) +                                      (replace' currentT))))))                ## else -              (lang.throw variant-tag-out-of-bounds [expected-size tag inferT]))) +              (///.throw variant-tag-out-of-bounds [expected-size tag inferT])))        (#.Apply inputT funcT)        (case (type.apply (list inputT) funcT) @@ -250,7 +250,7 @@          (variant tag expected-size outputT)          #.None -        (lang.throw invalid-type-application inferT)) +        (///.throw invalid-type-application inferT))        _ -      (lang.throw not-a-variant-type inferT)))) +      (///.throw not-a-variant-type inferT)))) diff --git a/stdlib/source/lux/lang/analysis/primitive.lux b/stdlib/source/lux/lang/compiler/analysis/primitive.lux index 74596fba2..74596fba2 100644 --- a/stdlib/source/lux/lang/analysis/primitive.lux +++ b/stdlib/source/lux/lang/compiler/analysis/primitive.lux diff --git a/stdlib/source/lux/lang/analysis/reference.lux b/stdlib/source/lux/lang/compiler/analysis/reference.lux index cceb4db7d..6f4908f9d 100644 --- a/stdlib/source/lux/lang/analysis/reference.lux +++ b/stdlib/source/lux/lang/compiler/analysis/reference.lux @@ -4,15 +4,16 @@         [macro]         (macro [code])         (lang (type ["tc" check]))) -  [// #+ Analysis] +  [///] +  [// #+ Analysis Operation]    [//type] -  [///reference] -  [///scope]) +  [////reference] +  [////scope])  ## [Analysers]  (def: (definition def-name) -  (-> Ident (Meta Analysis)) -  (do macro.Monad<Meta> +  (-> Ident (Operation Analysis)) +  (do ///.Monad<Operation>      [[actualT def-anns _] (macro.find-def def-name)]      (case (macro.get-symbol-ann (ident-for #.alias) def-anns)        (#.Some real-def-name) @@ -21,27 +22,27 @@        _        (do @          [_ (//type.infer actualT)] -        (:: @ map (|>> ///reference.constant #//.Reference) +        (:: @ map (|>> ////reference.constant #//.Reference)              (macro.normalize def-name))))))  (def: (variable var-name) -  (-> Text (Meta (Maybe Analysis))) -  (do macro.Monad<Meta> -    [?var (///scope.find var-name)] +  (-> Text (Operation (Maybe Analysis))) +  (do ///.Monad<Operation> +    [?var (////scope.find var-name)]      (case ?var        (#.Some [actualT ref])        (do @          [_ (//type.infer actualT)] -        (wrap (#.Some (|> ref ///reference.variable #//.Reference)))) +        (wrap (#.Some (|> ref ////reference.variable #//.Reference))))        #.None        (wrap #.None))))  (def: #export (reference reference) -  (-> Ident (Meta Analysis)) +  (-> Ident (Operation Analysis))    (case reference      ["" simple-name] -    (do macro.Monad<Meta> +    (do ///.Monad<Operation>        [?var (variable simple-name)]        (case ?var          (#.Some varA) diff --git a/stdlib/source/lux/lang/analysis/structure.lux b/stdlib/source/lux/lang/compiler/analysis/structure.lux index bc527cd49..78b36bc32 100644 --- a/stdlib/source/lux/lang/analysis/structure.lux +++ b/stdlib/source/lux/lang/compiler/analysis/structure.lux @@ -10,16 +10,16 @@                     (dictionary ["dict" unordered #+ Dict]))               text/format)         [macro] -       (macro [code]) -       [lang] -       (lang [type] -             (type ["tc" check]) -             [analysis #+ Analysis Analyser] -             (analysis [".A" type] -                       [".A" primitive] -                       [".A" inference])))) - -(exception: #export (invalid-variant-type {type Type} {tag analysis.Tag} {code Code}) +       (macro [code])) +  (//// [type] +        (type ["tc" check])) +  [///] +  [// #+ Tag Analysis Operation Compiler] +  [//type] +  [//primitive] +  [//inference]) + +(exception: #export (invalid-variant-type {type Type} {tag Tag} {code Code})    (ex.report ["Type" (%type type)]               ["Tag" (%n tag)]               ["Expression" (%code code)])) @@ -37,7 +37,7 @@    (%type type))  (do-template [<name>] -  [(exception: #export (<name> {type Type} {tag analysis.Tag} {code Code}) +  [(exception: #export (<name> {type Type} {tag Tag} {code Code})       (ex.report ["Type" (%type type)]                  ["Tag" (%n tag)]                  ["Expression" (%code code)]))] @@ -74,10 +74,10 @@                                        code.record))]))  (def: #export (sum analyse tag valueC) -  (-> Analyser Nat Code (Meta Analysis)) -  (do macro.Monad<Meta> +  (-> Compiler Nat Code (Operation Analysis)) +  (do ///.Monad<Operation>      [expectedT macro.expected-type] -    (lang.with-stacked-errors +    (///.with-stacked-errors        (function (_ _)          (ex.construct cannot-analyse-variant [expectedT tag valueC]))        (case expectedT @@ -87,38 +87,38 @@            (case (list.nth tag flat)              (#.Some variant-type)              (do @ -              [valueA (typeA.with-type variant-type +              [valueA (//type.with-type variant-type                          (analyse valueC))] -              (wrap (analysis.sum-analysis type-size tag valueA))) +              (wrap (//.sum-analysis type-size tag valueA)))              #.None -            (lang.throw inferenceA.variant-tag-out-of-bounds [type-size tag expectedT]))) +            (///.throw //inference.variant-tag-out-of-bounds [type-size tag expectedT])))          (#.Named name unnamedT) -        (typeA.with-type unnamedT +        (//type.with-type unnamedT            (sum analyse tag valueC))          (#.Var id)          (do @ -          [?expectedT' (typeA.with-env +          [?expectedT' (//type.with-env                           (tc.read id))]            (case ?expectedT'              (#.Some expectedT') -            (typeA.with-type expectedT' +            (//type.with-type expectedT'                (sum analyse tag valueC))              _              ## Cannot do inference when the tag is numeric.              ## This is because there is no way of knowing how many              ## cases the inferred sum type would have. -            (lang.throw cannot-infer-numeric-tag [expectedT tag valueC]) +            (///.throw cannot-infer-numeric-tag [expectedT tag valueC])              ))          (^template [<tag> <instancer>]            (<tag> _)            (do @ -            [[instance-id instanceT] (typeA.with-env <instancer>)] -            (typeA.with-type (maybe.assume (type.apply (list instanceT) expectedT)) +            [[instance-id instanceT] (//type.with-env <instancer>)] +            (//type.with-type (maybe.assume (type.apply (list instanceT) expectedT))                (sum analyse tag valueC))))          ([#.UnivQ tc.existential]           [#.ExQ tc.var]) @@ -127,30 +127,30 @@          (case funT            (#.Var funT-id)            (do @ -            [?funT' (typeA.with-env (tc.read funT-id))] +            [?funT' (//type.with-env (tc.read funT-id))]              (case ?funT'                (#.Some funT') -              (typeA.with-type (#.Apply inputT funT') +              (//type.with-type (#.Apply inputT funT')                  (sum analyse tag valueC))                _ -              (lang.throw invalid-variant-type [expectedT tag valueC]))) +              (///.throw invalid-variant-type [expectedT tag valueC])))            _            (case (type.apply (list inputT) funT)              #.None -            (lang.throw not-a-quantified-type funT) +            (///.throw not-a-quantified-type funT)              (#.Some outputT) -            (typeA.with-type outputT +            (//type.with-type outputT                (sum analyse tag valueC))))          _ -        (lang.throw invalid-variant-type [expectedT tag valueC]))))) +        (///.throw invalid-variant-type [expectedT tag valueC])))))  (def: (typed-product analyse membersC+) -  (-> Analyser (List Code) (Meta Analysis)) -  (do macro.Monad<Meta> +  (-> Compiler (List Code) (Operation Analysis)) +  (do ///.Monad<Operation>      [expectedT macro.expected-type]      (loop [expectedT expectedT             membersC+ membersC+] @@ -158,17 +158,17 @@          ## If the tuple runs out, whatever expression is the last gets          ## matched to the remaining type.          [tailT (#.Cons tailC #.Nil)] -        (typeA.with-type tailT +        (//type.with-type tailT            (analyse tailC))          ## If the type and the code are still ongoing, match each          ## sub-expression to its corresponding type.          [(#.Product leftT rightT) (#.Cons leftC rightC)]          (do @ -          [leftA (typeA.with-type leftT +          [leftA (//type.with-type leftT                     (analyse leftC))             rightA (recur rightT rightC)] -          (wrap (#analysis.Structure (#analysis.Product leftA rightA)))) +          (wrap (#//.Structure (#//.Product leftA rightA))))          ## If, however, the type runs out but there is still enough          ## tail, the remaining elements get packaged into another @@ -184,14 +184,14 @@          (|> tailC              code.tuple              analyse -            (typeA.with-type tailT) -            (:: @ map (|>> analysis.no-op))))))) +            (//type.with-type tailT) +            (:: @ map (|>> //.no-op)))))))  (def: #export (product analyse membersC) -  (-> Analyser (List Code) (Meta Analysis)) -  (do macro.Monad<Meta> +  (-> Compiler (List Code) (Operation Analysis)) +  (do ///.Monad<Operation>      [expectedT macro.expected-type] -    (lang.with-stacked-errors +    (///.with-stacked-errors        (function (_ _)          (ex.construct cannot-analyse-tuple [expectedT membersC]))        (case expectedT @@ -199,33 +199,33 @@          (..typed-product analyse membersC)          (#.Named name unnamedT) -        (typeA.with-type unnamedT +        (//type.with-type unnamedT            (product analyse membersC))          (#.Var id)          (do @ -          [?expectedT' (typeA.with-env +          [?expectedT' (//type.with-env                           (tc.read id))]            (case ?expectedT'              (#.Some expectedT') -            (typeA.with-type expectedT' +            (//type.with-type expectedT'                (product analyse membersC))              _              ## Must do inference...              (do @ -              [membersTA (monad.map @ (|>> analyse typeA.with-inference) +              [membersTA (monad.map @ (|>> analyse //type.with-inference)                                      membersC) -               _ (typeA.with-env +               _ (//type.with-env                     (tc.check expectedT                               (type.tuple (list/map product.left membersTA))))] -              (wrap (analysis.product-analysis (list/map product.right membersTA)))))) +              (wrap (//.product-analysis (list/map product.right membersTA))))))          (^template [<tag> <instancer>]            (<tag> _)            (do @ -            [[instance-id instanceT] (typeA.with-env <instancer>)] -            (typeA.with-type (maybe.assume (type.apply (list instanceT) expectedT)) +            [[instance-id instanceT] (//type.with-env <instancer>)] +            (//type.with-type (maybe.assume (type.apply (list instanceT) expectedT))                (product analyse membersC))))          ([#.UnivQ tc.existential]           [#.ExQ tc.var]) @@ -234,31 +234,31 @@          (case funT            (#.Var funT-id)            (do @ -            [?funT' (typeA.with-env (tc.read funT-id))] +            [?funT' (//type.with-env (tc.read funT-id))]              (case ?funT'                (#.Some funT') -              (typeA.with-type (#.Apply inputT funT') +              (//type.with-type (#.Apply inputT funT')                  (product analyse membersC))                _ -              (lang.throw invalid-tuple-type [expectedT membersC]))) +              (///.throw invalid-tuple-type [expectedT membersC])))            _            (case (type.apply (list inputT) funT)              #.None -            (lang.throw not-a-quantified-type funT) +            (///.throw not-a-quantified-type funT)              (#.Some outputT) -            (typeA.with-type outputT +            (//type.with-type outputT                (product analyse membersC))))          _ -        (lang.throw invalid-tuple-type [expectedT membersC]) +        (///.throw invalid-tuple-type [expectedT membersC])          ))))  (def: #export (tagged-sum analyse tag valueC) -  (-> Analyser Ident Code (Meta Analysis)) -  (do macro.Monad<Meta> +  (-> Compiler Ident Code (Operation Analysis)) +  (do ///.Monad<Operation>      [tag (macro.normalize tag)       [idx group variantT] (macro.resolve-tag tag)       expectedT macro.expected-type] @@ -266,9 +266,9 @@        (#.Var _)        (do @          [#let [case-size (list.size group)] -         inferenceT (inferenceA.variant idx case-size variantT) -         [inferredT valueA+] (inferenceA.general analyse inferenceT (list valueC))] -        (wrap (analysis.sum-analysis case-size idx (|> valueA+ list.head maybe.assume)))) +         inferenceT (//inference.variant idx case-size variantT) +         [inferredT valueA+] (//inference.general analyse inferenceT (list valueC))] +        (wrap (//.sum-analysis case-size idx (|> valueA+ list.head maybe.assume))))        _        (..sum analyse idx valueC)))) @@ -278,38 +278,38 @@  ## Normalization just means that all the tags get resolved to their  ## canonical form (with their corresponding module identified).  (def: #export (normalize record) -  (-> (List [Code Code]) (Meta (List [Ident Code]))) -  (monad.map macro.Monad<Meta> +  (-> (List [Code Code]) (Operation (List [Ident Code]))) +  (monad.map ///.Monad<Operation>               (function (_ [key val])                 (case key                   [_ (#.Tag key)] -                 (do macro.Monad<Meta> +                 (do ///.Monad<Operation>                     [key (macro.normalize key)]                     (wrap [key val]))                   _ -                 (lang.throw record-keys-must-be-tags [key record]))) +                 (///.throw record-keys-must-be-tags [key record])))               record))  ## Lux already possesses the means to analyse tuples, so  ## re-implementing the same functionality for records makes no sense.  ## Records, thus, get transformed into tuples by ordering the elements.  (def: #export (order record) -  (-> (List [Ident Code]) (Meta [(List Code) Type])) +  (-> (List [Ident Code]) (Operation [(List Code) Type]))    (case record      ## empty-record = empty-tuple = unit = []      #.Nil -    (:: macro.Monad<Meta> wrap [(list) Any]) +    (:: ///.Monad<Operation> wrap [(list) Any])      (#.Cons [head-k head-v] _) -    (do macro.Monad<Meta> +    (do ///.Monad<Operation>        [head-k (macro.normalize head-k)         [_ tag-set recordT] (macro.resolve-tag head-k)         #let [size-record (list.size record)               size-ts (list.size tag-set)]         _ (if (n/= size-ts size-record)             (wrap []) -           (lang.throw record-size-mismatch [size-ts size-record recordT record])) +           (///.throw record-size-mismatch [size-ts size-record recordT record]))         #let [tuple-range (list.n/range +0 (dec size-ts))               tag->idx (dict.from-list ident.Hash<Ident> (list.zip2 tag-set tuple-range))]         idx->val (monad.fold @ @@ -318,11 +318,11 @@                                  [key (macro.normalize key)]                                  (case (dict.get key tag->idx)                                    #.None -                                  (lang.throw tag-does-not-belong-to-record [key recordT]) +                                  (///.throw tag-does-not-belong-to-record [key recordT])                                    (#.Some idx)                                    (if (dict.contains? idx idx->val) -                                    (lang.throw cannot-repeat-tag [key record]) +                                    (///.throw cannot-repeat-tag [key record])                                      (wrap (dict.put idx val idx->val))))))                              (: (Dict Nat Code)                                 (dict.new number.Hash<Nat>)) @@ -333,13 +333,13 @@      ))  (def: #export (record analyse members) -  (-> Analyser (List [Code Code]) (Meta Analysis)) -  (do macro.Monad<Meta> +  (-> Compiler (List [Code Code]) (Operation Analysis)) +  (do ///.Monad<Operation>      [members (normalize members)       [membersC recordT] (order members)]      (case membersC        (^ (list)) -      primitiveA.unit +      //primitive.unit        (^ (list singletonC))        (analyse singletonC) @@ -350,9 +350,9 @@          (case expectedT            (#.Var _)            (do @ -            [inferenceT (inferenceA.record recordT) -             [inferredT membersA] (inferenceA.general analyse inferenceT membersC)] -            (wrap (analysis.product-analysis membersA))) +            [inferenceT (//inference.record recordT) +             [inferredT membersA] (//inference.general analyse inferenceT membersC)] +            (wrap (//.product-analysis membersA)))            _            (..product analyse membersC)))))) diff --git a/stdlib/source/lux/lang/analysis/type.lux b/stdlib/source/lux/lang/compiler/analysis/type.lux index a7f9b3b29..9fcfb2743 100644 --- a/stdlib/source/lux/lang/analysis/type.lux +++ b/stdlib/source/lux/lang/compiler/analysis/type.lux @@ -1,56 +1,57 @@  (.module:    lux    (lux (control [monad #+ do]) -       (data ["e" error]) +       (data [error])         [macro] -       [lang] -       (lang (type ["tc" check])))) +       (lang (type ["tc" check]))) +  [///] +  [// #+ Operation])  (def: #export (with-type expected action) -  (All [a] (-> Type (Meta a) (Meta a))) +  (All [a] (-> Type (Operation a) (Operation a)))    (function (_ compiler)      (case (action (set@ #.expected (#.Some expected) compiler)) -      (#e.Success [compiler' output]) +      (#error.Success [compiler' output])        (let [old-expected (get@ #.expected compiler)] -        (#e.Success [(set@ #.expected old-expected compiler') -                     output])) +        (#error.Success [(set@ #.expected old-expected compiler') +                         output])) -      (#e.Error error) -      (#e.Error error)))) +      (#error.Error error) +      (#error.Error error))))  (def: #export (with-env action) -  (All [a] (-> (tc.Check a) (Meta a))) +  (All [a] (-> (tc.Check a) (Operation a)))    (function (_ compiler)      (case (action (get@ #.type-context compiler)) -      (#e.Error error) -      ((lang.fail error) compiler) +      (#error.Error error) +      ((///.fail error) compiler) -      (#e.Success [context' output]) -      (#e.Success [(set@ #.type-context context' compiler) -                   output])))) +      (#error.Success [context' output]) +      (#error.Success [(set@ #.type-context context' compiler) +                       output]))))  (def: #export (with-fresh-env action) -  (All [a] (-> (Meta a) (Meta a))) +  (All [a] (-> (Operation a) (Operation a)))    (function (_ compiler)      (let [old (get@ #.type-context compiler)]        (case (action (set@ #.type-context tc.fresh-context compiler)) -        (#e.Success [compiler' output]) -        (#e.Success [(set@ #.type-context old compiler') -                     output]) +        (#error.Success [compiler' output]) +        (#error.Success [(set@ #.type-context old compiler') +                         output])          output          output))))  (def: #export (infer actualT) -  (-> Type (Meta Any)) -  (do macro.Monad<Meta> +  (-> Type (Operation Any)) +  (do ///.Monad<Operation>      [expectedT macro.expected-type]      (with-env        (tc.check expectedT actualT))))  (def: #export (with-inference action) -  (All [a] (-> (Meta a) (Meta [Type a]))) -  (do macro.Monad<Meta> +  (All [a] (-> (Operation a) (Operation [Type a]))) +  (do ///.Monad<Operation>      [[_ varT] (..with-env                  tc.var)       output (with-type varT diff --git a/stdlib/source/lux/lang/compiler/extension.lux b/stdlib/source/lux/lang/compiler/extension.lux new file mode 100644 index 000000000..28dcd4637 --- /dev/null +++ b/stdlib/source/lux/lang/compiler/extension.lux @@ -0,0 +1,68 @@ +(.module: +  lux +  (lux (control [monad #+ do] +                ["ex" exception #+ exception:]) +       (data [error #+ Error] +             [text] +             (coll (dictionary ["dict" unordered #+ Dict])))) +  [// #+ Eval] +  [//compiler #+ Operation Compiler] +  [//analysis #+ Analyser] +  [//synthesis #+ Synthesizer] +  [//translation #+ Translator]) + +(type: #export (Extension i) +  (#Base i) +  (#Extension [Text (List (Extension i))])) + +(with-expansions [<Bundle> (as-is (Dict Text (-> Text (Handler s i o))))] +  (type: #export (Handler s i o) +    (-> (Compiler [s <Bundle>] (Extension i) (Extension o)) +        (Compiler [s <Bundle>] (List (Extension i)) (Extension o)))) + +  (type: #export (Bundle s i o) +    <Bundle>)) + +(do-template [<name>] +  [(exception: #export (<name> {name Text}) +     (ex.report ["Name" name]))] + +  [unknown-extension] +  [cannot-overwrite-existing-extension] +  ) + +(def: #export (extend compiler) +  (All [s i o] +    (-> (Compiler s i o) +        (Compiler [s (Bundle s i o)] +                  (Extension i) +                  (Extension o)))) +  (function (compiler' input (^@ stateE [stateB bundle])) +    (case input +      (#Base input') +      (do error.Monad<Error> +        [[stateB' output] (compiler input' stateB)] +        (wrap [[stateB' bundle] (#Base output)])) +       +      (#Extension name parameters) +      (case (dict.get name bundle) +        (#.Some handler) +        (do error.Monad<Error> +          [[stateE' output] (handler name compiler' parameters stateE)] +          (wrap [stateE' output])) +         +        #.None +        (ex.throw unknown-extension name))))) + +(def: #export (install name handler) +  (All [s i o] +    (-> Text (-> Text (Handler s i o)) +        (Operation [s (Bundle s i o)] Any))) +  (function (_ (^@ stateE [_ bundle])) +    (if (dict.contains? name bundle) +      (ex.throw cannot-overwrite-existing-extension name) +      (ex.return [stateE (dict.put name handler bundle)])))) + +(def: #export fresh +  Bundle +  (dict.new text.Hash<Text>)) diff --git a/stdlib/source/lux/lang/extension/analysis.lux b/stdlib/source/lux/lang/compiler/extension/analysis.lux index b412e28df..77439643e 100644 --- a/stdlib/source/lux/lang/extension/analysis.lux +++ b/stdlib/source/lux/lang/compiler/extension/analysis.lux @@ -3,12 +3,14 @@    (lux (data [text]               (coll [list "list/" Functor<List>]                     (dictionary ["dict" unordered #+ Dict])))) +  [///analysis #+ Analysis State] +  [///synthesis #+ Synthesis]    [//]    [/common]    [/host])  (def: #export defaults -  (//.Extension //.Analysis) +  (//.Bundle State Analysis Synthesis)    (|> /common.extensions        (dict.merge /host.extensions)        dict.entries diff --git a/stdlib/source/lux/lang/compiler/extension/analysis/common.lux b/stdlib/source/lux/lang/compiler/extension/analysis/common.lux new file mode 100644 index 000000000..6bd1a93bf --- /dev/null +++ b/stdlib/source/lux/lang/compiler/extension/analysis/common.lux @@ -0,0 +1,396 @@ +(.module: +  lux +  (lux (control [monad #+ do] +                ["ex" exception #+ exception:] +                [thread #+ Box]) +       (concurrency [atom #+ Atom]) +       (data [text] +             text/format +             (coll [list "list/" Functor<List>] +                   [array] +                   (dictionary ["dict" unordered #+ Dict]))) +       [lang] +       (lang (type ["tc" check]) +             (analysis [".A" type] +                       [".A" case] +                       [".A" function])) +       [io #+ IO]) +  (//// [compiler] +        [analysis #+ Analysis]) +  [///] +  [///bundle]) + +(type: Handler +  (///.Handler .Lux .Code Analysis)) + +## [Utils] +(def: (simple extension inputsT+ outputT) +  (-> Text (List Type) Type ..Handler) +  (let [num-expected (list.size inputsT+)] +    (function (_ analyse args) +      (let [num-actual (list.size args)] +        (if (n/= num-expected num-actual) +          (do compiler.Monad<Operation> +            [_ (typeA.infer outputT) +             argsA (monad.map @ +                              (function (_ [argT argC]) +                                (typeA.with-type argT +                                  (analyse argC))) +                              (list.zip2 inputsT+ args))] +            (wrap (#///.Extension extension argsA))) +          (lang.throw ///bundle.incorrect-arity [extension num-expected num-actual])))))) + +(def: #export (nullary valueT extension) +  (-> Type Text ..Handler) +  (simple extension (list) valueT)) + +(def: #export (unary inputT outputT extension) +  (-> Type Type Text ..Handler) +  (simple extension (list inputT) outputT)) + +(def: #export (binary subjectT paramT outputT extension) +  (-> Type Type Type Text ..Handler) +  (simple extension (list subjectT paramT) outputT)) + +(def: #export (trinary subjectT param0T param1T outputT extension) +  (-> Type Type Type Type Text ..Handler) +  (simple extension (list subjectT param0T param1T) outputT)) + +## [Analysers] +## "lux is" represents reference/pointer equality. +(def: (lux//is extension) +  (-> Text ..Handler) +  (function (_ analyse args) +    (do compiler.Monad<Operation> +      [[var-id varT] (typeA.with-env tc.var)] +      ((binary varT varT Bool extension) +       analyse args)))) + +## "lux try" provides a simple way to interact with the host platform's +## error-handling facilities. +(def: (lux//try extension) +  (-> Text ..Handler) +  (function (_ analyse args) +    (case args +      (^ (list opC)) +      (do compiler.Monad<Operation> +        [[var-id varT] (typeA.with-env tc.var) +         _ (typeA.infer (type (Either Text varT))) +         opA (typeA.with-type (type (IO varT)) +               (analyse opC))] +        (wrap (#///.Extension extension (list opA)))) +       +      _ +      (lang.throw ///bundle.incorrect-arity [extension +1 (list.size args)])))) + +(def: (lux//in-module extension) +  (-> Text ..Handler) +  (function (_ analyse argsC+) +    (case argsC+ +      (^ (list [_ (#.Text module-name)] exprC)) +      (lang.with-current-module module-name +        (analyse exprC)) +       +      _ +      (lang.throw ///bundle.invalid-syntax [extension])))) + +## (do-template [<name> <type>] +##   [(def: (<name> extension) +##      (-> Text ..Handler) +##      (function (_ analyse args) +##        (case args +##          (^ (list typeC valueC)) +##          (do compiler.Monad<Operation> +##            [actualT (eval Type typeC) +##             _ (typeA.infer (:! Type actualT))] +##            (typeA.with-type <type> +##              (analyse valueC))) + +##          _ +##          (lang.throw ///bundle.incorrect-arity [extension +2 (list.size args)]))))] + +##   [lux//check  (:! Type actualT)] +##   [lux//coerce Any] +##   ) + +(def: (lux//check//type extension) +  (-> Text ..Handler) +  (function (_ analyse args) +    (case args +      (^ (list valueC)) +      (do compiler.Monad<Operation> +        [_ (typeA.infer Type) +         valueA (typeA.with-type Type +                  (analyse valueC))] +        (wrap valueA)) +       +      _ +      (lang.throw ///bundle.incorrect-arity [extension +1 (list.size args)])))) + +(def: bundle/lux +  ///.Bundle +  (|> ///.fresh +      (///bundle.install "is" lux//is) +      (///bundle.install "try" lux//try) +      (///bundle.install "check" lux//check) +      (///bundle.install "coerce" lux//coerce) +      (///bundle.install "check type" lux//check//type) +      (///bundle.install "in-module" lux//in-module))) + +(def: bundle/io +  ///.Bundle +  (<| (///bundle.prefix "io") +      (|> ///.fresh +          (///bundle.install "log" (unary Text Any)) +          (///bundle.install "error" (unary Text Nothing)) +          (///bundle.install "exit" (unary Int Nothing)) +          (///bundle.install "current-time" (nullary Int))))) + +(def: bundle/bit +  ///.Bundle +  (<| (///bundle.prefix "bit") +      (|> ///.fresh +          (///bundle.install "and" (binary Nat Nat Nat)) +          (///bundle.install "or" (binary Nat Nat Nat)) +          (///bundle.install "xor" (binary Nat Nat Nat)) +          (///bundle.install "left-shift" (binary Nat Nat Nat)) +          (///bundle.install "logical-right-shift" (binary Nat Nat Nat)) +          (///bundle.install "arithmetic-right-shift" (binary Int Nat Int)) +          ))) + +(def: bundle/int +  ///.Bundle +  (<| (///bundle.prefix "int") +      (|> ///.fresh +          (///bundle.install "+" (binary Int Int Int)) +          (///bundle.install "-" (binary Int Int Int)) +          (///bundle.install "*" (binary Int Int Int)) +          (///bundle.install "/" (binary Int Int Int)) +          (///bundle.install "%" (binary Int Int Int)) +          (///bundle.install "=" (binary Int Int Bool)) +          (///bundle.install "<" (binary Int Int Bool)) +          (///bundle.install "min" (nullary Int)) +          (///bundle.install "max" (nullary Int)) +          (///bundle.install "to-nat" (unary Int Nat)) +          (///bundle.install "to-frac" (unary Int Frac)) +          (///bundle.install "char" (unary Int Text))))) + +(def: bundle/deg +  ///.Bundle +  (<| (///bundle.prefix "deg") +      (|> ///.fresh +          (///bundle.install "+" (binary Deg Deg Deg)) +          (///bundle.install "-" (binary Deg Deg Deg)) +          (///bundle.install "*" (binary Deg Deg Deg)) +          (///bundle.install "/" (binary Deg Deg Deg)) +          (///bundle.install "%" (binary Deg Deg Deg)) +          (///bundle.install "=" (binary Deg Deg Bool)) +          (///bundle.install "<" (binary Deg Deg Bool)) +          (///bundle.install "scale" (binary Deg Nat Deg)) +          (///bundle.install "reciprocal" (binary Deg Nat Deg)) +          (///bundle.install "min" (nullary Deg)) +          (///bundle.install "max" (nullary Deg)) +          (///bundle.install "to-frac" (unary Deg Frac))))) + +(def: bundle/frac +  ///.Bundle +  (<| (///bundle.prefix "frac") +      (|> ///.fresh +          (///bundle.install "+" (binary Frac Frac Frac)) +          (///bundle.install "-" (binary Frac Frac Frac)) +          (///bundle.install "*" (binary Frac Frac Frac)) +          (///bundle.install "/" (binary Frac Frac Frac)) +          (///bundle.install "%" (binary Frac Frac Frac)) +          (///bundle.install "=" (binary Frac Frac Bool)) +          (///bundle.install "<" (binary Frac Frac Bool)) +          (///bundle.install "smallest" (nullary Frac)) +          (///bundle.install "min" (nullary Frac)) +          (///bundle.install "max" (nullary Frac)) +          (///bundle.install "not-a-number" (nullary Frac)) +          (///bundle.install "positive-infinity" (nullary Frac)) +          (///bundle.install "negative-infinity" (nullary Frac)) +          (///bundle.install "to-deg" (unary Frac Deg)) +          (///bundle.install "to-int" (unary Frac Int)) +          (///bundle.install "encode" (unary Frac Text)) +          (///bundle.install "decode" (unary Text (type (Maybe Frac))))))) + +(def: bundle/text +  ///.Bundle +  (<| (///bundle.prefix "text") +      (|> ///.fresh +          (///bundle.install "=" (binary Text Text Bool)) +          (///bundle.install "<" (binary Text Text Bool)) +          (///bundle.install "concat" (binary Text Text Text)) +          (///bundle.install "index" (trinary Text Text Nat (type (Maybe Nat)))) +          (///bundle.install "size" (unary Text Nat)) +          (///bundle.install "hash" (unary Text Nat)) +          (///bundle.install "replace-once" (trinary Text Text Text Text)) +          (///bundle.install "replace-all" (trinary Text Text Text Text)) +          (///bundle.install "char" (binary Text Nat (type (Maybe Nat)))) +          (///bundle.install "clip" (trinary Text Nat Nat (type (Maybe Text)))) +          ))) + +(def: (array//get extension) +  (-> Text ..Handler) +  (function (_ analyse args) +    (do compiler.Monad<Operation> +      [[var-id varT] (typeA.with-env tc.var)] +      ((binary (type (Array varT)) Nat (type (Maybe varT)) extension) +       analyse args)))) + +(def: (array//put extension) +  (-> Text ..Handler) +  (function (_ analyse args) +    (do compiler.Monad<Operation> +      [[var-id varT] (typeA.with-env tc.var)] +      ((trinary (type (Array varT)) Nat varT (type (Array varT)) extension) +       analyse args)))) + +(def: (array//remove extension) +  (-> Text ..Handler) +  (function (_ analyse args) +    (do compiler.Monad<Operation> +      [[var-id varT] (typeA.with-env tc.var)] +      ((binary (type (Array varT)) Nat (type (Array varT)) extension) +       analyse args)))) + +(def: bundle/array +  ///.Bundle +  (<| (///bundle.prefix "array") +      (|> ///.fresh +          (///bundle.install "new" (unary Nat Array)) +          (///bundle.install "get" array//get) +          (///bundle.install "put" array//put) +          (///bundle.install "remove" array//remove) +          (///bundle.install "size" (unary (type (Ex [a] (Array a))) Nat)) +          ))) + +(def: bundle/math +  ///.Bundle +  (<| (///bundle.prefix "math") +      (|> ///.fresh +          (///bundle.install "cos" (unary Frac Frac)) +          (///bundle.install "sin" (unary Frac Frac)) +          (///bundle.install "tan" (unary Frac Frac)) +          (///bundle.install "acos" (unary Frac Frac)) +          (///bundle.install "asin" (unary Frac Frac)) +          (///bundle.install "atan" (unary Frac Frac)) +          (///bundle.install "cosh" (unary Frac Frac)) +          (///bundle.install "sinh" (unary Frac Frac)) +          (///bundle.install "tanh" (unary Frac Frac)) +          (///bundle.install "exp" (unary Frac Frac)) +          (///bundle.install "log" (unary Frac Frac)) +          (///bundle.install "ceil" (unary Frac Frac)) +          (///bundle.install "floor" (unary Frac Frac)) +          (///bundle.install "round" (unary Frac Frac)) +          (///bundle.install "atan2" (binary Frac Frac Frac)) +          (///bundle.install "pow" (binary Frac Frac Frac)) +          ))) + +(def: (atom-new extension) +  (-> Text ..Handler) +  (function (_ analyse args) +    (case args +      (^ (list initC)) +      (do compiler.Monad<Operation> +        [[var-id varT] (typeA.with-env tc.var) +         _ (typeA.infer (type (Atom varT))) +         initA (typeA.with-type varT +                 (analyse initC))] +        (wrap (#///.Extension extension (list initA)))) +       +      _ +      (lang.throw ///bundle.incorrect-arity [extension +1 (list.size args)])))) + +(def: (atom-read extension) +  (-> Text ..Handler) +  (function (_ analyse args) +    (do compiler.Monad<Operation> +      [[var-id varT] (typeA.with-env tc.var)] +      ((unary (type (Atom varT)) varT extension) +       analyse args)))) + +(def: (atom//compare-and-swap extension) +  (-> Text ..Handler) +  (function (_ analyse args) +    (do compiler.Monad<Operation> +      [[var-id varT] (typeA.with-env tc.var)] +      ((trinary (type (Atom varT)) varT varT Bool extension) +       analyse args)))) + +(def: bundle/atom +  ///.Bundle +  (<| (///bundle.prefix "atom") +      (|> ///.fresh +          (///bundle.install "new" atom-new) +          (///bundle.install "read" atom-read) +          (///bundle.install "compare-and-swap" atom//compare-and-swap) +          ))) + +(def: (box//new extension) +  (-> Text ..Handler) +  (function (_ analyse args) +    (case args +      (^ (list initC)) +      (do compiler.Monad<Operation> +        [[var-id varT] (typeA.with-env tc.var) +         _ (typeA.infer (type (All [!] (Box ! varT)))) +         initA (typeA.with-type varT +                 (analyse initC))] +        (wrap (#///.Extension extension (list initA)))) +       +      _ +      (lang.throw ///bundle.incorrect-arity [extension +1 (list.size args)])))) + +(def: (box//read extension) +  (-> Text ..Handler) +  (function (_ analyse args) +    (do compiler.Monad<Operation> +      [[thread-id threadT] (typeA.with-env tc.var) +       [var-id varT] (typeA.with-env tc.var)] +      ((unary (type (Box threadT varT)) varT extension) +       analyse args)))) + +(def: (box//write extension) +  (-> Text ..Handler) +  (function (_ analyse args) +    (do compiler.Monad<Operation> +      [[thread-id threadT] (typeA.with-env tc.var) +       [var-id varT] (typeA.with-env tc.var)] +      ((binary varT (type (Box threadT varT)) Any extension) +       analyse args)))) + +(def: bundle/box +  ///.Bundle +  (<| (///bundle.prefix "box") +      (|> ///.fresh +          (///bundle.install "new" box//new) +          (///bundle.install "read" box//read) +          (///bundle.install "write" box//write) +          ))) + +(def: bundle/process +  ///.Bundle +  (<| (///bundle.prefix "process") +      (|> ///.fresh +          (///bundle.install "parallelism" (nullary Nat)) +          (///bundle.install "schedule" (binary Nat (type (IO Any)) Any)) +          ))) + +(def: #export bundle +  ///.Bundle +  (<| (///bundle.prefix "lux") +      (|> ///.fresh +          (dict.merge bundle/lux) +          (dict.merge bundle/bit) +          (dict.merge bundle/int) +          (dict.merge bundle/deg) +          (dict.merge bundle/frac) +          (dict.merge bundle/text) +          (dict.merge bundle/array) +          (dict.merge bundle/math) +          (dict.merge bundle/atom) +          (dict.merge bundle/box) +          (dict.merge bundle/process) +          (dict.merge bundle/io)) +      )) diff --git a/stdlib/source/lux/lang/extension/analysis/host.jvm.lux b/stdlib/source/lux/lang/compiler/extension/analysis/host.jvm.lux index 56da166c5..56da166c5 100644 --- a/stdlib/source/lux/lang/extension/analysis/host.jvm.lux +++ b/stdlib/source/lux/lang/compiler/extension/analysis/host.jvm.lux diff --git a/stdlib/source/lux/lang/compiler/extension/bundle.lux b/stdlib/source/lux/lang/compiler/extension/bundle.lux new file mode 100644 index 000000000..ff4bd66ad --- /dev/null +++ b/stdlib/source/lux/lang/compiler/extension/bundle.lux @@ -0,0 +1,31 @@ +(.module: +  lux +  (lux (control [monad #+ do] +                ["ex" exception #+ exception:]) +       (data [text] +             text/format +             (coll [list "list/" Functor<List>] +                   (dictionary ["dict" unordered #+ Dict])))) +  [//]) + +(exception: #export (incorrect-arity {name Text} {arity Nat} {args Nat}) +  (ex.report ["Extension" (%t name)] +             ["Expected arity" (|> arity .int %i)] +             ["Actual arity" (|> args .int %i)])) + +(exception: #export (invalid-syntax {name Text}) +  (ex.report ["Extension" name])) + +## [Utils] +(def: #export (install name anonymous) +  (All [s i o] +    (-> Text (-> Text (//.Handler s i o)) +        (-> (//.Bundle s i o) (//.Bundle s i o)))) +  (dict.put name anonymous)) + +(def: #export (prefix prefix) +  (All [s i o] +    (-> Text (-> (//.Bundle s i o) (//.Bundle s i o)))) +  (|>> dict.entries +       (list/map (function (_ [key val]) [(format prefix " " key) val])) +       (dict.from-list text.Hash<Text>))) diff --git a/stdlib/source/lux/lang/extension/synthesis.lux b/stdlib/source/lux/lang/compiler/extension/synthesis.lux index c48f3e3a5..c48f3e3a5 100644 --- a/stdlib/source/lux/lang/extension/synthesis.lux +++ b/stdlib/source/lux/lang/compiler/extension/synthesis.lux diff --git a/stdlib/source/lux/lang/extension/translation.lux b/stdlib/source/lux/lang/compiler/extension/translation.lux index bc95ed1f4..bc95ed1f4 100644 --- a/stdlib/source/lux/lang/extension/translation.lux +++ b/stdlib/source/lux/lang/compiler/extension/translation.lux diff --git a/stdlib/source/lux/lang/compiler/init.lux b/stdlib/source/lux/lang/compiler/init.lux new file mode 100644 index 000000000..92a066b7e --- /dev/null +++ b/stdlib/source/lux/lang/compiler/init.lux @@ -0,0 +1,51 @@ +(.module: +  lux +  [///] +  [///host]) + +(def: #export (cursor file) +  (-> Text Cursor) +  [file +1 +0]) + +(def: #export (source file code) +  (-> Text Text Source) +  [(cursor file) +0 code]) + +(def: dummy-source +  Source +  [.dummy-cursor +0 ""]) + +(def: #export type-context +  Type-Context +  {#.ex-counter +0 +   #.var-counter +0 +   #.var-bindings (list)}) + +(`` (def: #export info +      Info +      {#.target  (for {(~~ (static ///host.common-lisp)) ///host.common-lisp +                       (~~ (static ///host.js))          ///host.js +                       (~~ (static ///host.jvm))         ///host.jvm +                       (~~ (static ///host.lua))         ///host.lua +                       (~~ (static ///host.php))         ///host.php +                       (~~ (static ///host.python))      ///host.python +                       (~~ (static ///host.r))           ///host.r +                       (~~ (static ///host.ruby))        ///host.ruby +                       (~~ (static ///host.scheme))      ///host.scheme}) +       #.version ///.version +       #.mode    #.Build})) + +(def: #export (compiler host) +  (-> Any Lux) +  {#.info            ..info +   #.source          dummy-source +   #.cursor          .dummy-cursor +   #.current-module  #.None +   #.modules         (list) +   #.scopes          (list) +   #.type-context    ..type-context +   #.expected        #.None +   #.seed            +0 +   #.scope-type-vars (list) +   #.extensions      [] +   #.host            host}) diff --git a/stdlib/source/lux/lang/synthesis.lux b/stdlib/source/lux/lang/compiler/synthesis.lux index 1bf06cdd0..eece3c7ab 100644 --- a/stdlib/source/lux/lang/synthesis.lux +++ b/stdlib/source/lux/lang/compiler/synthesis.lux @@ -3,10 +3,9 @@    (lux (control [monad #+ do])         (data [error #+ Error]               (coll (dictionary ["dict" unordered #+ Dict])))) -  [// #+ Extension] -  [//reference #+ Register Variable Reference] -  [//analysis #+ Environment Arity Analysis] -  [//compiler #+ Operation Compiler]) +  [///reference #+ Register Variable Reference] +  [// #+ Operation Compiler] +  [//analysis #+ Environment Arity Analysis])  (type: #export Resolver (Dict Variable Variable)) @@ -18,7 +17,7 @@  (def: #export fresh-resolver    Resolver -  (dict.new //reference.Hash<Variable>)) +  (dict.new ///reference.Hash<Variable>))  (def: #export init    State @@ -88,8 +87,7 @@    (#Primitive Primitive)    (#Structure (Structure Synthesis))    (#Reference Reference) -  (#Control (Control Synthesis)) -  (#Extension (Extension Synthesis))) +  (#Control (Control Synthesis)))  (type: #export Path    (Path' Synthesis)) @@ -151,7 +149,7 @@  (do-template [<name> <value>]    [(def: #export <name>       (All [a] (-> (Operation ..State a) (Operation ..State a))) -     (//compiler.localized (set@ #direct? <value>)))] +     (//.localized (set@ #direct? <value>)))]    [indirectly false]    [directly   true] @@ -160,7 +158,7 @@  (do-template [<name> <type> <tag>]    [(def: #export (<name> value)       (-> <type> (All [a] (-> (Operation ..State a) (Operation ..State a)))) -     (//compiler.localized (set@ <tag> value)))] +     (//.localized (set@ <tag> value)))]    [with-scope-arity Arity    #scope-arity]    [with-resolver    Resolver #resolver] @@ -171,10 +169,10 @@    (All [o]      (-> Arity Resolver          (-> (Operation ..State o) (Operation ..State o)))) -  (//compiler.with-state {#scope-arity arity -                          #resolver resolver -                          #direct? true -                          #locals arity})) +  (//.with-state {#scope-arity arity +                  #resolver resolver +                  #direct? true +                  #locals arity}))  (do-template [<name> <tag> <type>]    [(def: #export <name> @@ -190,7 +188,7 @@  (def: #export with-new-local    (All [a] (-> (Operation ..State a) (Operation ..State a))) -  (<<| (do //compiler.Monad<Operation> +  (<<| (do //.Monad<Operation>           [locals ..locals])         (..with-locals (inc locals)))) @@ -220,8 +218,8 @@            <tag>            content))] -  [variable/local   //reference.local] -  [variable/foreign //reference.foreign] +  [variable/local   ///reference.local] +  [variable/foreign ///reference.foreign]    )  (do-template [<name> <family> <tag>] diff --git a/stdlib/source/lux/lang/synthesis/case.lux b/stdlib/source/lux/lang/compiler/synthesis/case.lux index b7f224168..b7f224168 100644 --- a/stdlib/source/lux/lang/synthesis/case.lux +++ b/stdlib/source/lux/lang/compiler/synthesis/case.lux diff --git a/stdlib/source/lux/lang/synthesis/expression.lux b/stdlib/source/lux/lang/compiler/synthesis/expression.lux index 52ea33805..52ea33805 100644 --- a/stdlib/source/lux/lang/synthesis/expression.lux +++ b/stdlib/source/lux/lang/compiler/synthesis/expression.lux diff --git a/stdlib/source/lux/lang/synthesis/function.lux b/stdlib/source/lux/lang/compiler/synthesis/function.lux index 35b9e047e..35b9e047e 100644 --- a/stdlib/source/lux/lang/synthesis/function.lux +++ b/stdlib/source/lux/lang/compiler/synthesis/function.lux diff --git a/stdlib/source/lux/lang/synthesis/loop.lux b/stdlib/source/lux/lang/compiler/synthesis/loop.lux index eb57eb7ad..eb57eb7ad 100644 --- a/stdlib/source/lux/lang/synthesis/loop.lux +++ b/stdlib/source/lux/lang/compiler/synthesis/loop.lux diff --git a/stdlib/source/lux/lang/translation.lux b/stdlib/source/lux/lang/compiler/translation.lux index c117bc019..c117bc019 100644 --- a/stdlib/source/lux/lang/translation.lux +++ b/stdlib/source/lux/lang/compiler/translation.lux diff --git a/stdlib/source/lux/lang/translation/scheme/case.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/case.jvm.lux index e5d12a005..e5d12a005 100644 --- a/stdlib/source/lux/lang/translation/scheme/case.jvm.lux +++ b/stdlib/source/lux/lang/compiler/translation/scheme/case.jvm.lux diff --git a/stdlib/source/lux/lang/translation/scheme/expression.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/expression.jvm.lux index 96bb17126..96bb17126 100644 --- a/stdlib/source/lux/lang/translation/scheme/expression.jvm.lux +++ b/stdlib/source/lux/lang/compiler/translation/scheme/expression.jvm.lux diff --git a/stdlib/source/lux/lang/translation/scheme/extension.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/extension.jvm.lux index 6475caf68..6475caf68 100644 --- a/stdlib/source/lux/lang/translation/scheme/extension.jvm.lux +++ b/stdlib/source/lux/lang/compiler/translation/scheme/extension.jvm.lux diff --git a/stdlib/source/lux/lang/translation/scheme/extension/common.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/extension/common.jvm.lux index 140045aaf..140045aaf 100644 --- a/stdlib/source/lux/lang/translation/scheme/extension/common.jvm.lux +++ b/stdlib/source/lux/lang/compiler/translation/scheme/extension/common.jvm.lux diff --git a/stdlib/source/lux/lang/translation/scheme/function.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/function.jvm.lux index 11c64076c..11c64076c 100644 --- a/stdlib/source/lux/lang/translation/scheme/function.jvm.lux +++ b/stdlib/source/lux/lang/compiler/translation/scheme/function.jvm.lux diff --git a/stdlib/source/lux/lang/translation/scheme/loop.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/loop.jvm.lux index 6f305336e..6f305336e 100644 --- a/stdlib/source/lux/lang/translation/scheme/loop.jvm.lux +++ b/stdlib/source/lux/lang/compiler/translation/scheme/loop.jvm.lux diff --git a/stdlib/source/lux/lang/translation/scheme/primitive.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/primitive.jvm.lux index ac775fa82..ac775fa82 100644 --- a/stdlib/source/lux/lang/translation/scheme/primitive.jvm.lux +++ b/stdlib/source/lux/lang/compiler/translation/scheme/primitive.jvm.lux diff --git a/stdlib/source/lux/lang/translation/scheme/reference.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/reference.jvm.lux index 453d4edb6..453d4edb6 100644 --- a/stdlib/source/lux/lang/translation/scheme/reference.jvm.lux +++ b/stdlib/source/lux/lang/compiler/translation/scheme/reference.jvm.lux diff --git a/stdlib/source/lux/lang/translation/scheme/runtime.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/runtime.jvm.lux index b30aff3a2..b30aff3a2 100644 --- a/stdlib/source/lux/lang/translation/scheme/runtime.jvm.lux +++ b/stdlib/source/lux/lang/compiler/translation/scheme/runtime.jvm.lux diff --git a/stdlib/source/lux/lang/translation/scheme/structure.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/structure.jvm.lux index a11434594..a11434594 100644 --- a/stdlib/source/lux/lang/translation/scheme/structure.jvm.lux +++ b/stdlib/source/lux/lang/compiler/translation/scheme/structure.jvm.lux diff --git a/stdlib/source/lux/lang/extension.lux b/stdlib/source/lux/lang/extension.lux deleted file mode 100644 index 7edac52c3..000000000 --- a/stdlib/source/lux/lang/extension.lux +++ /dev/null @@ -1,131 +0,0 @@ -(.module: -  lux -  (lux (control [monad #+ do] -                ["ex" exception #+ exception:]) -       (data ["e" error] -             [text] -             (coll (dictionary ["dict" unordered #+ Dict])))) -  [// #+ Eval] -  [//compiler #+ Operation Compiler] -  [//analysis #+ Analyser] -  [//synthesis #+ Synthesizer] -  [//translation #+ Translator]) - -(do-template [<name>] -  [(exception: #export (<name> {extension Text}) -     extension)] - -  [unknown-analysis] -  [unknown-synthesis] -  [unknown-translation] -  [unknown-statement] - -  [cannot-define-analysis-more-than-once] -  [cannot-define-synthesis-more-than-once] -  [cannot-define-translation-more-than-once] -  [cannot-define-statement-more-than-once] -  ) - -(type: #export Analysis -  (-> Analyser Eval -      (Compiler .Lux -                (List Code) -                //analysis.Analysis))) - -(type: #export Synthesis -  (-> Synthesizer -      (Compiler //synthesis.State -                (List //analysis.Analysis) -                //synthesis.Synthesis))) - -(type: #export (Translation anchor code) -  (-> (Translator anchor code) -      (Compiler (//translation.State anchor code) -                (List //synthesis.Synthesis) -                code))) - -(type: #export Statement -  (-> (List Code) (Meta Any))) - -(type: #export (Extension e) -  (Dict Text e)) - -(type: #export Extensions -  {#analysis (Extension Analysis) -   #synthesis (Extension Synthesis) -   #translation (Extension Translation) -   #statement (Extension Statement)}) - -(def: #export fresh -  Extensions -  {#analysis (dict.new text.Hash<Text>) -   #synthesis (dict.new text.Hash<Text>) -   #translation (dict.new text.Hash<Text>) -   #statement (dict.new text.Hash<Text>)}) - -(def: get -  (Meta Extensions) -  (function (_ compiler) -    (#e.Success [compiler -                 (|> compiler (get@ #.extensions) (:! Extensions))]))) - -(def: (set extensions) -  (-> Extensions (Meta Any)) -  (function (_ compiler) -    (#e.Success [(set@ #.extensions (:! Nothing extensions) compiler) -                 []]))) - -(do-template [<name> <type> <category> <exception>] -  [(def: #export (<name> name) -     (-> Text (Meta <type>)) -     (do //compiler.Monad<Operation> -       [extensions ..get] -       (case (dict.get name (get@ <category> extensions)) -         (#.Some extension) -         (wrap extension) - -         #.None -         (//compiler.throw <exception> name))))] - -  [find-analysis    Analysis    #analysis    unknown-analysis] -  [find-synthesis   Synthesis   #synthesis   unknown-synthesis] -  [find-translation Translation #translation unknown-translation] -  [find-statement   Statement   #statement   unknown-statement] -  ) - -(def: #export empty -  (All [e] (Extension e)) -  (dict.new text.Hash<Text>)) - -(do-template [<params> <all> <state> <type> <category>] -  [(def: #export <all> -     (All <params> (Operation <state> (Extension <type>))) -     (|> ..get -         (:: //compiler.Monad<Operation> map (get@ <category>))))] - -  [[]            all-analyses     .Lux -   Analysis    #analysis] -  [[]            all-syntheses    //synthesis.State -   Synthesis   #synthesis] -  [[anchor code] all-translations (//translation.State anchor code) -   Translation #translation] -  [[]            all-statements   Any -   Statement   #statement] -  ) - -(do-template [<name> <type> <category> <exception>] -  [(def: #export (<name> name extension) -     (-> Text <type> (Meta Any)) -     (do //compiler.Monad<Operation> -       [extensions ..get -        _ (if (not (dict.contains? name (get@ <category> extensions))) -            (wrap []) -            (//compiler.throw <exception> name)) -        _ (..set (update@ <category> (dict.put name extension) extensions))] -       (wrap [])))] - -  [install-analysis    Analysis    #analysis    cannot-define-analysis-more-than-once] -  [install-synthesis   Synthesis   #synthesis   cannot-define-synthesis-more-than-once] -  [install-translation Translation #translation cannot-define-translation-more-than-once] -  [install-statement   Statement   #statement   cannot-define-statement-more-than-once] -  ) diff --git a/stdlib/source/lux/lang/extension/analysis/common.lux b/stdlib/source/lux/lang/extension/analysis/common.lux deleted file mode 100644 index 3faae601b..000000000 --- a/stdlib/source/lux/lang/extension/analysis/common.lux +++ /dev/null @@ -1,444 +0,0 @@ -(.module: -  lux -  (lux (control [monad #+ do] -                ["ex" exception #+ exception:] -                [thread]) -       (concurrency [atom #+ Atom]) -       (data [text] -             text/format -             (coll [list "list/" Functor<List>] -                   [array] -                   (dictionary ["dict" unordered #+ Dict]))) -       [macro] -       (macro [code]) -       [lang] -       (lang (type ["tc" check]) -             [".L" analysis] -             (analysis [".A" type] -                       [".A" case] -                       [".A" function])) -       [io]) -  [///]) - -(exception: #export (incorrect-extension-arity {name Text} {arity Nat} {args Nat}) -  (ex.report ["Extension" (%t name)] -             ["Expected arity" (|> arity .int %i)] -             ["Actual arity" (|> args .int %i)])) - -(exception: #export (invalid-syntax {name Text} {arguments (List Code)}) -  (ex.report ["Extension" name] -             ["Inputs" (|> arguments -                           list.enumerate -                           (list/map (function (_ [idx argC]) -                                       (format "\n  " (%n idx) " " (%code argC)))) -                           (text.join-with ""))])) - -## [Utils] -(type: #export Bundle -  (Dict Text (-> Text ///.Analysis))) - -(def: #export (install name unnamed) -  (-> Text (-> Text ///.Analysis) -      (-> Bundle Bundle)) -  (dict.put name unnamed)) - -(def: #export (prefix prefix bundle) -  (-> Text Bundle Bundle) -  (|> bundle -      dict.entries -      (list/map (function (_ [key val]) [(format prefix " " key) val])) -      (dict.from-list text.Hash<Text>))) - -(def: (simple proc inputsT+ outputT) -  (-> Text (List Type) Type ///.Analysis) -  (let [num-expected (list.size inputsT+)] -    (function (_ analyse eval args) -      (let [num-actual (list.size args)] -        (if (n/= num-expected num-actual) -          (do macro.Monad<Meta> -            [_ (typeA.infer outputT) -             argsA (monad.map @ -                              (function (_ [argT argC]) -                                (typeA.with-type argT -                                  (analyse argC))) -                              (list.zip2 inputsT+ args))] -            (wrap (#analysisL.Extension proc argsA))) -          (lang.throw incorrect-extension-arity [proc num-expected num-actual])))))) - -(def: #export (nullary valueT proc) -  (-> Type Text ///.Analysis) -  (simple proc (list) valueT)) - -(def: #export (unary inputT outputT proc) -  (-> Type Type Text ///.Analysis) -  (simple proc (list inputT) outputT)) - -(def: #export (binary subjectT paramT outputT proc) -  (-> Type Type Type Text ///.Analysis) -  (simple proc (list subjectT paramT) outputT)) - -(def: #export (trinary subjectT param0T param1T outputT proc) -  (-> Type Type Type Type Text ///.Analysis) -  (simple proc (list subjectT param0T param1T) outputT)) - -## [Analysers] -## "lux is" represents reference/pointer equality. -(def: (lux//is proc) -  (-> Text ///.Analysis) -  (function (_ analyse eval args) -    (do macro.Monad<Meta> -      [[var-id varT] (typeA.with-env tc.var)] -      ((binary varT varT Bool proc) -       analyse eval args)))) - -## "lux try" provides a simple way to interact with the host platform's -## error-handling facilities. -(def: (lux//try proc) -  (-> Text ///.Analysis) -  (function (_ analyse eval args) -    (case args -      (^ (list opC)) -      (do macro.Monad<Meta> -        [[var-id varT] (typeA.with-env tc.var) -         _ (typeA.infer (type (Either Text varT))) -         opA (typeA.with-type (type (io.IO varT)) -               (analyse opC))] -        (wrap (#analysisL.Extension proc (list opA)))) -       -      _ -      (lang.throw incorrect-extension-arity [proc +1 (list.size args)])))) - -(def: (lux//function proc) -  (-> Text ///.Analysis) -  (function (_ analyse eval args) -    (case args -      (^ (list [_ (#.Symbol ["" func-name])] -               [_ (#.Symbol ["" arg-name])] -               body)) -      (functionA.function analyse func-name arg-name body) -       -      _ -      (lang.throw incorrect-extension-arity [proc +3 (list.size args)])))) - -(def: (lux//case proc) -  (-> Text ///.Analysis) -  (function (_ analyse eval args) -    (case args -      (^ (list input [_ (#.Record branches)])) -      (caseA.case analyse input branches) -       -      _ -      (lang.throw incorrect-extension-arity [proc +2 (list.size args)])))) - -(def: (lux//in-module proc) -  (-> Text ///.Analysis) -  (function (_ analyse eval argsC+) -    (case argsC+ -      (^ (list [_ (#.Text module-name)] exprC)) -      (lang.with-current-module module-name -        (analyse exprC)) -       -      _ -      (lang.throw invalid-syntax [proc argsC+])))) - -(do-template [<name> <type>] -  [(def: (<name> proc) -     (-> Text ///.Analysis) -     (function (_ analyse eval args) -       (case args -         (^ (list typeC valueC)) -         (do macro.Monad<Meta> -           [actualT (eval Type typeC) -            _ (typeA.infer (:! Type actualT))] -           (typeA.with-type <type> -             (analyse valueC))) -          -         _ -         (lang.throw incorrect-extension-arity [proc +2 (list.size args)]))))] - -  [lux//check  (:! Type actualT)] -  [lux//coerce Any] -  ) - -(def: (lux//check//type proc) -  (-> Text ///.Analysis) -  (function (_ analyse eval args) -    (case args -      (^ (list valueC)) -      (do macro.Monad<Meta> -        [_ (typeA.infer Type) -         valueA (typeA.with-type Type -                  (analyse valueC))] -        (wrap valueA)) -       -      _ -      (lang.throw incorrect-extension-arity [proc +1 (list.size args)])))) - -(def: lux-procs -  Bundle -  (|> (dict.new text.Hash<Text>) -      (install "is" lux//is) -      (install "try" lux//try) -      (install "function" lux//function) -      (install "case" lux//case) -      (install "check" lux//check) -      (install "coerce" lux//coerce) -      (install "check type" lux//check//type) -      (install "in-module" lux//in-module))) - -(def: io-procs -  Bundle -  (<| (prefix "io") -      (|> (dict.new text.Hash<Text>) -          (install "log" (unary Text Any)) -          (install "error" (unary Text Nothing)) -          (install "exit" (unary Int Nothing)) -          (install "current-time" (nullary Int))))) - -(def: bit-procs -  Bundle -  (<| (prefix "bit") -      (|> (dict.new text.Hash<Text>) -          (install "and" (binary Nat Nat Nat)) -          (install "or" (binary Nat Nat Nat)) -          (install "xor" (binary Nat Nat Nat)) -          (install "left-shift" (binary Nat Nat Nat)) -          (install "logical-right-shift" (binary Nat Nat Nat)) -          (install "arithmetic-right-shift" (binary Int Nat Int)) -          ))) - -(def: int-procs -  Bundle -  (<| (prefix "int") -      (|> (dict.new text.Hash<Text>) -          (install "+" (binary Int Int Int)) -          (install "-" (binary Int Int Int)) -          (install "*" (binary Int Int Int)) -          (install "/" (binary Int Int Int)) -          (install "%" (binary Int Int Int)) -          (install "=" (binary Int Int Bool)) -          (install "<" (binary Int Int Bool)) -          (install "min" (nullary Int)) -          (install "max" (nullary Int)) -          (install "to-nat" (unary Int Nat)) -          (install "to-frac" (unary Int Frac)) -          (install "char" (unary Int Text))))) - -(def: deg-procs -  Bundle -  (<| (prefix "deg") -      (|> (dict.new text.Hash<Text>) -          (install "+" (binary Deg Deg Deg)) -          (install "-" (binary Deg Deg Deg)) -          (install "*" (binary Deg Deg Deg)) -          (install "/" (binary Deg Deg Deg)) -          (install "%" (binary Deg Deg Deg)) -          (install "=" (binary Deg Deg Bool)) -          (install "<" (binary Deg Deg Bool)) -          (install "scale" (binary Deg Nat Deg)) -          (install "reciprocal" (binary Deg Nat Deg)) -          (install "min" (nullary Deg)) -          (install "max" (nullary Deg)) -          (install "to-frac" (unary Deg Frac))))) - -(def: frac-procs -  Bundle -  (<| (prefix "frac") -      (|> (dict.new text.Hash<Text>) -          (install "+" (binary Frac Frac Frac)) -          (install "-" (binary Frac Frac Frac)) -          (install "*" (binary Frac Frac Frac)) -          (install "/" (binary Frac Frac Frac)) -          (install "%" (binary Frac Frac Frac)) -          (install "=" (binary Frac Frac Bool)) -          (install "<" (binary Frac Frac Bool)) -          (install "smallest" (nullary Frac)) -          (install "min" (nullary Frac)) -          (install "max" (nullary Frac)) -          (install "not-a-number" (nullary Frac)) -          (install "positive-infinity" (nullary Frac)) -          (install "negative-infinity" (nullary Frac)) -          (install "to-deg" (unary Frac Deg)) -          (install "to-int" (unary Frac Int)) -          (install "encode" (unary Frac Text)) -          (install "decode" (unary Text (type (Maybe Frac))))))) - -(def: text-procs -  Bundle -  (<| (prefix "text") -      (|> (dict.new text.Hash<Text>) -          (install "=" (binary Text Text Bool)) -          (install "<" (binary Text Text Bool)) -          (install "concat" (binary Text Text Text)) -          (install "index" (trinary Text Text Nat (type (Maybe Nat)))) -          (install "size" (unary Text Nat)) -          (install "hash" (unary Text Nat)) -          (install "replace-once" (trinary Text Text Text Text)) -          (install "replace-all" (trinary Text Text Text Text)) -          (install "char" (binary Text Nat (type (Maybe Nat)))) -          (install "clip" (trinary Text Nat Nat (type (Maybe Text)))) -          ))) - -(def: (array//get proc) -  (-> Text ///.Analysis) -  (function (_ analyse eval args) -    (do macro.Monad<Meta> -      [[var-id varT] (typeA.with-env tc.var)] -      ((binary (type (Array varT)) Nat (type (Maybe varT)) proc) -       analyse eval args)))) - -(def: (array//put proc) -  (-> Text ///.Analysis) -  (function (_ analyse eval args) -    (do macro.Monad<Meta> -      [[var-id varT] (typeA.with-env tc.var)] -      ((trinary (type (Array varT)) Nat varT (type (Array varT)) proc) -       analyse eval args)))) - -(def: (array//remove proc) -  (-> Text ///.Analysis) -  (function (_ analyse eval args) -    (do macro.Monad<Meta> -      [[var-id varT] (typeA.with-env tc.var)] -      ((binary (type (Array varT)) Nat (type (Array varT)) proc) -       analyse eval args)))) - -(def: array-procs -  Bundle -  (<| (prefix "array") -      (|> (dict.new text.Hash<Text>) -          (install "new" (unary Nat Array)) -          (install "get" array//get) -          (install "put" array//put) -          (install "remove" array//remove) -          (install "size" (unary (type (Ex [a] (Array a))) Nat)) -          ))) - -(def: math-procs -  Bundle -  (<| (prefix "math") -      (|> (dict.new text.Hash<Text>) -          (install "cos" (unary Frac Frac)) -          (install "sin" (unary Frac Frac)) -          (install "tan" (unary Frac Frac)) -          (install "acos" (unary Frac Frac)) -          (install "asin" (unary Frac Frac)) -          (install "atan" (unary Frac Frac)) -          (install "cosh" (unary Frac Frac)) -          (install "sinh" (unary Frac Frac)) -          (install "tanh" (unary Frac Frac)) -          (install "exp" (unary Frac Frac)) -          (install "log" (unary Frac Frac)) -          (install "ceil" (unary Frac Frac)) -          (install "floor" (unary Frac Frac)) -          (install "round" (unary Frac Frac)) -          (install "atan2" (binary Frac Frac Frac)) -          (install "pow" (binary Frac Frac Frac)) -          ))) - -(def: (atom-new proc) -  (-> Text ///.Analysis) -  (function (_ analyse eval args) -    (case args -      (^ (list initC)) -      (do macro.Monad<Meta> -        [[var-id varT] (typeA.with-env tc.var) -         _ (typeA.infer (type (Atom varT))) -         initA (typeA.with-type varT -                 (analyse initC))] -        (wrap (#analysisL.Extension proc (list initA)))) -       -      _ -      (lang.throw incorrect-extension-arity [proc +1 (list.size args)])))) - -(def: (atom-read proc) -  (-> Text ///.Analysis) -  (function (_ analyse eval args) -    (do macro.Monad<Meta> -      [[var-id varT] (typeA.with-env tc.var)] -      ((unary (type (Atom varT)) varT proc) -       analyse eval args)))) - -(def: (atom//compare-and-swap proc) -  (-> Text ///.Analysis) -  (function (_ analyse eval args) -    (do macro.Monad<Meta> -      [[var-id varT] (typeA.with-env tc.var)] -      ((trinary (type (Atom varT)) varT varT Bool proc) -       analyse eval args)))) - -(def: atom-procs -  Bundle -  (<| (prefix "atom") -      (|> (dict.new text.Hash<Text>) -          (install "new" atom-new) -          (install "read" atom-read) -          (install "compare-and-swap" atom//compare-and-swap) -          ))) - -(def: (box//new proc) -  (-> Text ///.Analysis) -  (function (_ analyse eval args) -    (case args -      (^ (list initC)) -      (do macro.Monad<Meta> -        [[var-id varT] (typeA.with-env tc.var) -         _ (typeA.infer (type (All [!] (thread.Box ! varT)))) -         initA (typeA.with-type varT -                 (analyse initC))] -        (wrap (#analysisL.Extension proc (list initA)))) -       -      _ -      (lang.throw incorrect-extension-arity [proc +1 (list.size args)])))) - -(def: (box//read proc) -  (-> Text ///.Analysis) -  (function (_ analyse eval args) -    (do macro.Monad<Meta> -      [[thread-id threadT] (typeA.with-env tc.var) -       [var-id varT] (typeA.with-env tc.var)] -      ((unary (type (thread.Box threadT varT)) varT proc) -       analyse eval args)))) - -(def: (box//write proc) -  (-> Text ///.Analysis) -  (function (_ analyse eval args) -    (do macro.Monad<Meta> -      [[thread-id threadT] (typeA.with-env tc.var) -       [var-id varT] (typeA.with-env tc.var)] -      ((binary varT (type (thread.Box threadT varT)) Any proc) -       analyse eval args)))) - -(def: box-procs -  Bundle -  (<| (prefix "box") -      (|> (dict.new text.Hash<Text>) -          (install "new" box//new) -          (install "read" box//read) -          (install "write" box//write) -          ))) - -(def: process-procs -  Bundle -  (<| (prefix "process") -      (|> (dict.new text.Hash<Text>) -          (install "parallelism-level" (nullary Nat)) -          (install "schedule" (binary Nat (type (io.IO Any)) Any)) -          ))) - -(def: #export extensions -  Bundle -  (<| (prefix "lux") -      (|> (dict.new text.Hash<Text>) -          (dict.merge lux-procs) -          (dict.merge bit-procs) -          (dict.merge int-procs) -          (dict.merge deg-procs) -          (dict.merge frac-procs) -          (dict.merge text-procs) -          (dict.merge array-procs) -          (dict.merge math-procs) -          (dict.merge atom-procs) -          (dict.merge box-procs) -          (dict.merge process-procs) -          (dict.merge io-procs)))) diff --git a/stdlib/source/lux/lang/target.lux b/stdlib/source/lux/lang/host.lux index ee0eee74d..218de67a4 100644 --- a/stdlib/source/lux/lang/target.lux +++ b/stdlib/source/lux/lang/host.lux @@ -1,10 +1,10 @@  (.module:    lux) -(type: #export Target Text) +(type: #export Host Text)  (do-template [<name> <value>] -  [(def: #export <name> Target <value>)] +  [(def: #export <name> Host <value>)]    [common-lisp "Common Lisp"]    [js          "JavaScript"] diff --git a/stdlib/source/lux/lang/init.lux b/stdlib/source/lux/lang/init.lux deleted file mode 100644 index 40a7fc69c..000000000 --- a/stdlib/source/lux/lang/init.lux +++ /dev/null @@ -1,61 +0,0 @@ -(.module: -  lux -  [//] -  (// ["//." target] -      [".L" extension] -      (extension [".E" analysis] -                 [".E" synthesis] -                 [".E" translation] -                 ## [".E" statement] -                 ))) - -(def: #export (cursor file) -  (-> Text Cursor) -  [file +1 +0]) - -(def: #export (source file code) -  (-> Text Text Source) -  [(cursor file) +0 code]) - -(def: dummy-source -  Source -  [.dummy-cursor +0 ""]) - -(def: #export type-context -  Type-Context -  {#.ex-counter +0 -   #.var-counter +0 -   #.var-bindings (list)}) - -(`` (def: #export info -      Info -      {#.target  (for {(~~ (static //target.common-lisp)) //target.common-lisp -                       (~~ (static //target.js))          //target.js -                       (~~ (static //target.jvm))         //target.jvm -                       (~~ (static //target.lua))         //target.lua -                       (~~ (static //target.php))         //target.php -                       (~~ (static //target.python))      //target.python -                       (~~ (static //target.r))           //target.r -                       (~~ (static //target.ruby))        //target.ruby -                       (~~ (static //target.scheme))      //target.scheme}) -       #.version //.version -       #.mode    #.Build})) - -(def: #export (compiler host) -  (-> Any Lux) -  {#.info            ..info -   #.source          dummy-source -   #.cursor          .dummy-cursor -   #.current-module  #.None -   #.modules         (list) -   #.scopes          (list) -   #.type-context    ..type-context -   #.expected        #.None -   #.seed            +0 -   #.scope-type-vars (list) -   #.extensions      {#extensionL.analysis analysisE.defaults -                      #extensionL.synthesis synthesisE.defaults -                      #extensionL.translation translationE.defaults -                      #extensionL.statement (:!! []) ## statementE.defaults -                      } -   #.host            host}) diff --git a/stdlib/source/lux/lang/module.lux b/stdlib/source/lux/lang/module.lux index 161fd073a..d6b66da74 100644 --- a/stdlib/source/lux/lang/module.lux +++ b/stdlib/source/lux/lang/module.lux @@ -9,7 +9,8 @@               (coll [list "list/" Fold<List> Functor<List>]                     (dictionary [plist])))         [macro]) -  [//]) +  [//compiler] +  (//compiler [analysis]))  (type: #export Tag Text) @@ -17,13 +18,13 @@    module)  (exception: #export (cannot-declare-tag-twice {module Text} {tag Text}) -  (format "Module: " module "\n" -          "   Tag: " tag "\n")) +  (ex.report ["Module" module] +             ["Tag" tag]))  (do-template [<name>]    [(exception: #export (<name> {tags (List Text)} {owner Type}) -     (format "Tags: " (text.join-with " " tags) "\n" -             "Type: " (%type owner) "\n"))] +     (ex.report ["Tags" (text.join-with " " tags)] +                ["Type" (%type owner)]))]    [cannot-declare-tags-for-unnamed-type]    [cannot-declare-tags-for-foreign-type] @@ -33,16 +34,16 @@    (%ident name))  (exception: #export (can-only-change-state-of-active-module {module Text} {state Module-State}) -  (format "       Module: " module "\n" -          "Desired state: " (case state -                              #.Active   "Active" -                              #.Compiled "Compiled" -                              #.Cached   "Cached") "\n")) +  (ex.report ["Module" module] +             ["Desired state" (case state +                                #.Active   "Active" +                                #.Compiled "Compiled" +                                #.Cached   "Cached")]))  (exception: #export (cannot-set-module-annotations-more-than-once {module Text} {old Code} {new Code}) -  (format "         Module: " module "\n" -          "Old annotations: " (%code old) "\n" -          "New annotations: " (%code new) "\n")) +  (ex.report ["Module" module] +             ["Old annotations" (%code old)] +             ["New annotations" (%code new)]))  (def: (new hash)    (-> Nat Module) @@ -69,7 +70,7 @@                       []]))        (#.Some old) -      (//.throw cannot-set-module-annotations-more-than-once [self-name old annotations])))) +      (//compiler.throw cannot-set-module-annotations-more-than-once [self-name old annotations]))))  (def: #export (import module)    (-> Text (Meta Any)) @@ -119,7 +120,7 @@                       []])          (#.Some already-existing) -        ((//.throw cannot-define-more-than-once [self-name name]) compiler))))) +        ((//compiler.throw cannot-define-more-than-once [self-name name]) compiler)))))  (def: #export (create hash name)    (-> Nat Text (Meta [])) @@ -134,7 +135,7 @@    (All [a] (-> Nat Text (Meta a) (Meta [Module a])))    (do macro.Monad<Meta>      [_ (create hash name) -     output (//.with-current-module name +     output (analysis.with-current-module name                action)       module (macro.find-module name)]      (wrap [module output]))) @@ -153,11 +154,11 @@                                     (plist.put module-name (set@ #.module-state <tag> module))                                     compiler)                            []]) -             ((//.throw can-only-change-state-of-active-module [module-name <tag>]) +             ((//compiler.throw can-only-change-state-of-active-module [module-name <tag>])                compiler)))           #.None -         ((//.throw unknown-module module-name) compiler)))) +         ((//compiler.throw unknown-module module-name) compiler))))     (def: #export (<asker> module-name)       (-> Text (Meta Bool)) @@ -170,7 +171,7 @@                          _     false)])           #.None -         ((//.throw unknown-module module-name) compiler))))] +         ((//compiler.throw unknown-module module-name) compiler))))]    [set-active   active?   #.Active]    [set-compiled compiled? #.Compiled] @@ -186,7 +187,7 @@           (#e.Success [compiler (get@ <tag> module)])           #.None -         ((//.throw unknown-module module-name) compiler))))] +         ((//compiler.throw unknown-module module-name) compiler))))]    [tags  #.tags        (List [Text [Nat (List Ident) Bool Type]])]    [types #.types       (List [Text [(List Ident) Bool Type]])] @@ -204,7 +205,7 @@                        (wrap [])                        (#.Some _) -                      (//.throw cannot-declare-tag-twice [module-name tag]))) +                      (//compiler.throw cannot-declare-tag-twice [module-name tag])))                    tags)]      (wrap []))) @@ -217,10 +218,10 @@                                 (wrap type-ident)                                 _ -                               (//.throw cannot-declare-tags-for-unnamed-type [tags type])) +                               (//compiler.throw cannot-declare-tags-for-unnamed-type [tags type]))       _ (ensure-undeclared-tags self-name tags) -     _ (//.assert cannot-declare-tags-for-foreign-type [tags type] -                  (text/= self-name type-module))] +     _ (//compiler.assert cannot-declare-tags-for-foreign-type [tags type] +                          (text/= self-name type-module))]      (function (_ compiler)        (case (|> compiler (get@ #.modules) (plist.get self-name))          (#.Some module) @@ -236,4 +237,4 @@                                  compiler)                         []]))          #.None -        ((//.throw unknown-module self-name) compiler))))) +        ((//compiler.throw unknown-module self-name) compiler))))) | 
