--- -------------------------------------------------------------------------- --- Some auxiliary operations for the REPL --- --- @author Michael Hanus --- @version November 2022 --- -------------------------------------------------------------------------- module REPL.Utils ( showMonoTypeExpr, showMonoQualTypeExpr , moduleNameToPath, validModuleName , getTimeCmd, getTimeoutCmd, removeFileIfExists , notNull, strip, lpad, rpad, writeErrorMsg ) where import Control.Monad ( when ) import Data.Char ( isSpace ) import Data.List ( intercalate ) import AbstractCurry.Types import System.Directory ( doesFileExist, removeFile ) import System.FilePath ( FilePath, () ) import REPL.State -------------------------------------------------------------------------- --- Shows an AbstractCurry type expression in standard Curry syntax. --- If the first argument is True, all occurrences of type variables --- are replaced by "()". showMonoQualTypeExpr :: Bool -> CQualTypeExpr -> String showMonoQualTypeExpr mono (CQualType cx ty) = showContext mono cx ++ showMonoTypeExpr mono ty --- Shows an AbstractCurry context in standard Curry syntax. --- If the first argument is True, no context is shown. showContext :: Bool -> CContext -> String showContext False (CContext cs) | null cs = "" | otherwise = parens (length cs > 1) (intercalate ", " (map showConstraint cs)) ++ " => " showContext True _ = "" --- Shows an AbstractCurry constraint in standard Curry syntax. showConstraint :: CConstraint -> String showConstraint ((_, name), ty) = showIdentifier name ++ " " ++ showMonoTypeExpr' False 2 ty --- Shows an AbstractCurry type expression in standard Curry syntax. --- If the first argument is True, all occurrences of type variables --- are replaced by "()". showMonoTypeExpr :: Bool -> CTypeExpr -> String showMonoTypeExpr mono ty = showMonoTypeExpr' mono 0 ty showMonoTypeExpr' :: Bool -> Int -> CTypeExpr -> String showMonoTypeExpr' mono _ (CTVar (_,name)) = if mono then "()" else showIdentifier name showMonoTypeExpr' mono p (CFuncType domain range) = parens (p > 0) $ showMonoTypeExpr' mono 1 domain ++ " -> " ++ showMonoTypeExpr' mono 0 range showMonoTypeExpr' _ _ (CTCons (_,name)) = name showMonoTypeExpr' mono p texp@(CTApply tcon targ) = maybe (parens (p > 1) $ showMonoTypeExpr' mono 2 tcon ++ " " ++ showMonoTypeExpr' mono 2 targ) (\ (mod,name) -> parens (p > 0) $ showTypeCons mono mod name (argsOfApply texp)) (funOfApply texp) where funOfApply te = case te of CTApply (CTCons qn) _ -> Just qn CTApply tc _ -> funOfApply tc _ -> Nothing argsOfApply te = case te of CTApply (CTCons _) ta -> [ta] CTApply tc ta -> argsOfApply tc ++ [ta] _ -> [] showTypeCons :: Bool -> String -> String -> [CTypeExpr] -> String showTypeCons _ _ name [] = name showTypeCons mono mod name ts@(_:_) | mod == "Prelude" = showPreludeTypeCons mono name ts | otherwise = name ++ prefixMap (showMonoTypeExpr' mono 2) ts " " showPreludeTypeCons :: Bool -> String -> [CTypeExpr] -> String showPreludeTypeCons mono name typelist | name == "[]" && head typelist == CTCons (pre "Char") = "String" | name == "[]" = "[" ++ showMonoTypeExpr' mono 0 (head typelist) ++ "]" | isTuple name = "(" ++ combineMap (showMonoTypeExpr' mono 0) typelist "," ++ ")" | otherwise = name ++ prefixMap (showMonoTypeExpr' mono 2) typelist " " -- Remove characters '<' and '>' from identifiers since these characters -- are sometimes introduced in new identifiers generated by the front end -- (for sections) showIdentifier :: String -> String showIdentifier = filter (`notElem` "<>") -- enclose string with parentheses if required by first argument parens :: Bool -> String -> String parens True s = '(' : s ++ ")" parens False s = s prefixMap :: (a -> [b]) -> [a] -> [b] -> [b] prefixMap f xs s = concatMap (s ++) (map f xs) combineMap :: (a -> [b]) -> [a] -> [b] -> [b] combineMap _ [] _ = [] combineMap f (x:xs) s = f x ++ prefixMap f xs s isTuple :: String -> Bool isTuple [] = False isTuple (x:xs) = x == '(' && p1_isTuple xs where p1_isTuple [] = False p1_isTuple (z:[]) = z == ')' p1_isTuple (z1:z2:zs) = z1 == ',' && p1_isTuple (z2:zs) --------------------------------------------------------------------------- --- Transforms a hierarchical module identifier into a file path. --- `moduleNameToPath "Data.Set"` evaluates to `"Data/Set"`. moduleNameToPath :: String -> FilePath moduleNameToPath = foldr1 () . splitModuleIdentifiers --- Split up the components of a module identifier. For instance, --- `splitModuleIdentifiers "Data.Set"` evaluates to `["Data", "Set"]`. splitModuleIdentifiers :: String -> [String] splitModuleIdentifiers s = let (pref, rest) = break (== '.') s in pref : case rest of [] -> [] _ : s' -> splitModuleIdentifiers s' --- Is a string a valid module name? validModuleName :: String -> Bool validModuleName = all (\c -> isAlphaNum c || c == '_' || c == '.') --------------------------------------------------------------------------- -- Decorates a shell command so that timing information is shown if -- the corresponding option is set. getTimeCmd :: ReplState -> String -> String -> IO String getTimeCmd rst timename cmd | showTime rst = return $ timeCmd ++ cmd | otherwise = return cmd where timeCmd = "time --format=\"" ++ timename ++ " time: %Us / elapsed: %E\" " -- Decorates a shell command with a timeout if the corresponding option is set. getTimeoutCmd :: ReplState -> String -> IO String getTimeoutCmd rst cmd | timeOut rst > 0 = do extocmd <- doesFileExist timeoutCmd return $ if extocmd then timeoutOptCmd ++ cmd else cmd | otherwise = return cmd where timeoutCmd = "/usr/bin/timeout" timeoutOptCmd = timeoutCmd ++ " " ++ show (timeOut rst) ++ "s " --- Removes the specified file only if it exists. removeFileIfExists :: FilePath -> IO () removeFileIfExists file = do exists <- doesFileExist file when exists $ removeFile file --------------------------------------------------------------------------- notNull :: [a] -> Bool notNull = not . null --- Remove leading and trailing whitespace strip :: String -> String strip = reverse . dropWhile isSpace . reverse . dropWhile isSpace --- Extend a String to a given minimal length by adding *leading* spaces. lpad :: Int -> String -> String lpad n s = replicate (n - length s) ' ' ++ s --- Extend a String to a given minimal length by adding *trailing* spaces. rpad :: Int -> String -> String rpad n s = s ++ replicate (n - length s) ' ' --------------------------------------------------------------------------- --- Shows an error message. writeErrorMsg :: String -> IO () writeErrorMsg msg = putStrLn $ "ERROR: " ++ msg ---------------------------------------------------------------------------