Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: 6272950693
Fetching contributors…

Cannot retrieve contributors at this time

482 lines (430 sloc) 17.242 kb
{-# 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 ++ ")."
-}
Jump to Line
Something went wrong with that request. Please try again.