git.iko.soy/Idris-dev
on 5aaa39e help sign in
Idris-dev/src/Util/System.hs
134 lines 4.7 kB history raw
1{-|
2Module : Util.System
3Description : Utilities for interacting with the system.
4Copyright :
5License : BSD3
6Maintainer : The Idris Community.
7-}
8{-# LANGUAGE CPP, ForeignFunctionInterface #-}
9module Util.System( tempfile
10 , withTempdir
11 , rmFile
12 , catchIO
13 , isWindows
14 , writeSource
15 , writeSourceText
16 , readSource
17 , setupBundledCC
18 , isATTY
19 ) where
21import Control.Exception as CE
22import Control.Monad (when)
23import qualified Data.Text as T
24import qualified Data.Text.IO as TIO
25import Foreign.C
26import System.Directory (createDirectoryIfMissing, getTemporaryDirectory,
27 removeDirectoryRecursive, removeFile)
28import System.FilePath (normalise, (</>))
29import System.Info
30import System.IO
31import System.IO.Error
33#ifdef FREESTANDING
34import Data.List (intercalate)
35import System.Directory (doesDirectoryExist)
36import System.Environment (getEnv, getExecutablePath, setEnv)
37import System.FilePath (dropFileName, isAbsolute, searchPathSeparator)
38import Tools_idris
39#endif
41#ifdef mingw32_HOST_OS
42import Graphics.Win32.Misc (getStdHandle, sTD_OUTPUT_HANDLE)
43import System.Console.MinTTY (isMinTTYHandle)
44#endif
46catchIO :: IO a -> (IOError -> IO a) -> IO a
47catchIO = CE.catch
49isWindows :: Bool
50isWindows = os `elem` ["win32", "mingw32", "cygwin32"]
52-- | Create a temp file with the extensiom ext (in the format ".xxx")
53tempfile :: String -> IO (FilePath, Handle)
54tempfile ext = do dir <- getTemporaryDirectory
55 openTempFile (normalise dir) $ "idris" ++ ext
57-- | Read a source file, same as readFile but make sure the encoding is utf-8.
58readSource :: FilePath -> IO String
59readSource f = do h <- openFile f ReadMode
60 hSetEncoding h utf8
61 hGetContents h
63-- | Write a source file, same as writeFile except the encoding is set to utf-8
64writeSource :: FilePath -> String -> IO ()
65writeSource f s = withFile f WriteMode (\h -> hSetEncoding h utf8 >> hPutStr h s)
67-- | Write a utf-8 source file from Text
68writeSourceText :: FilePath -> T.Text -> IO ()
69writeSourceText f s = withFile f WriteMode (\h -> hSetEncoding h utf8 >> TIO.hPutStr h s)
71foreign import ccall "isatty" isATTYRaw :: CInt -> IO CInt
73isATTY :: IO Bool
74isATTY = do
75 tty <- isATTYRaw 1 -- fd stdout
76 mintty <- isMinTTY
77 return $ (tty /= 0) || mintty
79-- | Return 'True' if the process's standard output is attached to a MinTTY
80-- console (e.g., Cygwin or MSYS) on Windows. Return 'False' otherwise.
81--
82-- Unfortunately, we must check this separately since 'isATTY' always returns
83-- 'False' on MinTTY consoles.
84isMinTTY :: IO Bool
85#ifdef mingw32_HOST_OS
86isMinTTY = do
87 h <- getStdHandle sTD_OUTPUT_HANDLE
88 isMinTTYHandle h
89#else
90isMinTTY = return False
91#endif
93withTempdir :: String -> (FilePath -> IO a) -> IO a
94withTempdir subdir callback
95 = do dir <- getTemporaryDirectory
96 let tmpDir = normalise dir </> subdir
97 removeLater <- catchIO (createDirectoryIfMissing True tmpDir >> return True)
98 (\ ioError -> if isAlreadyExistsError ioError then return False
99 else throw ioError
100 )
101 result <- callback tmpDir
102 when removeLater $ removeDirectoryRecursive tmpDir
103 return result
105rmFile :: FilePath -> IO ()
106rmFile f = do
107 result <- try (removeFile f)
108 case result of
109 Right _ -> putStrLn $ "Removed: " ++ f
110 Left err -> handleExists err
111 where handleExists e
112 | isDoesNotExistError e = return ()
113 | otherwise = putStrLn $ "WARNING: Cannot remove file "
114 ++ f ++ ", Error msg:" ++ show e
116setupBundledCC :: IO()
117#ifdef FREESTANDING
118setupBundledCC = when hasBundledToolchain
119 $ do
120 exePath <- getExecutablePath
121 path <- getEnv "PATH"
122 tcDir <- return getToolchainDir
123 absolute <- return $ isAbsolute tcDir
124 target <- return $
125 if absolute
126 then tcDir
127 else dropFileName exePath ++ tcDir
128 present <- doesDirectoryExist target
129 when present $ do
130 newPath <- return $ intercalate [searchPathSeparator] [target, path]
131 setEnv "PATH" newPath
132#else
133setupBundledCC = return ()
134#endif