------------------------------------------------------------------------------ --- A universal REPL which can be used on top of a Curry compiler --- --- @author Michael Hanus --- @version March 2023 ------------------------------------------------------------------------------ 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:" , "" , " [ -- ]" , "" , "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 " , "set string for 'using' message in banner") , ("-Dprop=val" , "define rc property `prop' as `val'") , (": " , "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 checkAndCallCpmTool "curry-showflat" "showflatcurry" (\toolexec -> execCommandWithPath rst toolexec ["-int", modname]) --- 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 " - " [ ("" , "evaluate expression ") , ("let

= ", "add let binding for main expression") , (":load ", "load program '.[l]curry' as main module") , (":reload" , "recompile currently loaded modules") , (":add .. ", "add modules ,..., to currently loaded modules") , (":eval ", "evaluate expression ") , (":save ", "save executable with main expression ") , (":save" , "save executable with main expression 'main'") , (":type ", "show type of expression ") , (":quit" , "leave the system") ] ++ [ "\nFurther commands:\n" ] ++ formatVarVals " - " [ (":!" , "execute in shell") , (":browse" , "browse program and its imported modules") , (":cd

" , "change current directory to ") , (":compile " , "compile module (but do not load it)") , (":edit" , "load source of currently loaded module into editor") , (":edit " , "load source of module into editor") , (":fork " , "fork new process evaluating ") , (":help" , "show this message") , (":interface" , "show interface of currently loaded module") , (":interface ", "show interface of module ") , (":modules" , "show currently loaded modules with source information") , (":programs" , "show names of Curry modules available in load path") , (":set