From 7e18f589a05bde28b3f710d92f72b7bd6b6e144f Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 5 Dec 2017 02:41:59 -0400 Subject: - Added analysis, synthesis, translation and statement extensions. - No longer doing ad-hoc I/O in new-luxc. - Minor fixes and adjustments. --- new-luxc/source/luxc/lang/extension.lux | 84 +++++++++++ new-luxc/source/luxc/lang/extension/analysis.lux | 9 ++ new-luxc/source/luxc/lang/extension/statement.lux | 146 ++++++++++++++++++ new-luxc/source/luxc/lang/extension/synthesis.lux | 9 ++ .../source/luxc/lang/extension/translation.lux | 9 ++ new-luxc/source/luxc/lang/host/jvm.lux | 2 +- new-luxc/source/luxc/lang/module.lux | 10 +- new-luxc/source/luxc/lang/translation.lux | 164 +++++++++------------ .../source/luxc/lang/translation/common.jvm.lux | 2 - 9 files changed, 336 insertions(+), 99 deletions(-) create mode 100644 new-luxc/source/luxc/lang/extension.lux create mode 100644 new-luxc/source/luxc/lang/extension/analysis.lux create mode 100644 new-luxc/source/luxc/lang/extension/statement.lux create mode 100644 new-luxc/source/luxc/lang/extension/synthesis.lux create mode 100644 new-luxc/source/luxc/lang/extension/translation.lux (limited to 'new-luxc/source/luxc/lang') diff --git a/new-luxc/source/luxc/lang/extension.lux b/new-luxc/source/luxc/lang/extension.lux new file mode 100644 index 000000000..d38d564fb --- /dev/null +++ b/new-luxc/source/luxc/lang/extension.lux @@ -0,0 +1,84 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data ["e" error] + [text] + (coll [dict #+ Dict])) + [macro]) + [//]) + +(exception: #export Unknown-Analysis) +(exception: #export Unknown-Synthesis) +(exception: #export Unknown-Translation) +(exception: #export Unknown-Statement) + +(exception: #export Cannot-Define-Analysis-More-Than-Once) +(exception: #export Cannot-Define-Synthesis-More-Than-Once) +(exception: #export Cannot-Define-Translation-More-Than-Once) +(exception: #export Cannot-Define-Statement-More-Than-Once) + +(type: #export Expression + (-> (List Code) (Meta Code))) + +(type: #export Statement + (-> (List Code) (Meta Unit))) + +(type: #export Extensions + {#analysis (Dict Text Expression) + #synthesis (Dict Text Expression) + #translation (Dict Text Expression) + #statement (Dict Text Statement)}) + +(def: #export fresh + Extensions + {#analysis (dict.new text.Hash) + #synthesis (dict.new text.Hash) + #translation (dict.new text.Hash) + #statement (dict.new text.Hash)}) + +(def: get + (Meta Extensions) + (function [compiler] + (#e.Success [compiler + (|> compiler (get@ #.extensions) (:! Extensions))]))) + +(def: (set extensions) + (-> Extensions (Meta Unit)) + (function [compiler] + (#e.Success [(set@ #.extensions (:! Void extensions) compiler) + []]))) + +(do-template [ ] + [(def: #export ( name) + (-> Text (Meta )) + (do macro.Monad + [extensions ..get] + (case (dict.get name (get@ extensions)) + (#.Some extension) + (wrap extension) + + #.None + (//.throw name))))] + + [find-analysis Expression #analysis Unknown-Analysis] + [find-synthesis Expression #synthesis Unknown-Synthesis] + [find-translation Expression #translation Unknown-Translation] + [find-statement Statement #statement Unknown-Statement] + ) + +(do-template [ ] + [(def: #export ( name extension) + (-> Text (Meta Unit)) + (do macro.Monad + [extensions ..get + _ (//.assert name + (not (dict.contains? name (get@ extensions)))) + _ (..set (update@ (dict.put name extension) extensions))] + (wrap [])))] + + [install-analysis Expression #analysis Cannot-Define-Analysis-More-Than-Once] + [install-synthesis Expression #synthesis Cannot-Define-Synthesis-More-Than-Once] + [install-translation Expression #translation Cannot-Define-Translation-More-Than-Once] + [install-statement Statement #statement Cannot-Define-Statement-More-Than-Once] + ) diff --git a/new-luxc/source/luxc/lang/extension/analysis.lux b/new-luxc/source/luxc/lang/extension/analysis.lux new file mode 100644 index 000000000..d034f2919 --- /dev/null +++ b/new-luxc/source/luxc/lang/extension/analysis.lux @@ -0,0 +1,9 @@ +(.module: + lux + (lux (data [text] + (coll [dict #+ Dict]))) + [//]) + +(def: #export defaults + (Dict Text //.Expression) + (dict.new text.Hash)) diff --git a/new-luxc/source/luxc/lang/extension/statement.lux b/new-luxc/source/luxc/lang/extension/statement.lux new file mode 100644 index 000000000..6e9530f38 --- /dev/null +++ b/new-luxc/source/luxc/lang/extension/statement.lux @@ -0,0 +1,146 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data [text] + text/format + (coll [list "list/" Functor] + [dict #+ Dict])) + [macro] + (lang (type ["tc" check])) + [io #+ IO]) + [//] + (luxc [lang] + (lang [".L" host] + (host ["$" jvm]) + (analysis [".A" common] + [".A" expression]) + (synthesis [".S" expression]) + (translation [".T" expression] + [".T" statement] + [".T" eval]) + [".L" eval]))) + +(exception: #export Invalid-Statement) +(exception: #export Invalid-Alias) + +(def: (throw-invalid-statement procedure inputsC+) + (All [a] (-> Text (List Code) (Meta a))) + (lang.throw Invalid-Statement + (format "Statement: " procedure "\n" + " Inputs:" + (|> inputsC+ + list.enumerate + (list/map (function [[idx inputC]] + (format "\n " (%n idx) " " (%code inputC)))) + (text.join-with "")) "\n"))) + +(def: (process-annotations annsC) + (-> Code (Meta [$.Inst Code])) + (do macro.Monad + [[_ annsA] (lang.with-scope + (lang.with-type Code + (expressionA.analyser evalL.eval annsC))) + annsI (expressionT.translate (expressionS.synthesize annsA)) + annsV (evalT.eval annsI)] + (wrap [annsI (:! Code annsV)]))) + +(def: (ensure-valid-alias def-name annotations value) + (-> Text Code Code (Meta Unit)) + (case [annotations value] + (^multi [[_ (#.Record pairs)] [_ (#.Symbol _)]] + (|> pairs list.size (n/= +1))) + (:: macro.Monad wrap []) + + _ + (lang.throw Invalid-Alias def-name))) + +(def: (lux//def procedure) + (-> Text //.Statement) + (function [inputsC+] + (case inputsC+ + (^ (list [_ (#.Symbol ["" def-name])] valueC annotationsC)) + (hostL.with-context def-name + (lang.with-fresh-type-env + (do macro.Monad + [[annotationsI annotationsV] (process-annotations annotationsC)] + (case (macro.get-symbol-ann (ident-for #.alias) annotationsV) + (#.Some real-def) + (do @ + [_ (ensure-valid-alias def-name annotationsV valueC) + _ (lang.with-scope + (statementT.translate-def def-name Void id annotationsI annotationsV))] + (wrap [])) + + #.None + (do @ + [[_ valueT valueA] (lang.with-scope + (if (macro.type? (:! Code annotationsV)) + (do @ + [valueA (lang.with-type Type + (expressionA.analyser evalL.eval valueC))] + (wrap [Type valueA])) + (commonA.with-unknown-type + (expressionA.analyser evalL.eval valueC)))) + valueT (lang.with-type-env + (tc.clean valueT)) + valueI (expressionT.translate (expressionS.synthesize valueA)) + _ (lang.with-scope + (statementT.translate-def def-name valueT valueI annotationsI annotationsV))] + (wrap [])))))) + + _ + (throw-invalid-statement procedure inputsC+)))) + +(def: (lux//program procedure) + (-> Text //.Statement) + (function [inputsC+] + (case inputsC+ + (^ (list [_ (#.Symbol ["" args])] programC)) + (do macro.Monad + [[_ programA] (lang.with-scope + (lang.with-type (type (IO Unit)) + (expressionA.analyser evalL.eval programC))) + programI (expressionT.translate (expressionS.synthesize programA)) + _ (statementT.translate-program args programI)] + (wrap [])) + + _ + (throw-invalid-statement procedure inputsC+)))) + +(do-template [ ] + [(def: ( procedure) + (-> Text //.Statement) + (function [inputsC+] + (case inputsC+ + (^ (list [_ (#.Text name)] valueC)) + (do macro.Monad + [[_ valueA] (lang.with-scope + (lang.with-type + (expressionA.analyser evalL.eval valueC))) + valueI (expressionT.translate (expressionS.synthesize valueA)) + valueV (evalT.eval valueI) + _ ( name (:! valueV))] + (wrap [])) + + _ + (throw-invalid-statement procedure inputsC+))))] + + [lux//analysis //.Expression //.install-analysis] + [lux//synthesis //.Expression //.install-synthesis] + [lux//translation //.Expression //.install-translation] + [lux//statement //.Statement //.install-statement]) + +(def: #export defaults + (Dict Text //.Statement) + (`` (|> (dict.new text.Hash) + (~~ (do-template [ ] + [(dict.put ( ))] + + ["lux def" lux//def] + ["lux program" lux//program] + ["lux analysis" lux//analysis] + ["lux synthesis" lux//synthesis] + ["lux translation" lux//translation] + ["lux statement" lux//statement] + ))))) diff --git a/new-luxc/source/luxc/lang/extension/synthesis.lux b/new-luxc/source/luxc/lang/extension/synthesis.lux new file mode 100644 index 000000000..d034f2919 --- /dev/null +++ b/new-luxc/source/luxc/lang/extension/synthesis.lux @@ -0,0 +1,9 @@ +(.module: + lux + (lux (data [text] + (coll [dict #+ Dict]))) + [//]) + +(def: #export defaults + (Dict Text //.Expression) + (dict.new text.Hash)) diff --git a/new-luxc/source/luxc/lang/extension/translation.lux b/new-luxc/source/luxc/lang/extension/translation.lux new file mode 100644 index 000000000..d034f2919 --- /dev/null +++ b/new-luxc/source/luxc/lang/extension/translation.lux @@ -0,0 +1,9 @@ +(.module: + lux + (lux (data [text] + (coll [dict #+ Dict]))) + [//]) + +(def: #export defaults + (Dict Text //.Expression) + (dict.new text.Hash)) diff --git a/new-luxc/source/luxc/lang/host/jvm.lux b/new-luxc/source/luxc/lang/host/jvm.lux index cfe71656c..67b28b7b0 100644 --- a/new-luxc/source/luxc/lang/host/jvm.lux +++ b/new-luxc/source/luxc/lang/host/jvm.lux @@ -1,5 +1,5 @@ (.module: - [lux #- Type Def] + [lux #- Type] (lux (control monad ["p" parser]) (data (coll [list "list/" Functor])) diff --git a/new-luxc/source/luxc/lang/module.lux b/new-luxc/source/luxc/lang/module.lux index 58bf94571..ebc0ee7b0 100644 --- a/new-luxc/source/luxc/lang/module.lux +++ b/new-luxc/source/luxc/lang/module.lux @@ -25,7 +25,7 @@ (-> Nat Module) {#.module-hash hash #.module-aliases (list) - #.defs (list) + #.definitions (list) #.imports (list) #.tags (list) #.types (list) @@ -82,16 +82,16 @@ (def: #export (define (^@ full-name [module-name def-name]) definition) - (-> Ident Def (Meta Unit)) + (-> Ident Definition (Meta Unit)) (function [compiler] (case (&.pl-get module-name (get@ #.modules compiler)) (#.Some module) - (case (&.pl-get def-name (get@ #.defs module)) + (case (&.pl-get def-name (get@ #.definitions module)) #.None (#e.Success [(update@ #.modules (&.pl-put module-name - (update@ #.defs - (: (-> (List [Text Def]) (List [Text Def])) + (update@ #.definitions + (: (-> (List [Text Definition]) (List [Text Definition])) (|>> (#.Cons [def-name definition]))) module)) compiler) diff --git a/new-luxc/source/luxc/lang/translation.lux b/new-luxc/source/luxc/lang/translation.lux index 6cba6cc35..a0e5bca97 100644 --- a/new-luxc/source/luxc/lang/translation.lux +++ b/new-luxc/source/luxc/lang/translation.lux @@ -20,17 +20,24 @@ (lang [".L" module] [".L" host] [".L" macro] + [".L" extension] + (extension [".E" analysis] + [".E" synthesis] + [".E" translation] + [".E" statement]) (host ["$" jvm]) (analysis [".A" expression] [".A" common]) (synthesis [".S" expression]) (translation [".T" runtime] [".T" statement] - [".T" common] + [".T" common #+ Artifacts] [".T" expression] [".T" eval] [".T" imports]) - ["&." eval]) + ["&." eval] + ## [".L" cache] + ) )) (def: analyse @@ -39,7 +46,6 @@ (exception: #export Macro-Expansion-Failed) (exception: #export Unrecognized-Statement) -(exception: #export Invalid-Alias) (exception: #export Invalid-Macro) (def: (process-annotations annsC) @@ -60,55 +66,9 @@ (wrap (|> this (get@ #.module-aliases) (dict.from-list text.Hash) (: Aliases)))) new-compiler))) -(def: (ensure-valid-alias def-name annotations value) - (-> Text Code Code (Meta Unit)) - (case [annotations value] - (^multi [[_ (#.Record pairs)] [_ (#.Symbol _)]] - (|> pairs list.size (n/= +1))) - (:: macro.Monad wrap []) - - _ - (&.throw Invalid-Alias def-name))) - (def: #export (translate translate-module aliases code) (-> (-> Text Compiler (Process Compiler)) Aliases Code (Meta Aliases)) (case code - (^code ("lux def" (~ [_ (#.Symbol ["" def-name])]) (~ valueC) (~ annsC))) - (hostL.with-context def-name - (&.with-fresh-type-env - (do macro.Monad - [[annsI annsV] (process-annotations annsC)] - (case (macro.get-symbol-ann (ident-for #.alias) annsV) - (#.Some real-def) - (do @ - [_ (ensure-valid-alias def-name annsV valueC) - _ (&.with-scope - (statementT.translate-def def-name Void id annsI annsV))] - (wrap aliases)) - - #.None - (do @ - [[_ valueT valueA] (&.with-scope - (if (macro.type? (:! Code annsV)) - (do @ - [valueA (&.with-type Type - (analyse valueC))] - (wrap [Type valueA])) - (commonA.with-unknown-type - (analyse valueC)))) - valueT (&.with-type-env - (tc.clean valueT)) - ## #let [_ (if (or (text/= "string~" def-name)) - ## (log! (format "{" def-name "}\n" - ## " TYPE: " (%type valueT) "\n" - ## " ANALYSIS: " (%code valueA) "\n" - ## "SYNTHESIS: " (%code (expressionS.synthesize valueA)))) - ## [])] - valueI (expressionT.translate (expressionS.synthesize valueA)) - _ (&.with-scope - (statementT.translate-def def-name valueT valueI annsI annsV))] - (wrap aliases)))))) - (^code ("lux module" (~ annsC))) (do macro.Monad [[annsI annsV] (process-annotations annsC) @@ -120,15 +80,12 @@ (#e.Error error) (macro.fail error))) - (^code ("lux program" (~ [_ (#.Symbol ["" program-args])]) (~ programC))) + (^code ((~ [_ (#.Text statement)]) (~+ argsC+))) (do macro.Monad - [[_ programA] (&.with-scope - (&.with-type (type (io.IO Unit)) - (analyse programC))) - programI (expressionT.translate (expressionS.synthesize programA)) - _ (statementT.translate-program program-args programI)] + [statement (extensionL.find-statement statement) + _ (statement argsC+)] (wrap aliases)) - + (^code ((~ macroC) (~+ argsC+))) (do macro.Monad [[_ macroA] (&.with-scope @@ -199,6 +156,22 @@ (#e.Success [(set@ #.source source' compiler) output])))) +(def: (write-module target-dir module-name module artifacts) + (-> File Text Module Artifacts (Process Unit)) + (do io.Monad + [_ (monad.map @ (function [[name content]] + (&io.write target-dir + (format module-name "/" name (for {"JVM" ".class" + "JS" ".js"})) + content)) + (dict.entries artifacts))] + (wrap []) + ## (&io.write (format module-dir "/" cacheL.descriptor-name) + ## (text-to-blob (%code (cacheL.describe module)))) + )) + +(def: no-aliases Aliases (dict.new text.Hash)) + (def: #export (translate-module source-dirs target-dir module-name compiler) (-> (List File) File Text Compiler (Process Compiler)) (do io.Monad @@ -208,26 +181,23 @@ translate-module (translate-module source-dirs target-dir)]] (case (macro.run' compiler (do macro.Monad - [[_ artifacts _] (moduleL.with-module module-hash module-name - (commonT.with-artifacts - (with-active-compilation [module-name - file-name - file-content] - (forgive-eof - (loop [aliases (: Aliases - (dict.new text.Hash))] - (do @ - [code (read module-name aliases) - #let [[cursor _] code] - aliases' (&.with-cursor cursor - (translate translate-module aliases code))] - (forgive-eof (recur aliases'))))))))] - (wrap artifacts))) - (#e.Success [compiler artifacts]) + [[module artifacts _] (moduleL.with-module module-hash module-name + (commonT.with-artifacts + (with-active-compilation [module-name + file-name + file-content] + (forgive-eof + (loop [aliases no-aliases] + (do @ + [code (read module-name aliases) + #let [[cursor _] code] + aliases' (&.with-cursor cursor + (translate translate-module aliases code))] + (forgive-eof (recur aliases'))))))))] + (wrap [module artifacts]))) + (#e.Success [compiler [module artifacts]]) (do @ - [## _ (monad.map @ (function [[class-name class-bytecode]] - ## (&io.write-file target-dir class-name class-bytecode)) - ## (dict.entries artifacts)) + [## _ (write-module target-dir module-name module artifacts) ] (wrap compiler)) @@ -253,7 +223,7 @@ (-> commonT.Host Compiler) {#.info init-info #.source [init-cursor +0 ""] - #.cursor init-cursor + #.cursor .dummy-cursor #.current-module #.None #.modules (list) #.scopes (list) @@ -261,23 +231,35 @@ #.expected #.None #.seed +0 #.scope-type-vars (list) + #.extensions (:! Void extensionL.fresh) #.host (:! Void host)}) -(def: #export (translate-program sources target program) - (-> (List File) File Text (T.Task Unit)) - (do T.Monad - [compiler (|> (case (runtimeT.translate (init-compiler (io.run hostL.init-host))) - (#e.Error error) - (T.fail error) +(def: (initialize sources target) + (-> (List File) File (Process Compiler)) + (do io.Monad + [compiler (: (Process Compiler) + (case (runtimeT.translate (init-compiler (io.run hostL.init-host))) + (#e.Error error) + (io.fail error) - (#e.Success [compiler [runtime-bc function-bc]]) - (do @ - [_ (&io.prepare-target target) - _ (&io.write-file target (format hostL.runtime-class ".class") runtime-bc) - _ (&io.write-file target (format hostL.function-class ".class") function-bc)] - (wrap compiler))) - (: (T.Task Compiler)) - (:: @ map (|>> (translate-module sources target prelude) P.future)) (:: @ join) - (:: @ map (|>> (translate-module sources target program) P.future)) (:: @ join)) + (#e.Success [compiler [runtime-bc function-bc]]) + (do @ + [_ (&io.prepare-target target) + _ (&io.write target (format hostL.runtime-class ".class") runtime-bc) + _ (&io.write target (format hostL.function-class ".class") function-bc)] + (wrap (set@ #.extensions + (:! Void + {#extensionL.analysis analysisE.defaults + #extensionL.synthesis synthesisE.defaults + #extensionL.translation translationE.defaults + #extensionL.statement statementE.defaults}) + compiler)))))] + (translate-module sources target prelude compiler))) + +(def: #export (translate-program sources target program) + (-> (List File) File Text (Process Unit)) + (do io.Monad + [compiler (initialize sources target) + _ (translate-module sources target program compiler) #let [_ (log! "Compilation complete!")]] (wrap []))) diff --git a/new-luxc/source/luxc/lang/translation/common.jvm.lux b/new-luxc/source/luxc/lang/translation/common.jvm.lux index b75b0672b..1132928d0 100644 --- a/new-luxc/source/luxc/lang/translation/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/common.jvm.lux @@ -98,7 +98,5 @@ (#e.Success [compiler (ClassLoader::loadClass [name] (get@ #loader host))]) (ex.throw Unknown-Class name))))) -## (def: #export bytecode-version Int Opcodes::V1_6) - (def: #export value-field Text "_value") (def: #export $Object $.Type ($t.class "java.lang.Object" (list))) -- cgit v1.2.3