Merge pull request #825 from smucclaw/thomasgorissen/jsondecode-date-support

Add DATE type support for JSONDECODE

Author: serrynaimo

jl4-core/src/L4/EvaluateLazy/Machine.hs

@@ -1284,6 +1284,16 @@ jsonValueToWHNFTyped jsonValue ty = do
             Aeson.Bool b -> pure $ if b then ValBool True else ValBool False
             _ -> InternalException $ RuntimeTypeError $
                   "Expected JSON boolean but got: " <> Text.pack (show jsonValue)
+        "DATE" -> do
+          -- DATE fields in JSON should be ISO-8601 strings (YYYY-MM-DD)
+          case jsonValue of
+            Aeson.String s -> do
+              case parseDateText s of
+                Just day -> pure $ ValDate day
+                Nothing -> InternalException $ RuntimeTypeError $
+                  "Could not parse date string '" <> s <> "'. Expected format: YYYY-MM-DD"
+            _ -> InternalException $ RuntimeTypeError $
+                  "Expected JSON string for DATE field but got: " <> Text.pack (show jsonValue)
 
         -- Not a primitive, check if it's a custom record type
         _ -> do

jl4-decision-service/README.md

@@ -200,7 +200,7 @@ This is useful for building conversational interfaces that ask only relevant que
 
 ### State Graphs
 
-L4 regulative rules (using `MUST`, `MAY`, `SHANT`) define contract state machines. The decision service can extract and visualize these:
+L4 regulative rules (using `MUST`, `MAY`, `SHANT`, `DO`) define contract state machines. The decision service can extract and visualize these:
 
 - `GET  /functions/<name>/state-graphs`: List all state graphs in the module
 - `GET  /functions/<name>/state-graphs/<graphName>`: Get DOT source for a specific graph
@@ -219,15 +219,16 @@ curl -s 'http://localhost:8081/functions/weddingcontract/state-graphs/weddingcer
 ```
 
 State graphs show:
+
 - **States**: Initial, intermediate, fulfilled, and breach states
 - **Transitions**: Labeled with the triggering action and any temporal constraints (WITHIN deadlines)
 - **Deontic modality**: Whether transitions are obligations (MUST), permissions (MAY), or prohibitions (SHANT)
 
 ## Loading L4 Functions
 
-Three functions are hardcoded by default (`compute_qualifies`, `vermin_and_rodent`, `the_answer`); see [src/Examples.hs](src/Examples.hs) for details.
+When **no** `--sourcePaths` are provided, the service loads three hardcoded example functions (`compute_qualifies`, `vermin_and_rodent`, `the_answer`) for testing purposes; see [src/Examples.hs](src/Examples.hs) for details.
 
-Other functions can be loaded at start time using the `--sourcePaths` command line option.
+When `--sourcePaths` are provided, **only** functions from those files are loaded—the hardcoded examples are not included.
 
 The argument to the option is a directory or individual `.l4` files. The service automatically follows `IMPORT` statements to load dependencies.
 
@@ -303,15 +304,15 @@ function:
 
 ## CLI Options
 
-| Option | Description | Default |
-|--------|-------------|---------|
-| `--port`, `-p` | HTTP port | 8081 |
-| `--serverName`, `-s` | Server URL (for swagger.json) | - |
-| `--sourcePaths`, `-f` | L4 files or directories to load | - |
-| `--crudServerName` | Session backend hostname | localhost |
-| `--crudServerPort` | Session backend port | 5008 |
-| `--crudServerSecure` | Use HTTPS for session backend | false |
-| `--crudServerPath` | Path prefix for session backend | (empty) |
+| Option                | Description                     | Default   |
+| --------------------- | ------------------------------- | --------- |
+| `--port`, `-p`        | HTTP port                       | 8081      |
+| `--serverName`, `-s`  | Server URL (for swagger.json)   | -         |
+| `--sourcePaths`, `-f` | L4 files or directories to load | -         |
+| `--crudServerName`    | Session backend hostname        | localhost |
+| `--crudServerPort`    | Session backend port            | 5008      |
+| `--crudServerSecure`  | Use HTTPS for session backend   | false     |
+| `--crudServerPath`    | Path prefix for session backend | (empty)   |
 
 ### Session Backend Integration
 

jl4-decision-service/src/Application.hs

@@ -49,12 +49,18 @@ defaultMain = do
   when (null sourcePaths) $ putStrLn $ "sourcePaths expanded to empty: " <> show sourcePaths
   unless (null sourcePaths) $ putStrLn $ "Scanning .l4 files from: " <> show l4Files
 
-  (l4Functions, _moduleContext) <- Examples.loadL4Functions l4Files
-  unless (null sourcePaths) $ putStrLn $ "** Loaded l4 functions from disk: " <> show (length l4Functions)
-  unless (null l4Functions) $ print $ Map.keys l4Functions
-
-  exampleFunctions <- Examples.functionSpecs
-  dbRef <- newTVarIO (exampleFunctions <> l4Functions)
+  -- Only load hardcoded examples if no source paths provided
+  -- When source paths are given, only load functions from those files
+  functions <- if null sourcePaths
+    then do
+      putStrLn "* No source paths provided, loading hardcoded examples"
+      Examples.functionSpecs
+    else do
+      (l4Functions, _moduleContext) <- Examples.loadL4Functions l4Files
+      putStrLn $ "** Loaded l4 functions from disk: " <> show (length l4Functions)
+      unless (null l4Functions) $ print $ Map.keys l4Functions
+      pure l4Functions
+  dbRef <- newTVarIO functions
   mgr <- newManager defaultManagerSettings
   putStrLn $ "will contact crud server on following base url: " <> show crudServerName
   let

jl4-decision-service/src/Backend/CodeGen.hs

@@ -10,10 +10,43 @@ import qualified Data.Text as Text
 import qualified Data.Text.Lazy as TL
 import qualified Data.Text.Lazy.Encoding as TL
 import L4.Syntax (Type'(..), Resolved, getUnique)
-import L4.TypeCheck.Environment (booleanUnique)
+import L4.TypeCheck.Environment (booleanUnique, dateUnique)
 import Backend.Api (TraceLevel(..))
 import Backend.MaybeLift (liftTypeToMaybe)
 
+-- | Check if a type is exactly DATE (not MAYBE DATE, LIST OF DATE, etc.)
+-- Used to determine if we need TODATE conversion from JSON strings
+isDateType :: Type' Resolved -> Bool
+isDateType (TyApp _ name []) = getUnique name == dateUnique
+isDateType _ = False
+
+-- | Check if a type contains DATE at its core (unwrapping MAYBE)
+-- e.g., DATE -> True, MAYBE DATE -> True, MAYBE (MAYBE DATE) -> True
+-- but LIST OF DATE -> False (we don't handle nested structures yet)
+containsDateType :: Type' Resolved -> Bool
+containsDateType ty = isDateType (unwrapMaybe ty)
+  where
+    -- Unwrap MAYBE layers to get to the core type
+    -- Note: We can't easily check for maybeUnique here without importing it,
+    -- so we use a heuristic: if it's a TyApp with one type argument, check inner
+    unwrapMaybe :: Type' Resolved -> Type' Resolved
+    unwrapMaybe (TyApp _ _ [inner]) = unwrapMaybe inner
+    unwrapMaybe t = t
+
+-- | Quote an identifier with backticks if it contains spaces or special characters
+-- L4 requires backticks for identifiers with spaces
+quoteIdent :: Text -> Text
+quoteIdent name
+  | Text.any (== ' ') name = "`" <> name <> "`"
+  | otherwise = name
+
+-- | Create a safe unwrapped variable name
+-- For names with spaces, creates a backtick-quoted identifier like `unwrapped_tranche number`
+unwrappedVar :: Text -> Text
+unwrappedVar name
+  | Text.any (== ' ') name = "`unwrapped_" <> name <> "`"
+  | otherwise = "unwrapped_" <> name
+
 -- | Result of code generation
 data GeneratedCode = GeneratedCode
   { generatedWrapper :: Text
@@ -62,13 +95,13 @@ generateEvalWrapper funName givenParams assumeParams inputJson traceLevel = do
           isBooleanType :: Type' Resolved -> Bool
           isBooleanType (TyApp _ name []) = getUnique name == booleanUnique
           isBooleanType _ = False
-          -- Annotate GIVEN params with their boolean status and mark as GIVEN
-          givenParamInfo = map (\(name, ty) -> ((name, ty), isBooleanType ty, True)) givenParams
-          -- Annotate ASSUME params with their boolean status and mark as ASSUME
-          assumeParamInfo = map (\(name, ty) -> ((name, ty), isBooleanType ty, False)) assumeParams
+          -- Annotate GIVEN params with (type info, isBoolean, isGiven, isDate)
+          givenParamInfo = map (\(name, ty) -> ((name, ty), isBooleanType ty, True, containsDateType ty)) givenParams
+          -- Annotate ASSUME params with (type info, isBoolean, isGiven, isDate)
+          assumeParamInfo = map (\(name, ty) -> ((name, ty), isBooleanType ty, False, containsDateType ty)) assumeParams
           allParamInfo = givenParamInfo <> assumeParamInfo
           -- We always need prelude for fromMaybe (all booleans use it)
-          hasBooleans = any (\(_, isB, _) -> isB) allParamInfo
+          hasBooleans = any (\(_, isB, _, _) -> isB) allParamInfo
       in Right GeneratedCode
       { generatedWrapper = Text.unlines $
           [ ""
@@ -106,7 +139,9 @@ generateInputRecordLifted params = Text.unlines $
       let indent = if idx == 0 then "  " else ", "
           -- Lift ALL types to MAYBE
           tyText = liftTypeToMaybe ty
-      in indent <> name <> " IS A " <> tyText
+          -- Quote identifiers with spaces
+          quotedName = quoteIdent name
+      in indent <> quotedName <> " IS A " <> tyText
 
 -- | Generate typed decoder function
 generateDecoder :: Text
@@ -134,11 +169,11 @@ escapeAsL4String val =
 -- GIVEN params are passed as function arguments.
 -- ASSUME params are injected as LET bindings before the function call.
 --
--- Type signature: [((name, type), isBoolean, isGiven)]
+-- Type signature: [((name, type), isBoolean, isGiven, isDate)]
 generateEvalDirectiveLiftedWithAssumes
   :: Text
-  -> [((Text, Type' Resolved), Bool, Bool)]  -- ^ GIVEN params: ((name, type), isBoolean, isGiven=True)
-  -> [((Text, Type' Resolved), Bool, Bool)]  -- ^ ASSUME params: ((name, type), isBoolean, isGiven=False)
+  -> [((Text, Type' Resolved), Bool, Bool, Bool)]  -- ^ GIVEN params: ((name, type), isBoolean, isGiven=True, isDate)
+  -> [((Text, Type' Resolved), Bool, Bool, Bool)]  -- ^ ASSUME params: ((name, type), isBoolean, isGiven=False, isDate)
   -> TraceLevel
   -> Text
 generateEvalDirectiveLiftedWithAssumes funName givenParamInfo assumeParamInfo traceLevel =
@@ -150,33 +185,38 @@ generateEvalDirectiveLiftedWithAssumes funName givenParamInfo assumeParamInfo tr
       allParams = givenParamInfo <> assumeParamInfo
 
       -- Separate boolean and non-boolean params (for unwrapping logic)
-      nonBoolAllParams = filter (\(_, isB, _) -> not isB) allParams
+      nonBoolAllParams = filter (\(_, isB, _, _) -> not isB) allParams
 
       -- Generate argument expressions for GIVEN params only (in original order)
       -- Booleans use fromMaybe FALSE directly
       -- Non-booleans reference unwrapped variable names
+      -- Date types need conversion via dateConvertedVar
       givenArgExprs = map snd $ sortOn fst $
-        [(idx, expr) | (idx, ((name, _), True, _)) <- zip [0 :: Int ..] givenParamInfo
-                     , let expr = "(fromMaybe FALSE (args's " <> name <> "))"] ++
-        [(idx, expr) | (idx, ((name, _), False, _)) <- zip [0 :: Int ..] givenParamInfo
-                     , let expr = "unwrapped_" <> name]
+        [(idx, expr) | (idx, ((name, _), True, _, _)) <- zip [0 :: Int ..] givenParamInfo
+                     , let expr = "(fromMaybe FALSE (args's " <> quoteIdent name <> "))"] ++
+        [(idx, expr) | (idx, ((name, _), False, _, isDate)) <- zip [0 :: Int ..] givenParamInfo
+                     , let expr = if isDate then dateConvertedVar name else unwrappedVar name]
 
       -- Build function call with only GIVEN params as arguments
+      -- Quote function name if it contains spaces
+      quotedFunName = quoteIdent funName
       functionCall = if null givenArgExprs
-        then funName
-        else funName <> " " <> Text.unwords givenArgExprs
+        then quotedFunName
+        else quotedFunName <> " " <> Text.unwords givenArgExprs
 
       -- Wrap function call with LET bindings for ASSUME params
       -- Boolean ASSUMEs use fromMaybe FALSE
       -- Non-boolean ASSUMEs use unwrapped_ variables
+      -- Date ASSUMEs use dateConverted_ variables
       wrapWithAssumes :: Text -> Text
       wrapWithAssumes innerExpr = foldr wrapOne innerExpr assumeParamInfo
         where
-          wrapOne ((name, _), isBoolean, _) expr =
-            let valueExpr = if isBoolean
-                  then "(fromMaybe FALSE (args's " <> name <> "))"
-                  else "unwrapped_" <> name
-            in "LET " <> name <> " = " <> valueExpr <> " IN " <> expr
+          wrapOne ((name, _), isBoolean, _, isDate) expr =
+            let quotedName = quoteIdent name
+                valueExpr = if isBoolean
+                  then "(fromMaybe FALSE (args's " <> quotedName <> "))"
+                  else if isDate then dateConvertedVar name else unwrappedVar name
+            in "LET " <> quotedName <> " = " <> valueExpr <> " IN " <> expr
 
       -- The innermost expression (wrapped function call in JUST)
       innerCall = "JUST (" <> wrapWithAssumes functionCall <> ")"
@@ -201,29 +241,53 @@ generateEvalDirectiveLiftedWithAssumes funName givenParamInfo assumeParamInfo tr
 
 -- | Generate nested CONSIDER for unwrapping non-boolean MAYBE values,
 -- with LET bindings for ASSUME params at the innermost level.
+-- For DATE types, adds an additional CONSIDER to convert string -> DATE via TODATE.
 generateNestedConsiderWithAssumes
-  :: [((Text, Type' Resolved), Bool, Bool)]  -- ^ Non-boolean params to unwrap
-  -> Text                                     -- ^ Function call (GIVEN args only)
-  -> [((Text, Type' Resolved), Bool, Bool)]  -- ^ ASSUME params for LET bindings
-  -> Int                                      -- ^ Indentation level
+  :: [((Text, Type' Resolved), Bool, Bool, Bool)]  -- ^ Non-boolean params to unwrap (name, type, isBoolean, isGiven, isDate)
+  -> Text                                           -- ^ Function call (GIVEN args only)
+  -> [((Text, Type' Resolved), Bool, Bool, Bool)]  -- ^ ASSUME params for LET bindings
+  -> Int                                            -- ^ Indentation level
   -> [Text]
 generateNestedConsiderWithAssumes [] functionCall assumeParamInfo indent =
   let indentStr = Text.replicate indent "  "
       -- Wrap function call with LET bindings for ASSUME params
       wrapWithAssumes :: Text -> Text
       wrapWithAssumes innerExpr = foldr wrapOne innerExpr assumeParamInfo
         where
-          wrapOne ((name, _), isBoolean, _) expr =
-            let valueExpr = if isBoolean
-                  then "(fromMaybe FALSE (args's " <> name <> "))"
-                  else "unwrapped_" <> name
-            in "LET " <> name <> " = " <> valueExpr <> " IN " <> expr
+          wrapOne ((name, _), isBoolean, _, isDate) expr =
+            let quotedName = quoteIdent name
+                valueExpr = if isBoolean
+                  then "(fromMaybe FALSE (args's " <> quotedName <> "))"
+                  else if isDate then dateConvertedVar name else unwrappedVar name
+            in "LET " <> quotedName <> " = " <> valueExpr <> " IN " <> expr
   in [indentStr <> "JUST (" <> wrapWithAssumes functionCall <> ")"]
-generateNestedConsiderWithAssumes (((name, _), _, _):rest) functionCall assumeParamInfo indent =
+generateNestedConsiderWithAssumes (((name, _), _, _, isDate):rest) functionCall assumeParamInfo indent =
   let indentStr = Text.replicate indent "  "
-  in [ indentStr <> "CONSIDER args's " <> name
-     , indentStr <> "  WHEN JUST unwrapped_" <> name <> " THEN"
-     ] ++
-     generateNestedConsiderWithAssumes rest functionCall assumeParamInfo (indent + 2) ++
-     [ indentStr <> "  WHEN NOTHING THEN NOTHING"
-     ]
+      quotedName = quoteIdent name
+  in if isDate
+     then
+       -- For DATE types: first unwrap the MAYBE STRING, then convert to DATE via TODATE
+       [ indentStr <> "CONSIDER args's " <> quotedName
+       , indentStr <> "  WHEN JUST " <> unwrappedVar name <> " THEN"
+       , indentStr <> "    CONSIDER TODATE " <> unwrappedVar name
+       , indentStr <> "      WHEN JUST " <> dateConvertedVar name <> " THEN"
+       ] ++
+       generateNestedConsiderWithAssumes rest functionCall assumeParamInfo (indent + 4) ++
+       [ indentStr <> "      WHEN NOTHING THEN NOTHING  -- date parse failed"
+       , indentStr <> "  WHEN NOTHING THEN NOTHING"
+       ]
+     else
+       -- For non-DATE types: just unwrap the MAYBE
+       [ indentStr <> "CONSIDER args's " <> quotedName
+       , indentStr <> "  WHEN JUST " <> unwrappedVar name <> " THEN"
+       ] ++
+       generateNestedConsiderWithAssumes rest functionCall assumeParamInfo (indent + 2) ++
+       [ indentStr <> "  WHEN NOTHING THEN NOTHING"
+       ]
+
+-- | Create a variable name for date-converted values
+-- For names with spaces, creates a backtick-quoted identifier like `dateConverted_earn date`
+dateConvertedVar :: Text -> Text
+dateConvertedVar name
+  | Text.any (== ' ') name = "`dateConverted_" <> name <> "`"
+  | otherwise = "dateConverted_" <> name