diff options
Diffstat (limited to 'stdlib')
| -rw-r--r-- | stdlib/source/lux/lang/compiler/default/repl/type.lux | 197 |
1 files changed, 197 insertions, 0 deletions
diff --git a/stdlib/source/lux/lang/compiler/default/repl/type.lux b/stdlib/source/lux/lang/compiler/default/repl/type.lux new file mode 100644 index 000000000..2fc2c74b6 --- /dev/null +++ b/stdlib/source/lux/lang/compiler/default/repl/type.lux @@ -0,0 +1,197 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:] + ["p" parser] + pipe) + (data [error #+ Error] + text/format + (format [xml #+ XML] + [json #+ JSON]) + (coll [list])) + (time [instant #+ Instant] + [duration #+ Duration] + [date #+ Date]) + [function] + [macro] + (macro [code] + [poly #+ Poly]) + (lang [type]))) + +(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<Parser> + [_ (poly.this Any)] + (wrap (function.constant "[]"))) + + (~~ (do-template [<type> <formatter>] + [(do p.Monad<Parser> + [_ (poly.like <type>)] + (wrap (|>> (:coerce <type>) <formatter>)))] + + [Bool %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<Parser> + [_ (poly.like <type>)] + (wrap (|>> (:coerce <type>) <formatter>)))] + + [Type %type] + [Code %code] + [Instant %instant] + [Duration %duration] + [Date %date] + [JSON %json] + [XML %xml])) + + (do p.Monad<Parser> + [[_ elemT] (poly.apply (p.seq (poly.this List) poly.any)) + elemR (poly.local (list elemT) representation)] + (wrap (|>> (:coerce (List Any)) (%list elemR)))) + + (do p.Monad<Parser> + [[_ elemT] (poly.apply (p.seq (poly.this 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 Ident) (Poly Representation) (Poly Representation)) + (do p.Monad<Parser> + [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 Ident) (Poly Representation) (Poly Representation)) + (do p.Monad<Parser> + [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.n/range +0 (dec 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<Parser> + [[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.Error error) + (p.fail error)))) + +(def: (tuple-representation representation) + (-> (Poly Representation) (Poly Representation)) + (do p.Monad<Parser> + [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<Parser> + [[funcT inputsT+] (poly.apply (p.seq poly.any (p.many poly.any)))] + (case (type.apply inputsT+ funcT) + (#.Some outputT) + (poly.local (list outputT) representation) + + #.None + (p.fail ""))) + + (do p.Monad<Parser> + [[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.Error error) + (ex.construct cannot-represent-value [type]))) |