--- --------------------------------------------------------------------------
--- Some auxiliary operations for the REPL
--- --------------------------------------------------------------------------

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

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