aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--new-luxc/source/luxc/analyser/lux.lux144
-rw-r--r--new-luxc/source/luxc/base.lux38
2 files changed, 181 insertions, 1 deletions
diff --git a/new-luxc/source/luxc/analyser/lux.lux b/new-luxc/source/luxc/analyser/lux.lux
index e215412c6..7bce8ed8d 100644
--- a/new-luxc/source/luxc/analyser/lux.lux
+++ b/new-luxc/source/luxc/analyser/lux.lux
@@ -114,7 +114,7 @@
(TC;check expected actual))
=value (&;with-expected-type Top
(analyse eval value))]
- (wrap (&common;replace-type actual =value))))
+ (wrap (&common;replace-type expected =value))))
(def: (analyse-typed-tuple analyse cursor members)
(-> (-> Code (Lux Analysis)) Cursor
@@ -253,3 +253,145 @@
(TC;check expected (la;get-type =variant)))]
(wrap (&common;replace-type expected =variant)))
(&;fail (format "Invalid type for variant: " (%type expected)))))))
+
+## Functions
+(def: (maybe-to-lux input)
+ (All [a] (-> (Maybe a) (Lux a)))
+ (case input
+ #;None
+ (&;fail "")
+
+ (#;Some value)
+ (:: Monad<Lux> wrap value)))
+
+(def: (with-var body)
+ (All [a] (-> (-> [Nat Type] (Lux a)) (Lux a)))
+ (do Monad<Lux>
+ [[id var] (&;within-type-env TC;create-var)
+ output (body [id var])
+ _ (&;within-type-env (TC;delete-var id))]
+ (wrap output)))
+
+(def: (bind-var var-id bound-idx type)
+ (-> Nat Nat Type Type)
+ (case type
+ (#;Host name params)
+ (#;Host name (L/map (bind-var var-id bound-idx) params))
+
+ (^template [<tag>]
+ (<tag> left right)
+ (<tag> (bind-var var-id bound-idx left)
+ (bind-var var-id bound-idx right)))
+ ([#;Sum]
+ [#;Product]
+ [#;Function]
+ [#;App])
+
+ (#;Var id)
+ (if (n.= var-id id)
+ (#;Bound bound-idx)
+ type)
+
+ (^template [<tag>]
+ (<tag> env quantified)
+ (<tag> (L/map (bind-var var-id bound-idx) env)
+ (bind-var var-id (n.+ +2 bound-idx) quantified)))
+ ([#;UnivQ]
+ [#;ExQ])
+
+ (#;Named name unnamed)
+ (#;Named name
+ (bind-var var-id bound-idx unnamed))
+
+ _
+ type))
+
+(def: #export (analyse-function analyse cursor func-name arg-name body)
+ (-> (-> Code (Lux Analysis)) Cursor
+ Text Text Code
+ (Lux Analysis))
+ (do Monad<Lux>
+ [expected macro;expected-type]
+ (&;with-try
+ (function [error]
+ (let [raw (format "Functions require function types: " (type;to-text expected))]
+ (&;fail (if (T/= "" error)
+ raw
+ (format error "\n" raw)))))
+ (case expected
+ (#;Named name unnamed)
+ (do @
+ [=function (&;with-expected-type unnamed
+ (analyse-function analyse cursor func-name arg-name body))]
+ (wrap (&common;replace-type expected =function)))
+
+ (#;App funT argT)
+ (do @
+ [fully-applied (maybe-to-lux (type;apply-type funT argT))
+ =function (&;with-expected-type fully-applied
+ (analyse-function analyse cursor func-name arg-name body))]
+ (wrap (&common;replace-type expected =function)))
+
+ (#;UnivQ _)
+ (do @
+ [[var-id var] (&;within-type-env
+ TC;existential)
+ expected' (maybe-to-lux (type;apply-type expected var))
+ =function (&;with-expected-type expected'
+ (analyse-function analyse cursor func-name arg-name body))]
+ (wrap (&common;replace-type expected =function)))
+
+ (#;ExQ _)
+ (with-var
+ (function [[var-id var]]
+ (do @
+ [expected' (maybe-to-lux (type;apply-type expected var))
+ =function (&;with-expected-type expected'
+ (analyse-function analyse cursor func-name arg-name body))]
+ (&common;clean var =function))))
+
+ (#;Var id)
+ (do @
+ [? (&;within-type-env
+ (TC;bound? id))]
+ (if ?
+ (do @
+ [expected' (&;within-type-env
+ (TC;read-var id))]
+ (&;with-expected-type expected'
+ (analyse-function analyse cursor func-name arg-name body)))
+ ## Inference
+ (with-var
+ (function [[input-id inputT]]
+ (with-var
+ (function [[output-id outputT]]
+ (do @
+ [#let [funT (#;Function inputT outputT)]
+ =function (&;with-expected-type funT
+ (analyse-function analyse cursor func-name arg-name body))
+ funT' (&;within-type-env
+ (TC;clean output-id funT))
+ concrete-input? (&;within-type-env
+ (TC;bound? input-id))
+ funT'' (if concrete-input?
+ (&;within-type-env
+ (TC;clean input-id funT'))
+ (wrap (#;UnivQ (list) (bind-var input-id +1 funT'))))
+ _ (&;within-type-env
+ (TC;check expected funT''))]
+ (wrap (&common;replace-type expected =function)))
+ ))))))
+
+ (#;Function inputT outputT)
+ (do @
+ [[=scope =body] (&;with-scope
+ (&env;with-local [func-name expected]
+ (&env;with-local [arg-name inputT]
+ (&;with-expected-type outputT
+ (analyse body)))))]
+ (wrap [[expected cursor]
+ (#la;Function =scope =body)]))
+
+ _
+ (&;fail "")
+ ))))
diff --git a/new-luxc/source/luxc/base.lux b/new-luxc/source/luxc/base.lux
index 3a085e07e..74e316b3c 100644
--- a/new-luxc/source/luxc/base.lux
+++ b/new-luxc/source/luxc/base.lux
@@ -99,3 +99,41 @@
(#E;Success [compiler' output])
(#E;Success [(set@ #;source old-source compiler')
output])))))
+
+(def: #export (with-try handler action)
+ (All [a] (-> (-> Text (Lux a)) (Lux a) (Lux a)))
+ (function [compiler]
+ (case (action compiler)
+ (#E;Success [compiler' output])
+ (#E;Success [compiler' output])
+
+ (#E;Error error)
+ ((handler error) compiler))))
+
+(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] (-> (Lux a) (Lux [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))))