helium-1.8: src/TextHint/Main.hs
{-| Module : Main
License : GPL
Maintainer : helium@cs.uu.nl
Stability : experimental
Portability : portable
The textual Helium interpreter
-}
module Main where
import Data.Char
import Data.List(isInfixOf, isPrefixOf, isSuffixOf)
import Control.Monad
import System.IO(stdout, hFlush)
import Data.IORef ( IORef, readIORef, newIORef, writeIORef )
import System.IO.Unsafe ( unsafePerformIO )
import System.Environment(getArgs)
import System.Process(system)
import System.FilePath
import System.Exit
import System.Directory
import qualified Control.Exception as CE (catch, IOException)
import Helium.Main.Args
import TextHint.ConfigFile
import Paths_helium
data State =
State
{ maybeModName :: Maybe String
, maybeFileName :: Maybe String
, tempDir :: String
-- , binDir :: String
, compOptions :: [String] -- Contains both options for helium as well as lvmrun.
-- For lvmrun only the -P/--lvmpath options are selected to be passed on
}
-- The following three definitions are used to support the alert flag
-- for redoing a compilation and logging the compilation in a special way.
refToPreviousInvocation :: IORef (String, String)
refToPreviousInvocation = unsafePerformIO (newIORef ("", ""))
getPreviousInvocation :: (String, String)
getPreviousInvocation = unsafePerformIO (readIORef refToPreviousInvocation)
setPreviousInvocation :: String -> String -> IO ()
setPreviousInvocation heliumInvocation redirect =
writeIORef refToPreviousInvocation (heliumInvocation, redirect)
header :: String
header = unlines
[ " _ _ _ "
, "| | | (_) "
, "| |__ ___| |_ _ _ _ __ ___ -- Welcome to the Helium interpreter --"
, "| '_ \\ / _ \\ | | | | | '_ ` _ \\ ---------------------------------------"
, "| | | | __/ | | |_| | | | | | | -- Type an expression to evaluate --"
, "|_| |_|\\___|_|_|\\__,_|_| |_| |_| -- or a command (:? for a list) --"
]
slashify :: String -> String
slashify xs = if last xs == pathSeparator then xs else xs ++ [pathSeparator]
lvmrun :: String
lvmrun = "lvmrun"
main :: IO ()
main = do
canWeRun <- findExecutable lvmrun
case canWeRun of
Nothing -> do
putStrLn "Fatal error: lvmrun cannot be found in your system PATH.\nDid you run `cabal install lvmrun` yet?"
exitWith (ExitFailure 1)
Just _ -> return ()
-- Read all configuration info first
configFullname <- getDataFileName configFilename
configInfo <-
readConfig configFullname
tempDirFromEnv <- case lookup temppathKey configInfo of
Nothing -> getTemporaryDirectory
Just xs -> return xs
let configOptions = extractOptions configInfo
-- Load command-line parameter module
-- If the final parameter happens to refer to a source name, then that file is loaded.
args <- getArgs
-- Delete empty option strings since they screw things up
(options, maybeFilename) <- processTexthintArgs (filter (/= "") configOptions ++ args) -- args take precedence over config file
-- We can now assume the options are correct, and if maybeFileName is a Just, then we load this as file.
-- This might fail as an ordinary load might.
baseLibs <- getDataFileName $
if overloadingFromOptions options
then slashify "lib"
else slashify "lib" ++ slashify "simple" -- Where the base libs are.
let initialState =
State { tempDir = slashify tempDirFromEnv
, maybeModName = Nothing
, maybeFileName = Nothing
, compOptions = ("-P"++baseLibs): map show options -- -P is needed for lvmrun
}
stateAfterLoad <-
case maybeFilename of
Just filename ->
cmdLoadModule filename initialState
Nothing ->
return initialState
-- Logo
putStrLn header
-- Enter read-eval-print loop
_ <- loop stateAfterLoad
return ()
loop :: State -> IO State
loop state = do
putStr (prompt state)
hFlush stdout
command' <- getLine
let command = trim command'
newState <- case command of
(':':cmd:rest) ->
processCommand (toLower cmd) (trim rest) state
(':':_) -> do
putStrLn "Expecting command after colon. Type :? for help"
return state
expression ->
if null expression
then return state
else processExpression expression state
loop newState
where
prompt :: State -> String
prompt State{ maybeModName = Nothing} = "Prelude> "
prompt State{ maybeModName = Just modName} = modName ++ "> "
processCommand :: Char -> String -> State -> IO State
processCommand cmd rest state =
case cmd of
'!' -> cmdSystem rest state
't' -> cmdShowType rest state
'l' -> cmdLoadModule rest state
'r' -> cmdReloadModule state
'a' -> cmdAlert rest state
'b' -> cmdBrowse state
'h' -> cmdHelp state
'?' -> cmdHelp state
'q' -> do putStrLn "[Leaving texthint]"
exitSuccess
_ -> do putStrLn "Command not recognised. Type :? for help"
return state
------------------------
-- Command :!
------------------------
cmdSystem :: String -> State -> IO State
cmdSystem command state = do
_ <- system command
return state
------------------------
-- Command :t
------------------------
cmdShowType :: String -> State -> IO State
cmdShowType [] state = do
putStrLn "ERROR: Expecting expression after :t"
return state
cmdShowType expression state = do
let moduleContents = expressionModule expression state
writeInternalModule moduleContents state
(success, output) <- compileInternalModule "-i" state
if success then do
let typeLine = filter (interpreterMain `isPrefixOf`) (map trim (lines output))
unless (null typeLine) $ do
let typeString =
trim
. dropWhile (== ':')
. dropWhile isSpace
. drop (length interpreterMain)
. head
$ typeLine
putStrLn (expression ++ " :: " ++ typeString)
else
putStr (removeEvidence output)
return state
------------------------
-- Command :l
------------------------
cmdLoadModule :: String -> State -> IO State
cmdLoadModule [] state = -- unload
return state{maybeModName = Nothing, maybeFileName = Nothing }
cmdLoadModule fileName state = do
fileExists <- doesFileExist fileName
if fileExists
then loadExistingModule fileName state
else do
let fileNameWithHS = fileName ++ ".hs"
fileExistsWithHS <- doesFileExist fileNameWithHS
if fileExistsWithHS
then loadExistingModule fileNameWithHS state
else do
putStr $ "ERROR - Unable to open file \"" ++ fileName ++ "\"\n"
return state
loadExistingModule :: String -> State -> IO State
loadExistingModule fileName state = do
let (path, baseName, _) = splitFilePath fileName
unless (null path) $
setCurrentDirectory path
let newState = state{ maybeModName = Just baseName, maybeFileName = Just fileName }
moduleContents = expressionModule "()" newState
writeInternalModule moduleContents newState
(_, output) <- compileInternalModule "" newState
putStr (removeEvidence output)
return newState
------------------------
-- Command :r
------------------------
cmdReloadModule :: State -> IO State
cmdReloadModule state =
case maybeModName state of
Nothing -> return state
Just name -> cmdLoadModule name state
------------------------
-- Command :a
------------------------
cmdAlert :: String -> State -> IO State
cmdAlert msg state = do
let (invocation, outputFilePath) = getPreviousInvocation
-- putStrLn (" -- " ++ invocation ++ " -- " ++ outputFilePath)
when (invocation /= "")
(do
(_, output) <- execCompileModule (invocation ++ " --alert=\"" ++ escape alertESCAPABLES msg ++ "\" -b --enable-logging ") outputFilePath
putStr (removeEvidence output)
return ())
return state
------------------------
-- Command :b
------------------------
cmdBrowse :: State -> IO State
cmdBrowse state =
case maybeModName state of
Nothing -> do
let moduleContents = "import Prelude\n"
writeInternalModule moduleContents state
(_, output) <- compileInternalModule "-I -3 -B" state
putStr (unlines (safeTail (lines output)))
return state
Just modName -> do
(_, output) <- compileModule modName "-i -3 -B" state
putStr (unlines (safeTail (lines output)))
return state
------------------------
-- Command :?
------------------------
cmdHelp :: State -> IO State
cmdHelp state = do
putStrLn ":h, :? display this help screen"
putStrLn ":l <filename> load module"
putStrLn ":l unload module"
putStrLn ":r reload module"
putStrLn ":a <message> alert to previous compile (message optional)"
putStrLn ":t <expression> show type of expression"
putStrLn ":b browse definitions in current module"
putStrLn ":! <command> shell command"
putStrLn ":q quit"
return state
------------------------
-- Expression
------------------------
processExpression :: String -> State -> IO State
processExpression expression state = do
removeLVM state
let moduleContents = expressionModule expression state
writeInternalModule moduleContents state
(success, output) <- compileInternalModule "" state
putStr (removeEvidence output)
when success $
executeInternalModule state
return state
------------------------
-- Interpreter module
------------------------
outputFileName, internalModule, interpreterMain :: String
outputFileName = "InterpreterOutput.txt"
internalModule = "Interpreter"
interpreterMain = "interpreter_main"
internalModulePath :: State -> String
internalModulePath state = tempDir state ++ internalModule
writeInternalModule :: String -> State -> IO ()
writeInternalModule contents state =
writeModule (internalModulePath state) contents
writeModule :: String -> String -> IO ()
writeModule modulePath contents = do
let hsFile = modulePath ++ ".hs"
handler :: CE.IOException -> IO ()
handler _ = fatal ("Unable to write to file \"" ++ hsFile ++ "\"")
writeFile hsFile contents
`CE.catch` handler
compileInternalModule :: String -> State -> IO (Bool, String)
compileInternalModule options state =
compileModule (internalModulePath state) options state
compileModule :: String -> String -> State -> IO (Bool, String)
compileModule fileName options state = do
let outputFilePath = tempDir state ++ outputFileName
-- putStrLn (fileName ++ "." ++ options ++ "." ++ unwords (compOptions state))
-- mapM putStrLn (compOptions state)
let heliumInvocation = "helium " ++ unwords (compOptions state)
++ " " ++ options ++ " " ++ fileName
setPreviousInvocation heliumInvocation outputFilePath
execCompileModule heliumInvocation outputFilePath
verbose :: String -> Bool
verbose = isInfixOf "--verbose"
execCompileModule :: String -> String -> IO (Bool, String)
execCompileModule invocation outputFilePath =
let
handler :: CE.IOException -> IO String
handler _ = fatal ("Unable to read from file \"" ++ outputFilePath ++ "\"")
in
do
when (verbose invocation) $
putStrLn invocation
exitCode <- sys (invocation ++ " > " ++ outputFilePath)
contents <- readFile outputFilePath `CE.catch` handler
return (exitCode == ExitSuccess, contents)
executeInternalModule :: State -> IO ()
executeInternalModule state =
executeModule (internalModulePath state) state
lvmOptionsFilter :: [String] -> String
lvmOptionsFilter opts =
case lvmPathFromOptions (simplifyOptions (argsToOptions opts)) of
Nothing -> ""
(Just paths) -> "-P" ++ paths
executeModule :: String -> State -> IO ()
executeModule fileName state = do
let invocation = lvmrun ++ " " ++ lvmOptionsFilter (compOptions state) ++ " "++ fileName
_ <- sys invocation
return ()
removeLVM :: State -> IO ()
removeLVM state = do
let lvmFile = tempDir state ++ internalModule ++ ".lvm"
lvmExist <- doesFileExist lvmFile
when lvmExist $ removeFile lvmFile
expressionModule :: String -> State -> String
expressionModule expression state =
unlines
( case maybeModName state of
Nothing -> []
Just name -> [ "import " ++ name ]
++ [ interpreterMain ++ " = " ++ expression ]
)
sys :: String -> IO ExitCode
sys = system
------------------------
-- Remove evidence
------------------------
-- remove evidence that there is an Interpreter module
-- that is compiled each time you type an expression
-- or ask for a type
removeEvidence :: String -> String
removeEvidence =
unlines . firstState . lines
where
firstState :: [String] -> [String]
firstState [] = []
firstState (line:ls)
| "Compiling" `isPrefixOf` line &&
(internalModule ++ ".hs") `isSuffixOf` line =
interpreterState [] ls
| "Compiling" `isPrefixOf` line =
line : otherModuleState ls
| "is up to date" `isSuffixOf` line =
firstState ls
| otherwise =
line : firstState ls
interpreterState soFar [] = soFar
interpreterState soFar (line:ls)
| "Compilation successful" `isPrefixOf` line =
firstState ls
| "Compilation" `isPrefixOf` line =
map removePositions soFar ++ firstState ls
| otherwise =
interpreterState (soFar ++ [line]) ls
otherModuleState [] = []
otherModuleState (line:ls)
| "Compilation" `isPrefixOf` line =
line : firstState ls
| otherwise =
line : otherModuleState ls
removePositions line =
let (upToColon, rest) = span (/= ':') line
in if not (all isSpace upToColon) &&
all (\c -> isDigit c || c `elem` "(), ") upToColon then
safeTail rest
else
line
------------------------
-- Utility functions
------------------------
fatal :: String -> IO a
fatal msg = do
putStrLn msg
putStrLn "Make sure that the environment variable TEMP points to a valid directory"
exitWith (ExitFailure 1)
safeTail :: [a] -> [a]
safeTail (_:xs) = xs
safeTail [] = []
contains :: Eq a => [a] -> [a] -> Bool
_ `contains` [] = True
[] `contains` _ = False
(large@(_:rest)) `contains` small =
small `isPrefixOf` large || rest `contains` small
-- Split file name
-- e.g. /docs/haskell/Hello.hs =>
-- filePath = /docs/haskell baseName = Hello ext = hs
splitFilePath :: String -> (String, String, String)
splitFilePath filePath =
let slashes = "\\/"
(revFileName, revPath) = span (`notElem` slashes) (reverse filePath)
(baseName, ext) = span (/= '.') (reverse revFileName)
in (reverse revPath, baseName, dropWhile (== '.') ext)
-- As copied from Logger.hs
escapeChar :: Char
escapeChar = '\\';
alertESCAPABLES :: String
alertESCAPABLES = ['"', escapeChar]
-- Escapes all characters from the list escapables
escape :: [Char] -> String -> String
escape _ [] = []
escape escapables (x:xs) =
if x `elem` escapables
then escapeChar : rest
else rest
where
rest = x : escape escapables xs