This repository has been archived by the owner on Feb 3, 2021. It is now read-only.
forked from audreyt/Pugs.hs
/
Pugs.hs
481 lines (430 loc) · 16.8 KB
/
Pugs.hs
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
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
{-# OPTIONS_GHC -fglasgow-exts -fallow-overlapping-instances -fffi #-}
{-|
Public API for the Pugs system.
> Dance all ye joyful, now dance all together!
> Soft is the grass, and let foot be like feather!
> The river is silver, the shadows are fleeting;
> Merry is May-time, and merry our meeting.
-}
module Pugs (
module Pugs,
Command(..),
banner,
liftSTM,
printCommandLineHelp,
intro,
initializeShell,
getCommand,
pretty,
printInteractiveHelp,
) where
import Pugs.AST
import Pugs.CodeGen
import Pugs.Config
import Pugs.Embed
import Pugs.Eval
import Pugs.External
import Pugs.Help
import Pugs.Internals
import Pugs.Monads
import Pugs.Parser.Program
import Pugs.Pretty
import Pugs.Run
import Pugs.Shell
import Pugs.Types
import Data.IORef
import qualified Data.Map as Map
import qualified System.FilePath as FilePath (combine, splitFileName)
import Control.Timeout
import Control.Exception (SomeException)
{-|
The entry point of Pugs. Uses 'Pugs.Run.runWithArgs' to normalise the command-line
arguments and pass them to 'run'.
-}
pugsMain :: IO ()
pugsMain = do
let ?debugInfo = Nothing
timeout <- getEnv "PUGS_TIMEOUT"
case timeout of
Just str | [(t, _)] <- reads str -> do
addTimeout t (hPutStrLn stderr "*** TIMEOUT" >> _exit 1)
return ()
_ -> return ()
mainWith run
foreign import ccall unsafe _exit :: Int -> IO ()
defaultProgramName :: String
defaultProgramName = "<interactive>"
runFile :: String -> IO ()
runFile file = do
withArgs [file] pugsMain
run :: [String] -> IO ()
run xs = let ?debugInfo = Nothing in run' xs
-- see also Run/Args.hs
run' :: (?debugInfo :: DebugInfo) => [String] -> IO ()
run' ("-d":rest) = do
info <- newDebugInfo
let ?debugInfo = info
run' rest
run' ("-l":rest) = run' rest
run' ("-w":rest) = run' rest
run' ("-I":_:rest) = run' rest
-- XXX should raise an error here:
-- run ("-I":[]) = do
-- print "Empty -I"
run' ("-h":_) = printCommandLineHelp
run' ("-V":_) = printConfigInfo []
run' ("-V:":item:_) = printConfigInfo [item]
run' ("-v":_) = banner
-- turn :file: and "-e":frag into a common subroutine/token
run' ("-c":"-e":prog:_) = doCheck "-e" prog
run' ("-c":file:_) = readFile file >>= doCheck file
-- -CPIL1.Perl5 outputs PIL formatted as Perl 5.
run' ("-C":backend:args) | (== map toLower backend) `any` ["js","perl5","js-perl5"] = do
exec <- getArg0
doHelperRun backend ("--compile-only":("--pugs="++exec):args)
run' ("-C":backend:"-e":prog:_) = doCompileDump backend "-e" prog
run' ("-C":backend:file:_) = readFile file >>= doCompileDump backend file
run' ("-B":backend:_) | (== map toLower backend) `any` ["js","perl5","js-perl5","redsix"] = do
exec <- getArg0
args <- getArgs
doHelperRun backend (("--pugs="++exec):args)
run' ("-B":backend:"-e":prog:_) = doCompileRun backend "-e" prog
run' ("-B":backend:file:_) = readFile file >>= doCompileRun backend file
run' ("--external":mod:"-e":prog:_) = doExternal mod "-e" prog
run' ("--external":mod:file:_) = readFile file >>= doExternal mod file
run' ("-e":prog:args) = do doRun "-e" args prog
-- -E is like -e, but not accessible as a normal parameter and used only
-- internally:
-- "-e foo bar.pl" executes "foo" with @*ARGS[0] eq "bar.pl",
-- "-E foo bar.pl" executes "foo" and then bar.pl.
-- XXX - Wrong -- Need to preserve environment across -E runs
run' ("-E":prog:rest) = run' ("-e":prog:[]) >> run' rest
run' ("-":args) = do doRun "-" args =<< readStdin
run' (file:args) = readFile file >>= doRun file args
run' [] = do
isTTY <- hIsTerminalDevice stdin
if isTTY
then do banner >> intro >> repLoop
else run' ["-"]
readStdin :: IO String
readStdin = do
eof <- isEOF
if eof then return [] else do
ch <- getChar
rest <- readStdin
return (ch:rest)
repLoop :: IO ()
repLoop = initializeShell $ do
tvEnv <- io . newTVarIO . noEnvDebug =<< io (tabulaRasa defaultProgramName)
fix $ \loop -> do
command <- getCommand
let parseEnv f prog = do
env <- stm (readTVar tvEnv)
doParse env f defaultProgramName prog
resetEnv = do
env <- fmap noEnvDebug (tabulaRasa defaultProgramName)
stm (writeTVar tvEnv env)
if command == CmdQuit then io $ putStrLn "Leaving pugs." else do
io $ case command of
CmdLoad fn -> doLoad tvEnv fn
CmdRun opts prog -> doRunSingle tvEnv opts prog
CmdParse prog -> parseEnv pretty prog
CmdParseRaw prog -> parseEnv show prog
CmdHelp -> printInteractiveHelp
CmdReset -> resetEnv
_ -> return ()
loop
mainWith :: ([String] -> IO a) -> IO ()
mainWith run = do
hSetBuffering stdout LineBuffering
-- when (isJust _DoCompile) $ do
-- writeIORef (fromJust _DoCompile) doCompile
runWithArgs run
globalFinalize
-- convenience functions for GHCi
eval :: String -> IO ()
eval prog = do
args <- getArgs
runProgramWith id (putStrLn . encodeUTF8 . pretty) defaultProgramName args (encodeUTF8 prog)
parse :: String -> IO ()
parse prog = do
env <- tabulaRasa defaultProgramName
doParse env (encodeUTF8 . pretty) "-" (encodeUTF8 prog)
dump :: String -> IO ()
dump = (doParseWith $ \env _ -> print $ envBody env) "-"
globalFinalize :: IO ()
globalFinalize = join $ readIORef _GlobalFinalizer
dumpGlob :: String -> IO ()
dumpGlob = (doParseWith $ \env _ -> do
glob <- stm . readMPad $ envGlobal env
print $ filterUserDefinedPad glob) "-"
{-|
Create a \'blank\' 'Env' for our program to execute in. Of course,
'prepareEnv' actually declares quite a few symbols in the environment,
e.g. \'\@\*ARGS\', \'\$\*PID\', \'\$\*ERR\' etc.
('Tabula rasa' is Latin for 'a blank slate'.)
-}
tabulaRasa :: String -> IO Env
tabulaRasa name = prepareEnv name []
doCheck :: FilePath -> String -> IO ()
doCheck = doParseWith $ \_ name -> do
putStrLn $ name ++ " syntax OK"
doExternal :: String -> FilePath -> String -> IO ()
doExternal mod = doParseWith $ \env _ -> do
str <- externalize mod $ envBody env
putStrLn str
doCompile :: String -> FilePath -> String -> IO String
doCompile backend = doParseWith $ \env file -> do
globRef <- stm $ do
glob <- readMPad $ envGlobal env
newMPad $ filterUserDefinedPad glob
codeGen backend file env{ envGlobal = globRef }
initCompile :: IO ()
initCompile = do
compPrelude <- getEnv "PUGS_COMPILE_PRELUDE"
let bypass = case compPrelude of
Nothing -> True
Just "" -> True
Just "0" -> True
_ -> False
setEnv "PUGS_COMPILE_PRELUDE" (if bypass then "0" else "") True
doCompileDump :: String -> FilePath -> String -> IO ()
doCompileDump backend file prog = do
initCompile
str <- doCompile backend' file prog
putStr str
where
backend' = capitalizeWord backend
capitalizeWord [] = []
capitalizeWord (c:cs) = toUpper c:(map toLower cs)
doCompileRun :: String -> FilePath -> String -> IO ()
doCompileRun backend file prog = do
initCompile
str <- doCompile backend' file prog
evalEmbedded backend' str
where
backend' = capitalizeWord backend
capitalizeWord [] = []
capitalizeWord (c:cs) = toUpper c:(map toLower cs)
doHelperRun :: String -> [String] -> IO ()
doHelperRun backend args =
case map toLower backend of
"js" -> if (args' == [])
then (doExecuteHelper "jspugs.pl" args)
else (doExecuteHelper "runjs.pl" args)
"perl5" -> doExecuteHelper "v6.pm" args
"js-perl5" -> doExecuteHelper "runjs.pl" (jsPerl5Args ++ args)
"redsix" -> doExecuteHelper "redsix" args
_ -> fail ("unknown backend: " ++ backend)
where
args' = f args
jsPerl5Args = words "--run=jspm --perl5"
f [] = []
f (bjs:rest) | "-BJS" `isPrefixOf` map toUpper bjs = f rest
f ("-B":js:rest) | "JS" `isPrefixOf` map toUpper js = f rest
f (pugspath:rest) | "--pugs=" `isPrefixOf` pugspath = f rest
f (x:xs) = x:f xs
doExecuteHelper :: FilePath -> [String] -> IO ()
doExecuteHelper helper args = do
let searchPaths = concatMap (\x -> map (x++) suffixes) [["."], ["..", ".."], [getConfig "sourcedir"], [getConfig "sourcedir", "blib6", "pugs"], [getConfig "privlib", "auto", "pugs"], [getConfig "sitelib", "auto", "pugs"]]
mbin <- runMaybeT (findHelper searchPaths)
case mbin of
Just binary -> do
let (p, _) = FilePath.splitFileName binary
exitWith =<< executeFile' perl5 True (("-I" ++ p):binary:args) Nothing
_ -> fail ("Couldn't find helper program " ++ helper ++ " (searched in " ++ show (map (foldl1 FilePath.combine) searchPaths) ++ ")")
where
suffixes =
[ []
, ["perl5", "PIL2JS"] -- sourcedir/perl5/PIL2JS/jspugs.pl
, ["perl5", "lib"] -- pugslibdir/perl5/lib/jspugs.pl
, ["misc", "pX", "Common", "redsix"] -- sourcedir/misc/pX/Common/redsix/redsix
]
perl5 = getConfig "perl5_path"
findHelper :: [[FilePath]] -> MaybeT IO FilePath
findHelper [] = fail "Can't find anything"
findHelper (x:xs) = maybeFindFile file
`mplus` maybeFindFile (file ++ getConfig "exe_ext")
`mplus` findHelper xs
where
file = foldl1 FilePath.combine (x ++ [helper])
maybeFindFile :: FilePath -> MaybeT IO FilePath
maybeFindFile pathname = do
dir <- liftIO $ getDirectoryContents path `catchIO` (\(_ :: SomeException) -> return [])
guard (filename `elem` dir)
return pathname
where
(path, filename) = FilePath.splitFileName pathname
doParseWith :: (Env -> FilePath -> IO a) -> FilePath -> String -> IO a
doParseWith f name prog = do
env <- tabulaRasa name
f' $ parseProgram env{ envDebug = Nothing } name prog
where
f' env | Val err@(VError _ _) <- envBody env = do
hPutStrLn stderr $ pretty err
globalFinalize
exitFailure
f' env = f env name
doParse :: Env -> (Exp -> String) -> FilePath -> String -> IO ()
doParse env prettyFunc name prog = do
case envBody $ parseProgram env name prog of
(Val err@(VError _ _)) -> putStrLn $ pretty err
exp -> putStrLn $ prettyFunc exp
doLoad :: TVar Env -> String -> IO ()
doLoad env fn = do
runImperatively env (evaluate exp)
return ()
where
exp = App (_Var "&require") Nothing [Val $ VStr fn]
doRunSingle :: TVar Env -> RunOptions -> String -> IO ()
doRunSingle menv opts prog = (`catchIO` handler) $ do
exp <- makeProper =<< parse
if exp == Noop then return () else do
env <- theEnv
rv <- runImperatively env (evaluate exp)
result <- case rv of
VControl (ControlContinuation env' val _) -> do
stm $ writeTVar menv env'
return val
_ -> return rv
printer env result
where
parse = do
env <- stm $ readTVar menv
return $ envBody $ parseProgram env defaultProgramName $
(dropTrailingSemi prog)
dropTrailingSemi = reverse .
(\x -> ';' : (dropWhile (`elem` " \t\r\n;") x)) .
reverse
hasTrailingSemi = case f prog of ';':_ -> True; _ -> False
where f = dropWhile (`elem` " \t\r\n\f") . reverse
theEnv = do
ref <- if runOptSeparately opts
then (io . newTVarIO) =<< tabulaRasa defaultProgramName
else return menv
debug <- if runOptDebug opts
then newDebugInfo
else return Nothing
stm $ modifyTVar ref $ \e -> e{ envDebug = debug }
return ref
printer' = if runOptShowPretty opts then putStrLn . pretty else print
printer env = \val -> do
final <- runImperatively env (fromVal' val)
if hasTrailingSemi
then case final of (VError _ _) -> printer' final ; _ -> return ()
else printer' final
makeProper exp = case exp of
Val err@(VError (VStr msg) _)
| runOptShowPretty opts
, any (== "Unexpected end of input") (lines msg) -> do
cont <- readline "....> "
case cont of
Just line -> do
doRunSingle menv opts (prog ++ ('\n':line))
return Noop
_ -> fail $ pretty err
Val err@VError{} -> fail $ pretty err
_ | runOptSeparately opts -> return exp
App (Syn "block" [Val (VCode cv)]) invs args -> return $
App (Syn "block" [Val (VCode cv{ subBody = makeDumpEnv (subBody cv) })]) invs args
_ -> return $ makeDumpEnv exp
-- XXX Generalize this into structural folding
makeDumpEnv Noop = Syn "continuation" []
makeDumpEnv (Stmts x Noop) = Stmts (Ann (Cxt cxtItemAny) x) (Syn "continuation" [])
makeDumpEnv (Stmts x exp) = Stmts x $ makeDumpEnv exp
makeDumpEnv (Ann ann exp) = Ann ann $ makeDumpEnv exp
makeDumpEnv (Sym x y z w exp) = Sym x y z w $ makeDumpEnv exp
makeDumpEnv exp = Stmts (Ann (Cxt cxtItemAny) exp) (Syn "continuation" [])
{-
handler (IOException ioe) | isUserError ioe = do
putStrLn "Internal error while running expression:"
putStrLn $ ioeGetErrorString ioe
-}
handler (err :: SomeException) = do
putStrLn "Internal error while running expression:"
putStrLn $ show err
runImperatively :: TVar Env -> Eval Val -> IO Val
runImperatively menv eval = do
env <- stm $ readTVar menv
runEvalIO env $ do
val <- eval
newEnv <- ask
stm $ writeTVar menv newEnv
return val
doRun :: (?debugInfo :: DebugInfo) => String -> [String] -> String -> IO ()
doRun = do
runProgramWith (\e -> e{ envDebug = ?debugInfo }) end
where
end err@(VError _ _) = do
hPutStrLn stderr $ encodeUTF8 $ pretty err
globalFinalize
exitFailure
end (VControl (ControlExit exit)) = do
globalFinalize
exitWith exit
end _ = return ()
noEnvDebug :: Env -> Env
noEnvDebug e = e{ envDebug = Nothing }
runProgramWith ::
(Env -> Env) -> (Val -> IO a) -> VStr -> [VStr] -> String -> IO a
runProgramWith fenv f name args prog = do
env <- prepareEnv name args
-- Cache the compilation tree right here.
-- We only really care about envGlobal and envBody here.
val <- runEnv $ parseProgram (fenv env) name prog
f val
createConfigLine :: String -> String
createConfigLine item = "\t" ++ item ++ ": " ++ (Map.findWithDefault "UNKNOWN" item config)
printConfigInfo :: [String] -> IO ()
printConfigInfo [] = do
libs <- getLibs
putStrLn $ unlines $
["This is " ++ version ++ " built for " ++ getConfig "archname"
,""
,"Summary of pugs configuration:" ]
++ map (\x -> createConfigLine x) (map (fst) (Map.toList config))
++ [ "" ]
++ [ "@*INC:" ] ++ libs
printConfigInfo (item:_) = do
putStrLn $ createConfigLine item
compPIR :: String -> IO ()
compPIR prog = do
pir <- doCompile "PIR" "-" prog
putStr $ (subMain ++ (last $ split subMain pir))
where
subMain = ".sub main"
runPIR :: String -> IO ()
runPIR prog = do
pir <- doCompile "PIR" "-" prog
writeFile "a.pir" pir
fail "evalParrotFile is bitrotten."
-- evalParrotFile "a.pir"
{-
withInlinedIncludes :: String -> IO String
withInlinedIncludes prog = do
libs <- getLibs
expandInc libs prog
where
expandInc :: [FilePath] -> String -> IO String
expandInc incs str = case breakOnGlue "\nuse " ('\n':str) of
Nothing -> case breakOnGlue "\nrequire " ('\n':str) of
Nothing -> return str
Just (pre, post) -> do
let (mod, (_:rest)) = span (/= ';') (dropWhile isSpace post)
mod' <- includeInc incs mod
rest' <- expandInc incs rest
return $ pre ++ mod' ++ rest'
Just (pre, post) -> do
let (mod, (_:rest)) = span isAlphaNum (dropWhile isSpace post)
mod' <- includeInc incs mod
rest' <- expandInc incs rest
return $ pre ++ "\n{" ++ mod' ++ "\n}\n" ++ rest'
includeInc :: [FilePath] -> String -> IO String
includeInc _ ('v':_) = return []
includeInc incs name = do
let name' = concat (intersperse "/" names) ++ ".pm"
names = split "::" name
pathName <- requireInc incs name' (errMsg name incs)
readFile pathName
errMsg fn incs = "Can't locate " ++ fn ++ " in @*INC (@*INC contains: " ++ unwords incs ++ ")."
-}