diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2012 Simon Hengel + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/base-compat.cabal b/base-compat.cabal new file mode 100644 --- /dev/null +++ b/base-compat.cabal @@ -0,0 +1,58 @@ +name: base-compat +version: 0.0.0 +license: MIT +license-file: LICENSE +copyright: (c) 2012 Simon Hengel +author: Simon Hengel +maintainer: Simon Hengel +build-type: Simple +cabal-version: >= 1.8 +category: System +synopsis: Provide new additions to base for older versions of base +description: Provide new additions to base for older versions of base, so + that you can use them without sacrificing backward + compatibility. + . + Currently the following is covered: + . + * Text.Read.readMaybe + . + * Text.Read.readEither + . + * System.Environment.lookupEnv + . + * System.Environment.getExecutablePath + +source-repository head + type: git + location: https://github.com/sol/base-compat + +library + ghc-options: + -Wall + hs-source-dirs: + src + exposed-modules: + System.Environment.Compat + Text.Read.Compat + other-modules: + -- This is compiled, even if it is not needed (base >= 4.6.0.0). We + -- probably want to prevent this. + System.Environment.ExecutablePath + build-depends: + base == 4.* + +test-suite spec + type: + exitcode-stdio-1.0 + ghc-options: + -Wall -Werror + hs-source-dirs: + test + main-is: + Spec.hs + build-depends: + base + , base-compat + , hspec >= 1.3 + , setenv diff --git a/src/System/Environment/Compat.hs b/src/System/Environment/Compat.hs new file mode 100644 --- /dev/null +++ b/src/System/Environment/Compat.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE CPP #-} +-- | Miscellaneous information about the system environment. +module System.Environment.Compat ( + getArgs +, getProgName +, getExecutablePath +, getEnv +, lookupEnv +, withArgs +, withProgName +, getEnvironment +) where + +import System.Environment + +#if !MIN_VERSION_base(4,6,0) +import System.Environment.ExecutablePath +#endif + +#if !MIN_VERSION_base(4,6,0) +-- | Return the value of the environment variable @var@, or @Nothing@ if +-- there is no such value. +-- +-- For POSIX users, this is equivalent to 'System.Posix.Env.getEnv'. +lookupEnv :: String -> IO (Maybe String) +lookupEnv k = lookup k `fmap` getEnvironment +#endif diff --git a/src/System/Environment/ExecutablePath.hsc b/src/System/Environment/ExecutablePath.hsc new file mode 100644 --- /dev/null +++ b/src/System/Environment/ExecutablePath.hsc @@ -0,0 +1,172 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE CPP, ForeignFunctionInterface #-} + +----------------------------------------------------------------------------- +-- | +-- Module : System.Environment.ExecutablePath +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Function to retrieve the absolute filepath of the current executable. +-- +----------------------------------------------------------------------------- + +module System.Environment.ExecutablePath ( getExecutablePath ) where + +-- The imports are purposely kept completely disjoint to prevent edits +-- to one OS implementation from breaking another. + +#if defined(darwin_HOST_OS) +import Data.Word +import Foreign.C +import Foreign.Marshal.Alloc +import Foreign.Ptr +import Foreign.Storable +import System.Posix.Internals +#elif defined(linux_HOST_OS) +import Foreign.C +import Foreign.Marshal.Array +import System.Posix.Internals +#elif defined(mingw32_HOST_OS) +import Data.Word +import Foreign.C +import Foreign.Marshal.Array +import Foreign.Ptr +import System.Posix.Internals +#else +import Foreign.C +import Foreign.Marshal.Alloc +import Foreign.Ptr +import Foreign.Storable +import System.Posix.Internals +#endif + +-- The exported function is defined outside any if-guard to make sure +-- every OS implements it with the same type. + +-- | Returns the absolute pathname of the current executable. +-- +-- Note that for scripts and interactive sessions, this is the path to +-- the interpreter (e.g. ghci.) +getExecutablePath :: IO FilePath + +-------------------------------------------------------------------------------- +-- Mac OS X + +#if defined(darwin_HOST_OS) + +type UInt32 = Word32 + +foreign import ccall unsafe "mach-o/dyld.h _NSGetExecutablePath" + c__NSGetExecutablePath :: CString -> Ptr UInt32 -> IO CInt + +-- | Returns the path of the main executable. The path may be a +-- symbolic link and not the real file. +-- +-- See dyld(3) +_NSGetExecutablePath :: IO FilePath +_NSGetExecutablePath = + allocaBytes 1024 $ \ buf -> -- PATH_MAX is 1024 on OS X + alloca $ \ bufsize -> do + poke bufsize 1024 + status <- c__NSGetExecutablePath buf bufsize + if status == 0 + then peekFilePath buf + else do reqBufsize <- fromIntegral `fmap` peek bufsize + allocaBytes reqBufsize $ \ newBuf -> do + status2 <- c__NSGetExecutablePath newBuf bufsize + if status2 == 0 + then peekFilePath newBuf + else error "_NSGetExecutablePath: buffer too small" + +foreign import ccall unsafe "stdlib.h realpath" + c_realpath :: CString -> CString -> IO CString + +-- | Resolves all symbolic links, extra \/ characters, and references +-- to \/.\/ and \/..\/. Returns an absolute pathname. +-- +-- See realpath(3) +realpath :: FilePath -> IO FilePath +realpath path = + withFilePath path $ \ fileName -> + allocaBytes 1024 $ \ resolvedName -> do + _ <- throwErrnoIfNull "realpath" $ c_realpath fileName resolvedName + peekFilePath resolvedName + +getExecutablePath = _NSGetExecutablePath >>= realpath + +-------------------------------------------------------------------------------- +-- Linux + +#elif defined(linux_HOST_OS) + +foreign import ccall unsafe "readlink" + c_readlink :: CString -> CString -> CSize -> IO CInt + +-- | Reads the @FilePath@ pointed to by the symbolic link and returns +-- it. +-- +-- See readlink(2) +readSymbolicLink :: FilePath -> IO FilePath +readSymbolicLink file = + allocaArray0 4096 $ \buf -> do + withFilePath file $ \s -> do + len <- throwErrnoPathIfMinus1 "readSymbolicLink" file $ + c_readlink s buf 4096 + peekFilePathLen (buf,fromIntegral len) + +getExecutablePath = readSymbolicLink $ "/proc/self/exe" + +-------------------------------------------------------------------------------- +-- Windows + +#elif defined(mingw32_HOST_OS) + +# if defined(i386_HOST_ARCH) +## define WINDOWS_CCONV stdcall +# elif defined(x86_64_HOST_ARCH) +## define WINDOWS_CCONV ccall +# else +# error Unknown mingw32 arch +# endif + +foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW" + c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32 + +getExecutablePath = go 2048 -- plenty, PATH_MAX is 512 under Win32 + where + go size = allocaArray (fromIntegral size) $ \ buf -> do + ret <- c_GetModuleFileName nullPtr buf size + case ret of + 0 -> error "getExecutablePath: GetModuleFileNameW returned an error" + _ | ret < size -> peekFilePath buf + | otherwise -> go (size * 2) + +-------------------------------------------------------------------------------- +-- Fallback to argv[0] + +#else + +foreign import ccall unsafe "getFullProgArgv" + c_getFullProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO () + +getExecutablePath = + alloca $ \ p_argc -> + alloca $ \ p_argv -> do + c_getFullProgArgv p_argc p_argv + argc <- peek p_argc + if argc > 0 + -- If argc > 0 then argv[0] is guaranteed by the standard + -- to be a pointer to a null-terminated string. + then peek p_argv >>= peek >>= peekFilePath + else error $ "getExecutablePath: " ++ msg + where msg = "no OS specific implementation and program name couldn't be " ++ + "found in argv" + +-------------------------------------------------------------------------------- + +#endif diff --git a/src/Text/Read/Compat.hs b/src/Text/Read/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Text/Read/Compat.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Text.Read +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : non-portable (uses Text.ParserCombinators.ReadP) +-- +-- Converting strings to values. +-- +-- The "Text.Read" library is the canonical library to import for +-- 'Read'-class facilities. For GHC only, it offers an extended and much +-- improved 'Read' class, which constitutes a proposed alternative to the +-- Haskell 98 'Read'. In particular, writing parsers is easier, and +-- the parsers are much more efficient. +-- +----------------------------------------------------------------------------- +module Text.Read.Compat ( + -- * The 'Read' class + Read(..), + ReadS, + + -- * Haskell 98 functions + reads, + read, + readParen, + lex, + + -- * New parsing functions + module Text.ParserCombinators.ReadPrec, + Lexeme(..), + lexP, + parens, + readListDefault, + readListPrecDefault, + readEither, + readMaybe +) where + +import Text.Read +import Text.ParserCombinators.ReadPrec + +#if !MIN_VERSION_base(4,6,0) +import qualified Text.ParserCombinators.ReadP as P + +-- | Parse a string using the 'Read' instance. +-- Succeeds if there is exactly one valid result. +-- A 'Left' value indicates a parse error. +readEither :: Read a => String -> Either String a +readEither s = + case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of + [x] -> Right x + [] -> Left "Prelude.read: no parse" + _ -> Left "Prelude.read: ambiguous parse" + where + read' = + do x <- readPrec + lift P.skipSpaces + return x + +-- | Parse a string using the 'Read' instance. +-- Succeeds if there is exactly one valid result. +readMaybe :: Read a => String -> Maybe a +readMaybe s = case readEither s of + Left _ -> Nothing + Right a -> Just a +#endif diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}