From f7cd8abb5eda335c7c2beb66fd28d594e3f3b956 Mon Sep 17 00:00:00 2001
From: LLLL Colonq <llll@colonq>
Date: Tue, 16 Jan 2024 21:32:53 -0500
Subject: Support JSON output

---
 fig-bless/src/Fig/Bless/Syntax.hs | 32 +++++++++++++++++++++++++-------
 1 file changed, 25 insertions(+), 7 deletions(-)

(limited to 'fig-bless/src/Fig/Bless/Syntax.hs')

diff --git a/fig-bless/src/Fig/Bless/Syntax.hs b/fig-bless/src/Fig/Bless/Syntax.hs
index b58c516..fc43917 100644
--- a/fig-bless/src/Fig/Bless/Syntax.hs
+++ b/fig-bless/src/Fig/Bless/Syntax.hs
@@ -27,8 +27,11 @@ import qualified Text.Megaparsec as P
 import qualified Text.Megaparsec.Char as P.C
 import qualified Text.Megaparsec.Char.Lexer as P.C.L
 
+import qualified Data.Aeson as Aeson
+
 newtype Word = Word Text
-  deriving (Show, Eq, Ord)
+  deriving (Show, Eq, Ord, Generic)
+instance Aeson.ToJSON Word
 instance IsString Word where
   fromString = Word . fromString
 instance Pretty Word where
@@ -38,14 +41,16 @@ data Literal
   = LiteralInteger Integer
   | LiteralDouble Double
   | LiteralString Text
-  deriving (Show, Eq, Ord)
+  deriving (Show, Eq, Ord, Generic)
+instance Aeson.ToJSON Literal
 instance Pretty Literal where
   pretty (LiteralInteger i) = tshow i
   pretty (LiteralDouble d) = tshow d
   pretty (LiteralString s) = tshow s
 
 newtype ProgramF t = Program [t]
-  deriving (Show, Eq, Ord, Functor)
+  deriving (Show, Eq, Ord, Generic, Functor)
+instance Aeson.ToJSON t => Aeson.ToJSON (ProgramF t)
 instance Pretty t => Pretty (ProgramF t) where
   pretty (Program ts) = unwords $ pretty <$> ts
 type Program = ProgramF (Fix TermF)
@@ -54,7 +59,8 @@ data TermF t
   = TermWord Word
   | TermLiteral Literal
   | TermQuote (ProgramF t)
-  deriving (Show, Eq, Ord, Functor)
+  deriving (Show, Eq, Ord, Generic, Functor)
+instance Aeson.ToJSON t => Aeson.ToJSON (TermF t)
 instance Pretty t => Pretty (TermF t) where
   pretty (TermWord w) = pretty w
   pretty (TermLiteral l) = pretty l
@@ -83,7 +89,7 @@ ws = P.C.L.space
   (P.C.L.skipBlockComment "/*" "*/")
 
 wordChar :: Char -> Bool
-wordChar c = not $ elem @[] c ['[', ']'] || isSpace c
+wordChar c = not $ elem @[] c ['[', ']', '=', ';'] || isSpace c
 word :: Parser Word
 word = Word . pack <$> P.some (P.satisfy wordChar)
 
@@ -133,8 +139,14 @@ dictionary :: Parser Dictionary
 dictionary = dictionaryF $ Fix <$> term
 
 newtype ParseError = ParseError (P.ParseErrorBundle Text Void)
-  deriving (Show)
+  deriving (Show, Generic)
 instance Exception ParseError
+instance Aeson.ToJSON ParseError where
+  toJSON (ParseError b) = Aeson.object
+    [ "errors" Aeson..= Aeson.toJSON (bimap P.parseErrorPretty P.sourcePosPretty <$> posed)
+    ]
+    where
+      (posed, _) = P.attachSourcePos P.errorOffset (P.bundleErrors b) (P.bundlePosState b)
 instance Pretty ParseError where
   pretty (ParseError b) = mconcat
     [ "failed to read program:\n"
@@ -146,7 +158,13 @@ data Spanning = Spanning
   , start :: P.SourcePos
   , end :: P.SourcePos
   }
-  deriving (Show, Eq, Ord)
+  deriving (Show, Eq, Ord, Generic)
+instance Aeson.ToJSON Spanning where
+  toJSON s = Aeson.object
+    [ "term" Aeson..= Aeson.toJSON s.t
+    , "start" Aeson..= pack (P.sourcePosPretty s.start)
+    , "end" Aeson..= pack (P.sourcePosPretty s.end)
+    ]
 instance Pretty Spanning where
   pretty s = mconcat
     [ pretty s.t, "\n"
-- 
cgit v1.2.3