From 8892e902809e680a067da9c85d54cae2acc82ce8 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Tue, 19 Feb 2019 21:47:48 -0400
Subject: Moved pattern-matching machinery over.
---
.../source/luxc/lang/translation/js/case.jvm.lux | 191 ---------------------
1 file changed, 191 deletions(-)
delete mode 100644 new-luxc/source/luxc/lang/translation/js/case.jvm.lux
(limited to 'new-luxc/source/luxc')
diff --git a/new-luxc/source/luxc/lang/translation/js/case.jvm.lux b/new-luxc/source/luxc/lang/translation/js/case.jvm.lux
deleted file mode 100644
index e8fdcb00c..000000000
--- a/new-luxc/source/luxc/lang/translation/js/case.jvm.lux
+++ /dev/null
@@ -1,191 +0,0 @@
-(.module:
- lux
- (lux (control [monad #+ do]
- ["ex" exception #+ exception:])
- (data text/format
- (coll [list "list/" Fold<List>]))
- [macro #+ "meta/" Monad<Meta>])
- (luxc [lang]
- (lang ["ls" synthesis]
- (host [js #+ JS Expression Statement])))
- [//]
- (// [".T" runtime]
- [".T" primitive]
- [".T" reference]))
-
-(def: #export (translate-let translate register valueS bodyS)
- (-> (-> ls.Synthesis (Meta Expression)) Nat ls.Synthesis ls.Synthesis
- (Meta Expression))
- (do macro.Monad<Meta>
- [valueJS (translate valueS)
- bodyJS (translate bodyS)]
- (wrap (format "(function() {"
- "var " (referenceT.variable register) " = " valueJS ";"
- "return " bodyJS ";"
- "})()"))))
-
-(def: #export (translate-record-get translate valueS path)
- (-> (-> ls.Synthesis (Meta Expression)) ls.Synthesis (List [Nat Bit])
- (Meta Expression))
- (do macro.Monad<Meta>
- [valueJS (translate valueS)]
- (wrap (list/fold (function (_ [idx tail?] source)
- (let [method (if tail? runtimeT.product//right runtimeT.product//left)]
- (format method "(" source "," (|> idx .int %i) ")")))
- (format "(" valueJS ")")
- path))))
-
-(def: #export (translate-if testJS thenJS elseJS)
- (-> Expression Expression Expression
- Expression)
- (format "(" testJS " ? " thenJS " : " elseJS ")"))
-
-(def: savepoint
- Expression
- "pm_cursor_savepoint")
-
-(def: cursor
- Expression
- "pm_cursor")
-
-(def: (push-cursor value)
- (-> Expression Expression)
- (format cursor ".push(" value ");"))
-
-(def: save-cursor
- Statement
- (format savepoint ".push(" cursor ".slice());"))
-
-(def: restore-cursor
- Statement
- (format cursor " = " savepoint ".pop();"))
-
-(def: peek-cursor
- Expression
- (format cursor "[" cursor ".length - 1]"))
-
-(def: pop-cursor
- Statement
- (format cursor ".pop();"))
-
-(def: pm-error
- Expression
- (%t "PM-ERROR"))
-
-(def: fail-pattern-matching
- Statement
- (format "throw " pm-error ";"))
-
-(exception: #export (Unrecognized-Path {message Text})
- message)
-
-(def: (translate-pattern-matching' translate path)
- (-> (-> ls.Synthesis (Meta Expression)) Code (Meta Expression))
- (case path
- (^code ("lux case exec" (~ bodyS)))
- (do macro.Monad<Meta>
- [bodyJS (translate bodyS)]
- (wrap (format "return " bodyJS ";")))
-
- (^code ("lux case pop"))
- (meta/wrap pop-cursor)
-
- (^code ("lux case bind" (~ [_ (#.Nat register)])))
- (meta/wrap (format "var " (referenceT.variable register) " = " peek-cursor ";"))
-
- (^template [<tag> <translate>]
- [_ (<tag> value)]
- (do macro.Monad<Meta>
- [valueJS (<translate> value)]
- (wrap (format "if(!" (format runtimeT.int//= "(" peek-cursor "," valueJS ")") ") { " fail-pattern-matching " }"))))
- ([#.Nat primitiveT.translate-nat]
- [#.Int primitiveT.translate-int]
- [#.Rev primitiveT.translate-rev])
-
- (^template [<tag> <format>]
- [_ (<tag> value)]
- (meta/wrap (format "if(" peek-cursor " !== " (<format> value) ") { " fail-pattern-matching " }")))
- ([#.Bit %b]
- [#.Frac %f]
- [#.Text %t])
-
- (^template [<pm> <getter>]
- (^code (<pm> (~ [_ (#.Nat idx)])))
- (meta/wrap (push-cursor (format <getter> "(" peek-cursor "," (|> idx .int %i) ")"))))
- (["lux case tuple left" runtimeT.product//left]
- ["lux case tuple right" runtimeT.product//right])
-
- (^template [<pm> <flag>]
- (^code (<pm> (~ [_ (#.Nat idx)])))
- (meta/wrap (format "temp = " runtimeT.sum//get "(" peek-cursor "," (|> idx .int %i) "," <flag> ");"
- "if(temp == null) {"
- fail-pattern-matching
- "}"
- "else {"
- (push-cursor "temp")
- "}")))
- (["lux case variant left" "null"]
- ["lux case variant right" "\"\""])
-
- (^code ("lux case seq" (~ leftP) (~ rightP)))
- (do macro.Monad<Meta>
- [leftJS (translate-pattern-matching' translate leftP)
- rightJS (translate-pattern-matching' translate rightP)]
- (wrap (format leftJS rightJS)))
-
- (^code ("lux case alt" (~ leftP) (~ rightP)))
- (do macro.Monad<Meta>
- [leftJS (translate-pattern-matching' translate leftP)
- rightJS (translate-pattern-matching' translate rightP)]
- (wrap (format "try {"
- save-cursor
- leftJS
- "}"
- "catch(ex) {"
- "if(ex === " pm-error ") {"
- restore-cursor
- rightJS
- "}"
- "else {"
- "throw ex;"
- "}"
- "}")))
-
- _
- (lang.throw Unrecognized-Path (%code path))
- ))
-
-(def: report-pattern-matching-error
- Statement
- (format "if(ex === " pm-error ") {"
- "throw \"Invalid expression for pattern-matching.\";"
- "}"
- "else {"
- "throw ex;"
- "}"))
-
-(def: (translate-pattern-matching translate path)
- (-> (-> ls.Synthesis (Meta Expression)) Code (Meta Expression))
- (do macro.Monad<Meta>
- [pmJS (translate-pattern-matching' translate path)]
- (wrap (format "try {" pmJS "}"
- "catch(ex) {"
- report-pattern-matching-error
- "}"))))
-
-(def: (initialize-pattern-matching stack-init)
- (-> Expression Statement)
- (format "var temp;"
- "var " cursor " = [" stack-init "];"
- "var " savepoint " = [];"))
-
-(def: #export (translate-case translate valueS path)
- (-> (-> ls.Synthesis (Meta Expression)) ls.Synthesis Code (Meta Expression))
- (do macro.Monad<Meta>
- [valueJS (translate valueS)
- pmJS (translate-pattern-matching translate path)]
- (wrap (format "(function() {"
- "\"use strict\";"
- (initialize-pattern-matching valueJS)
- pmJS
- "})()"))))
--
cgit v1.2.3