|
sourcecode:
|
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), ts) = unwords $
showIdentifier name : map (showMonoTypeExpr' False 2) ts
--- 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
---------------------------------------------------------------------------
|