|
sourcecode:
|
module REPL.Main where
import Control.Monad ( when, unless )
import Curry.Compiler.Distribution ( installDir )
import Data.Char ( toLower, toUpper )
import Data.List ( intercalate, intersperse, isInfixOf, isPrefixOf
, maximum, nub, partition, sort, sortBy )
import System.Environment ( getArgs, getEnv )
import System.FilePath ( (</>), (<.>) )
import System.IO ( hClose, hFlush, hPutStrLn, isEOF, stdout )
import AbstractCurry.Types hiding (preludeName)
import AbstractCurry.Files
import AbstractCurry.Build ( ioType, stringType, unitType )
import AbstractCurry.Select
import System.CurryPath ( inCurrySubdir, lookupModuleSource, modNameToPath
, stripCurrySuffix )
import System.Directory ( doesDirectoryExist, doesFileExist, getAbsolutePath
, getDirectoryContents, getHomeDirectory
, renameFile, setCurrentDirectory )
import System.FilePath ( searchPathSeparator, splitExtension
, splitFileName, splitSearchPath )
import System.FrontendExec
import System.IOExts ( connectToCommand )
import System.Process ( exitWith, getPID, system )
import REPL.Compiler
import REPL.RCFile
import REPL.State
import REPL.Utils ( showMonoTypeExpr, showMonoQualTypeExpr
, getTimeCmd, getTimeoutCmd, moduleNameToPath
, validModuleName, notNull, removeFileIfExists
, strip, writeErrorMsg )
-- ---------------------------------------------------------------------------
--- The main operation to start the REPL. It is parameterized over
--- a description of a Curry compiler.
mainREPL :: CCDescription -> IO ()
mainREPL cd = do
rcFileDefs <- readRC cd
args <- getArgs
let (nodefargs,defargs) = extractRCArgs args
(mainargs,rtargs) = break (=="--") nodefargs
rcDefs = updateRCDefs rcFileDefs defargs
furtherRcDefs = filter (\da -> fst da `notElem` map fst rcFileDefs)
defargs
rst <- initReplState cd
ipath <- defaultImportPaths rst
let rst1 = rst { importPaths = ipath
, rcVars = rcDefs
, rtsArgs = if null rtargs then "" else unwords (tail rtargs)
}
if null furtherRcDefs
then processArgsAndStart
rst1
(map strip (words (rcValue (rcVars rst1) "defaultparams")) ++
mainargs)
else putStrLn $ "Error: rc property name '" ++ fst (head furtherRcDefs) ++
"' not found in rc file!"
processArgsAndStart :: ReplState -> [String] -> IO ()
processArgsAndStart rst []
| quit rst = cleanUpAndExitRepl rst
| otherwise = do
writeVerboseInfo rst 1 (ccBanner (compiler rst))
unless (null (usingOption rst)) $ writeVerboseInfo rst 1 $
"(using " ++ usingOption rst ++ ")\n"
writeVerboseInfo rst 1 $
"Type \":h\" for help (contact: " ++ ccEmail (compiler rst) ++ ")"
when (currMod rst == "Prelude") $ do
writeVerboseInfo rst 1 $ "Compiling Prelude..."
processCompile (reduceVerbose rst) "Prelude" >> return ()
repLoop rst
processArgsAndStart rst (arg:args)
-- ignore empty arguments which can be provided by single or double quotes
| null arg
= processArgsAndStart rst args
-- ignore '--nocypm|-n' or '--noreadline'
-- (since they already processed by separate script to invoke the REPL)
| arg == "--using" && not (null args)
= processArgsAndStart rst { usingOption = head args } (tail args)
| arg `elem` ["-n", "--nocypm", "--noreadline"]
= processArgsAndStart rst args
| arg == "-h" || arg == "--help" || arg == "-?"
= printHelp rst >> cleanUpAndExitRepl rst
| arg == "-q" || arg == "--quiet"
= processArgsAndStart rst { verbose = 0 } args
| arg == "-V" || arg == "--version"
= do putStrLn (ccBanner (compiler rst))
processArgsAndStart rst { quit = True} args
| arg `elem` versionOpts -- process all version options and quit:
= do let (vopts,mopts) = partition (`elem` versionOpts) args
if null mopts
then do system $ unwords (ccExec (compiler rst) : arg : vopts)
cleanUpAndExitRepl rst
else writeErrorMsg ("illegal options: " ++ unwords mopts)
| isCommand arg = do
let (cmdargs, more) = break isCommand args
mbrst <- processCommand rst (tail (unwords (arg:cmdargs)))
maybe (printHelp rst) (\rst' -> processArgsAndStart rst' more) mbrst
| otherwise
= writeErrorMsg ("unknown option: " ++ unwords (arg:args)) >> printHelp rst
where
versionOpts = ["--compiler-name", "--numeric-version", "--base-version"]
--- May a `String` be a REPL command?
isCommand :: String -> Bool
isCommand s = case s of
':' : _ -> True
_ -> False
printHelp :: ReplState -> IO ()
printHelp rst = putStrLn $ unlines $
[ "Invoke interactive environment:"
, ""
, " <repl> <options> [ -- <run-time arguments>]"
, ""
, "with options:"
, ""] ++
formatVarVals ": "
(ccMainOpts (compiler rst) ++
[ ("-h|--help|-?" , "show this message and quit")
, ("-V|--version" , "show version and quit")
, ("--compiler-name" , "show the compiler name and quit")
, ("--numeric-version", "show the compiler version number and quit")
, ("--base-version ", "show the version of the base libraries and quit")
, ("-q|--quiet" , "work silently")
, ("--using <s>" , "set string for 'using' message in banner")
, ("-Dprop=val" , "define rc property `prop' as `val'")
, (":<cmd> <args>" , "commands of the interactive environment")
]) ++
[ "" ]
-- ---------------------------------------------------------------------------
-- The main read-eval-print loop:
repLoop :: ReplState -> IO ()
repLoop rst = do
putStr prompt >> hFlush stdout
eof <- isEOF
if eof then cleanUpAndExitRepl rst
else mGetLine >>= maybe (cleanUpAndExitRepl rst) (checkInput . strip)
where
prompt = calcPrompt rst
checkInput inp
| null inp
= repLoop rst
| ord (head inp) == 0 -- indicates sometimes EOF
= cleanUpAndExitRepl rst
| otherwise
= do when (withEcho rst) $ putStrLn $ prompt ++ inp
processInput rst inp
-- A variant of `Prelude.getLine` which returns `Nothing` if EOF is reached.
mGetLine :: IO (Maybe String)
mGetLine = do
eof <- isEOF
if eof
then return Nothing
else do
c <- getChar
if ord c == 0 -- indices EOF in Curry2Go
then return Nothing
else if c == '\n'
then return $ Just []
else do mGetLine >>= maybe (return Nothing)
(\cs -> return $ Just (c:cs))
-- Calculates the prompt string w.r.t. the currently loaded modules.
calcPrompt :: ReplState -> String
calcPrompt rst =
substS (unwords (currMod rst : addMods rst)) (prompt rst)
-- Substitute `%s` in a string with a given string (first argument).
substS :: String -> String -> String
substS replacement = sub
where
sub [] = []
sub [c] = [c]
sub (c:d:cs) = case c of
'%' -> case d of
'%' -> '%' : cs
's' -> replacement ++ sub cs
_ -> c : d : sub cs
_ -> c : sub (d:cs)
-- Clean resources of REPL and terminate it with exit status.
cleanUpAndExitRepl :: ReplState -> IO ()
cleanUpAndExitRepl rst = do
terminateSourceProgGUIs rst
exitWith (exitStatus rst)
processInput :: ReplState -> String -> IO ()
processInput rst g
| null g = repLoop rst
| isCommand g = do mbrst <- processCommand rst (strip (tail g))
maybe (repLoop (rst { exitStatus = 1 }))
(\rst' -> if quit rst' then cleanUpAndExitRepl rst'
else repLoop rst')
mbrst
| "let " `isPrefixOf` g
= getAcyOfExpr rst (g ++ "\n in ()") >>=
maybe (repLoop rst)
(\_ -> repLoop rst { letBinds = letBinds rst ++ [g] })
| otherwise = evalExpression rst g >>= repLoop
--- Evaluate an expression w.r.t. currently loaded modules
evalExpression :: ReplState -> String -> IO ReplState
evalExpression rst expr = do
exst <- compileMainExpression rst expr True
return rst { exitStatus = exst }
-- Check whether the main module imports an "Unsafe" module.
importUnsafeModule :: ReplState -> IO Bool
importUnsafeModule rst =
if containsUnsafe (addMods rst)
then return True
else do
let acyMainModFile = acyFileName rst (currMod rst)
frontendParams = currentFrontendParams rst (verbose rst <= 1)
catch (do verbCallFrontendWithParams rst ACY frontendParams (currMod rst)
p <- readAbstractCurryFile acyMainModFile
return $ containsUnsafe (imports p))
(\_ -> return (currMod rst /= "Prelude")) -- just to be safe
where
containsUnsafe = any ("Unsafe" `isInfixOf`)
-- Compute the front-end parameters for the current state:
currentFrontendParams :: ReplState -> Bool -> FrontendParams
currentFrontendParams rst quiet =
setQuiet quiet
$ setFrontendPath (ccFrontend cc)
$ setFullPath (loadPaths rst)
$ setExtended (rcValue (rcVars rst) "curryextensions" /= "no")
$ setOverlapWarn (rcValue (rcVars rst) "warnoverlapping" /= "no")
$ setSpecials (parseOpts rst)
$ setDefinitions [("__" ++ map toUpper (ccName cc) ++ "__", maj*100 + min)]
$ setOutDir (compilerOutDir rst)
defaultParams
where
cc = compiler rst
(maj,min,_) = ccVersion cc
-- Computes the directory for auxiliary Curry files w.r.t. the current compiler.
compilerOutDir :: ReplState -> String
compilerOutDir rst =
".curry" </> map toLower (ccName cc) ++ "-" ++
intercalate "." (map show [maj,min,rev])
where
cc = compiler rst
(maj,min,rev) = ccVersion cc
-- Computes the name of the AbstractCurry file for a given module
-- w.r.t. the current compiler
acyFileName :: ReplState -> String -> String
acyFileName rst prog = compilerOutDir rst </> modNameToPath prog <.> "acy"
-- Call the front end and report the call if required by verbosity.
verbCallFrontendWithParams :: ReplState -> FrontendTarget -> FrontendParams
-> String -> IO ()
verbCallFrontendWithParams rst target params modpath = do
when (verbose rst > 1) $ do
parsecmd <- getFrontendCall target params modpath
writeVerboseInfo rst 2 $ "Executing: " ++ parsecmd
callFrontendWithParams target params modpath
-- ---------------------------------------------------------------------------
-- Main expression file stuff
-- ---------------------------------------------------------------------------
writeSimpleMainExpFile :: ReplState -> String -> IO ()
writeSimpleMainExpFile rst exp = writeMainExpFile rst [] Nothing exp
-- write the file with the main exp where necessary imports
-- and possibly a type string is provided:
writeMainExpFile :: ReplState -> [String] -> Maybe String -> String -> IO ()
writeMainExpFile rst imports mtype exp =
writeFile (mainExpFile rst) $ unlines $
[noMissingSigs, "module " ++ mainExpMod rst ++ " where"] ++
map ("import " ++) allImports ++
maybe [] (\ts -> ["main :: " ++ ts]) mtype ++
["main = " ++ concatMap (++ " in\n ") (letBinds rst)
++ qualifyMain (strip exp)]
where
allImports = filter (/="Prelude") . nub $ currMod rst : addMods rst ++ imports
noMissingSigs = "{-# OPTIONS_FRONTEND -W no-missing-signatures #-}"
-- simple hack to avoid name conflict with "main":
-- (better solution: pretty print parsed main expression with qualification)
qualifyMain :: String -> String
qualifyMain [] = []
qualifyMain s@(x:xs)
| "main" `isPrefixOf` s = case drop 3 xs of
[] -> currMod rst ++ ".main"
c:_ | not (isAlphaNum c)
-> currMod rst ++ ".main" ++ drop 3 xs
_ -> x : qualifyMain xs
| isAlphaNum x = let (prev, next) = span isAlphaNum xs
in x : prev ++ qualifyMain next
| otherwise = x : qualifyMain xs
-- Generate, read, and delete .acy file of main expression module.
-- Return Nothing if some error occurred during parsing.
getAcyOfMainExpMod :: ReplState -> IO (Maybe CurryProg)
getAcyOfMainExpMod rst = do
let acyMainExpFile = acyFileName rst (mainExpMod rst)
frontendParams = currentFrontendParams rst (verbose rst <= 1)
prog <- catch (verbCallFrontendWithParams rst ACY frontendParams
(mainExpMod rst) >>
tryReadACYFile acyMainExpFile)
(\_ -> return Nothing)
unlessKeepFiles rst $ removeFileIfExists acyMainExpFile
return prog
getAcyOfExpr :: ReplState -> String -> IO (Maybe CurryProg)
getAcyOfExpr rst expr = do
writeSimpleMainExpFile rst expr
mbProg <- getAcyOfMainExpMod rst
unlessKeepFiles rst $ removeFileIfExists (mainExpFile rst)
return mbProg
-- Prints the type of an expression w.r.t. main program.
printTypeOfExp :: ReplState -> String -> IO Bool
printTypeOfExp rst exp = do
mbProg <- getAcyOfExpr rst exp
maybe (do writeVerboseInfo rst 3 "Cannot read AbstractCurry file"
return False)
(\ (CurryProg _ _ _ _ _ _ [CFunc _ _ _ qty _] _) -> do
putStrLn $ exp ++ " :: " ++ showMonoQualTypeExpr False qty
return True)
mbProg
-- Get the module of a function visible in the main program:
getModuleOfFunction :: ReplState -> String -> IO String
getModuleOfFunction rst funname = do
mbprog <- getAcyOfExpr rst $
if isAlpha (head funname) then funname else '(' : funname ++ ")"
return $ maybe ""
(\ (CurryProg _ _ _ _ _ _ [CFunc _ _ _ _ mainrules] _) ->
modOfMain mainrules)
mbprog
where modOfMain r = case r of
[CRule [] (CSimpleRhs (CSymbol (m, _)) [])] -> m
[CRule [] (CGuardedRhs [(_, CSymbol (m, _))] [])] -> m
_ -> ""
-- ---------------------------------------------------------------------------
-- Processing of REPL commands
-- ---------------------------------------------------------------------------
-- Process a command of the REPL.
-- The result is either just a new ReplState or Nothing if an error occurred.
processCommand :: ReplState -> String -> IO (Maybe ReplState)
processCommand rst cmds
| null cmds = skipCommand "unknown command"
| head cmds == '!' = unsafeExec rst $ processSysCall rst (strip $ tail cmds)
| otherwise = case matchedCmds of
[] -> skipCommand $ "unknown command: ':" ++ cmds ++ "'"
[(fcmd, act)] -> if fcmd `elem` ["eval","load","quit","reload"]
then act rst (strip args)
else unsafeExec rst $ act rst (strip args)
(_:_:_) -> skipCommand $ "ambiguous command: ':" ++ cmds ++ "'"
where (cmd, args) = break (==' ') cmds
matchedCmds = filter (isPrefixOf (map toLower cmd) . fst) replCommands
unsafeExec :: ReplState -> IO (Maybe ReplState) -> IO (Maybe ReplState)
unsafeExec rst act =
if safeExec rst
then skipCommand "Operation not allowed in safe mode!"
else act
-- all available REPL commands
replCommands :: [(String, ReplState -> String -> IO (Maybe ReplState))]
replCommands =
[ ("?" , processHelp )
, ("add" , processAdd )
, ("browse" , processBrowse )
, ("cd" , processCd )
, ("compile" , processCompile )
, ("edit" , processEdit )
, ("eval" , processEval )
, ("fork" , processFork )
, ("help" , processHelp )
, ("interface" , processInterface )
, ("load" , processLoad )
, ("modules" , processModules )
, ("programs" , processPrograms )
, ("reload" , processReload )
, ("quit" , processQuit )
, ("save" , processSave )
, ("set" , processSetOption )
, ("source" , processSource )
, ("show" , processShow )
, ("type" , processType )
, ("usedimports", processUsedImports )
]
--- Skip an erroneous command with an error message
skipCommand :: String -> IO (Maybe ReplState)
skipCommand msg = writeErrorMsg msg >> return Nothing
--- Execute a call to a system command
processSysCall :: ReplState -> String -> IO (Maybe ReplState)
processSysCall rst cmd
| null cmd = skipCommand "missing system command"
| otherwise = system cmd >> return (Just rst)
--- Process :add command
processAdd :: ReplState -> String -> IO (Maybe ReplState)
processAdd rst0 args
| null args = skipCommand "Missing module name"
| otherwise = Just `fmap` foldIO add rst0 (map stripCurrySuffix (words args))
where
add rst m =
if validModuleName m
then do
mbf <- lookupModuleSource (loadPaths rst) m
case mbf of
Nothing -> do
writeErrorMsg $ "Source file of module '" ++ m ++ "' not found"
return rst
Just _ ->
if m `elem` addMods rst
then return rst
else compileCurryProgram rst m >>=
maybe (return rst)
(\rs' -> return rs' { addMods = insM (addMods rs') })
else do writeErrorMsg $ "Illegal module name (ignored): " ++ m
return rst
where
insM [] = [m]
insM ms@(n:ns) | m < n = m : ms
| m == n = ms
| otherwise = n : insM ns
foldIO _ a [] = return a
foldIO f a (x:xs) = f a x >>= \fax -> foldIO f fax xs
--- Process :browse command
processBrowse :: ReplState -> String -> IO (Maybe ReplState)
processBrowse rst args
| notNull $ stripCurrySuffix args = skipCommand "superfluous argument"
| otherwise = checkForWish $ do
writeVerboseInfo rst 1 "Starting Curry Browser in separate window..."
checkAndCallCpmTool "curry-browse" "currybrowse"
(\toolexec -> execCommandWithPath rst toolexec [currMod rst])
--- Process :cd command
processCd :: ReplState -> String -> IO (Maybe ReplState)
processCd rst args = do
dirname <- getAbsolutePath args
exists <- doesDirectoryExist dirname
if exists then setCurrentDirectory dirname >> return (Just rst)
else skipCommand $ "directory does not exist"
--- Process :compile command
processCompile :: ReplState -> String -> IO (Maybe ReplState)
processCompile rst args = do
let modname = stripCurrySuffix args
if null modname
then skipCommand "missing module name"
else compileCurryProgram rst modname
--- Process :edit command
processEdit :: ReplState -> String -> IO (Maybe ReplState)
processEdit rst args = do
modname <- getModuleName rst args
mbf <- lookupModuleSource (loadPaths rst) modname
editenv <- getEnv "EDITOR"
let editcmd = rcValue (rcVars rst) "editcommand"
editprog = if null editcmd then editenv else editcmd
if null editenv && null editcmd
then skipCommand "no editor defined"
else maybe (skipCommand "source file not found")
(\ (_,fn) -> do system (editprog ++ " " ++ fn ++ "& ")
return (Just rst))
mbf
--- Process :eval command
processEval :: ReplState -> String -> IO (Maybe ReplState)
processEval rst args = evalExpression rst args >>= return . Just
--- Process :fork command
processFork :: ReplState -> String -> IO (Maybe ReplState)
processFork rst args
| currMod rst == preludeName rst
= skipCommand "no program loaded"
| otherwise
= do exst <- compileMainExpression rst (if null args then "main" else args)
False
if exst == 0
then do
pid <- getPID
let execname = "." </> "MAINFORK" ++ show pid
renameFile ("." </> mainExpMod rst) execname
writeVerboseInfo rst 3 $
"Starting executable '" ++ execname ++ "'..."
system $ "( " ++ execname ++ " && rm -f " ++ execname ++ ") " ++
"> /dev/null 2> /dev/null &"
return $ Just rst
else return Nothing
--- Process :help command
processHelp :: ReplState -> String -> IO (Maybe ReplState)
processHelp rst _ = do
printHelpOnCommands
return (Just rst)
--- Process :interface command
processInterface :: ReplState -> String -> IO (Maybe ReplState)
processInterface rst args = do
modname <- getModuleName rst args
mbshowflatbin <- getCpmTool "curry-showflat"
maybe (checkAndCallCpmTool "curry-showinterface" "curry-interface"
(\toolexec -> execCommandWithPath rst toolexec [modname]))
(\showflatbin ->
getCpmTool "curry-showinterface" >>=
maybe (execCommandWithPath rst showflatbin ["-int", modname])
(\showint -> execCommandWithPath rst showint [modname]))
mbshowflatbin
--- Process :load command
processLoad :: ReplState -> String -> IO (Maybe ReplState)
processLoad rst args = do
rst' <- terminateSourceProgGUIs rst
let dirmodname = stripCurrySuffix args
if null dirmodname
then skipCommand "missing module name"
else do
let (dirname, modname) = splitFileName dirmodname
mbrst <- if (dirname == "./") then return (Just rst')
else do putStrLn $ "Changing working directory to " ++ dirname
processCd rst' dirname
maybe (return Nothing)
(\rst2 ->
lookupModuleSource (loadPaths rst2) modname >>=
maybe (skipCommand $
"source file of module '" ++ dirmodname ++ "' not found")
(\_ -> loadCurryProgram rst2 { currMod = modname, addMods = [] }
modname)
)
mbrst
--- Process :reload command
processReload :: ReplState -> String -> IO (Maybe ReplState)
processReload rst args
| currMod rst == preludeName rst
= skipCommand "no program loaded!"
| null (stripCurrySuffix args)
= loadCurryProgram rst (currMod rst)
| otherwise
= skipCommand "superfluous argument"
--- Process :modules command
processModules :: ReplState -> String -> IO (Maybe ReplState)
processModules rst _ = printAllLoadedModules rst >> return (Just rst)
--- Process :programs command
processPrograms :: ReplState -> String -> IO (Maybe ReplState)
processPrograms rst _ = printAllLoadPathPrograms rst >> return (Just rst)
--- Process :quit command
processQuit :: ReplState -> String -> IO (Maybe ReplState)
processQuit rst _ = return (Just rst { quit = True })
processSave :: ReplState -> String -> IO (Maybe ReplState)
processSave rst args
| currMod rst == preludeName rst
= skipCommand "no program loaded"
| otherwise
= do exst <- compileMainExpression rst (if null args then "main" else args)
False
if exst == 0
then do renameFile ("." </> mainExpMod rst) (currMod rst)
writeVerboseInfo rst 1 $
"Executable saved in '" ++ currMod rst ++ "'"
return $ Just rst
else return Nothing
--- Process :show command
processShow :: ReplState -> String -> IO (Maybe ReplState)
processShow rst args = do
modname <- getModuleName rst args
mbf <- lookupModuleSource (loadPaths rst) modname
case mbf of
Nothing -> skipCommand "source file not found"
Just (_,fn) -> do
pager <- getEnv "PAGER"
let rcshowcmd = rcValue (rcVars rst) "showcommand"
showprog = if not (null rcshowcmd)
then rcshowcmd
else (if null pager then "cat" else pager)
system $ showprog ++ ' ' : fn
putStrLn ""
return (Just rst)
--- Process :source command
processSource :: ReplState -> String -> IO (Maybe ReplState)
processSource rst args
| null args = skipCommand "missing function name"
| null dotfun = do m <- getModuleOfFunction rst args
if null m
then skipCommand "function not found"
else showFunctionInModule rst m args
| otherwise = showFunctionInModule rst mod (tail dotfun)
where (mod, dotfun) = break (== '.') args
--- Process :type command
processType :: ReplState -> String -> IO (Maybe ReplState)
processType rst args = do
typeok <- printTypeOfExp rst args
return (if typeok then Just rst else Nothing)
--- Process :usedimports command
processUsedImports :: ReplState -> String -> IO (Maybe ReplState)
processUsedImports rst args = do
let modname = if null args then currMod rst else stripCurrySuffix args
checkAndCallCpmTool "curry-usedimports" "importusage"
(\toolexec -> execCommandWithPath rst toolexec [modname])
printHelpOnCommands :: IO ()
printHelpOnCommands = putStrLn $ unlines $
[ "Basic commands (commands can be abbreviated to a prefix if unique):\n" ] ++
formatVarVals " - "
[ ("<expr>" , "evaluate expression <expr>")
, ("let <p> = <expr>", "add let binding for main expression")
, (":load <prog>", "load program '<prog>.[l]curry' as main module")
, (":reload" , "recompile currently loaded modules")
, (":add <m1> .. <mn>",
"add modules <m1>,...,<mn> to currently loaded modules")
, (":eval <expr>", "evaluate expression <expr>")
, (":save <expr>", "save executable with main expression <expr>")
, (":save" , "save executable with main expression 'main'")
, (":type <expr>", "show type of expression <expr>")
, (":quit" , "leave the system") ] ++
[ "\nFurther commands:\n" ] ++
formatVarVals " - "
[ (":!<command>" , "execute <command> in shell")
, (":browse" , "browse program and its imported modules")
, (":cd <dir>" , "change current directory to <dir>")
, (":compile <m>" , "compile module <m> (but do not load it)")
, (":edit" , "load source of currently loaded module into editor")
, (":edit <m>" , "load source of module <m> into editor")
, (":fork <expr>" , "fork new process evaluating <expr>")
, (":help" , "show this message")
, (":interface" , "show interface of currently loaded module")
, (":interface <m>", "show interface of module <m>")
, (":modules" ,
"show currently loaded modules with source information")
, (":programs" , "show names of Curry modules available in load path")
, (":set <option>" , "set an option")
, (":set" , "see help on options and current options")
, (":show" , "show currently loaded source program")
, (":show <m>" , "show source of module <m>")
, (":source <f>" , "show source of (visible!) function <f>")
, (":source <m>.<f> ", "show source of function <f> in module <m>")
, (":usedimports" , "show all used imported functions/constructors") ]
--- Print all Curry programs in current load path.
--- Programs found in subdirectories are assumed to be hierarchical.
--- To avoid loops in cyclic directory structure, we put a depth limit
--- on the recursive search.
printAllLoadedModules :: ReplState -> IO ()
printAllLoadedModules rst = do
putStrLn "Currently loaded modules:"
let mods = currMod rst : addMods rst
mapM getSrc mods >>= putStr . unlines . map fmtSrc
where
getSrc m = lookupModuleSource (loadPaths rst) m >>=
return . maybe (m,"???") (\ (_,s) -> (m, s))
fmtSrc (m,s) = m ++ take (20 - length m) (repeat ' ') ++ " (from " ++ s ++ ")"
--- Print all Curry programs in current load path.
--- Programs found in subdirectories are assumed to be hierarchical.
--- To avoid loops in cyclic directory structure, we put a depth limit
--- on the recursive search.
printAllLoadPathPrograms :: ReplState -> IO ()
printAllLoadPathPrograms rst = mapM_ printDirPrograms (loadPaths rst)
where
depthLimit = 10
printDirPrograms dir = do
putStrLn $ "Curry programs in directory '" ++ dir ++ "':"
progs <- getDirPrograms depthLimit "" dir
putStrLn $ unwords $ sort $ progs
putStrLn ""
getDirPrograms dlimit prefix dir = do
exdir <- doesDirectoryExist dir
files <- if exdir && dlimit > 0 then getDirectoryContents dir
else return []
subprogs <- mapM (\d -> getDirPrograms (dlimit - 1) (prefix ++ d ++ ".")
(dir </> d))
(filter (\f -> let c = head f in c>='A' && c<='Z') files)
return $ concat subprogs ++
concatMap (\f -> let (base, sfx) = splitExtension f
in if sfx `elem` [".curry", ".lcurry"] && notNull base
then [prefix ++ base]
else [])
files
---------------------------------------------------------------------------
-- Process setting of an option
processSetOption :: ReplState -> String -> IO (Maybe ReplState)
processSetOption rst option
| null (strip option)
= printOptions rst >> return (Just rst)
| otherwise
= case matched of
[] -> skipCommand $ "unknown option: '" ++ option ++ "'"
[(_,act)] -> act rst (strip args)
_ -> skipCommand $ "ambiguous option: ':" ++ option ++ "'"
where
(opt, args) = break (==' ') option
matched = filter (isPrefixOf (map toLower opt) . fst)
(replOptions rst)
-- Returns a list of pairs of option names and the corresponding
-- action to set the option with a given parameter in the state.
replOptions :: ReplState
-> [(String, ReplState -> String -> IO (Maybe ReplState))]
replOptions rst =
[ ("v0" , \r _ -> return (Just r { verbose = 0 }))
, ("v1" , \r _ -> return (Just r { verbose = 1 }))
, ("v2" , \r _ -> return (Just r { verbose = 2 }))
, ("v3" , \r _ -> return (Just r { verbose = 3 }))
, ("v4" , \r _ -> return (Just r { verbose = 4 }))
, ("path" , setOptionPath )
, ("prompt" , setPrompt )
, ("safe" , \r _ -> return (Just r { safeExec = True }))
, ("parser" , \r a -> return (Just r { parseOpts = a }))
, ("timeout" , setTimeout )
, ("args" , \r a -> return (Just r { rtsArgs = a }))
-- , ("prelude" , \r a -> return (Just r { preludeName = a }))
, ("+bindings" , \r _ -> return (Just r { showBindings = True }))
, ("-bindings" , \r _ -> return (Just r { showBindings = False }))
, ("+echo" , \r _ -> return (Just r { withEcho = True }))
, ("-echo" , \r _ -> return (Just r { withEcho = False }))
, ("+show" , \r _ -> return (Just r { withShow = True }))
, ("-show" , \r _ -> return (Just r { withShow = False }))
, ("+time" , \r _ -> return (Just r { showTime = True }))
, ("-time" , \r _ -> return (Just r { showTime = False }))
] ++
concatMap setCmpOpt ccopts
where
ccopts = ccOpts (compiler rst)
setCmpOpt (CCOption _ _ tags) = map setOptTag tags
setOptTag opt@(ConstOpt tag _) =
(tag,
\r _ -> return (Just r { cmpOpts = map (replaceCompilerOption ccopts opt)
(cmpOpts r) }))
setOptTag (ArgOpt tag _ fo) = (tag, checkArg)
where
checkArg r a =
maybe (skipCommand "Illegal option argument!")
(\_ -> return (Just r { cmpOpts = map (replaceCompilerOption ccopts
(ArgOpt tag a fo))
(cmpOpts r) }))
(fo a)
setPrompt :: ReplState -> String -> IO (Maybe ReplState)
setPrompt rst p
| null rawPrompt = skipCommand "no prompt specified"
| otherwise = case head rawPrompt of
'"' -> case reads rawPrompt of
[(strPrompt, [])] -> return (Just rst { prompt = strPrompt })
_ -> skipCommand "could not parse prompt"
_ -> return (Just rst { prompt = rawPrompt })
where rawPrompt = strip p
setTimeout :: ReplState -> String -> IO (Maybe ReplState)
setTimeout rst rawopt
| null opts = skipCommand "no value for timeout given"
| otherwise = case reads opts of
[(n, [])] -> return (Just rst { timeOut = if n<0 then 0 else n })
_ -> skipCommand "illegal timeout parameter (no integer)"
where opts = strip rawopt
------------------------------------------------------------------------------
-- Show help on options and current settings.
printOptions :: ReplState -> IO ()
printOptions rst = putStrLn $ unlines $ filter notNull
[ "Options for ':set' command:" ] ++
formatVarVals " - "
([ ("v<n>", "verbosity level\n" ++
"0: quiet (errors and warnings only)\n" ++
"1: show status messages (default)\n" ++
"2: show commands\n" ++
"3: show intermediate infos\n" ++
"4: show all details")
, ("path <paths>" , "set additional search paths for imported modules")
, ("prompt <prompt>", "set the user prompt")
, ("safe" , "safe execution mode without I/O actions")
, ("parser <opts>" , "additional options passed to parser (front end)")
, ("timeout <n>" ,
"timeout (in seconds) for main evaluation (0 = unlimited)")
, ("args <args>" , "run-time arguments passed to main program") ] ++
sort
([ ("+/-time" , "show compilation and execution time")
, ("+/-echo" , "turn on/off echoing of commands")
, ("+/-show" , "use 'Prelude.show' to show evaluation results")
, ("+/-bindings", "show bindings of free variables in initial goal")
] ++ map showCompilerOptionDescr (ccOpts (compiler rst)))) ++
[ showCurrentOptions rst ]
showCurrentOptions :: ReplState -> String
showCurrentOptions rst = intercalate "\n" $ filter notNull
[ "\nCurrent settings:" ] ++
formatVarVals ": "
[ ("import paths ", intercalate [searchPathSeparator] (loadPaths rst))
, ("parser options ", parseOpts rst)
, ("timeout ", show (timeOut rst))
, ("run-time arguments", rtsArgs rst)
, ("verbosity ", show (verbose rst))
, ("prompt ", show (prompt rst))
, ("let bindings ", unlines (letBinds rst))
, ("...............and"
, unwordsOpts $ sortBy (\f1 f2 -> setFlag f1 <= setFlag f2) $
[ showOnOff (showBindings rst) ++ "bindings"
, showOnOff (withEcho rst) ++ "echo"
, showOnOff (withShow rst) ++ "show"
, showOnOff (showTime rst) ++ "time"
] ++ map showCompilerOption (cmpOpts rst)) ] ++
(if verbose rst > 2
then [ "\nProperties from rc file:" ] ++
formatVarVals " = " (rcVars rst) ++
[ "\nREPL configuration:" ] ++
formatVarVals ": "
[ ("prelude name" , preludeName rst)
, ("main exp module" , mainExpMod rst)
, ("parser executable" , ccFrontend ccdesc)
, ("parser option" , ccParseOpt ccdesc "OPTS")
, ("compiler home dir" , ccHome ccdesc)
, ("compiler executable", ccExec ccdesc)
, ("verbosity option" , ccVerbOpt ccdesc "VERB")
, ("compile option" , ccCmplOpt ccdesc "MOD")
, ("executable option" , ccExecOpt ccdesc "MOD")
, ("clean command" , ccCleanCmd ccdesc "MOD") ]
else [])
where
ccdesc = compiler rst
unwordsOpts xs = let s = unwords xs
in if length s >= 60 then unlines (unwordsN 5 xs)
else s
unwordsN n xs = let (ns,ms) = splitAt n xs
in unwords ns : if null ms then [] else unwordsN n ms
setFlag [] = []
setFlag (c:cs) = if c `elem` "+-" then '~':cs else c:cs
showOnOff b = if b then "+" else "-"
-- Format a list of variable/value string pairs and put the first argument
-- between these strings.
formatVarVals :: String -> [(String,String)] -> [String]
formatVarVals sep vvs =
map (\ (var,val) -> var ++ blanks (maxvar - length var) ++ sep ++
intercalate ('\n' : blanks (maxvar + length sep)) (lines val))
vvs
where
blanks n = take n (repeat ' ')
maxvar = maximum (map (length . fst) vvs)
---------------------------------------------------------------------------
--- The default import paths of the Curry compiler.
--- It consists of the path defined by the environment variable CURRYPATH,
--- and the "libraries" property defined in ~/.<compiler>rc
defaultImportPaths :: ReplState -> IO [String]
defaultImportPaths rst = do
currypath <- getEnv "CURRYPATH"
let rclibs = rcValue (rcVars rst) "libraries"
return $ filter (/= ".") $ splitSearchPath currypath ++ splitSearchPath rclibs
defaultImportPathsWith :: ReplState -> String -> IO [String]
defaultImportPathsWith rst dirs = do
defipath <- defaultImportPaths rst
adirs <- mapM getAbsolutePath (splitSearchPath dirs)
return (adirs ++ defipath)
setOptionPath :: ReplState -> String -> IO (Maybe ReplState)
setOptionPath rst args = do
ipath <- if null args then defaultImportPaths rst
else defaultImportPathsWith rst args
return (Just rst { importPaths = ipath })
---------------------------------------------------------------------------
-- Compiles a main expression by creating a "main" module.
-- If the third argument is `True`, the generated executable is
-- invoked and then removed.
compileMainExpression :: ReplState -> String -> Bool -> IO Int
compileMainExpression rst exp runrmexec = do
if safeExec rst
then do -- check for imports of Unsafe
unsafeused <- importUnsafeModule rst
if unsafeused
then do writeErrorMsg "Import of 'Unsafe' not allowed in safe mode!"
return 1
else compileProgExp
else compileProgExp
where
compileProgExp = do
(ecg, freevars) <- generateMainExpFile
let mainexpmod = mainExpMod rst
if ecg /= 0
then do cleanModule rst mainexpmod
return ecg
else do
when (verbose rst > 3) $ do
putStrLn "GENERATED MAIN MODULE:"
readFile (mainExpFile rst) >>= putStrLn
let compilecmd = curryCompilerCommand (reduceVerbose rst) freevars ++
" " ++ (ccExecOpt (compiler rst)) mainexpmod
timecompilecmd <- getTimeCmd rst "Compilation" compilecmd
if ccCurryPath (compiler rst)
then execCommandWithPath rst timecompilecmd [] >> return ()
else do writeVerboseInfo rst 2 $ "Executing: " ++ timecompilecmd
system timecompilecmd >> return ()
cleanModule rst mainexpmod
if runrmexec
then do
timecmd <- getTimeCmd rst "Execution"
(unwords ["./" ++ mainexpmod, rtsArgs rst])
getTimeoutCmd rst timecmd >>= execAndRemove rst mainexpmod
else return 0
generateMainExpFile = do
unlessKeepFiles rst $ removeFileIfExists $ acyFileName rst (mainExpMod rst)
writeSimpleMainExpFile rst exp
getAcyOfMainExpMod rst >>=
maybe (return (1, []))
(\cprog -> makeMainExpMonomorphic rst cprog exp >>=
maybe
(return (1, []))
(\ (mprog,mexp) ->
insertFreeVarsShowInMainExp rst mprog mexp >>=
maybe (return (1, []))
(\ (_,_,freevars) -> return (0, freevars))))
-- Invokes a command (third argument) and removes the executable (second
-- argument) after execution (unless `keepfiles` option is set).
-- In order to support the deletion of the executable event after Ctrl-C,
-- the execution is wrapped into a shell which traps interrupts.
execAndRemove :: ReplState -> String -> String -> IO Int
execAndRemove rst executable execcmd = do
writeVerboseInfo rst 2 $ "Executing: " ++ execcmd
let scriptfile = executable ++ ".sh"
let shellscript = shellScript scriptfile
writeFile scriptfile shellscript
writeVerboseInfo rst 3 $ "...with shell script:\n" ++ shellscript
ecx <- system $ "/bin/sh " ++ scriptfile
unless (ecx == 0) $ writeVerboseInfo rst 1 $
"Execution terminated with exit status: " ++ show ecx
unlessKeepFiles rst $ do
removeFileIfExists scriptfile
removeFileIfExists executable
return ecx
where
shellScript scriptfile = unlines
[ "#!/bin/sh"
, "cleanup_mainfiles() {"
, " ECODE=$?"
, " # change exit code 130 (Ctrl-C) to 1 to avoid exit of REPL:"
, " if [ $ECODE -eq 130 ] ; then ECODE=1 ; fi"
, (if keepFiles rst
then ""
else " /bin/rm -f " ++ executable ++ " " ++ scriptfile ++ " && ")
++ " exit $ECODE"
, "}"
, "trap 'cleanup_mainfiles' 1 2 3 6"
, execcmd
, "######################## end of script ###################"
]
-- Removes a Curry module and intermediate files.
cleanModule :: ReplState -> String -> IO ()
cleanModule rst mainmod = unlessKeepFiles rst $ do
writeVerboseInfo rst 2 $ "Executing: " ++ cleancmd
system cleancmd
return ()
where
cleancmd = ccCleanCmd (compiler rst) mainmod
-- Executes an I/O action if the RC values `keepfiles` is not `yes`.
unlessKeepFiles :: ReplState -> IO () -> IO ()
unlessKeepFiles rst act = unless (keepFiles rst) act
-- Returns `True` if RC value `keepfiles` is set to `yes`.
keepFiles :: ReplState -> Bool
keepFiles rst = rcValue (rcVars rst) "keepfiles" == "yes"
---------------------------------------------------------------------------
-- Transforming main expression into appropriate form.
-- In LegacyFreeMode:
-- Insert free variables occurring in the main expressions
-- as components of the main expression so that their bindings are shown.
-- The arguments are the AbstractCurry program of the main expression
-- and the main expression as a string.
-- Also adds show/print if desired.
-- The result is Nothing (if some error occurred) or the transformed
-- AbstractCurry program, expression and any free variables.
-- If not in LegacyFreeMode:
-- Only add show/print if desired,
-- the rest is done by the respective compiler.
-- The result structure is the same as in LegacyFreeMode.
insertFreeVarsShowInMainExp :: ReplState -> CurryProg -> String
-> IO (Maybe (CurryProg, String, [String]))
insertFreeVarsShowInMainExp rst (CurryProg _ _ _ _ _ _ fdecls _) mainexp = do
let [mfunc@(CFunc _ _ _ (CQualType _ ty) _)] = fdecls
let freevars = freeVarsInFuncRule mfunc
(exp, whereclause) = breakWhereFreeClause mainexp
if safeExec rst && isIOType ty
then do writeErrorMsg "Operation not allowed in safe mode!"
return Nothing
else
if null freevars
|| not (showBindings rst)
|| ((not (withShow rst) && isLegacyFreeMode (freeMode rst))
&& length freevars > 10) -- due to tuple limit
|| null whereclause
then do
let freevarexp = addPrintShow exp ty ++ whereclause
writeVerboseInfo rst 2 "Adding show/print to expression"
writeVerboseInfo rst 3 $ "New expression: " ++ freevarexp
writeSimpleMainExpFile rst freevarexp
getAcyOfMainExpMod rst >>=
maybe (return Nothing)
(\p -> return $ Just (p,freevarexp,[]))
else if isLegacyFreeMode (freeMode rst)
then do
let freevarexp = addFreeShowLegacy exp freevars whereclause ty
writeVerboseInfo rst 2 $
"Adding printing of bindings for free variables: " ++
intercalate "," freevars
writeVerboseInfo rst 3 $ "New expression: " ++ freevarexp
writeSimpleMainExpFile rst freevarexp
getAcyOfMainExpMod rst >>=
maybe (return Nothing)
(\p -> return $ Just (p,freevarexp, []))
else do
let freevarexp = addFreeShowCmdLine exp whereclause ty
writeVerboseInfo rst 2 "Adding show/print to expression"
writeVerboseInfo rst 3 $ "New expression: " ++ freevarexp
writeSimpleMainExpFile rst freevarexp
getAcyOfMainExpMod rst >>=
maybe (return Nothing)
(\p -> return $ Just (p,freevarexp,freevars))
where
addPrintShow exp ty
| withShow rst && isIOReturnType ty = exp ++ " Prelude.>>= Prelude.print"
| withShow rst && not (isIOType ty) = "show (" ++ exp ++ ")"
| otherwise = exp
addFreeShowLegacy exp freevars whereclause ty = unwords $
if withShow rst
then if null freevars || isIOReturnType ty
then [addPrintShow exp ty, whereclause]
else
["((\"{\""] ++
intersperse ("++ \", \" ")
(map (\v-> "++ \"" ++ v ++ " = \" ++ show " ++ v) freevars) ++
["++ \"} \") ++) $!! "] ++ [addPrintShow exp ty] ++ [whereclause]
else ["(", exp] ++
map (\v-> ", \"" ++ v ++ ":\", " ++ v) freevars ++
[")"] ++ [whereclause]
addFreeShowCmdLine exp whereclause ty = unwords $
if withShow rst
then [addPrintShow exp ty, whereclause]
else [exp, whereclause]
freeVarsInFuncRule f = case f of
CFunc _ _ _ _ (CRule _ rhs : _) -> freeVarsInRhs rhs
_ -> error "REPL.insertFreeVarsShowInMainGoal.freeVarsInFuncRule"
freeVarsInRhs rhs = case rhs of
CSimpleRhs _ ldecls -> concatMap lvarName ldecls
CGuardedRhs _ ldecls -> concatMap lvarName ldecls
lvarName ldecl = case ldecl of CLocalVars vs -> map snd vs
_ -> []
-- Breaks a main expression into an expression and a where...free clause.
-- If the where clause is not present, the `where` part is empty.
breakWhereFreeClause :: String -> (String,String)
breakWhereFreeClause exp =
let revexp = reverse exp
in if take 4 revexp == "eerf"
then let woWhere = findWhere (drop 4 revexp)
in if null woWhere
then (exp,"")
else (reverse woWhere, drop (length woWhere) exp)
else (exp,"")
where
findWhere [] = []
findWhere (c:cs) | isSpace c && take 6 cs == "erehw " = drop 6 cs
| otherwise = findWhere cs
--- If the main expression is polymorphic, make it monomorphic by adding
--- a type declaration where type variables are replaced by type `()`.
--- Before, type variables with a numeric constraint like `Num`/`Integral` or
--- `Fractional`/`Floating` are defaulted to the types `Int` or `Float`,
--- respectively. The type of the main expression is only allowed to contain
--- numeric constraints.
--- If the main exp has type `IO t` where t is monomorphic and not a function,
--- t /= (), and `withShow` is `True`, then `>>= print` is added
--- to the expression to print the computed value.
--- Otherwise (if the main exp has type `IO t`), `>>= return` is added
--- in order to support raising non-determinism errors during the
--- monadic bind operation.
--- The arguments are the AbstractCurry program of the main expression
--- and the main expression as a string.
--- The result is Nothing (if some error occurred) or the transformed
--- AbstractCurry program and expression.
makeMainExpMonomorphic :: ReplState -> CurryProg -> String
-> IO (Maybe (CurryProg, String))
makeMainExpMonomorphic rst prog exp = case prog of
CurryProg _ _ _ _ _ _ [CFunc _ _ _ qty _] _ -> makeMonoType qty
_ -> error "REPL.makeMainExpMonomorphic"
where
makeMonoType qty@(CQualType _ ty)
| isFunctionalType ty
= do writeErrorMsg "expression is of functional type"
return Nothing
| isPolyType ty
= case defaultQualTypeExpr qty of
CQualType (CContext []) defTy -> do
when (defTy /= ty) $ writeVerboseInfo rst 2 $
"Defaulted type of main expression: " ++
showMonoTypeExpr False defTy
let (nwexp, whereclause) = breakWhereFreeClause exp
nwexpR = addReturn nwexp defTy
mtype = showMonoTypeExpr True defTy
mexp = "(" ++ nwexpR ++ " :: " ++ mtype ++ ") " ++ whereclause
writeMainExpFile rst (modsOfType defTy) (Just mtype) mexp
writeVerboseInfo rst 3 $ "New expression: " ++ mexp
when (isPolyType defTy) $ writeVerboseInfo rst 2 $
"Type of main expression \"" ++ showMonoTypeExpr False defTy
++ "\" made monomorphic by replacing type variables by \"()\""
getAcyOfMainExpMod rst >>=
maybe (return Nothing)
(\p -> return $ Just (p,mexp))
_ -> do writeErrorMsg $
"cannot handle overloaded top-level expression of type: " ++
showMonoQualTypeExpr False qty
return Nothing
| otherwise
= if newexp == exp
then return $ Just (prog,exp)
else do writeSimpleMainExpFile rst newexp
getAcyOfMainExpMod rst >>=
maybe (return Nothing)
(\p -> return $ Just (p,newexp))
where
newexp = let (nwexp, whereclause) = breakWhereFreeClause exp
nwexpR = addReturn nwexp ty
in nwexpR ++ whereclause
-- raise ND-in-IO Errors
addReturn e te = if isIOType te
then '(' : e ++ ") Prelude.>>= Prelude.return"
else e
-- Defaults type variables with a numeric constraint like `Num`/`Integral` or
-- `Fractional`/`Floating` to the types `Int` or `Float`, respectively.
-- Moreover, existing `Data`, `Eq`, `Ord`, `Read`, and `Show` constraints
-- for the same type variable are removed.
-- Finally, remaining type variables with `Data` and `Monad` constraints are
-- defaulted to `Prelude.Bool` and `Prelude.IO`, respectively.
defaultQualTypeExpr :: CQualTypeExpr -> CQualTypeExpr
defaultQualTypeExpr (CQualType (CContext ctxt) cty) =
defaultMonad $ defaultData $ defaultTExp ctxt (CQualType (CContext []) cty)
where
defaultData qty@(CQualType (CContext dctxt) dcty) = case dctxt of
[] -> qty
(qtcons, [CTVar tv]) : cs | qtcons == pre "Data"
-> defaultData (CQualType (CContext cs)
(substTypeVar tv (CTCons (pre "Bool")) dcty))
_ -> qty
defaultMonad qty@(CQualType (CContext dctxt) dcty) = case dctxt of
[] -> qty
(qtcons, [CTVar tv]) : cs | qtcons `elem` map pre ["Monad","MonadFail"]
-> defaultMonad (CQualType (CContext cs)
(substTypeVar tv (CTCons (pre "IO")) dcty))
_ -> qty
defaultTExp :: [CConstraint] -> CQualTypeExpr -> CQualTypeExpr
defaultTExp [] qty = qty
defaultTExp (c:cs) (CQualType (CContext cs2) ty) = case c of
(("Prelude", ptype), [CTVar tv]) ->
if ptype `elem` ["Num", "Integral", "Fractional", "Floating"]
then let defptype = if ptype `elem` ["Fractional", "Floating"]
then "Float"
else "Int"
in defaultTExp
(removeConstraints tv defptype cs)
(CQualType (CContext (removeConstraints tv defptype cs2))
(substTypeVar tv (CTCons (pre defptype)) ty))
else defaultTExp cs (CQualType (CContext (cs2 ++ [c])) ty)
_ -> defaultTExp cs (CQualType (CContext (cs2 ++ [c])) ty)
removeConstraints _ _ [] = []
removeConstraints tv dflttype (c3:cs3) = case c3 of
(("Prelude", cls), [CTVar tv2])
| tv == tv2 && cls `elem` ["Data", "Eq", "Ord", "Read", "Show"]
-> removeConstraints tv dflttype cs3
| tv == tv2 && dflttype == "Int" && cls == "Enum"
-> removeConstraints tv dflttype cs3
_ -> c3 : removeConstraints tv dflttype cs3
-- Replaces a type variable with a type expression.
substTypeVar :: CTVarIName -> CTypeExpr -> CTypeExpr -> CTypeExpr
substTypeVar tv def te@(CTVar tv2) = if tv == tv2 then def else te
substTypeVar _ _ te@(CTCons _) = te
substTypeVar tv def (CFuncType te1 te2) =
CFuncType (substTypeVar tv def te1) (substTypeVar tv def te2)
substTypeVar tv def (CTApply te1 te2) =
CTApply (substTypeVar tv def te1) (substTypeVar tv def te2)
---------------------------------------------------------------------------
-- Parse a Curry program to detect errors (for load/reload command):
parseCurryProgram :: ReplState -> String -> Bool -> IO (Maybe ReplState)
parseCurryProgram rst curryprog tfcy = do
let frontendparams = currentFrontendParams rst (verbose rst == 0)
target = if tfcy then TFCY else FCY
catch (verbCallFrontendWithParams rst target frontendparams curryprog
>> return (Just rst))
(\_ -> return Nothing)
-- Load a Curry program (parse only or compile it):
loadCurryProgram :: ReplState -> String -> IO (Maybe ReplState)
loadCurryProgram rst0 curryprog = do
let rst = rst0 { letBinds = [] }
maybe (compileCurryProgram rst curryprog)
(parseCurryProgram rst curryprog)
(ccTypedFC (compiler rst))
-- Compile a Curry program with the Curry compiler:
compileCurryProgram :: ReplState -> String -> IO (Maybe ReplState)
compileCurryProgram rst curryprog = do
let compilecmd = curryCompilerCommand rst [] ++ " " ++
(ccCmplOpt (compiler rst)) curryprog
timecompilecmd <- getTimeCmd rst "Compilation" compilecmd
if ccCurryPath (compiler rst)
then execCommandWithPath rst timecompilecmd []
else do writeVerboseInfo rst 2 $ "Executing: " ++ timecompilecmd
es <- system timecompilecmd
return $ if es == 0 then Just rst else Nothing
-- Generate the base command to call the Curry compiler:
curryCompilerCommand :: ReplState -> [String] -> String
curryCompilerCommand rst vs = unwords [ccExec (compiler rst), cmpopts]
where
cmpopts = unwords $
[ -- pass current value of "bindingoptimization" property to compiler:
-- "-Dbindingoptimization=" ++ rcValue (rcVars rst) "bindingoptimization"
(ccVerbOpt (compiler rst)) (show (verbose rst))
] ++
(if ccCurryPath (compiler rst)
then []
else map ("-i" ++) (loadPaths rst)) ++
filter notNull (map mapCompilerOption (cmpOpts rst)) ++
(if null (parseOpts rst)
then []
else [(ccParseOpt (compiler rst)) (parseOpts rst)]) ++
(case freeMode rst of
LegacyFreeMode -> []
CommandLineFreeMode trans -> [trans (zip vs [1..])] ++
[ "-B" | showBindings rst])
--- Extract a module name, possibly prefixed by a path, from an argument,
--- or return the current module name if the argument is the empty string.
getModuleName :: ReplState -> String -> IO String
getModuleName rst args =
if null args
then return (currMod rst)
else let (dirname, mname) = splitFileName (stripCurrySuffix args)
in if dirname == "./"
then return mname
else getAbsolutePath (stripCurrySuffix args)
-- Reduce verbosity in the REPL state.
reduceVerbose :: ReplState -> ReplState
reduceVerbose rst = rst { verbose = redVerb (verbose rst) }
where
redVerb n | n == 0 = 0
| otherwise = n - 1
---------------------------------------------------------------------------
-- Operations to call auxiliary tools.
-- Showing source code of functions via SourcProgGUI tool.
-- If necessary, open a new connection and remember it in the repl state.
showFunctionInModule :: ReplState -> String -> String -> IO (Maybe ReplState)
showFunctionInModule rst mod fun =
checkForWish $
checkAndCallCpmTool "curry-showsource" "sourceproggui" $ \spgui -> do
writeVerboseInfo rst 1 $
"Showing source code of function '" ++ mod ++ "." ++ fun ++
"' in separate window..."
let spguicmd = "CURRYPATH=" ++
intercalate [searchPathSeparator] (loadPaths rst) ++
" && export CURRYPATH && " ++ spgui ++ " " ++ mod
writeVerboseInfo rst 2 $ "Executing: " ++ spguicmd
(rst',h') <- maybe (do h <- connectToCommand spguicmd
return (rst {sourceguis = (mod,(fun,h))
: sourceguis rst }, h))
(\ (f,h) -> do
hPutStrLn h ('-':f)
hFlush h
return (rst {sourceguis = updateFun (sourceguis rst)
mod fun }, h))
(lookup mod (sourceguis rst))
hPutStrLn h' ('+':fun)
hFlush h'
return (Just rst')
where
updateFun [] _ _ = []
updateFun ((m,(f,h)):sguis) md fn =
if m==md then (m,(fn,h)):sguis
else (m,(f,h)) : updateFun sguis md fn
-- Check whether some tool installable by CPM is available, i.e.,
-- either in the current path or in the CPM bin directory,
-- and return its name or path.
getCpmTool :: String -> IO (Maybe String)
getCpmTool toolbin = do
excmd <- system $ "which " ++ toolbin ++ " > /dev/null"
if excmd == 0
then return $ Just toolbin
else do homedir <- getHomeDirectory
let cpmtoolfile = homedir </> ".cpm" </> "bin" </> toolbin
excpm <- doesFileExist cpmtoolfile
if excpm
then return $ Just cpmtoolfile
else return Nothing
-- Check whether some CPM tool is available, i.e., either in the current
-- path or in the CPM bin directory. If it is not available,
-- skip the command with an error message how to install the tool from
-- the package (specified in the second argument). Otherwise, continue with
-- the last argument by passing the name of the CPM tool.
checkAndCallCpmTool :: String -> String -> (String -> IO (Maybe ReplState))
-> IO (Maybe ReplState)
checkAndCallCpmTool tool package continue =
getCpmTool tool >>= maybe (skipCommand errmsg) continue
where
errmsg = "'" ++ tool ++ "' not found. Install it by: 'cypm install " ++
package ++ "'!"
-- Execute some command (first argument) with some arguments (second argument).
-- The current load path is exported to the command via the environment
-- variable CURRYPATH.
execCommandWithPath :: ReplState -> String -> [String]
-> IO (Maybe ReplState)
execCommandWithPath rst cmd args = do
let setpath = "CURRYPATH=" ++
intercalate [searchPathSeparator] (loadPaths rst) ++
" && export CURRYPATH && "
syscmd = setpath ++ cmd ++ ' ' : unwords args
writeVerboseInfo rst 2 $ "Executing: " ++ syscmd
system syscmd >> return (Just rst)
-- Check whether some system command is available. If it is not available,
-- skip the command with the given error message, otherwise continue with
-- the last argument.
checkForCommand :: String -> String -> IO (Maybe ReplState)
-> IO (Maybe ReplState)
checkForCommand cmd errmsg continue = do
excmd <- system $ "which " ++ cmd ++ " > /dev/null"
if (excmd>0) then skipCommand errmsg
else continue
-- Check whether the windowing shell "wish" is available.
checkForWish :: IO (Maybe ReplState) -> IO (Maybe ReplState)
checkForWish =
checkForCommand "wish"
"Windowing shell `wish' not found. Please install package `tk'!"
-- Terminate all open SourceProgGUIs
terminateSourceProgGUIs :: ReplState -> IO ReplState
terminateSourceProgGUIs rst
| null sguis = return rst
| otherwise = do
writeVerboseInfo rst 1 "Terminating source program GUIs..."
catch (mapM_ (\ (_,(_,h)) -> hPutStrLn h "q" >> hFlush h >> hClose h)
sguis)
(\_ -> return ())
return rst { sourceguis = [] }
where sguis = sourceguis rst
---------------------------------------------------------------------------
|