Support JSON output

4 files changed, 44 insertions, 16 deletions

diff --git a/fig-bless/src/Fig/Bless/Runtime.hs b/fig-bless/src/Fig/Bless/Runtime.hs
index cc19437..cbef849 100644
--- a/fig-bless/src/Fig/Bless/Runtime.hs
+++ b/fig-bless/src/Fig/Bless/Runtime.hs
@@ -19,6 +19,8 @@ import qualified Data.Text as Text
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 
+import qualified Data.Aeson as Aeson
+
 import Fig.Bless.Types
 import qualified Fig.Bless.Syntax as Syn
 
@@ -28,7 +30,8 @@ data ValueF t v
   | ValueString Text
   | ValueProgram (Syn.ProgramF t)
   | ValueArray [v]
-  deriving (Show, Eq, Ord)
+  deriving (Show, Eq, Ord, Generic)
+instance (Aeson.ToJSON t, Aeson.ToJSON v) => Aeson.ToJSON (ValueF t v)
 instance (Pretty t, Pretty v) => Pretty (ValueF t v) where
   pretty (ValueInteger i) = tshow i
   pretty (ValueDouble d) = tshow d
@@ -48,7 +51,8 @@ data ValueSort
   | ValueSortWord
   | ValueSortProgram
   | ValueSortArray
-  deriving (Show, Eq, Ord)
+  deriving (Show, Eq, Ord, Generic)
+instance Aeson.ToJSON ValueSort
 instance Pretty ValueSort where
   pretty ValueSortInteger = "integer"
   pretty ValueSortDouble = "double"
@@ -56,7 +60,6 @@ instance Pretty ValueSort where
   pretty ValueSortWord = "word"
   pretty ValueSortProgram = "program"
   pretty ValueSortArray = "list"
-
 valueSort :: ValueF t v -> ValueSort
 valueSort (ValueInteger _) = ValueSortInteger
 valueSort (ValueDouble _) = ValueSortDouble
@@ -69,14 +72,14 @@ data RuntimeError t
   | RuntimeErrorOutOfFuel (Maybe t)
   | RuntimeErrorStackUnderflow (Maybe t)
   | RuntimeErrorSortMismatch (Maybe t) ValueSort ValueSort
-  deriving (Show, Eq, Ord)
+  deriving (Show, Eq, Ord, Generic)
 instance (Show t, Typeable t) => Exception (RuntimeError t)
+instance Aeson.ToJSON t => Aeson.ToJSON (RuntimeError t)
 runtimeErrorPrefix :: Pretty t => Maybe t -> Text
 runtimeErrorPrefix Nothing = ""
 runtimeErrorPrefix (Just t) = mconcat
   [ "while evaluating term: ", pretty t, "\n"
   ]
-
 instance Pretty t => Pretty (RuntimeError t) where
   pretty (RuntimeErrorWordNotFound t w) = mconcat
     [ runtimeErrorPrefix t
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"
diff --git a/fig-bless/src/Fig/Bless/TypeChecker.hs b/fig-bless/src/Fig/Bless/TypeChecker.hs
index dedc66a..0ee8eaf 100644
--- a/fig-bless/src/Fig/Bless/TypeChecker.hs
+++ b/fig-bless/src/Fig/Bless/TypeChecker.hs
@@ -10,6 +10,8 @@ import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
 
+import qualified Data.Aeson as Aeson
+
 import Fig.Bless.Syntax
 import Fig.Bless.Types
 import Fig.Bless.Runtime
@@ -23,8 +25,9 @@ data TypeError t
   = TypeErrorWordNotFound (Maybe t) Word
   | TypeErrorMismatch (Maybe t) BType BType
   | TypeErrorArityMismatch (Maybe t) BProgType BProgType
-  deriving (Show, Eq, Ord)
+  deriving (Show, Eq, Ord, Generic)
 instance (Show t, Typeable t) => Exception (TypeError t)
+instance Aeson.ToJSON t => Aeson.ToJSON (TypeError t)
 typeErrorPrefix :: Pretty t => Maybe t -> Text
 typeErrorPrefix Nothing = ""
 typeErrorPrefix (Just t) = mconcat
@@ -142,4 +145,4 @@ checkDictionary env d = foldM
         }
   )
   env
-  (reverse d.defs)
+  d.defs
diff --git a/fig-bless/src/Fig/Bless/Types.hs b/fig-bless/src/Fig/Bless/Types.hs
index 162358c..ae8d9d4 100644
--- a/fig-bless/src/Fig/Bless/Types.hs
+++ b/fig-bless/src/Fig/Bless/Types.hs
@@ -7,13 +7,16 @@ import qualified Data.Map.Strict as Map
 import Data.Set (Set)
 import qualified Data.Set as Set
 
+import qualified Data.Aeson as Aeson
+
 data BType
   = BTypeVariable Text
   | BTypeInteger
   | BTypeDouble
   | BTypeString
   | BTypeProgram BProgType
-  deriving (Show, Eq, Ord)
+  deriving (Show, Eq, Ord, Generic)
+instance Aeson.ToJSON BType
 instance Pretty BType where
   pretty (BTypeVariable s) = "!" <> s
   pretty BTypeInteger = "integer"
@@ -25,7 +28,8 @@ data BProgType = BProgType
   { inp :: [BType]
   , out :: [BType]
   }
-  deriving (Show, Eq, Ord)
+  deriving (Show, Eq, Ord, Generic)
+instance Aeson.ToJSON BProgType
 instance Pretty BProgType where
   pretty p = unwords (pretty <$> p.inp) <> " -- " <> unwords (pretty <$> p.out)