Changeset 7344 for src/Main.hs

Show
Ignore:
Timestamp:
10/06/05 21:07:40 (3 years ago)
Author:
autrijus
Message:

* The main Pugs API entry, for crazy people who'd like to use

Pugs in embedded applications.

Files:
1 modified

Legend:

Unmodified
Added
Removed

  • src/Main.hs

    r7325 r7344  
    1515-} 
    1616 
    17 module Main (module Main, withArgs) where 
     17module Main (module Main, module Pugs) where 
     18import Pugs 
    1819import Pugs.Internals 
    19 import Pugs.Config 
    20 import Pugs.Run 
    21 import Pugs.AST 
    22 import Pugs.Types 
    23 import Pugs.Eval 
    24 import Pugs.External 
    25 import Pugs.Shell 
    26 import Pugs.Parser.Program 
    27 import Pugs.Help 
    28 import Pugs.Pretty 
    29 import Pugs.CodeGen 
    30 import Pugs.Embed 
    31 import Pugs.Prim.Eval (requireInc) 
    32 import qualified Data.Map as Map 
    33 import Data.IORef 
    34 import System.FilePath 
    3520 
    3621{-| 
    … …  
    3924-} 
    4025main :: IO () 
    41 main = do 
    42     hSetBuffering stdout NoBuffering 
    43     when (isJust _DoCompile) $ do 
    44         writeIORef (fromJust _DoCompile) doCompile 
    45     runWithArgs run 
    46     globalFinalize 
     26main = mainWith run 
    4727 
    48 globalFinalize :: IO () 
    49 globalFinalize = join $ readIORef _GlobalFinalizer 
    50  
    51 warn :: Show a => a -> IO () 
    52 warn x = do 
    53             hPrint stderr $ show x 
     28runFile :: String -> IO () 
     29runFile file = do 
     30    withArgs [file] main 
    5431 
    5532-- see also Run/Args.hs 
    … …  
    12097    return (ch:rest) 
    12198 
    122 -- convenience functions for GHCi 
    123 eval :: String -> IO () 
    124 eval prog = do 
    125     args <- getArgs 
    126     runProgramWith id (putStrLn . pretty) "<interactive>" args prog 
    127  
    128 parse :: String -> IO () 
    129 parse = doParse pretty "-" 
    130  
    131 dump :: String -> IO () 
    132 dump = (doParseWith $ \env _ -> print $ envBody env) "-" 
    133  
    134 dumpGlob :: String -> IO () 
    135 dumpGlob = (doParseWith $ \env _ -> do 
    136     glob <- liftSTM $ readTVar $ envGlobal env 
    137     print $ userDefined glob) "-" 
    138  
    139 userDefined :: Pad -> Pad 
    140 userDefined (MkPad pad) = MkPad $ Map.filterWithKey doFilter pad 
    141     where 
    142     doFilter key _ = not (key `elem` reserved) 
    143     reserved = words $ 
    144         "@*ARGS @*INC %*INC $*PUGS_HAS_HSPLUGINS $*EXECUTABLE_NAME " ++ 
    145         "$*PROGRAM_NAME $*PID $*UID $*EUID $*GID $*EGID @*CHECK @*INIT $*IN " ++ 
    146         "$*OUT $*ERR $*ARGS $/ %*ENV $*CWD @=POD $=POD $?PUGS_VERSION " ++ 
    147         "$*OS &?BLOCK_EXIT %?CONFIG $*_ $*AUTOLOAD" 
    148  
    14999repLoop :: IO () 
    150100repLoop = do 
    … …  
    161111            CmdHelp           -> printInteractiveHelp >> loop 
    162112            CmdReset          -> tabulaRasa "<interactive>" >>= (liftSTM . writeTVar env) >> loop 
    163  
    164 {-| 
    165 Create a \'blank\' 'Env' for our program to execute in. Of course, 
    166 'prepareEnv' actually declares quite a few symbols in the environment, 
    167 e.g. \'\@\*ARGS\', \'\$\*PID\', \'\$\*ERR\' etc. 
    168  
    169 ('Tabula rasa' is Latin for 'a blank slate'.) 
    170 -} 
    171 tabulaRasa :: String -> IO Env 
    172 tabulaRasa name = prepareEnv name [] 
    173  
    174 doCheck :: FilePath -> String -> IO () 
    175 doCheck = doParseWith $ \_ name -> do 
    176     putStrLn $ name ++ " syntax OK" 
    177  
    178 doExternal :: String -> FilePath -> String -> IO () 
    179 doExternal mod = doParseWith $ \env _ -> do 
    180     str <- externalize mod $ envBody env 
    181     putStrLn str 
    182  
    183 doCompile :: String -> FilePath -> String -> IO String 
    184 doCompile backend = doParseWith $ \env _ -> do 
    185     globRef <- liftSTM $ do 
    186         glob <- readTVar $ envGlobal env 
    187         newTVar $ userDefined glob 
    188     codeGen backend env{ envGlobal = globRef } 
    189  
    190 initCompile :: IO () 
    191 initCompile = do 
    192     compPrelude <- getEnv "PUGS_COMPILE_PRELUDE" 
    193     writeIORef _BypassPreludePC $ case compPrelude of 
    194         Nothing     -> True 
    195         Just ""     -> True 
    196         Just "0"    -> True 
    197         _           -> False 
    198  
    199 doCompileDump :: String -> FilePath -> String -> IO () 
    200 doCompileDump backend file prog = do 
    201     initCompile 
    202     str <- doCompile backend' file prog 
    203     putStr str 
    204     where 
    205     backend' = capitalizeWord backend 
    206     capitalizeWord []     = [] 
    207     capitalizeWord (c:cs) = toUpper c:(map toLower cs) 
    208  
    209 doCompileRun :: String -> FilePath -> String -> IO () 
    210 doCompileRun backend file prog = do 
    211     initCompile 
    212     str <- doCompile backend' file prog 
    213     evalEmbedded backend' str 
    214     where 
    215     backend' = capitalizeWord backend 
    216     capitalizeWord []     = [] 
    217     capitalizeWord (c:cs) = toUpper c:(map toLower cs) 
    218  
    219 doHelperRun :: String -> [String] -> IO () 
    220 doHelperRun backend args = 
    221     case map toLower backend of 
    222         "js"    -> if (args' == []) 
    223                    then (doExecuteHelper [ "perl5", "PIL2JS",  "jspugs.pl"  ] []) 
    224                    else (doExecuteHelper [ "perl5", "PIL2JS",  "runjs.pl"   ] args) 
    225         "perl5" ->       doExecuteHelper [ "perl5", "PIL-Run", "pugs-p5.pl" ] args 
    226         _       ->       fail ("unknown backend: " ++ backend) 
    227     where 
    228     args' = f args 
    229     f [] = [] 
    230     f (bjs:rest)      | map toUpper bjs == "-BJS"       = f rest 
    231     f ("-B":js:rest)  | map toUpper  js == "JS"         = f rest 
    232     f (pugspath:rest) | "--pugs=" `isPrefixOf` pugspath = f rest 
    233     f (x:xs) = x:f xs 
    234  
    235 doExecuteHelper :: [FilePath] -> [String] -> IO () 
    236 doExecuteHelper helper args = do 
    237     let searchPaths = [["."], ["..", ".."], [getConfig "installsitelib"], [getConfig "sourcedir"]] 
    238     mbin <- findHelper searchPaths 
    239     case mbin of 
    240         Just binary -> do 
    241             exitWith =<< executeFile' perl5 True (binary:args) Nothing 
    242         _ -> fail ("Couldn't find helper program " ++ (foldl1 joinFileName helper) ++ " (searched in " ++ show searchPaths ++ ")") 
    243     where 
    244     perl5 = getConfig "perl5path" 
    245     findHelper :: [[FilePath]] -> IO (Maybe FilePath) 
    246     findHelper []     = return Nothing 
    247     {- interesting riddle: how to do the following monadically? 
    248     findHelper (x:xs) 
    249         | fileExists $ file  x = Just $ file  x 
    250         | fileExists $ file' x = Just $ file' x 
    251         | otherwise            = findHelper xs 
    252     -} 
    253     findHelper (x:xs) = do -- not lazy, but that's not really important here 
    254         filex  <- fileExists (file  x) 
    255         filex' <- fileExists (file' x) 
    256         case () of 
    257             _ 
    258                 | filex     -> return $ Just $ file  x 
    259                 | filex'    -> return $ Just $ file' x 
    260                 | otherwise -> findHelper xs 
    261     file  x = foldl1 joinFileName (x ++ helper) 
    262     file' x = (file x) ++ (getConfig "exe_ext") 
    263     fileExists path = do 
    264         let (p,f) = splitFileName path 
    265         dir <- (fmap Just $ getDirectoryContents p) `catch` (const $ return Nothing) 
    266         case dir of 
    267             Just dir' -> return $ f `elem` dir' 
    268             _         -> return False 
    269  
    270 doParseWith :: (Env -> FilePath -> IO a) -> FilePath -> String -> IO a 
    271 doParseWith f name prog = do 
    272     env <- tabulaRasa name 
    273     f' $ parseProgram env name $ decodeUTF8 prog 
    274     where 
    275     f' env | Val err@(VError _ _) <- envBody env = do 
    276         hPutStrLn stderr $ pretty err 
    277         globalFinalize 
    278         exitFailure 
    279     f' env = f env name 
    280  
    281 doParse :: (Exp -> String) -> FilePath -> String -> IO () 
    282 doParse prettyFunc name prog = do 
    283     env <- tabulaRasa name 
    284     case envBody $ parseProgram env name (decodeUTF8 prog) of 
    285         (Val err@(VError _ _)) -> putStrLn $ pretty err 
    286         exp -> putStrLn $ prettyFunc exp 
    287  
    288 doLoad :: TVar Env -> String -> IO () 
    289 doLoad env fn = do 
    290     runImperatively env (evaluate exp) 
    291     return () 
    292     where 
    293     exp = App (Var "&require") Nothing [Val $ VStr fn] 
    294  
    295 doRunSingle :: TVar Env -> RunOptions -> String -> IO () 
    296 doRunSingle menv opts prog = (`catch` handler) $ do 
    297     exp     <- makeProper =<< parse 
    298     env     <- theEnv 
    299     rv      <- runImperatively env (evaluate exp) 
    300     result  <- case rv of 
    301         VControl (ControlEnv env') -> do 
    302             ref <- liftSTM $ findSymRef "$*_" =<< readTVar (envGlobal env') 
    303             val <- runEvalIO env' $ readRef ref 
    304             liftSTM $ writeTVar menv env' 
    305             return val 
    306         _ -> return rv 
    307     printer env result 
    308     where 
    309     parse = do 
    310         env <- liftSTM $ readTVar menv 
    311         return $ envBody $ parseProgram env "<interactive>" $ 
    312           (decodeUTF8 prog) 
    313     theEnv = do 
    314         ref <- if runOptSeparately opts 
    315                 then (liftSTM . newTVar) =<< tabulaRasa "<interactive>" 
    316                 else return menv 
    317         debug <- if runOptDebug opts 
    318                 then fmap Just (liftSTM $ newTVar Map.empty) 
    319                 else return Nothing 
    320         liftSTM $ modifyTVar ref $ \e -> e{ envDebug = debug } 
    321         return ref 
    322     printer env = if runOptShowPretty opts 
    323         then \val -> do 
    324             final <- runImperatively env (fromVal' val) 
    325             putStrLn $ pretty final 
    326         else print 
    327     makeProper exp = case exp of 
    328         Val err@(VError _ _) -> fail $ pretty err 
    329         _ | runOptSeparately opts -> return exp 
    330         _ -> return $ makeDumpEnv exp 
    331     -- XXX Generalize this into structural folding 
    332     makeDumpEnv (Stmts x exp)   = Stmts x   $ makeDumpEnv exp 
    333     makeDumpEnv (Cxt x exp)     = Cxt x     $ makeDumpEnv exp 
    334     makeDumpEnv (Pad x y exp)   = Pad x y   $ makeDumpEnv exp 
    335     makeDumpEnv (Sym x y exp)   = Sym x y   $ makeDumpEnv exp 
    336     makeDumpEnv (Pos x exp)     = Pos x     $ makeDumpEnv exp 
    337     makeDumpEnv exp = Stmts exp (Syn "env" []) 
    338     handler err = if not (isUserError err) then ioError err else do 
    339         putStrLn "Internal error while running expression:" 
    340         putStrLn $ ioeGetErrorString err 
    341  
    342 runImperatively :: TVar Env -> Eval Val -> IO Val 
    343 runImperatively menv eval = do 
    344     env <- liftSTM $ readTVar menv 
    345     runEvalIO env $ do 
    346         val <- eval 
    347         newEnv <- ask 
    348         liftSTM $ writeTVar menv newEnv 
    349         return val 
    350  
    351 doRun :: String -> [String] -> String -> IO () 
    352 doRun = do 
    353     runProgramWith (\e -> e{ envDebug = Nothing }) end 
    354     where 
    355     end err@(VError _ _)  = do 
    356         hPutStrLn stderr $ encodeUTF8 $ pretty err 
    357         globalFinalize 
    358         exitFailure 
    359     end (VControl (ControlExit exit)) = do 
    360         globalFinalize 
    361         exitWith exit 
    362     end _ = return () 
    363  
    364 runFile :: String -> IO () 
    365 runFile file = do 
    366     withArgs [file] main 
    367  
    368 runProgramWith :: 
    369     (Env -> Env) -> (Val -> IO a) -> VStr -> [VStr] -> String -> IO a 
    370 runProgramWith fenv f name args prog = do 
    371     env <- prepareEnv name args 
    372     val <- runEnv $ parseProgram (fenv env) name $ decodeUTF8 prog 
    373     f val 
    374  
    375 createConfigLine :: String -> String 
    376 createConfigLine item = "\t" ++ item ++ ": " ++ (Map.findWithDefault "UNKNOWN" item config) 
    377  
    378 printConfigInfo :: [String] -> IO () 
    379 printConfigInfo [] = do 
    380     libs <- getLibs 
    381     putStrLn $ unlines $ 
    382         ["This is " ++ version ++ " built for " ++ getConfig "archname" 
    383         ,"" 
    384         ,"Summary of pugs configuration:" ] 
    385         ++ map (\x -> createConfigLine x) (map (fst) (Map.toList config)) 
    386         ++ [ "" ] 
    387         ++ [ "@*INC:" ] ++ libs 
    388  
    389 printConfigInfo (item:_) = do 
    390         putStrLn $ createConfigLine item 
    391  
    392 compPIR :: String -> IO () 
    393 compPIR prog = do 
    394     pir <- doCompile "PIR" "-" prog 
    395     putStr $ (subMain ++ (last $ split subMain pir)) 
    396     where 
    397     subMain = ".sub main" 
    398  
    399 runPIR :: String -> IO () 
    400 runPIR prog = do 
    401     pir <- doCompile "PIR" "-" prog 
    402     writeFile "a.pir" pir 
    403     evalParrotFile "a.pir" 
    404  
    405 slurpFile :: FilePath -> IO String 
    406 slurpFile file = do 
    407     prog <- readFile file 
    408     libs <- getLibs 
    409     file <- expandInc libs prog 
    410     -- writeFile "ZZZ" file 
    411     return file 
    412     where 
    413     expandInc :: [FilePath] -> String -> IO String 
    414     expandInc incs str = case breakOnGlue "\nuse " str of 
    415         Nothing -> case breakOnGlue "\nrequire " str of 
    416             Nothing -> return str 
    417             Just (pre, post) -> do 
    418                 let (mod, (_:rest)) = span (/= ';') (dropWhile isSpace post) 
    419                 mod'    <- includeInc incs mod 
    420                 rest'   <- expandInc incs rest 
    421                 return $ pre ++ mod' ++ rest' 
    422         Just (pre, post) -> do 
    423             let (mod, (_:rest)) = span isAlphaNum (dropWhile isSpace post) 
    424             mod'    <- includeInc incs mod 
    425             rest'   <- expandInc incs rest 
    426             return $ pre ++ mod' ++ rest' 
    427     includeInc :: [FilePath] -> String -> IO String 
    428     includeInc _ ('v':_) = return [] 
    429     includeInc incs name = do 
    430         let name' = concat (intersperse "/" names) ++ ".pm" 
    431             names = split "::" name 
    432         pathName    <- requireInc incs name' (errMsg name incs) 
    433         readFile pathName 
    434     errMsg file incs = "Can't locate " ++ file ++ " in @*INC (@*INC contains: " ++ unwords incs ++ ")." 
    435