summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--fig-bless/main/Main.hs37
-rw-r--r--fig-bless/src/Fig/Bless/Runtime.hs13
-rw-r--r--fig-bless/src/Fig/Bless/Syntax.hs32
-rw-r--r--fig-bless/src/Fig/Bless/TypeChecker.hs7
-rw-r--r--fig-bless/src/Fig/Bless/Types.hs8
-rw-r--r--fig-utils/fig-utils.cabal1
-rw-r--r--fig-utils/src/Fig/Prelude.hs9
7 files changed, 79 insertions, 28 deletions
diff --git a/fig-bless/main/Main.hs b/fig-bless/main/Main.hs
index ea9531d..c43bfc6 100644
--- a/fig-bless/main/Main.hs
+++ b/fig-bless/main/Main.hs
@@ -20,7 +20,7 @@ import qualified Fig.Bless.Syntax as Syn
data EvalOptions = EvalOptions
{ src :: Text
, fuel :: Maybe Integer
- }
+ } deriving Show
parseEvalOptions :: Parser EvalOptions
parseEvalOptions = do
@@ -30,7 +30,7 @@ parseEvalOptions = do
newtype TypeOptions = TypeOptions
{ src :: Text
- }
+ } deriving Show
parseTypeOptions :: Parser TypeOptions
parseTypeOptions = do
@@ -41,7 +41,7 @@ data DictionaryOptions = DictionaryOptions
{ path :: FilePath
, entrypoint :: Word
, fuel :: Maybe Integer
- }
+ } deriving Show
parseDictionaryOptions :: Parser DictionaryOptions
parseDictionaryOptions = do
@@ -54,6 +54,7 @@ data Command
= Eval EvalOptions
| Type TypeOptions
| Dict DictionaryOptions
+ deriving Show
parseCommand :: Parser Command
parseCommand = subparser $ mconcat
@@ -65,7 +66,7 @@ parseCommand = subparser $ mconcat
data Options = Options
{ cmd :: Command
, json :: Bool
- }
+ } deriving Show
parseOptions :: Parser Options
parseOptions = do
@@ -75,9 +76,23 @@ parseOptions = do
writeError :: (MonadIO m, Pretty e, Aeson.ToJSON e) => Options -> e -> m ()
writeError o e
- | o.json = liftIO . putStrLn . decodeUtf8 . B.L.toStrict $ Aeson.encode e
+ | o.json = liftIO . putStrLn . decodeUtf8 . B.L.toStrict . Aeson.encode $ Aeson.object
+ [ "status" Aeson..= ("error" :: Text)
+ , "data" Aeson..= Aeson.object
+ [ "structure" Aeson..= e
+ , "message" Aeson..= pretty e
+ ]
+ ]
| otherwise = liftIO . hPutStrLn stderr $ pretty e
+writeSuccess :: (MonadIO m, Pretty e, Aeson.ToJSON e) => Options -> e -> m ()
+writeSuccess o e
+ | o.json = liftIO . putStrLn . decodeUtf8 . B.L.toStrict . Aeson.encode $ Aeson.object
+ [ "status" Aeson..= ("success" :: Text)
+ , "data" Aeson..= e
+ ]
+ | otherwise = liftIO . putStrLn $ pretty e
+
main :: IO ()
main = do
opts <- execParser $ info (parseOptions <**> helper)
@@ -96,13 +111,13 @@ main = do
let
stack :: [ValueF Spanning (Fix (ValueF Spanning))]
stack = vm'.stack
- forM_ stack $ putStrLn . pretty
+ writeSuccess opts stack
Type to -> do
prog <- parse "<input>" (programF spanning <* eof) to.src
let ?term = Nothing
let ext = pure . unSpanning
ty <- typeOfProgram (initializeEnv ext builtins) prog
- putStrLn $ pretty ty
+ writeSuccess opts ty
Dict o -> do
src <- T.IO.readFile o.path
dict <- parse "<input>" (dictionaryF spanning <* eof) src
@@ -114,9 +129,9 @@ main = do
let
stack :: [ValueF Spanning (Fix (ValueF Spanning))]
stack = vm'.stack
- forM_ stack $ putStrLn . pretty
+ writeSuccess opts stack
)
- [ Handler \(e :: Syn.ParseError) -> hPutStrLn stderr $ pretty e
- , Handler \(e :: RuntimeError Spanning) -> hPutStrLn stderr $ pretty e
- , Handler \(e :: TypeError Spanning) -> hPutStrLn stderr $ pretty e
+ [ Handler \(e :: Syn.ParseError) -> writeError opts e
+ , Handler \(e :: RuntimeError Spanning) -> writeError opts e
+ , Handler \(e :: TypeError Spanning) -> writeError opts e
]
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)
diff --git a/fig-utils/fig-utils.cabal b/fig-utils/fig-utils.cabal
index 9bb115d..e5bc2c9 100644
--- a/fig-utils/fig-utils.cabal
+++ b/fig-utils/fig-utils.cabal
@@ -17,6 +17,7 @@ library
Fig.Utils.SExpr
build-depends:
base
+ , aeson
, binary
, bytestring
, containers
diff --git a/fig-utils/src/Fig/Prelude.hs b/fig-utils/src/Fig/Prelude.hs
index 85a3ab3..80e5829 100644
--- a/fig-utils/src/Fig/Prelude.hs
+++ b/fig-utils/src/Fig/Prelude.hs
@@ -65,7 +65,7 @@ import Data.Void (Void)
import Data.Bool (Bool(..), otherwise, not, (&&), (||))
import Data.Char (Char, isUpper)
import Data.Int (Int)
-import Data.Text (Text, pack, unpack, unwords)
+import Data.Text (Text, pack, unpack, unwords, unlines)
import Data.Text.IO (hPutStrLn)
import Data.Text.Encoding (decodeUtf8, decodeUtf8', encodeUtf8)
import Data.ByteString (ByteString, readFile, writeFile)
@@ -95,6 +95,8 @@ import Control.Monad.State.Class (MonadState(..), get, put, modify)
import Control.Monad.Reader.Class (MonadReader(..), ask)
import Control.Exception.Safe (Exception, SomeException, IOException, MonadThrow, MonadCatch, MonadMask, throwM, try, catch, catchIO, bracket, bracketOnError)
+import qualified Data.Aeson as Aeson
+
tshow :: Show a => a -> Text
tshow = pack . show
@@ -123,6 +125,9 @@ class Pretty a where
instance Pretty Void where
pretty _ = ""
+instance Pretty a => Pretty [a] where
+ pretty xs = unlines $ pretty <$> xs
+
newtype Fix f = Fix { unFix :: f (Fix f) }
unFix :: Fix f -> f (Fix f)
unFix (Fix x) = x
@@ -130,3 +135,5 @@ instance Pretty (f (Fix f)) => Pretty (Fix f) where
pretty (Fix x) = pretty x
instance Show (f (Fix f)) => Show (Fix f) where
show (Fix x) = show x
+instance Aeson.ToJSON (f (Fix f)) => Aeson.ToJSON (Fix f) where
+ toJSON (Fix x) = Aeson.toJSON x
generated by cgit v1.2.3 (git 2.25.1) at 2026-05-09 13:37:10 +0000