Merge pull request #58 from LuxLang/hierarchy_normalization

Hierarchy normalization

1 files changed, 225 insertions, 0 deletions

diff --git a/stdlib/source/library/lux/time/month.lux b/stdlib/source/library/lux/time/month.lux
new file mode 100644
index 000000000..381094933
--- /dev/null
+++ b/stdlib/source/library/lux/time/month.lux
@@ -0,0 +1,225 @@
+(.module:
+  [library
+   [lux #*
+    [abstract
+     [equivalence (#+ Equivalence)]
+     [hash (#+ Hash)]
+     [order (#+ Order)]
+     [enum (#+ Enum)]
+     [codec (#+ Codec)]]
+    [control
+     ["." try (#+ Try)]
+     ["." exception (#+ exception:)]]
+    [data
+     ["." text]]
+    [macro
+     ["." template]]
+    [math
+     [number
+      ["n" nat]]]]])
+
+(type: #export Month
+  #January
+  #February
+  #March
+  #April
+  #May
+  #June
+  #July
+  #August
+  #September
+  #October
+  #November
+  #December)
+
+(implementation: #export equivalence
+  (Equivalence Month)
+  
+  (def: (= reference sample)
+    (case [reference sample]
+      (^template [<tag>]
+        [[<tag> <tag>]
+         true])
+      ([#January]
+       [#February]
+       [#March]
+       [#April]
+       [#May]
+       [#June]
+       [#July]
+       [#August]
+       [#September]
+       [#October]
+       [#November]
+       [#December])
+
+      _
+      false)))
+
+(with_expansions [<pairs> (as_is [01 #January]
+                                 [02 #February]
+                                 [03 #March]
+                                 [04 #April]
+                                 [05 #May]
+                                 [06 #June]
+                                 [07 #July]
+                                 [08 #August]
+                                 [09 #September]
+                                 [10 #October]
+                                 [11 #November]
+                                 [12 #December])]
+  (def: #export (number month)
+    (-> Month Nat)
+    (case month
+      (^template [<number> <month>]
+        [<month> <number>])
+      (<pairs>)))
+
+  (exception: #export (invalid_month {number Nat})
+    (exception.report
+     ["Number" (\ n.decimal encode number)]
+     ["Valid range" ($_ "lux text concat"
+                        (\ n.decimal encode (..number #January))
+                        " ~ "
+                        (\ n.decimal encode (..number #December)))]))
+
+  (def: #export (by_number number)
+    (-> Nat (Try Month))
+    (case number
+      (^template [<number> <month>]
+        [<number> (#try.Success <month>)])
+      (<pairs>)
+      _ (exception.throw ..invalid_month [number])))
+  )
+
+(implementation: #export hash
+  (Hash Month)
+
+  (def: &equivalence ..equivalence)
+  (def: hash ..number))
+
+(implementation: #export order
+  (Order Month)
+  
+  (def: &equivalence ..equivalence)
+  
+  (def: (< reference sample)
+    (n.< (..number reference) (..number sample))))
+
+(implementation: #export enum
+  (Enum Month)
+  
+  (def: &order ..order)
+  
+  (def: (succ month)
+    (case month
+      #January   #February
+      #February  #March
+      #March     #April
+      #April     #May
+      #May       #June
+      #June      #July
+      #July      #August
+      #August    #September
+      #September #October
+      #October   #November
+      #November  #December
+      #December  #January))
+  
+  (def: (pred month)
+    (case month
+      #February  #January
+      #March     #February
+      #April     #March
+      #May       #April
+      #June      #May
+      #July      #June
+      #August    #July
+      #September #August
+      #October   #September
+      #November  #October
+      #December  #November
+      #January   #December)))
+
+(def: #export (days month)
+  (-> Month Nat)
+  (case month
+    (^template [<days> <month>]
+      [<month> <days>])
+    ([31 #January]
+     [28 #February]
+     [31 #March]
+     
+     [30 #April]
+     [31 #May]
+     [30 #June]
+     
+     [31 #July]
+     [31 #August]
+     [30 #September]
+     
+     [31 #October]
+     [30 #November]
+     [31 #December])))
+
+(def: #export (leap_year_days month)
+  (-> Month Nat)
+  (case month
+    #February (inc (..days month))
+    _ (..days month)))
+
+(def: #export year
+  (List Month)
+  (list #January
+        #February
+        #March
+        #April
+        #May
+        #June
+        #July
+        #August
+        #September
+        #October
+        #November
+        #December))
+
+(exception: #export (not_a_month_of_the_year {value Text})
+  (exception.report
+   ["Value" (text.format value)]))
+
+(implementation: #export codec
+  (Codec Text Month)
+
+  (def: (encode value)
+    (case value
+      (^template [<tag>]
+        [<tag> (template.text [<tag>])])
+      ([#..January]
+       [#..February]
+       [#..March]
+       [#..April]
+       [#..May]
+       [#..June]
+       [#..July]
+       [#..August]
+       [#..September]
+       [#..October]
+       [#..November]
+       [#..December])))
+  (def: (decode value)
+    (case value
+      (^template [<tag>]
+        [(^ (template.text [<tag>])) (#try.Success <tag>)])
+      ([#..January]
+       [#..February]
+       [#..March]
+       [#..April]
+       [#..May]
+       [#..June]
+       [#..July]
+       [#..August]
+       [#..September]
+       [#..October]
+       [#..November]
+       [#..December])
+      _ (exception.throw ..not_a_month_of_the_year [value]))))