1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186

--- --------------------------------------------------------------------------
--- 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

---------------------------------------------------------------------------