1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
|
{-# Language ApplicativeDo, ImplicitParams #-}
module Main where
import Fig.Prelude
import Options.Applicative
import Control.Exception.Safe (Handler(..), catches)
import Data.Text.IO (putStr, putStrLn)
import qualified Data.Text.IO as T.IO
import qualified Data.ByteString.Lazy as B.L
import qualified Data.Aeson as Aeson
import Fig.Bless
import qualified Fig.Bless.Syntax as Syn
data EvalOptions = EvalOptions
{ src :: Text
, fuel :: Maybe Integer
} deriving Show
parseEvalOptions :: Parser EvalOptions
parseEvalOptions = do
fuel <- optional $ option auto (long "fuel" <> short 'f' <> metavar "N" <> help "Maximum number of terms to run")
src <- unwords <$> some (argument str (metavar "TERM..."))
pure EvalOptions{..}
newtype TypeOptions = TypeOptions
{ src :: Text
} deriving Show
parseTypeOptions :: Parser TypeOptions
parseTypeOptions = do
src <- unwords <$> some (argument str (metavar "TERM..."))
pure TypeOptions{..}
data DictionaryOptions = DictionaryOptions
{ path :: FilePath
, entrypoint :: Word
, fuel :: Maybe Integer
} deriving Show
parseDictionaryOptions :: Parser DictionaryOptions
parseDictionaryOptions = do
fuel <- optional $ option auto (long "fuel" <> short 'f' <> metavar "N" <> help "Maximum number of terms to run")
entrypoint <- fmap (fromMaybe "main") . optional $ strOption (long "entrypoint" <> short 'e' <> metavar "WORD" <> help "Word to evaluate")
path <- argument str (metavar "PATH")
pure DictionaryOptions{..}
data Command
= Eval EvalOptions
| Type TypeOptions
| Dict DictionaryOptions
deriving Show
parseCommand :: Parser Command
parseCommand = subparser $ mconcat
[ command "eval" $ info (Eval <$> parseEvalOptions) (progDesc "Evaluate a Bless program")
, command "type" $ info (Type <$> parseTypeOptions) (progDesc "Check the type of a Bless program")
, command "dictionary" $ info (Dict <$> parseDictionaryOptions) (progDesc "Load and run a Bless dictionary")
]
data Options = Options
{ cmd :: Command
, json :: Bool
} deriving Show
parseOptions :: Parser Options
parseOptions = do
json <- flag False True (long "json" <> short 'j' <> help "Write output as JSON")
cmd <- parseCommand
pure Options{..}
writeError :: (MonadIO m, Pretty e, Aeson.ToJSON e) => Options -> e -> m ()
writeError o 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
writeEval :: (MonadIO m, Pretty t, Aeson.ToJSON t) => Options -> [ValueF t] -> [EffectF t] -> m ()
writeEval o st ef
| o.json = liftIO . putStrLn . decodeUtf8 . B.L.toStrict . Aeson.encode $ Aeson.object
[ "status" Aeson..= ("success" :: Text)
, "data" Aeson..= Aeson.object
[ "stack" Aeson..= st
, "effects" Aeson..= reverse ef
]
]
| otherwise = do
liftIO . putStr $ "Stack:\n" <> pretty st
liftIO . putStr $ "Effects:\n" <> pretty (reverse ef)
writeType :: (MonadIO m, Pretty e, Aeson.ToJSON e) => Options -> e -> m ()
writeType o t
| o.json = liftIO . putStrLn . decodeUtf8 . B.L.toStrict . Aeson.encode $ Aeson.object
[ "status" Aeson..= ("error" :: Text)
, "data" Aeson..= t
]
| otherwise = liftIO . hPutStrLn stderr $ pretty t
main :: IO ()
main = do
opts <- execParser $ info (parseOptions <**> helper)
( fullDesc
<> header "fig-bless - tools for the Bless language"
)
catches
( case opts.cmd of
Eval eo -> do
prog <- parse "<input>" (programF spanning <* eof) eo.src
let ?term = Nothing
let ext = pure . unSpanning
_ty <- typeOfProgram (initializeEnv ext builtins) prog
let vm = initialize eo.fuel (Dictionary mempty) builtins
vm' <- runProgram ext prog vm
writeEval opts vm'.stack vm'.effects
Type to -> do
prog <- parse "<input>" (programF spanning <* eof) to.src
let ?term = Nothing
let ext = pure . unSpanning
ty <- typeOfProgram (initializeEnv ext builtins) prog
writeType opts ty
Dict o -> do
src <- T.IO.readFile o.path
dict <- parse "<input>" (dictionaryF spanning <* eof) src
let ?term = Nothing
let ext = pure . unSpanning
_env <- checkDictionary (initializeEnv ext builtins) dict
let vm = initialize o.fuel dict builtins
vm' <- runWord ext o.entrypoint vm
writeEval opts vm'.stack vm'.effects
)
[ Handler \(e :: Syn.ParseError) -> writeError opts e
, Handler \(e :: RuntimeError Spanning) -> writeError opts e
, Handler \(e :: TypeError Spanning) -> writeError opts e
]
|
