Skip to content

Commit 95b8e33

Browse files
FLOWleplusbeauFLOWleplusbeau
committed
feat: better cli
1 parent f4c625b commit 95b8e33

File tree

1 file changed

+116
-101
lines changed

1 file changed

+116
-101
lines changed

‎app/Main.hs‎

Lines changed: 116 additions & 101 deletions
Original file line numberDiff line numberDiff line change
@@ -7,45 +7,53 @@
77

88
module Main (main) where
99

10+
import AST
11+
import Compiler
1012
import Control.Exception (IOException, SomeException, try)
1113
import Control.Monad (foldM)
14+
import Data.Char (isSpace)
1215
import qualified Data.Map as Map
1316
import qualified Data.Vector as Vector
14-
import System.Environment (getArgs)
15-
import System.Exit (ExitCode (ExitFailure, ExitSuccess), exitSuccess, exitWith)
16-
import System.IO (hFlush, hIsTerminalDevice, hPutStrLn, isEOF, stderr, stdin, stdout)
17-
import Data.Char (isSpace)
18-
19-
import AST
20-
import Compiler
2117
import Desugar
2218
import Disasm
2319
import SExprParser
20+
import System.Environment (getArgs)
21+
import System.Exit (ExitCode (ExitFailure, ExitSuccess), exitSuccess, exitWith)
22+
import System.FilePath (takeExtension)
23+
import System.IO (hFlush, hIsTerminalDevice, hPutStrLn, isEOF, stderr, stdin, stdout)
2424
import TopineurParser
2525
import VM
26-
import System.FilePath (takeExtension)
2726

2827
main :: IO ()
2928
main = do
3029
args <- getArgs
3130
let (noCache, restArgs) = parseFlags args
32-
config = defaultConfig { cfgUseCache = not noCache }
31+
config = defaultConfig {cfgUseCache = not noCache}
3332
case restArgs of
3433
[] -> repl
3534
["--help"] -> printHelp
35+
["-h"] -> printHelp
3636
["--disasm", file] -> disasmFile config file
37+
["-d", file] -> disasmFile config file
3738
["--ast", file] -> showAst file
39+
["-a", file] -> showAst file
3840
["--compiled", file] -> showCompiled config file
41+
["-c", file] -> showCompiled config file
3942
["--bytecode", file] -> showBytecode config file
43+
["-b", file] -> showBytecode config file
4044
["--parse-top", file] -> parseTopineurFile file
41-
["--version"] -> putStrLn "GLaDOS version 1.0.0\nThe Topineur and Lisp compiler."
45+
["-p", file] -> parseTopineurFile file
46+
["--version"] -> version
47+
["-v"] -> version
4248
[file] -> runFile config file
4349
_ ->
4450
exitWithError "Invalid arguments. Use --help for usage."
4551
where
4652
parseFlags :: [String] -> (Bool, [String])
4753
parseFlags xs = ("--no-cache" `elem` xs, filter (/= "--no-cache") xs)
4854

55+
version = putStrLn "GLaDOS version 1.0.0\nThe Topineur and Lisp compiler."
56+
4957
exitWithError :: String -> IO a
5058
exitWithError msg =
5159
hPutStrLn stderr ("[ERROR] : " ++ msg)
@@ -67,21 +75,23 @@ renderValue VUnit = "#<void>"
6775
renderValue (VList values) = "(" ++ unwords (map renderValue values) ++ ")"
6876
renderValue (VTuple values) = "#(" ++ unwords (map renderValue values) ++ ")"
6977
renderValue (VObject name fields) =
70-
"#<object:" ++ name ++ " {" ++
71-
intercalate ", " (map (\(k, v) -> k ++ ": " ++ renderValue v) fields) ++
72-
"}>"
78+
"#<object:"
79+
++ name
80+
++ " {"
81+
++ intercalate ", " (map (\(k, v) -> k ++ ": " ++ renderValue v) fields)
82+
++ "}>"
7383
where
7484
intercalate _ [] = ""
7585
intercalate _ [x] = x
76-
intercalate sep (x:xs) = x ++ sep ++ intercalate sep xs
86+
intercalate sep (x : xs) = x ++ sep ++ intercalate sep xs
7787

7888
runProgram :: String -> IO (Either String Value)
7989
runProgram source =
8090
case compileWithDefs defaultConfig source of
8191
Left err -> return $ Left (formatCompileError err)
8292
Right (code, defs) -> do
8393
let allCodeObjects = Map.insert "main" code defs
84-
initialVmState = initVMState { vCodeObjects = allCodeObjects }
94+
initialVmState = initVMState {vCodeObjects = allCodeObjects}
8595
vmState <- initializeGlobals initialVmState defs
8696
execResult <- try (execVM vmState code) :: IO (Either SomeException (Either VMError Value))
8797
case execResult of
@@ -92,34 +102,35 @@ runProgram source =
92102
initializeGlobals :: VMState -> Map.Map Name CodeObject -> IO VMState
93103
initializeGlobals vmState defs =
94104
foldM
95-
(\state (name, codeObj) ->
96-
if coArity codeObj == 0
97-
then do
98-
result <- execVM state codeObj
99-
case result of
100-
Right val ->
101-
return $ state { vGlobals = Map.insert name val (vGlobals state) }
102-
Left _err -> return state
103-
else return state)
105+
( \state (name, codeObj) ->
106+
if coArity codeObj == 0
107+
then do
108+
result <- execVM state codeObj
109+
case result of
110+
Right val ->
111+
return $ state {vGlobals = Map.insert name val (vGlobals state)}
112+
Left _err -> return state
113+
else return state
114+
)
104115
vmState
105116
(Map.toList defs)
106117

107118
runProgramWithSource :: CompilerConfig -> String -> String -> IO (Either String Value)
108119
runProgramWithSource config source filePath =
109120
let isTopineur = takeExtension filePath == ".top"
110-
in if isTopineur
111-
then do
112-
compileResult <- compileTopineurFile config filePath
113-
case compileResult of
121+
in if isTopineur
122+
then do
123+
compileResult <- compileTopineurFile config filePath
124+
case compileResult of
125+
Left err -> return $ Left (formatCompileError err)
126+
Right (code, defs) -> execute code defs
127+
else case compileWithDefs config source of
114128
Left err -> return $ Left (formatCompileError err)
115129
Right (code, defs) -> execute code defs
116-
else case compileWithDefs config source of
117-
Left err -> return $ Left (formatCompileError err)
118-
Right (code, defs) -> execute code defs
119130
where
120131
execute code defs = do
121132
let allCodeObjects = Map.insert "main" code defs
122-
initialVmState = initVMState { vCodeObjects = allCodeObjects }
133+
initialVmState = initVMState {vCodeObjects = allCodeObjects}
123134
vmState <- initializeGlobals initialVmState defs
124135
execResult <- try (execVM vmState code) :: IO (Either SomeException (Either VMError Value))
125136
case execResult of
@@ -131,29 +142,30 @@ printHelp :: IO ()
131142
printHelp =
132143
mapM_
133144
putStrLn
134-
[ "GLaDOS - A LISP and Topineur compiler and VM"
135-
, ""
136-
, "Usage:"
137-
, " ./glados [file] Compile and run a LISP file"
138-
, " ./glados --disasm [file] Disassemble a LISP file"
139-
, " ./glados --ast [file] Show AST of a LISP file"
140-
, " ./glados --compiled [file] Show compiled code of a LISP file"
141-
, " ./glados --bytecode [file] Show bytecode instructions of a LISP file"
142-
, " ./glados --parse-top [file] Show parsed structure of a Topineur file"
143-
, " ./glados Start REPL (interactive mode)"
144-
, " ./glados --help Show this help message"
145-
, ""
146-
, "Options:"
147-
, " --no-cache Disable bytecode cache (.topo files)"
148-
, ""
149-
, "Examples:"
150-
, " ./glados program.lisp"
151-
, " ./glados program.top"
152-
, " ./glados --no-cache program.top"
153-
, " ./glados --disasm program.lisp"
154-
, " ./glados --ast program.lisp"
155-
, " ./glados --compiled program.lisp"
156-
, " ./glados --parse-topineur program.top"
145+
[ "GLaDOS - A LISP and Topineur compiler and VM",
146+
"",
147+
"Usage:",
148+
" ./glados [file] Compile and run a TOPINEUR or LISP file",
149+
" ./glados -d|--disasm [file] Disassemble a TOPINEUR or LISP file",
150+
" ./glados -a|--ast [file] Show AST of a TOPINEUR or LISP file",
151+
" ./glados -c|--compiled [file] Show compiled code of a TOPINEUR or LISP file",
152+
" ./glados -b|--bytecode [file] Show bytecode instructions of a TOPINEUR or LISP file",
153+
" ./glados -p|--parse-top [file] Show parsed structure of a Topineur file",
154+
" ./glados Start REPL (interactive mode)",
155+
" ./glados -h|--help Show this help message",
156+
" ./glados -v|--version Show version information",
157+
"",
158+
"Options:",
159+
" --no-cache Disable bytecode cache (.topo files)",
160+
"",
161+
"Examples:",
162+
" ./glados program.lisp",
163+
" ./glados program.top",
164+
" ./glados --no-cache program.top",
165+
" ./glados -d program.lisp",
166+
" ./glados -a program.lisp",
167+
" ./glados -c program.lisp",
168+
" ./glados -p program.top"
157169
]
158170

159171
runFile :: CompilerConfig -> FilePath -> IO ()
@@ -178,7 +190,7 @@ valueToExitCode (VInt n)
178190
| n == 0 = ExitSuccess
179191
| otherwise = ExitFailure (fromInteger n)
180192
valueToExitCode VUnit = ExitSuccess
181-
valueToExitCode _ = ExitSuccess -- Default to success for other types
193+
valueToExitCode _ = ExitSuccess -- Default to success for other types
182194

183195
disasmFile :: CompilerConfig -> FilePath -> IO ()
184196
disasmFile config file = do
@@ -197,24 +209,25 @@ disasmFile config file = do
197209
>> dumpCodeObject code
198210
>> putStrLn "\n=== Nested Definitions ==="
199211
>> mapM_
200-
(\(name, obj) ->
201-
putStrLn ("\n--- " ++ name ++ " ---")
202-
>> dumpCodeObject obj)
212+
( \(name, obj) ->
213+
putStrLn ("\n--- " ++ name ++ " ---")
214+
>> dumpCodeObject obj
215+
)
203216
(Map.toList defs)
204217
>> exitSuccess
205-
else
206-
case compileWithDefs config source of
207-
Left err -> exitWithError (formatCompileError err)
208-
Right (code, defs) ->
209-
putStrLn "=== Main Code ==="
210-
>> dumpCodeObject code
211-
>> putStrLn "\n=== Nested Definitions ==="
212-
>> mapM_
213-
(\(name, obj) ->
218+
else case compileWithDefs config source of
219+
Left err -> exitWithError (formatCompileError err)
220+
Right (code, defs) ->
221+
putStrLn "=== Main Code ==="
222+
>> dumpCodeObject code
223+
>> putStrLn "\n=== Nested Definitions ==="
224+
>> mapM_
225+
( \(name, obj) ->
214226
putStrLn ("\n--- " ++ name ++ " ---")
215-
>> dumpCodeObject obj)
216-
(Map.toList defs)
217-
>> exitSuccess
227+
>> dumpCodeObject obj
228+
)
229+
(Map.toList defs)
230+
>> exitSuccess
218231

219232
showAst :: FilePath -> IO ()
220233
showAst file = do
@@ -249,24 +262,25 @@ showCompiled config file = do
249262
>> dumpCodeInfo code
250263
>> putStrLn "\n=== Nested Definitions ==="
251264
>> mapM_
252-
(\(name, obj) ->
253-
putStrLn ("\n--- " ++ name ++ " ---")
254-
>> dumpCodeInfo obj)
265+
( \(name, obj) ->
266+
putStrLn ("\n--- " ++ name ++ " ---")
267+
>> dumpCodeInfo obj
268+
)
255269
(Map.toList defs)
256270
>> exitSuccess
257-
else
258-
case compileWithDefs config source of
259-
Left err -> exitWithError (formatCompileError err)
260-
Right (code, defs) ->
261-
putStrLn "=== Main Code ==="
262-
>> dumpCodeInfo code
263-
>> putStrLn "\n=== Nested Definitions ==="
264-
>> mapM_
265-
(\(name, obj) ->
271+
else case compileWithDefs config source of
272+
Left err -> exitWithError (formatCompileError err)
273+
Right (code, defs) ->
274+
putStrLn "=== Main Code ==="
275+
>> dumpCodeInfo code
276+
>> putStrLn "\n=== Nested Definitions ==="
277+
>> mapM_
278+
( \(name, obj) ->
266279
putStrLn ("\n--- " ++ name ++ " ---")
267-
>> dumpCodeInfo obj)
268-
(Map.toList defs)
269-
>> exitSuccess
280+
>> dumpCodeInfo obj
281+
)
282+
(Map.toList defs)
283+
>> exitSuccess
270284

271285
showBytecode :: CompilerConfig -> FilePath -> IO ()
272286
showBytecode config file = do
@@ -285,24 +299,25 @@ showBytecode config file = do
285299
>> dumpBytecode code
286300
>> putStrLn "\n=== Nested Definitions ==="
287301
>> mapM_
288-
(\(name, obj) ->
289-
putStrLn ("\n--- " ++ name ++ " ---")
290-
>> dumpBytecode obj)
302+
( \(name, obj) ->
303+
putStrLn ("\n--- " ++ name ++ " ---")
304+
>> dumpBytecode obj
305+
)
291306
(Map.toList defs)
292307
>> exitSuccess
293-
else
294-
case compileWithDefs config source of
295-
Left err -> exitWithError (formatCompileError err)
296-
Right (code, defs) ->
297-
putStrLn "=== Main Bytecode ==="
298-
>> dumpBytecode code
299-
>> putStrLn "\n=== Nested Definitions ==="
300-
>> mapM_
301-
(\(name, obj) ->
308+
else case compileWithDefs config source of
309+
Left err -> exitWithError (formatCompileError err)
310+
Right (code, defs) ->
311+
putStrLn "=== Main Bytecode ==="
312+
>> dumpBytecode code
313+
>> putStrLn "\n=== Nested Definitions ==="
314+
>> mapM_
315+
( \(name, obj) ->
302316
putStrLn ("\n--- " ++ name ++ " ---")
303-
>> dumpBytecode obj)
304-
(Map.toList defs)
305-
>> exitSuccess
317+
>> dumpBytecode obj
318+
)
319+
(Map.toList defs)
320+
>> exitSuccess
306321

307322
parseTopineurFile :: FilePath -> IO ()
308323
parseTopineurFile file = do

0 commit comments

Comments
 (0)