New "format" hierarchy.

2 files changed, 431 insertions, 0 deletions

diff --git a/stdlib/source/format/lux/data/binary.lux b/stdlib/source/format/lux/data/binary.lux
new file mode 100644
index 000000000..e29a737ce
--- /dev/null
+++ b/stdlib/source/format/lux/data/binary.lux
@@ -0,0 +1,298 @@
+(.using
+ [library
+  [lux (.except and or nat int rev list type symbol)
+   [ffi (.only)]
+   [abstract
+    [monoid (.only Monoid)]
+    [monad (.only Monad do)]
+    [equivalence (.only Equivalence)]]
+   [control
+    ["[0]" pipe]
+    ["[0]" function]
+    ["<>" parser (.open: "[1]#[0]" monad)
+     ["</>" binary (.only Offset Size Parser)]]]
+   [data
+    ["[0]" product]
+    [text
+     ["%" \\format (.only format)]
+     [encoding
+      ["[0]" utf8]]]
+    [collection
+     ["[0]" list]
+     ["[0]" sequence (.only Sequence) (.open: "[1]#[0]" functor)]
+     ["[0]" set (.only Set)]
+     [array
+      [\\unsafe (.only)]]]]
+   [macro
+    ["^" pattern]]
+   [math
+    [number
+     ["n" nat]
+     ["[0]" i64]
+     ["[0]" frac]]]]]
+ [\\unsafe
+  ["[0]" / (.only Binary)]])
+
+(with_template [<name> <extension> <post>]
+  [(def: <name>
+     (template (<name> <parameter> <subject>)
+       [(<post> (<extension> (.int <parameter>) (.int <subject>)))]))]
+
+  [n#= "lux i64 =" .|>]
+  [n#+ "lux i64 +" .nat]
+  [n#* "lux i64 *" .nat]
+  )
+
+(def: mask
+  (-> Size (I64 Any))
+  (|>> (n#* i64.bits_per_byte) i64.mask))
+
+(type: .public Mutation
+  (-> [Offset Binary] [Offset Binary]))
+
+(type: .public Specification
+  [Size Mutation])
+
+(def: .public no_op
+  Specification
+  [0 function.identity])
+
+(def: .public (instance [size mutation])
+  (-> Specification Binary)
+  (|> size /.empty [0] mutation product.right))
+
+(def: .public monoid
+  (Monoid Specification)
+  (implementation
+   (def: identity
+     ..no_op)
+   
+   (def: (composite [sizeL mutL] [sizeR mutR])
+     [(n#+ sizeL sizeR)
+      (|>> mutL mutR)])))
+
+(type: .public (Writer a)
+  (-> a Specification))
+
+(def: .public (result writer value)
+  (All (_ a) (-> (Writer a) a Binary))
+  (..instance (writer value)))
+
+(with_template [<name> <size> <write>]
+  [(def: .public <name>
+     (Writer (I64 Any))
+     (function (_ value)
+       [<size>
+        (function (_ [offset binary])
+          [(n#+ <size> offset)
+           (<write> offset value binary)])]))]
+
+  [bits_8  </>.size_8  /.has_8!]
+  [bits_16 </>.size_16 /.has_16!]
+  [bits_32 </>.size_32 /.has_32!]
+  [bits_64 </>.size_64 /.has_64!]
+  )
+
+(def: .public (or left right)
+  (All (_ l r) (-> (Writer l) (Writer r) (Writer (Or l r))))
+  (function (_ altV)
+    (case altV
+      (^.with_template [<number> <tag> <writer>]
+        [{<tag> caseV}
+         (let [[caseS caseT] (<writer> caseV)]
+           [(.++ caseS)
+            (function (_ [offset binary])
+              (|> binary
+                  (/.has_8! offset <number>)
+                  [(.++ offset)]
+                  caseT))])])
+      ([0 .#Left left]
+       [1 .#Right right])
+      )))
+
+(def: .public (and pre post)
+  (All (_ a b) (-> (Writer a) (Writer b) (Writer [a b])))
+  (function (_ [preV postV])
+    (at ..monoid composite (pre preV) (post postV))))
+
+(def: .public (rec body)
+  (All (_ a) (-> (-> (Writer a) (Writer a)) (Writer a)))
+  (function (again value)
+    (body again value)))
+
+(def: .public any
+  (Writer Any)
+  (function.constant ..no_op))
+
+(def: .public bit
+  (Writer Bit)
+  (|>> (pipe.case #0 0 #1 1) ..bits_8))
+
+(with_template [<name> <type>]
+  [(def: .public <name> (Writer <type>) ..bits_64)]
+
+  [nat Nat]
+  [int Int]
+  [rev Rev]
+  )
+
+(def: .public frac
+  (Writer Frac)
+  (|>> frac.bits ..bits_64))
+
+(def: .public (segment size)
+  (-> Nat (Writer Binary))
+  (function (_ value)
+    [size
+     (function (_ [offset binary])
+       [(n#+ size offset)
+        (/.copy! (n.min size (/.size value))
+                 0
+                 value
+                 offset
+                 binary)])]))
+
+(with_template [<name> <bits> <size> <write>]
+  [(def: .public <name>
+     (Writer Binary)
+     (let [mask (..mask <size>)]
+       (function (_ value)
+         (let [size (|> value /.size (i64.and mask))
+               size' (n#+ <size> size)]
+           [size'
+            (function (_ [offset binary])
+              [(n#+ size' offset)
+               (|> binary
+                   (<write> offset size)
+                   (/.copy! size 0 value (n#+ <size> offset)))])]))))]
+
+  [binary_8  ..bits_8  </>.size_8  /.has_8!]
+  [binary_16 ..bits_16 </>.size_16 /.has_16!]
+  [binary_32 ..bits_32 </>.size_32 /.has_32!]
+  [binary_64 ..bits_64 </>.size_64 /.has_64!]
+  )
+
+(with_template [<name> <binary>]
+  [(def: .public <name>
+     (Writer Text)
+     (|>> (at utf8.codec encoded) <binary>))]
+
+  [utf8_8  ..binary_8]
+  [utf8_16 ..binary_16]
+  [utf8_32 ..binary_32]
+  [utf8_64 ..binary_64]
+  )
+
+(def: .public text ..utf8_64)
+
+(with_template [<name> <size> <write>]
+  [(def: .public (<name> valueW)
+     (All (_ v) (-> (Writer v) (Writer (Sequence v))))
+     (function (_ value)
+       (let [original_count (sequence.size value)
+             capped_count (i64.and (..mask <size>)
+                                   original_count)
+             value (if (n#= original_count capped_count)
+                     value
+                     (|> value sequence.list (list.first capped_count) sequence.of_list))
+             (open "specification#[0]") ..monoid
+             [size mutation] (|> value
+                                 (sequence#each valueW)
+                                 (at sequence.mix mix
+                                     (function (_ post pre)
+                                       (specification#composite pre post))
+                                     specification#identity))]
+         [(n#+ <size> size)
+          (function (_ [offset binary])
+            (|> binary
+                (<write> offset capped_count)
+                [(n#+ <size> offset)]
+                mutation))])))]
+
+  [sequence_8  </>.size_8  /.has_8!]
+  [sequence_16 </>.size_16 /.has_16!]
+  [sequence_32 </>.size_32 /.has_32!]
+  [sequence_64 </>.size_64 /.has_64!]
+  )
+
+(def: .public maybe
+  (All (_ a) (-> (Writer a) (Writer (Maybe a))))
+  (..or ..any))
+
+(def: .public (list value)
+  (All (_ a) (-> (Writer a) (Writer (List a))))
+  (..rec
+   (|>> (..and value)
+        (..or ..any))))
+
+(def: .public (set value)
+  (All (_ a) (-> (Writer a) (Writer (Set a))))
+  (|>> set.list (..list value)))
+
+(def: .public symbol
+  (Writer Symbol)
+  (..and ..text ..text))
+
+(def: .public type
+  (Writer Type)
+  (..rec
+   (function (_ again)
+     (let [pair (..and again again)
+           indexed ..nat
+           quantified (..and (..list again) again)]
+       (function (_ altV)
+         (case altV
+           (^.with_template [<number> <tag> <writer>]
+             [{<tag> caseV}
+              (let [[caseS caseT] (<writer> caseV)]
+                [(.++ caseS)
+                 (function (_ [offset binary])
+                   (|> binary
+                       (/.has_8! offset <number>)
+                       [(.++ offset)]
+                       caseT))])])
+           ([0 .#Primitive (..and ..text (..list again))]
+            [1 .#Sum pair]
+            [2 .#Product pair]
+            [3 .#Function pair]
+            [4 .#Parameter indexed]
+            [5 .#Var indexed]
+            [6 .#Ex indexed]
+            [7 .#UnivQ quantified]
+            [8 .#ExQ quantified]
+            [9 .#Apply pair]
+            [10 .#Named (..and ..symbol again)])
+           ))))))
+
+(def: .public location
+  (Writer Location)
+  (all ..and ..text ..nat ..nat))
+
+(def: .public code
+  (Writer Code)
+  (..rec
+   (function (_ again)
+     (let [sequence (..list again)]
+       (..and ..location
+              (function (_ altV)
+                (case altV
+                  (^.with_template [<number> <tag> <writer>]
+                    [{<tag> caseV}
+                     (let [[caseS caseT] (<writer> caseV)]
+                       [(.++ caseS)
+                        (function (_ [offset binary])
+                          (|> binary
+                              (/.has_8! offset <number>)
+                              [(.++ offset)]
+                              caseT))])])
+                  ([0 .#Bit ..bit]
+                   [1 .#Nat ..nat]
+                   [2 .#Int ..int]
+                   [3 .#Rev ..rev]
+                   [4 .#Frac ..frac]
+                   [5 .#Text ..text]
+                   [6 .#Symbol ..symbol]
+                   [7 .#Form sequence]
+                   [8 .#Variant sequence]
+                   [9 .#Tuple sequence])
+                  )))))))
diff --git a/stdlib/source/format/lux/data/text.lux b/stdlib/source/format/lux/data/text.lux
new file mode 100644
index 000000000..606cace14
--- /dev/null
+++ b/stdlib/source/format/lux/data/text.lux
@@ -0,0 +1,133 @@
+(.using
+ [library
+  [lux (.except list nat int rev type symbol)
+   [abstract
+    [monad (.only do)]
+    [functor
+     ["[0]" contravariant]]]
+   [control
+    ["<>" parser (.only)
+     ["<[0]>" code (.only Parser)]]]
+   [data
+    ["[0]" bit]
+    ["[0]" text]
+    [format
+     ["[0]" xml]
+     ["[0]" json]]
+    [collection
+     ["[0]" list (.open: "[1]#[0]" monad)]]]
+   ["[0]" time (.only)
+    ["[0]" instant]
+    ["[0]" duration]
+    ["[0]" date]
+    ["[0]" day]
+    ["[0]" month]]
+   [math
+    ["[0]" modular]
+    [number
+     ["[0]" nat]
+     ["[0]" int]
+     ["[0]" rev]
+     ["[0]" frac]
+     ["[0]" ratio]]]
+   [macro
+    [syntax (.only syntax)]
+    ["[0]" code]
+    ["[0]" template]]
+   [meta
+    ["[0]" location]
+    ["[0]" symbol]]
+   ["[0]" type]]])
+
+(type: .public (Format a)
+  (-> a Text))
+
+(def: .public functor
+  (contravariant.Functor Format)
+  (implementation
+   (def: (each f fb)
+     (|>> f fb))))
+
+(def: .public format
+  (syntax (_ [fragments (<>.many <code>.any)])
+    (in (.list (` (all "lux text concat" (~+ fragments)))))))
+
+(with_template [<name> <type> <formatter>]
+  [(def: .public <name>
+     (Format <type>)
+     <formatter>)]
+
+  [bit      Bit               (at bit.codec encoded)]
+  [nat      Nat               (at nat.decimal encoded)]
+  [int      Int               (at int.decimal encoded)]
+  [rev      Rev               (at rev.decimal encoded)]
+  [frac     Frac              (at frac.decimal encoded)]
+  [text     Text              text.format]
+  
+  [ratio    ratio.Ratio       (at ratio.codec encoded)]
+  [symbol   Symbol            (at symbol.codec encoded)]
+  [location Location          location.format]
+  [code     Code              code.format]
+  [type     Type              type.format]
+  
+  [instant  instant.Instant   (at instant.codec encoded)]
+  [duration duration.Duration (at duration.codec encoded)]
+  [date     date.Date         (at date.codec encoded)]
+  [time     time.Time         (at time.codec encoded)]
+  [day      day.Day           (at day.codec encoded)]
+  [month    month.Month       (at month.codec encoded)]
+  
+  [xml      xml.XML           (at xml.codec encoded)]
+  [json     json.JSON         (at json.codec encoded)]
+  )
+
+(with_template [<type> <format>,<codec>]
+  [(`` (with_template [<format> <codec>]
+         [(def: .public <format>
+            (Format <type>)
+            (at <codec> encoded))]
+
+         (~~ (template.spliced <format>,<codec>))))]
+
+  [Nat
+   [[nat_2 nat.binary]
+    [nat_8 nat.octal]
+    [nat_10 nat.decimal]
+    [nat_16 nat.hex]]]
+  [Int
+   [[int_2 int.binary]
+    [int_8 int.octal]
+    [int_10 int.decimal]
+    [int_16 int.hex]]]
+  [Rev
+   [[rev_2 rev.binary]
+    [rev_8 rev.octal]
+    [rev_10 rev.decimal]
+    [rev_16 rev.hex]]]
+  [Frac
+   [[frac_2 frac.binary]
+    [frac_8 frac.octal]
+    [frac_10 frac.decimal]
+    [frac_16 frac.hex]]]
+  )
+
+(def: .public (mod modular)
+  (All (_ m) (Format (modular.Mod m)))
+  (let [codec (modular.codec (modular.modulus modular))]
+    (at codec encoded modular)))
+
+(def: .public (list formatter)
+  (All (_ a) (-> (Format a) (Format (List a))))
+  (|>> (list#each (|>> formatter (format " ")))
+       text.together
+       (text.enclosed ["(list" ")"])))
+
+(def: .public (maybe format)
+  (All (_ a) (-> (Format a) (Format (Maybe a))))
+  (function (_ value)
+    (case value
+      {.#None}
+      "{.#None}"
+
+      {.#Some value}
+      (..format "{.#Some " (format value) "}"))))