Merge pull request #848 from smucclaw/mengwong/cli-batch-json

Author: mengwong

jl4-core/src/L4/Evaluate/ValueLazy.hs

@@ -2,6 +2,11 @@ module L4.Evaluate.ValueLazy where
 
 import Base
 import Control.Concurrent (ThreadId)
+import Data.Aeson (ToJSON(..), object, (.=))
+import qualified Data.Aeson as Aeson
+import qualified Data.Aeson.Key as Key
+import Data.Ratio (numerator, denominator)
+import qualified Data.Vector as Vector
 import Data.Time (Day, UTCTime)
 import Data.Time.LocalTime (TimeOfDay)
 import L4.Syntax
@@ -242,3 +247,72 @@ instance NFData TernaryBuiltinFun where
   rnf TernaryAlwaysBetween = ()
   rnf TernaryTimeFromHMS = ()
   rnf TernaryDatetimeFromDTZ = ()
+
+-- ----------------------------------------------------------------------------
+-- ToJSON instances for batch --json output
+-- ----------------------------------------------------------------------------
+
+-- | Get the constructor name as Text from a Resolved name.
+resolvedNameText :: Resolved -> Text
+resolvedNameText = rawNameToText . rawName . getOriginal
+
+-- | Flatten a ValCons/ValNil chain into a JSON array.
+-- If the structure is not a proper list, fall back to a two-element array.
+flattenList :: ToJSON a => a -> a -> Aeson.Value
+flattenList x xs = case toJSON xs of
+  Aeson.Array arr -> Aeson.Array (Vector.cons (toJSON x) arr)
+  _               -> toJSON [toJSON x, toJSON xs]
+
+instance ToJSON NF where
+  toJSON (MkNF val) = toJSON val
+  toJSON Omitted    = Aeson.Null
+
+instance ToJSON a => ToJSON (Value a) where
+  toJSON (ValNumber r)
+    | denominator r == 1 = toJSON (numerator r)
+    | otherwise          = toJSON (fromRational r :: Double)
+  toJSON (ValString s)            = toJSON s
+  toJSON (ValDate d)              = toJSON (show d)
+  toJSON (ValTime t)              = toJSON (show t)
+  toJSON (ValDateTime utc tz)     = object ["utc" .= utc, "timezone" .= tz]
+  toJSON ValNil                   = toJSON ([] :: [Aeson.Value])
+  toJSON (ValCons x xs)           = flattenList x xs
+  toJSON (ValConstructor name [])
+    | cname == "NOTHING"          = Aeson.Null
+    | cname == "EMPTY"            = toJSON ([] :: [Aeson.Value])
+    | cname == "TRUE"             = Aeson.Bool True
+    | cname == "FALSE"            = Aeson.Bool False
+    | otherwise                   = toJSON cname
+    where cname = resolvedNameText name
+  toJSON (ValConstructor name [v])
+    | resolvedNameText name == "JUST" = toJSON v
+  toJSON (ValConstructor name fields) = object
+    [ Key.fromText (resolvedNameText name) .= toJSON fields ]
+  toJSON (ValClosure{})           = toJSON ("<function>" :: Text)
+  toJSON (ValObligation{})        = toJSON ("<obligation>" :: Text)
+  toJSON (ValROp{})               = toJSON ("<deferred-op>" :: Text)
+  toJSON (ValNullaryBuiltinFun{}) = toJSON ("<builtin>" :: Text)
+  toJSON (ValUnaryBuiltinFun{})   = toJSON ("<builtin>" :: Text)
+  toJSON (ValBinaryBuiltinFun{})  = toJSON ("<builtin>" :: Text)
+  toJSON (ValTernaryBuiltinFun{}) = toJSON ("<builtin>" :: Text)
+  toJSON (ValPartialTernary{})    = toJSON ("<partial>" :: Text)
+  toJSON (ValPartialTernary2{})   = toJSON ("<partial>" :: Text)
+  toJSON (ValUnappliedConstructor r) = toJSON (resolvedNameText r)
+  toJSON (ValAssumed r)           = toJSON ("<assumed:" <> resolvedNameText r <> ">" :: Text)
+  toJSON (ValEnvironment{})       = toJSON ("<environment>" :: Text)
+  toJSON (ValBreached reason)     = object ["breached" .= toJSON reason]
+
+instance ToJSON a => ToJSON (ReasonForBreach a) where
+  toJSON (DeadlineMissed deadline now elapsed _party action limit) = object
+    [ "type" .= ("deadline_missed" :: Text)
+    , "deadline" .= deadline
+    , "now" .= now
+    , "elapsed" .= (fromRational elapsed :: Double)
+    , "action" .= show action
+    , "limit" .= (fromRational limit :: Double)
+    ]
+  toJSON (ExplicitBreach mParty mReason) = object
+    [ "type" .= ("explicit_breach" :: Text)
+    , "party" .= mParty
+    , "reason" .= mReason
+    ]

jl4-core/src/L4/EvaluateLazy.hs

@@ -374,6 +374,26 @@ prettyEvalDirectiveResultWithFields fields (MkEvalDirectiveResult _range res mtr
         Nothing -> Text.empty
         Just t  -> "\n─────\n" <> prettyLayout t
 
+-- ----------------------------------------------------------------------------
+-- ToJSON instances for batch --json output
+-- ----------------------------------------------------------------------------
+
+instance Aeson.ToJSON EvalDirectiveResult where
+  toJSON (MkEvalDirectiveResult _range res _trace) = Aeson.object
+    [ "result" Aeson..= res
+    , "trace"  Aeson..= Aeson.Null
+    ]
+
+instance Aeson.ToJSON EvalDirectiveValue where
+  toJSON (Assertion b) = Aeson.object
+    [ "type"  Aeson..= ("assertion" :: Text)
+    , "value" Aeson..= b
+    ]
+  toJSON (Reduction (Right val)) = Aeson.toJSON val
+  toJSON (Reduction (Left exc)) = Aeson.object
+    [ "error" Aeson..= Text.unlines (prettyEvalException exc)
+    ]
+
 prettyEvalDirectiveValueWithFields :: ConstructorFieldNames -> EvalDirectiveValue -> Text
 prettyEvalDirectiveValueWithFields _fields (Assertion True)        = "assertion satisfied"
 prettyEvalDirectiveValueWithFields _fields (Assertion False)       = "assertion failed"

jl4/app/Main.hs

@@ -365,10 +365,13 @@ main = do
                           pure mEval
 
                         let (status, output, diagnostics) = case mEvalRes of
-                              Nothing -> 
+                              Nothing ->
                                 ("error" :: Text, Aeson.Null, Aeson.toJSON evalErrs)
-                              Just evalResults ->
-                                ("success", Aeson.toJSON (map (Text.pack . show) evalResults), Aeson.Array mempty)
+                              Just evalResults
+                                | options.batchJson ->
+                                  ("success", Aeson.toJSON evalResults, Aeson.Array mempty)
+                                | otherwise ->
+                                  ("success", Aeson.toJSON (map (Text.pack . show) evalResults), Aeson.Array mempty)
 
                         pure $ Aeson.object
                           [ "input" Aeson..= input
@@ -537,6 +540,7 @@ data Options = MkOptions
   , batchFormat :: Maybe Text
   , entrypoint :: Maybe Text
   , stateGraph :: Bool              -- Output state transition graph from regulative rules
+  , batchJson :: Bool               -- Output batch results as clean JSON instead of Show
   }
 
 optionsDescription :: Options.Parser Options
@@ -556,6 +560,7 @@ optionsDescription = MkOptions
   <*> optional (Options.strOption (long "format" <> short 'f' <> metavar "FORMAT" <> help "Input/output format (json|yaml|csv); required when reading from stdin"))
   <*> optional (Options.strOption (long "entrypoint" <> short 'e' <> metavar "FUNCTION" <> help "Name of @export function to call (defaults to @export default or first @export)"))
   <*> switch (long "state-graph" <> help "Output state transition graph from regulative rules as GraphViz DOT")
+  <*> switch (long "json" <> help "Output batch results as clean JSON values instead of Haskell Show representation")
 
 fixedNowReader :: ReadM UTCTime
 fixedNowReader =