aboutsummaryrefslogtreecommitdiff
path: root/stdlib
diff options
context:
space:
mode:
authorEduardo Julian2019-04-21 20:27:58 -0400
committerEduardo Julian2019-04-21 20:27:58 -0400
commit448eb9d9ae01569459f72ad4de740f960b02bfad (patch)
tree6f2099fa5f315ab4efef0c861de2a8ac5438eb8f /stdlib
parentdaff89b83c4cbcdb3f0b068e7b4189bdc3adeb72 (diff)
- Improved debugging machinery.
- Now also displaying dynamic values with the help of "lux/debug.representation".
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/debug.lux157
-rw-r--r--stdlib/source/lux/tool/interpreter/type.lux204
-rw-r--r--stdlib/source/lux/type/dynamic.lux17
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)))
)