More code for aajson

smucclaw · Oct 3, 2024 · 09f45b8 · 09f45b8
1 parent 38cc083
commit 09f45b8
Show file tree

Hide file tree

Showing 2 changed files with 48 additions and 27 deletions.
diff --git a/lib/haskell/natural4/src/LS/XPile/AaJson.hs b/lib/haskell/natural4/src/LS/XPile/AaJson.hs
@@ -17,7 +17,7 @@ module LS.XPile.AaJson
 where
 
 import AnyAll qualified as AA
-import AnyAll.BoolStruct (alwaysLabeled)
+import AnyAll.BoolStruct (alwaysLabeled, BoolStructLT)
 import Control.Monad (join)
 import Data.Bifunctor (Bifunctor (..), second)
 import Data.Char qualified as Char
@@ -66,6 +66,10 @@ import LS.XPile.Logging
   )
 import PGF (showLanguage)
 import Text.Pretty.Simple (pShowNoColor)
+import Data.Aeson (ToJSON(toJSON), object, (.=),Value, encode)
+import Data.Aeson.Key (fromString)
+import Base (Generic)
+import Data.Aeson.Encode.Pretty (encodePretty)
 
 -- | extract the tree-structured rules from Interpreter
 -- currently: construct a Data.Map of rulenames to exposed decision root expanded BSR
@@ -77,6 +81,22 @@ import Text.Pretty.Simple (pShowNoColor)
 data Tuple a b = Tuple a b
   deriving (Show, Eq, Ord)
 
+labelToAaJson :: AA.Label T.Text -> Value
+labelToAaJson (AA.Pre a) = object [ "Pre" .= a ]
+labelToAaJson (AA.PrePost a b) = object [ "PrePost" .= [a,b] ]
+labelToAaJson (AA.Metadata a) = object [ "Metadata" .= a ]
+
+bsToAaJson :: BoolStructLT -> Value
+bsToAaJson (AA.All l bs) = object [ "All" .= object["label" .= labelToAaJson l, "children" .= [bsToAaJson c | c <- bs] ]]
+bsToAaJson (AA.Any l bs) = object [ "Any" .= object["label" .= labelToAaJson l, "children" .=  [bsToAaJson c | c <- bs] ]]
+bsToAaJson (AA.Leaf a) = object [ "Leaf" .= a ]
+bsToAaJson (AA.Not bs) = object [ "Not" .= bs]
+
+instance ToJSON (Tuple String BoolStructLT) where
+ toJSON (Tuple a b) =
+    object [ fromString a .= bsToAaJson b]
+
+
 -- | output Haskell tuples to Purescript
 toTuple :: (a,b) -> Tuple a b
 toTuple (x,y) = Tuple x y
@@ -309,8 +329,7 @@ translate2AaJson nlgEnvs eng l4i = do
       case hornByLang of
         Left err -> xpError err
         Right hornByLang -> xpReturn [__i|
-          {
-            #{pShowNoColor $ DL.nub hornByLang}
+            #{encodePretty $ toJSON $ DL.nub hornByLang}
         |]
   -- mutterdhsf 2 "qaHornsAllLangs" pShowNoColorS qaHornsRights
 

diff --git a/lib/haskell/natural4/test/testdata/golden/AaJsonSpec/must_sing.json.expected b/lib/haskell/natural4/test/testdata/golden/AaJsonSpec/must_sing.json.expected
@@ -1,31 +1,33 @@
 
 
-{
-    "Person": {
-        "All": {
-            "label": {
-                "Pre": "all of:"
-            },
-            "children": [
-                {
-                    "Leaf": "does the person walk?"
-                },
-                {
-                    "Any": {
-                        "label": {
-                            "Pre": "any of:"
-                        },
-                        "children": [
-                            {
-                                "Leaf": "does the person eat?"
-                            },
-                            {
-                                "Leaf": "does the person drink?"
+[
+    {
+        "Person": {
+            "All": {
+                "children": [
+                    {
+                        "Leaf": "does the person walk?"
+                    },
+                    {
+                        "Any": {
+                            "children": [
+                                {
+                                    "Leaf": "does the person eat?"
+                                },
+                                {
+                                    "Leaf": "does the person drink?"
+                                }
+                            ],
+                            "label": {
+                                "Pre": "any of:"
                             }
-                        ]
+                        }
                     }
+                ],
+                "label": {
+                    "Pre": "all of:"
                 }
-            ]
+            }
         }
     }
-}
+]