diff options
Diffstat (limited to 'stdlib/source/lux/tool/interpreter/type.lux')
| -rw-r--r-- | stdlib/source/lux/tool/interpreter/type.lux | 203 |
1 files changed, 203 insertions, 0 deletions
diff --git a/stdlib/source/lux/tool/interpreter/type.lux b/stdlib/source/lux/tool/interpreter/type.lux new file mode 100644 index 000000000..f6a66a76a --- /dev/null +++ b/stdlib/source/lux/tool/interpreter/type.lux @@ -0,0 +1,203 @@ +(.module: + [lux #* + [control + [monad (#+ do)] + ["ex" exception (#+ exception:)] + ["p" 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 (#+ Poly)]]]) + +(exception: #export (cannot-represent-value {type Type}) + (ex.report ["Type" (%type type)])) + +(type: Representation (-> Any Text)) + +(def: primitive-representation + (Poly Representation) + (`` ($_ p.either + (do p.monad + [_ (poly.exactly Any)] + (wrap (function.constant "[]"))) + + (~~ (do-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) + (-> (Poly Representation) (Poly Representation)) + (`` ($_ p.either + (~~ (do-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) (Poly Representation) (Poly 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) (Poly Representation) (Poly 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 (Poly Representation) (Poly 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) + (-> (Poly Representation) (Poly 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 (Poly 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]))) |