diff options
Diffstat (limited to 'new-luxc/source/luxc')
| -rw-r--r-- | new-luxc/source/luxc/lang/translation.lux | 6 | ||||
| -rw-r--r-- | new-luxc/source/luxc/repl.lux | 316 |
2 files changed, 319 insertions, 3 deletions
diff --git a/new-luxc/source/luxc/lang/translation.lux b/new-luxc/source/luxc/lang/translation.lux index 80484b7e8..86b9842b6 100644 --- a/new-luxc/source/luxc/lang/translation.lux +++ b/new-luxc/source/luxc/lang/translation.lux @@ -69,7 +69,7 @@ _ (&;throw Invalid-Alias def-name))) -(def: (translate translate-module aliases code) +(def: #export (translate translate-module aliases code) (-> (-> Text Compiler (Process Compiler)) Aliases Code (Meta Aliases)) (case code (^code ((~ [_ (#;Symbol macro-name)]) (~@ args))) @@ -174,7 +174,7 @@ output output))) -(def: prelude Text "lux") +(def: #export prelude Text "lux") (def: (with-active-compilation [module-name file-name source-code] action) (All [a] (-> [Text Text Text] (Meta a) (Meta a))) @@ -196,7 +196,7 @@ (#e;Success [(set@ #;source source' compiler) output])))) -(def: (translate-module source-dirs target-dir module-name compiler) +(def: #export (translate-module source-dirs target-dir module-name compiler) (-> (List File) File Text Compiler (Process Compiler)) (do io;Monad<Process> [## _ (&io;prepare-module target-dir module-name) diff --git a/new-luxc/source/luxc/repl.lux b/new-luxc/source/luxc/repl.lux new file mode 100644 index 000000000..5b957269f --- /dev/null +++ b/new-luxc/source/luxc/repl.lux @@ -0,0 +1,316 @@ +(;module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:] + ["p" parser] + pipe) + (data [maybe] + ["e" error #+ Error] + [text "text/" Eq<Text>] + text/format + (format [xml #+ XML] + [json #+ JSON]) + (coll [array] + [list "list/" Functor<List>] + [dict])) + (time [instant #+ Instant] + [duration #+ Duration] + [date #+ Date]) + [function #+ const] + [macro] + (macro [code] + [poly #+ Poly]) + (lang [syntax #+ Aliases] + [type] + (type [check])) + (concurrency [promise] + [task #+ Task]) + [io] + (world [file #+ File] + [console #+ Console])) + (luxc [lang] + (lang [";L" module] + [";L" scope] + [";L" host] + [";L" translation] + [";L" eval] + (translation [";T" runtime])))) + +(exception: #export REPL-Initialization-Failed) +(exception: #export REPL-Error) + +(def: repl-module "<REPL>") + +(def: no-aliases Aliases (dict;new text;Hash<Text>)) + +(def: (initialize source-dirs target-dir console) + (-> (List File) File Console (Task Compiler)) + (do promise;Monad<Promise> + [output (promise;future + (do io;Monad<IO> + [host hostL;init-host] + (case (macro;run' (translationL;init-compiler host) + (moduleL;with-module +0 repl-module + runtimeT;translate)) + (#e;Success [compiler _]) + (translationL;translate-module source-dirs target-dir translationL;prelude compiler) + + (#e;Error error) + (wrap (#e;Error error)))))] + (case output + (#e;Success compiler) + (do task;Monad<Task> + [_ (console;write (format "\nWelcome to the REPL!\n" + "Type \"exit\" to leave.\n\n") + console)] + (wrap compiler)) + + (#e;Error message) + (task;throw REPL-Initialization-Failed message)))) + +(def: (add-line line [where offset input]) + (-> Text Source Source) + [where offset (format input "\n" line)]) + +(type: Representation (-> Top Text)) + +(def: (represent-together representations values) + (-> (List Representation) (List Top) (List Text)) + (|> (list;zip2 representations values) + (list/map (function [[representation value]] (representation value))))) + +(def: primitive-representation + (Poly Representation) + (`` ($_ p;either + (do p;Monad<Parser> + [_ poly;unit] + (wrap (const "[]"))) + + (~~ (do-template [<parser> <type> <formatter>] + [(do p;Monad<Parser> + [_ <parser>] + (wrap (|>. (:! <type>) <formatter>)))] + + [poly;bool Bool %b] + [poly;nat Nat %n] + [poly;int Int %i] + [poly;deg Deg %d] + [poly;frac Frac %f] + [poly;text Text %t]))))) + +(def: (special-representation representation) + (-> (Poly Representation) (Poly Representation)) + (`` ($_ p;either + (~~ (do-template [<type> <formatter>] + [(do p;Monad<Parser> + [_ (poly;this <type>)] + (wrap (|>. (:! <type>) <formatter>)))] + + [Type %type] + [Code %code] + [Instant %instant] + [Duration %duration] + [Date %date] + [JSON %json] + [XML %xml] + )) + + (do p;Monad<Parser> + [[_ elemT] (poly;apply (p;seq (poly;this List) poly;any)) + elemR (poly;local (list elemT) representation)] + (wrap (|>. (:! (List Top)) (%list elemR)))) + + (do p;Monad<Parser> + [[_ elemT] (poly;apply (p;seq (poly;this Maybe) poly;any)) + elemR (poly;local (list elemT) representation)] + (wrap (|>. (:! (Maybe Top)) + (case> #;None + "#;None" + + (#;Some elemV) + (elemR elemV)))))))) + +(def: (record-representation tags representation) + (-> (List Ident) (Poly Representation) (Poly Representation)) + (do p;Monad<Parser> + [membersR+ (poly;tuple (p;many representation)) + _ (p;assert "Number of tags does not match record type size." + (n.= (list;size tags) (list;size membersR+)))] + (wrap (function [recordV] + (let [record-body (loop [pairs-left (list;zip2 tags membersR+) + recordV recordV] + (case pairs-left + #;Nil + "" + + (#;Cons [tag repr] #;Nil) + (format (%code (code;tag tag)) " " (repr recordV)) + + (#;Cons [tag repr] tail) + (let [[leftV rightV] (:! [Top Top] recordV)] + (format (%code (code;tag tag)) " " (repr leftV) " " + (recur tail rightV)))))] + (format "{" record-body "}")))))) + +(def: (variant-representation tags representation) + (-> (List Ident) (Poly Representation) (Poly Representation)) + (do p;Monad<Parser> + [casesR+ (poly;variant (p;many representation)) + #let [num-tags (list;size tags)] + _ (p;assert "Number of tags does not match variant type size." + (n.= num-tags (list;size casesR+)))] + (wrap (function [variantV] + (loop [cases-left (list;zip3 tags + (list;n.range +0 (n.dec num-tags)) + casesR+) + variantV variantV] + (case cases-left + #;Nil + "" + + (#;Cons [tag-name tag-idx repr] #;Nil) + (let [[_tag _last? _value] (:! [Nat Text Top] variantV)] + (if (n.= tag-idx _tag) + (format "(" (%code (code;tag tag-name)) " " (repr _value) ")") + (undefined))) + + (#;Cons [tag-name tag-idx repr] tail) + (let [[_tag _last? _value] (:! [Nat Text Top] variantV)] + (if (n.= tag-idx _tag) + (format "(" (%code (code;tag tag-name)) " " (repr _value) ")") + (recur tail variantV))))))))) + +(def: (tagged-representation compiler representation) + (-> Compiler (Poly Representation) (Poly Representation)) + (do p;Monad<Parser> + [[name anonymous] poly;named] + (case (macro;run compiler (macro;tags-of name)) + (#e;Success ?tags) + (case ?tags + (#;Some tags) + (poly;local (list anonymous) + (p;either (record-representation tags representation) + (variant-representation tags representation))) + + #;None + representation) + + (#e;Error error) + (p;fail error)))) + +(def: (tuple-representation representation) + (-> (Poly Representation) (Poly Representation)) + (do p;Monad<Parser> + [membersR+ (poly;tuple (p;many representation))] + (wrap (function [tupleV] + (let [tuple-body (loop [representations membersR+ + tupleV tupleV] + (case representations + #;Nil + "" + + (#;Cons lastR #;Nil) + (lastR tupleV) + + (#;Cons headR tailR) + (let [[leftV rightV] (:! [Top Top] tupleV)] + (format (headR leftV) " " (recur tailR rightV)))))] + (format "[" tuple-body "]")))))) + +(def: (representation compiler) + (-> Compiler (Poly Representation)) + (p;rec + (function [representation] + ($_ p;either + primitive-representation + (special-representation representation) + (tagged-representation compiler representation) + (tuple-representation representation) + + (do p;Monad<Parser> + [[funcT inputsT+] (poly;apply (p;seq poly;any (p;many poly;any)))] + (case (type;apply inputsT+ funcT) + (#;Some outputT) + (poly;local (list outputT) representation) + + #;None + (p;fail ""))) + + (do p;Monad<Parser> + [[name anonymous] poly;named] + (poly;local (list anonymous) representation)) + + (p;fail "") + )))) + +(def: (represent compiler type value) + (-> Compiler Type Top Text) + (case (poly;run type (representation compiler)) + (#e;Success representation) + (representation value) + + (#e;Error error) + ". . . cannot represent value . . .")) + +(def: (repl-translate source-dirs target-dir code) + (-> (List File) File Code (Meta [Type Top])) + (function [compiler] + (case ((translationL;translate (translationL;translate-module source-dirs target-dir) + no-aliases + code) + compiler) + (#e;Success [compiler' aliases']) + (#e;Success [compiler' [Void []]]) + + (#e;Error error) + (if (ex;match? translationL;Unrecognized-Statement error) + ((do macro;Monad<Meta> + [[var-id varT] (lang;with-type-env check;var) + exprV (scopeL;with-scope repl-module + (evalL;eval varT code)) + ?exprT (lang;with-type-env (check;read var-id))] + (wrap [(maybe;assume ?exprT) exprV])) + compiler) + (#e;Error error))))) + +(def: fresh-source Source [[repl-module +1 +0] +0 ""]) + +(def: #export (run source-dirs target-dir) + (-> (List File) File (Task Unit)) + (do task;Monad<Task> + [console (promise;future console;open) + compiler (initialize source-dirs target-dir console)] + (loop [compiler compiler + source fresh-source + multi-line? false] + (do @ + [_ (if multi-line? + (console;write " " console) + (console;write "> " console)) + line (console;read-line console)] + (if (text/= "exit" line) + (console;write "Till next time..." console) + (case (do e;Monad<Error> + [[source' exprC] (syntax;read repl-module no-aliases (add-line line source))] + (macro;run' compiler + (lang;with-current-module repl-module + (do macro;Monad<Meta> + [[exprT exprV] (repl-translate source-dirs target-dir exprC) + ## [var-id varT] (lang;with-type-env check;var) + ## exprV (evalL;eval varT exprC) + ## ?exprT (lang;with-type-env (check;read var-id)) + ] + (wrap [source' exprT exprV]))))) + (#e;Success [compiler' [source' exprT exprV]]) + (do @ + [_ (console;write (format " Type: " (type;to-text exprT) "\n" + "Value: " (represent compiler' exprT exprV) "\n\n") + console)] + (recur compiler' source' false)) + + (#e;Error error) + (if (ex;match? syntax;End-Of-File error) + (recur compiler source true) + (exec (log! (REPL-Error error)) + (recur compiler fresh-source false)))))) + ))) |