Globals for zoned date times

Author: gmorpheme

harness/test/044_time.eu

@@ -3,6 +3,9 @@ time: cal.now."{h:%02d}:{m:%02d}:{s:%02d}"
 tests: {
   α: cal.now.y > 2000 //= true
   β: cal.now.s < 62 //= true
+  γ: cal.zdt(2019, 12, 1, 11, 23, 77, "+0400") cal.fields (.h) //= 11
+  δ: cal.datetime({y: 2019 m: 11 d: 21}) cal.fields (.d) //= 21
+  ε: cal.datetime({h: 12 M: 12 s: 12}) cal.fields (."{h:%02d}!{M:%02d}") //= "12!12"
 }
 
 RESULT: tests values all-true? then(:PASS, :FAIL)

harness/test/x044_date_times.eu

@@ -1,5 +1,3 @@
-# -*- mode: conf -*-
-
 # Eucalypt standard prelude
 
 ##
@@ -763,7 +761,31 @@ cal: {
   ifields: block ∘__IFIELDS
 
   now: io.epoch-time ifields
+  
   epoch: 0 ifields
+
+  ` "Intrinsics for working with unwrapped zoned date times"
+  Γ: {
+    zdt: __ZDT
+    wrap: '__ZDT.WRAP'
+    unwrap: '__ZDT.UNWRAP'
+    fields: '__ZDT.FIELDS'
+  }
+
+  ` "`cal.zdt(y, m, d, h, M, s, Z)` - create zoned date time from datetime components and timezone string (e.g. '+0100')"
+  zdt(y, m, d, h, M, s, Z): Γ.zdt(y, m, d, h, M, s, Z) Γ.wrap
+
+  ` "`cal.time(b)` - convert block of time fields to time (with 0 / UTC defaults)"
+  datetime(b): zdt(b lookup-or(:y, 0),
+                   b lookup-or(:m, 0),
+	                 b lookup-or(:d, 0),
+	                 b lookup-or(:h, 0),
+	                 b lookup-or(:M, 0),
+	                 b lookup-or(:s, 0),
+	                 b lookup-or(:Z, "UTC"))
+
+  ` "cal.fields(t) - decompose a zoned date time into a block of its component fields"
+  fields: block ∘ Γ.fields ∘ Γ.unwrap
 }
 
 

lib/prelude.eu

@@ -95,6 +95,10 @@ globalRegistry =
   , GlobalInfo "UPPER" [Strict]
   , GlobalInfo "LOWER" [Strict]
   , GlobalInfo "IFIELDS" [Strict]
+  , GlobalInfo "ZDT" [Strict, Strict, Strict, Strict, Strict, Strict, Strict]
+  , GlobalInfo "ZDT.WRAP" [Strict]
+  , GlobalInfo "ZDT.UNWRAP" [Strict]
+  , GlobalInfo "ZDT.FIELDS" [Strict]
   , GlobalInfo "ALIST.MERGE" [Strict, Strict]
   , GlobalInfo "ALIST.PRUNE" [Strict]
   , GlobalInfo "ALIST.DEEPMERGE" [Strict, Strict]

src/Eucalypt/Stg/GlobalInfo.hs

@@ -13,12 +13,20 @@ module Eucalypt.Stg.Globals.Time
   ) where
 
 import Data.Symbol
+import Eucalypt.Stg.Globals.Common (wrapBifStrict)
+import Eucalypt.Stg.GlobalInfo (gref)
+import Eucalypt.Stg.Native (Native(..))
 import Eucalypt.Stg.Syn
 import Eucalypt.Stg.Intrinsics (intrinsicIndex)
+import Eucalypt.Stg.Tags
 
 globals :: [(Symbol, LambdaForm)]
 globals =
   [ ("IFIELDS", euIFields)
+  , ("ZDT", euZdt)
+  , ("ZDT.WRAP", euZdtWrap)
+  , ("ZDT.UNWRAP", euZdtUnwrap)
+  , ("ZDT.FIELDS", euZdtFields)
   ]
 
 euIFields :: LambdaForm
@@ -27,3 +35,24 @@ euIFields =
   ann_ "__IFIELDS" 0 $
   force_ (Atom (L 0)) $
   appbif_ (intrinsicIndex "IFIELDS") [L 1]
+
+
+-- | __ZDT(y, m, d, h, M, s, Z)
+euZdt :: LambdaForm
+euZdt = wrapBifStrict "ZDT"
+
+-- | __ZDT.WRAP(zdt)
+euZdtWrap :: LambdaForm
+euZdtWrap = lam_ 0 1 $ ann_ "ZDT.WRAP" 0 $ appcon_ stgZDT [L 0]
+
+-- | __ZDT.UNWRAP(zdt)
+euZdtUnwrap :: LambdaForm
+euZdtUnwrap =
+  lam_ 0 1 $
+  ann_ "ZDT.UNWRAP" 0 $
+  casedef_ (Atom (L 0)) [(stgZDT, (1, atom_ (L 1)))] $
+  appfn_ (gref "PANIC") [V $ NativeString "Expected zoned date time"]
+
+-- | __ZDT.FIELDS(zdt)
+euZdtFields :: LambdaForm
+euZdtFields = wrapBifStrict "ZDT.FIELDS"

src/Eucalypt/Stg/Globals/Time.hs

@@ -13,21 +13,23 @@ module Eucalypt.Stg.Intrinsics.Time
   , toZonedDateTime
   ) where
 
-import Eucalypt.Stg.Error
-import Eucalypt.Stg.IntrinsicInfo
-import Eucalypt.Stg.Intrinsics.Common (invoke, returnList, returnDynamic)
-import Eucalypt.Stg.Native
-import Eucalypt.Stg.Machine
+import Data.Dynamic
 import Data.Scientific
 import Data.Time.Calendar
 import Data.Time.Clock.POSIX
 import Data.Time.LocalTime
-import Text.Regex.PCRE.Heavy (scan, re)
+import Eucalypt.Stg.Error
+import Eucalypt.Stg.IntrinsicInfo
+import Eucalypt.Stg.Intrinsics.Common (cast, invoke, returnDynamic, returnList)
+import Eucalypt.Stg.Machine
+import Eucalypt.Stg.Native
+import Text.Regex.PCRE.Heavy (re, scan)
 
 intrinsics :: [IntrinsicInfo]
 intrinsics =
   [ IntrinsicInfo "IFIELDS" 1 (invoke instantToUTCFields)
   , IntrinsicInfo "ZDT" 7 (invoke toZonedDateTime)
+  , IntrinsicInfo "ZDT.FIELDS" 1 (invoke zdtFields)
   ]
 
 
@@ -38,21 +40,23 @@ instantToUTCFields s d =
       z = utcToZonedTime utc u
    in returnList s $ zonedDateTimeFields z
 
+-- | Represent a 'ZonedTime' as its component fields
 zonedDateTimeFields :: ZonedTime -> [(Native, Native)]
 zonedDateTimeFields ZonedTime {..} =
   let LocalTime {..} = zonedTimeToLocalTime
       tz = timeZoneOffsetString zonedTimeZone
       (year, month, day) = toGregorian localDay
       TimeOfDay {..} = localTimeOfDay
    in [ (NativeSymbol "y", NativeNumber $ fromIntegral year)
-      , (NativeSymbol "M", NativeNumber $ fromIntegral month)
+      , (NativeSymbol "m", NativeNumber $ fromIntegral month)
       , (NativeSymbol "d", NativeNumber $ fromIntegral day)
       , (NativeSymbol "h", NativeNumber $ fromIntegral todHour)
-      , (NativeSymbol "m", NativeNumber $ fromIntegral todMin)
+      , (NativeSymbol "M", NativeNumber $ fromIntegral todMin)
       , (NativeSymbol "s", NativeNumber $ fromRational $ toRational todSec)
       , (NativeSymbol "Z", NativeString tz)
       ]
 
+-- | Parse a time zone string into a 'TimeZone', supports numeric or "UTC"
 timeZoneFromString :: MachineState -> String -> IO TimeZone
 timeZoneFromString _ "UTC" = return utc
 timeZoneFromString _ "" = return utc
@@ -68,6 +72,7 @@ timeZoneFromString ms s =
        in return $ minutesToTimeZone $ sig * (60 * h + m)
     _ -> throwIn ms $ InvalidArgument "Time zone was not valid"
 
+-- | Create a raw zoned date time from its components
 toZonedDateTime ::
      MachineState
   -> Scientific
@@ -87,3 +92,10 @@ toZonedDateTime ms y m d h mins s tz =
       dtz <- timeZoneFromString ms tz
       returnDynamic ms $ ZonedTime locTime dtz
     _ -> throwIn ms $ InvalidArgument "Time field was invalid"
+
+-- | Split up a raw zoned date time into its components (as k-v pairs
+-- for populating a block).
+zdtFields :: MachineState -> Dynamic -> IO MachineState
+zdtFields ms zdtDyn = do
+  zdt <- cast ms zdtDyn
+  returnList ms $ zonedDateTimeFields zdt