diff options
Diffstat (limited to 'stdlib')
| -rw-r--r-- | stdlib/source/lux/debug.lux | 157 | ||||
| -rw-r--r-- | stdlib/source/lux/tool/interpreter/type.lux | 204 | ||||
| -rw-r--r-- | stdlib/source/lux/type/dynamic.lux | 17 |
3 files changed, 167 insertions, 211 deletions
diff --git a/stdlib/source/lux/debug.lux b/stdlib/source/lux/debug.lux index 63a46aff4..43d3f4762 100644 --- a/stdlib/source/lux/debug.lux +++ b/stdlib/source/lux/debug.lux @@ -1,14 +1,31 @@ (.module: [lux #* + ["." type] + ["." host (#+ import:)] + [abstract + [monad (#+ do)]] + [control + ["." function] + ["." exception (#+ exception:)] + ["<>" parser + ["<.>" type (#+ Parser)]] + pipe] [data + ["." error (#+ Error)] ["." text format] + [format + [xml (#+ XML)] + [json (#+ JSON)]] [collection ["." array (#+ Array)] ["." list ("#@." functor)]]] + [time + [instant (#+ Instant)] + [duration (#+ Duration)] + [date (#+ Date)]] [macro - ["." template]] - ["." host (#+ import:)]]) + ["." template]]]) (import: #long java/lang/String) @@ -73,3 +90,139 @@ #.None) (java/lang/Object::toString object))) )) + +(exception: #export (cannot-represent-value {type Type}) + (exception.report + ["Type" (%type type)])) + +(type: Representation (-> Any Text)) + +(def: primitive-representation + (Parser Representation) + (`` ($_ <>.either + (do <>.monad + [_ (<type>.exactly Any)] + (wrap (function.constant "[]"))) + + (~~ (template [<type> <formatter>] + [(do <>.monad + [_ (<type>.sub <type>)] + (wrap (|>> (:coerce <type>) <formatter>)))] + + [Bit %b] + [Nat %n] + [Int %i] + [Rev %r] + [Frac %f] + [Text %t]))))) + +(def: (special-representation representation) + (-> (Parser Representation) (Parser Representation)) + (`` ($_ <>.either + (~~ (template [<type> <formatter>] + [(do <>.monad + [_ (<type>.sub <type>)] + (wrap (|>> (:coerce <type>) <formatter>)))] + + [Type %type] + [Code %code] + [Instant %instant] + [Duration %duration] + [Date %date] + [JSON %json] + [XML %xml])) + + (do <>.monad + [[_ elemT] (<type>.apply (<>.and (<type>.exactly List) <type>.any)) + elemR (<type>.local (list elemT) representation)] + (wrap (|>> (:coerce (List Any)) (%list elemR)))) + + (do <>.monad + [[_ elemT] (<type>.apply (<>.and (<type>.exactly Maybe) <type>.any)) + elemR (<type>.local (list elemT) representation)] + (wrap (|>> (:coerce (Maybe Any)) + (case> #.None + "#.None" + + (#.Some elemV) + (format "(#.Some " (elemR elemV) ")")))))))) + +(def: (variant-representation representation) + (-> (Parser Representation) (Parser Representation)) + (do <>.monad + [membersR+ (<type>.variant (<>.many representation))] + (wrap (function (_ variantV) + (let [[lefts right? sub-repr] (loop [lefts 0 + representations membersR+ + variantV variantV] + (case representations + (#.Cons leftR (#.Cons rightR extraR+)) + (case (:coerce (| Any Any) variantV) + (#.Left left) + [lefts #0 (leftR left)] + + (#.Right right) + (case extraR+ + #.Nil + [lefts #1 (rightR right)] + + extraR+ + (recur (inc lefts) (#.Cons rightR extraR+) right))) + + _ + (undefined)))] + (format "(" (%n lefts) " " (%b right?) " " sub-repr ")")))))) + +(def: (tuple-representation representation) + (-> (Parser Representation) (Parser Representation)) + (do <>.monad + [membersR+ (<type>.tuple (<>.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] (:coerce [Any Any] tupleV)] + (format (headR leftV) " " (recur tailR rightV)))))] + (format "[" tuple-body "]")))))) + +(def: representation + (Parser Representation) + (<>.rec + (function (_ representation) + ($_ <>.either + primitive-representation + (special-representation representation) + (variant-representation representation) + (tuple-representation representation) + + (do <>.monad + [[funcT inputsT+] (<type>.apply (<>.and <type>.any (<>.many <type>.any)))] + (case (type.apply inputsT+ funcT) + (#.Some outputT) + (<type>.local (list outputT) representation) + + #.None + (<>.fail ""))) + + (do <>.monad + [[name anonymous] <type>.named] + (<type>.local (list anonymous) representation)) + + (<>.fail "") + )))) + +(def: #export (represent type value) + (-> Type Any (Error Text)) + (case (<type>.run type ..representation) + (#error.Success representation) + (#error.Success (representation value)) + + (#error.Failure error) + (exception.throw cannot-represent-value type))) diff --git a/stdlib/source/lux/tool/interpreter/type.lux b/stdlib/source/lux/tool/interpreter/type.lux deleted file mode 100644 index b9d4ebb5b..000000000 --- a/stdlib/source/lux/tool/interpreter/type.lux +++ /dev/null @@ -1,204 +0,0 @@ -(.module: - [lux #* - [control - [monad (#+ do)] - ["ex" exception (#+ exception:)] - ["p" parser - ["<.>" type (#+ Parser)]] - pipe] - [data - ["." error (#+ Error)] - [text - format] - [format - [xml (#+ XML)] - [json (#+ JSON)]] - [collection - ["." list]]] - [time - [instant (#+ Instant)] - [duration (#+ Duration)] - [date (#+ Date)]] - ["." function] - ["." type] - ["." macro - ["." code] - ["." poly]]]) - -(exception: #export (cannot-represent-value {type Type}) - (ex.report ["Type" (%type type)])) - -(type: Representation (-> Any Text)) - -(def: primitive-representation - (Parser Representation) - (`` ($_ p.either - (do p.monad - [_ (poly.exactly Any)] - (wrap (function.constant "[]"))) - - (~~ (template [<type> <formatter>] - [(do p.monad - [_ (poly.sub <type>)] - (wrap (|>> (:coerce <type>) <formatter>)))] - - [Bit %b] - [Nat %n] - [Int %i] - [Rev %r] - [Frac %f] - [Text %t]))))) - -(def: (special-representation representation) - (-> (Parser Representation) (Parser Representation)) - (`` ($_ p.either - (~~ (template [<type> <formatter>] - [(do p.monad - [_ (poly.sub <type>)] - (wrap (|>> (:coerce <type>) <formatter>)))] - - [Type %type] - [Code %code] - [Instant %instant] - [Duration %duration] - [Date %date] - [JSON %json] - [XML %xml])) - - (do p.monad - [[_ elemT] (poly.apply (p.and (poly.exactly List) poly.any)) - elemR (poly.local (list elemT) representation)] - (wrap (|>> (:coerce (List Any)) (%list elemR)))) - - (do p.monad - [[_ elemT] (poly.apply (p.and (poly.exactly Maybe) poly.any)) - elemR (poly.local (list elemT) representation)] - (wrap (|>> (:coerce (Maybe Any)) - (case> #.None - "#.None" - - (#.Some elemV) - (format "(#.Some " (elemR elemV) ")")))))))) - -(def: (record-representation tags representation) - (-> (List Name) (Parser Representation) (Parser Representation)) - (do p.monad - [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] (:coerce [Any Any] recordV)] - (format (%code (code.tag tag)) " " (repr leftV) " " - (recur tail rightV)))))] - (format "{" record-body "}")))))) - -(def: (variant-representation tags representation) - (-> (List Name) (Parser Representation) (Parser Representation)) - (do p.monad - [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.indices num-tags) - casesR+) - variantV variantV] - (case cases-left - #.Nil - "" - - (#.Cons [tag-name tag-idx repr] #.Nil) - (let [[_tag _last? _value] (:coerce [Nat Text Any] 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] (:coerce [Nat Text Any] variantV)] - (if (n/= tag-idx _tag) - (format "(" (%code (code.tag tag-name)) " " (repr _value) ")") - (recur tail variantV))))))))) - -(def: (tagged-representation compiler representation) - (-> Lux (Parser Representation) (Parser Representation)) - (do p.monad - [[name anonymous] poly.named] - (case (macro.run compiler (macro.tags-of name)) - (#error.Success ?tags) - (case ?tags - (#.Some tags) - (poly.local (list anonymous) - (p.either (record-representation tags representation) - (variant-representation tags representation))) - - #.None - representation) - - (#error.Failure error) - (p.fail error)))) - -(def: (tuple-representation representation) - (-> (Parser Representation) (Parser Representation)) - (do p.monad - [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] (:coerce [Any Any] tupleV)] - (format (headR leftV) " " (recur tailR rightV)))))] - (format "[" tuple-body "]")))))) - -(def: (representation compiler) - (-> Lux (Parser Representation)) - (p.rec - (function (_ representation) - ($_ p.either - primitive-representation - (special-representation representation) - (tagged-representation compiler representation) - (tuple-representation representation) - - (do p.monad - [[funcT inputsT+] (poly.apply (p.and poly.any (p.many poly.any)))] - (case (type.apply inputsT+ funcT) - (#.Some outputT) - (poly.local (list outputT) representation) - - #.None - (p.fail ""))) - - (do p.monad - [[name anonymous] poly.named] - (poly.local (list anonymous) representation)) - - (p.fail "") - )))) - -(def: #export (represent compiler type value) - (-> Lux Type Any Text) - (case (poly.run type (representation compiler)) - (#error.Success representation) - (ex.report ["Type" (%type type)] - ["Value" (representation value)]) - - (#error.Failure error) - (ex.construct cannot-represent-value [type]))) diff --git a/stdlib/source/lux/type/dynamic.lux b/stdlib/source/lux/type/dynamic.lux index cda9ac14b..aaa5ae6e7 100644 --- a/stdlib/source/lux/type/dynamic.lux +++ b/stdlib/source/lux/type/dynamic.lux @@ -1,9 +1,10 @@ (.module: [lux #* + ["." debug] [control - ["ex" exception (#+ exception:)]] + ["." exception (#+ exception:)]] [data - ["." error] + ["." error (#+ Error)] [text format]] [macro (#+ with-gensyms) @@ -12,8 +13,9 @@ abstract]]) (exception: #export (wrong-type {expected Type} {actual Type}) - (ex.report ["Expected" (%type expected)] - ["Actual" (%type actual)])) + (exception.report + ["Expected" (%type expected)] + ["Actual" (%type actual)])) (abstract: #export Dynamic {#.doc "A value coupled with its type, so it can be checked later."} @@ -39,5 +41,10 @@ (if (:: (~! type.equivalence) (~' =) (.type (~ type)) (~ g!type)) (#error.Success (:coerce (~ type) (~ g!value))) - ((~! ex.throw) ..wrong-type [(.type (~ type)) (~ g!type)]))))))))) + ((~! exception.throw) ..wrong-type [(.type (~ type)) (~ g!type)]))))))))) + + (def: #export (print value) + (-> Dynamic (Error Text)) + (let [[type value] (:representation value)] + (debug.represent type value))) ) |