# Copyright 2005,2008 David Roundy

# Redistribution and use in source and binary forms of this file, with or
# without modification, are permitted provided that redistributions of
# source code must retain the above copyright notice.

# TRY_COMPILE_GHC(PROGRAM, [ACTION-IF-TRUE], [ACTION-IF-FALSE])
# -----------
# Compile and link using ghc.
AC_DEFUN([TRY_COMPILE_GHC],[
cat << \EOF > conftest.hs
[$1]
-- this file generated by TRY-COMPILE-GHC
EOF
rm -f Main.hi Main.o
# Convert LDFLAGS and LIBS to the format GHC wants them in
GHCLDFLAGS=""
for f in $LDFLAGS ; do
  GHCLDFLAGS="$GHCLDFLAGS -optl$f"
done
GHCLIBS=""
for l in $LIBS ; do
  GHCLIBS="$GHCLIBS -optl$l"
done
if AC_TRY_COMMAND($GHC $GHCFLAGS $GHCLDFLAGS -o conftest conftest.hs $GHCLIBS) && test -s conftest
then
dnl Don't remove the temporary files here, so they can be examined.
  ifelse([$2], , :, [$2])
else
  echo "configure: failed program was:" >&AS_MESSAGE_LOG_FD
  cat conftest.hs >&AS_MESSAGE_LOG_FD
  echo "end of failed program." >&AS_MESSAGE_LOG_FD
ifelse([$3], , , [ rm -f Main.hi Main.o
  $3
])dnl
fi])

# TRY_RUN_GHC(PROGRAM, [ACTION-IF-TRUE], [ACTION-IF-FALSE])
# -----------
# Compile, link and run using ghc.
AC_DEFUN([TRY_RUN_GHC],[
  TRY_COMPILE_GHC([$1],
    AS_IF([AC_TRY_COMMAND(./conftest)],[$2],[$3]),
    [$3])
])

# GHC_CHECK_ONE_MODULE(MODULE, [ACTION-IF-FOUND], [ACTION-IF-NOT-FOUND])
# -----------
# Compile and link using ghc.
AC_DEFUN([GHC_CHECK_ONE_MODULE],[
TRY_COMPILE_GHC([import $1
main = seq ($2) (putStr "Hello world.\n")
                ],[$3],[$4])

])

# GHC_CHECK_MODULE(MODULE, PACKAGE, CODE, [ACTION-IF-FOUND], [ACTION-IF-NOT-FOUND])
# -----------
# Compile and link using ghc.
AC_DEFUN([GHC_CHECK_MODULE],[
AC_MSG_CHECKING([for module $1])
GHC_CHECK_ONE_MODULE([$1], [$3], [AC_MSG_RESULT([yes])
$4], [
  check_module_save_GHCFLAGS=$GHCFLAGS
  GHCFLAGS="$GHCFLAGS -package $2"
  GHC_CHECK_ONE_MODULE([$1], [$3], [AC_MSG_RESULT([in package $2])
$4],[
    GHCFLAGS=$check_module_save_GHCFLAGS
    AC_MSG_RESULT(no; and neither in package $2)
    $5])
  ])
])

# GHC_COMPILE_FFI(IMPORT, TYPE, [ACTION-IF-FOUND], [ACTION-IF-NOT-FOUND])
# -----------
# Compile and link ffi code using ghc.
AC_DEFUN([GHC_COMPILE_FFI],[
TRY_COMPILE_GHC([{-# OPTIONS -fffi -Werror #-}
module Main where

foreign import ccall unsafe "$1" fun :: $2

main = fun `seq` putStrLn "hello world"
],[$3],[$4])])

# GHC_CHECK_LIBRARY(LIBRARY, IMPORT, TYPE, [ACTION-IF-FOUND], [ACTION-IF-NOT-FOUND])
# -----------
# Compile and link with C library using ghc.
AC_DEFUN([GHC_CHECK_LIBRARY],[
AC_MSG_CHECKING([for library $1])
GHC_COMPILE_FFI([$2], [$3], [AC_MSG_RESULT([yes])
$4], [
  check_library_save_LIBS=$LIBS
  LIBS="$LIBS -l$1"
  GHC_COMPILE_FFI([$2], [$3], [AC_MSG_RESULT([in -l$1])
  $4],[
    LIBS=$check_library_save_LIBS
    AC_MSG_RESULT(no; and not with -l$1 either)
    $5])
  ])
])

# INIT_WORKAROUND
# ---------------
# Initialize src/Workaround.hs module.
AC_DEFUN([INIT_WORKAROUND],[
rm -f src/Workaround.hs.beginning src/Workaround.hs.ending
touch src/Workaround.hs.ending
cat << \EOF > src/Workaround.hs.prefix
{-# OPTIONS -w #-}
{- Workaround.hs

This file was created automatically by configure.  We disable warnings to
avoid issues with duplicate imports.

-}

module Workaround(
EOF
cat << \EOF > src/Workaround.hs.beginning
 ) where

EOF
])

# OUTPUT_WORKAROUND
# -----------------
# Create the src/Workaround.hs module.
AC_DEFUN([OUTPUT_WORKAROUND],[
cat src/Workaround.hs.prefix src/Workaround.hs.beginning src/Workaround.hs.ending > src/Workaround.hs
rm -f src/Workaround.hs.beginning src/Workaround.hs.ending src/Workaround.hs.prefix
])

# IMPORT_WORKAROUND(CODE)
# -----------------------
# Import a module into src/Workaround.hs
AC_DEFUN([IMPORT_WORKAROUND],[
cat << \EOF >> src/Workaround.hs.beginning
$1
EOF
])

# EXPORT_WORKAROUND(CODE)
# -----------------------
# Export from src/Workaround.hs
AC_DEFUN([EXPORT_WORKAROUND],[
cat << \EOF >> src/Workaround.hs.prefix
$1
EOF
])

# CODE_WORKAROUND(CODE)
# ---------------------
# Import a module into src/Workaround.hs
AC_DEFUN([CODE_WORKAROUND],[
cat << \EOF >> src/Workaround.hs.ending
$1
EOF
])

# WORKAROUND_POSIXSIGNALS(IMPORTS)
# -----------------------
# Work around missing POSIX signals code.
AC_DEFUN([WORKAROUND_POSIXSIGNALS],[
  EXPORT_WORKAROUND([$1])
  GHC_CHECK_MODULE(System.Posix.Signals($1), unix, undefined,
    [IMPORT_WORKAROUND([import System.Posix.Signals($1)])],
    GHC_CHECK_MODULE(Posix($1), util, undefined,
      [IMPORT_WORKAROUND([import Posix($1)])],
      [CODE_WORKAROUND([[

-- Dummy implementation of POSIX signals

data Handler = Default | Ignore | Catch (IO ())
type Signal = Int

installHandler :: Signal -> Handler -> Maybe () -> IO ()
installHandler _ _ _ = return ()

raiseSignal :: Signal -> IO ()
raiseSignal _ = return ()

sigINT, {- sigKILL, -} sigHUP, {- sigQUIT, -} sigABRT, sigALRM, sigTERM, sigPIPE :: Signal
sigINT = 0
-- not used: sigKILL = 0
sigHUP = 0
-- not used: sigQUIT = 0
sigABRT = 0
sigTERM = 0
sigPIPE = 0
sigALRM = 0

-- not used: raiseSignal :: Signal -> IO ()
-- not used: raiseSignal _ = return ()

]])]
    )
  )
])

# WORKAROUND_bracketOnError
# -----------------------
# Work around missing bracketOnError
AC_DEFUN([WORKAROUND_bracketOnError],[
  EXPORT_WORKAROUND([           bracketOnError, ])
  GHC_CHECK_MODULE(Control.Exception( bracketOnError ), base ,
    bracketOnError (return ()) (const $ return ()) (const $ return ()),
    [IMPORT_WORKAROUND([import Control.Exception( bracketOnError )])],
    [IMPORT_WORKAROUND([import qualified Control.Exception( catch, throw, block, unblock )])
     CODE_WORKAROUND([[

-- | Like bracket, but only performs the final action if there was an
-- exception raised by the in-between computation.
-- From GHC 6.6 (with twiddling for qualified block, catch, etc)
bracketOnError
	:: IO a		-- ^ computation to run first (\"acquire resource\")
	-> (a -> IO b)  -- ^ computation to run last (\"release resource\")
	-> (a -> IO c)	-- ^ computation to run in-between
	-> IO c		-- returns the value from the in-between computation
bracketOnError before after thing =
  Control.Exception.block (do
    a <- before
    Control.Exception.catch
	(Control.Exception.unblock (thing a))
	(\e -> do { after a; Control.Exception.throw e })
  )
]])
])
])

# WORKAROUND_createLink
# -----------------------
# Work around missing POSIX createLink code.
AC_DEFUN([WORKAROUND_createLink],[
  EXPORT_WORKAROUND([           createLink, ])
  GHC_CHECK_MODULE(System.Posix.Files( createLink ), unix, createLink "a" "b",
    [IMPORT_WORKAROUND([import System.Posix.Files( createLink )])],
    GHC_CHECK_MODULE(Posix( createLink ), util, createLink "a" "b",
      [IMPORT_WORKAROUND([import Posix( createLink )])],
      [CODE_WORKAROUND([[

-- Dummy implementation of createLink.

createLink :: FilePath -> FilePath -> IO ()
createLink _ _ = fail "Dummy create link error should be caught."
]])]
    )
  )
])

# WORKAROUND_createDirectoryIfMissing
# ------------------------------
# Work around missing createDirectoryIfMissing.
AC_DEFUN([WORKAROUND_createDirectoryIfMissing],[
  EXPORT_WORKAROUND([           createDirectoryIfMissing, ])
  AC_MSG_CHECKING([createDirectoryIfMissing])
  TRY_COMPILE_GHC([
import System.Directory(createDirectoryIfMissing)
main = createDirectoryIfMissing True ""
    ],
    [AC_MSG_RESULT([has createDirectoryIfMissing])
     IMPORT_WORKAROUND([import System.Directory(createDirectoryIfMissing)])],
    [AC_MSG_RESULT([doesn't have createDirectoryIfMissing])
      IMPORT_WORKAROUND([import System.Directory ( doesDirectoryExist, createDirectory )])
      CODE_WORKAROUND([[
createDirectoryIfMissing
  :: Bool     -- ^ Create its parents too?
  -> FilePath -- ^ The path to the directory you want to make
  -> IO ()
createDirectoryIfMissing parents file = do
  b <- doesDirectoryExist file
  case (b,parents, file) of
    (_,     _, "") -> return ()
    (True,  _,  _) -> return ()
    (_,  True,  _) -> mapM_ (createDirectoryIfMissing False) (tail (pathParents file))
    (_, False,  _) -> createDirectory file
 where    pathParents :: FilePath -> [FilePath]
          pathParents p =
              root'' : map ((++) root') (dropEmptyPath $ inits path')
              where
#ifdef WIN32
                 (root,path) = case break (== ':') p of
                    (rel,    "") -> ("",rel)
                    (drv,_:rel) -> (drv++":",rel)
#else
                 (root,path) = ("",p)
#endif
                 (root',root'',path') = case path of
                   (c:path'') | isPathSeparator c -> (root++[pathSeparator],root++[pathSeparator],path'')
                   _                              -> (root                 ,root++"."            ,path)
          
                 dropEmptyPath ("":paths) = paths
                 dropEmptyPath paths      = paths
          
                 inits :: String -> [String]
                 inits [] =  [""]
                 inits cs =
                   case pre of
                     "."  -> inits suf
                     ".." -> map (joinFileName pre) (dropEmptyPath $ inits suf)
                     _    -> "" : map (joinFileName pre) (inits suf)
                   where
                     (pre,suf) = case break isPathSeparator cs of
                        (pre',"")     -> (pre', "")
                        (pre',_:suf') -> (pre',suf')
                 isPathSeparator :: Char -> Bool
                 isPathSeparator ch = ch == pathSeparator || ch == '/'
                 pathSeparator :: Char
#ifdef WIN32
                 pathSeparator = '\\'
#else
                 pathSeparator = '/'
#endif
                 joinFileName :: String -> String -> FilePath
                 joinFileName ""  fname = fname
                 joinFileName "." fname = fname
                 joinFileName dir ""    = dir
                 joinFileName dir fname
                   | isPathSeparator (last dir) = dir++fname
                   | otherwise                  = dir++pathSeparator:fname
      ]])
    ]
  )
])

# WORKAROUND_getCurrentDirectory
# ------------------------------
# Work around getCurrentDirectory that uses '\\' rather than '/'.
AC_DEFUN([WORKAROUND_getCurrentDirectory],[
  EXPORT_WORKAROUND([           getCurrentDirectory, ])
  AC_MSG_CHECKING([getCurrentDirectory])
  TRY_RUN_GHC([
import System.Directory(getCurrentDirectory, setCurrentDirectory)
main = do setCurrentDirectory "src"
          d <- getCurrentDirectory
          case reverse $ take 4 $ reverse d of
              "/src" -> return ()
    ],
    [AC_MSG_RESULT([uses /])
     IMPORT_WORKAROUND([import System.Directory(getCurrentDirectory)])]
     GHC_SEPARATOR='/',
    [AC_MSG_RESULT([uses \\])
      IMPORT_WORKAROUND([import qualified System.Directory(getCurrentDirectory)])
      GHC_SEPARATOR='\\'
      CODE_WORKAROUND([[
{-
System.Directory.getCurrentDirectory returns a path with backslashes in it
under windows, and some of the code gets confused by that, so we override
getCurrentDirectory and translates '\\' to '/'
-}

getCurrentDirectory :: IO FilePath
getCurrentDirectory = do d <- System.Directory.getCurrentDirectory
                         return $ map rb d
    where rb '\\' = '/'
          rb c = c
      ]])
    ]
  )
])

# WORKAROUND_renameFile
# -----------------------
# Work around buggy renameFile.
AC_DEFUN([WORKAROUND_renameFile],[
  EXPORT_WORKAROUND([           renameFile, ])
  AC_MSG_CHECKING([renameFile])
  TRY_RUN_GHC([
import System.Directory ( renameFile )

main = do writeFile "conftest.data" "orig_data"
          writeFile "conftest.newdata" "new_data"
          renameFile "conftest.newdata" "conftest.data"
    ],
    [AC_MSG_RESULT([okay])
     IMPORT_WORKAROUND([import System.Directory ( renameFile )])],
    AC_MSG_RESULT([buggy!])
    IMPORT_WORKAROUND([import qualified System.Directory( renameFile, removeFile )])
    IMPORT_WORKAROUND([import qualified System.IO.Error])
    IMPORT_WORKAROUND([import qualified Control.Exception ( block )])
    CODE_WORKAROUND([
{-
System.Directory.renameFile incorrectly fails when the new file already
exists.  This code works around that bug at the cost of losing atomic
writes.
-}

renameFile :: FilePath -> FilePath -> IO ()
renameFile old new = Control.Exception.block $
   do System.Directory.removeFile new
        `System.IO.Error.catch`
         (\e -> if System.IO.Error.isDoesNotExistError e
                   then return ()
                   else System.IO.Error.ioError e)
      System.Directory.renameFile old new
     ])
  )
])

# WORKAROUND_fileModes
# --------------------
# Figure out how to set unix permissions on a file (or creates a dummy
# function for this).

AC_DEFUN([WORKAROUND_fileModes],[
  EXPORT_WORKAROUND([           fileMode, getFileStatus, setFileMode, ])
  GHC_CHECK_MODULE(System.Posix.Files( fileMode, getFileStatus, setFileMode ), unix, getFileStatus "",
    IMPORT_WORKAROUND([import System.Posix.Files(fileMode,getFileStatus,setFileMode)]),
    CODE_WORKAROUND([
fileMode :: () -> ()
fileMode _ = ()
getFileStatus :: FilePath -> IO ()
getFileStatus _ = return ()
setFileMode :: FilePath -> () -> IO ()
setFileMode _ _ = return ()
])
  )
])

# WORKAROUND_executable
# --------------------
# Figure out how to make a file executable (or test if it is).

AC_DEFUN([WORKAROUND_executable],[
  EXPORT_WORKAROUND([           setExecutable, ])
  GHC_CHECK_MODULE(System.Posix.Files( fileMode, getFileStatus, setFileMode, setFileCreationMask ),
                   unix, getFileStatus "",
    IMPORT_WORKAROUND([
import System.Posix.Files (fileMode,getFileStatus, setFileMode, nullFileMode,
                           setFileCreationMask,
                           ownerReadMode, ownerWriteMode, ownerExecuteMode,
                           groupReadMode, groupWriteMode, groupExecuteMode,
                           otherReadMode, otherWriteMode, otherExecuteMode)
import Data.Bits ( (.&.), (.|.), complement )

setExecutable :: FilePath -> Bool -> IO ()
setExecutable f ex =
  do st <- getFileStatus f
     umask <- setFileCreationMask 0
     setFileCreationMask umask
     let rw = fileMode st .&.
              (ownerReadMode .|. ownerWriteMode .|.
               groupReadMode .|. groupWriteMode .|.
               otherReadMode .|. otherWriteMode)
         total = if ex then rw .|.
                           ((ownerExecuteMode .|. groupExecuteMode .|. otherExecuteMode)
                            .&. complement umask)
                       else rw
     setFileMode f total
]),
    CODE_WORKAROUND([
setExecutable :: FilePath -> Bool -> IO ()
setExecutable _ _ = return ()
])
  )
])

# WORKAROUND_openFd
# -----------------------
# Work around changing openFd function
AC_DEFUN([WORKAROUND_openFd],[
  EXPORT_WORKAROUND([           openFd, ])
  AC_MSG_CHECKING([GHC.Handle.openFd])
  TRY_RUN_GHC([
import GHC.Handle ( openFd )
import IO ( IOMode(..))

main = openFd 1 Nothing "stdout" WriteMode True False
    ],
     AC_MSG_RESULT([okay])
     IMPORT_WORKAROUND([import GHC.Handle( openFd )]),
     AC_MSG_RESULT([NOT old API])
     AC_MSG_CHECKING([GHC.Handle.openFd new API])
     TRY_RUN_GHC([
import GHC.Handle ( openFd )
import IO ( IOMode(..))

main = openFd 1 Nothing False "stdout" WriteMode True
      ],
      AC_MSG_RESULT([okay])
      IMPORT_WORKAROUND([import qualified GHC.Handle ( openFd )
import System.IO ( Handle, IOMode )
import System.Posix.Internals ( FDType )
])
      CODE_WORKAROUND([[
{-
Work around change in the GHC.Handle.openFd API.
-}
openFd :: Int -> Maybe FDType -> FilePath -> IOMode -> Bool -> Bool -> IO Handle
openFd fd x y z a b = GHC.Handle.openFd fd x b y z a
        ]]),
       AC_MSG_RESULT([NOT 'new' API])
       AC_MSG_CHECKING([GHC.Handle.fdToHandle' API])
       TRY_RUN_GHC([
import GHC.Handle ( fdToHandle' )
import IO ( IOMode(..) )

main = fdToHandle' 1 Nothing False "stdout" WriteMode True
       ],
       AC_MSG_RESULT([okay])
       IMPORT_WORKAROUND([import qualified GHC.Handle ( fdToHandle' )
import System.IO ( Handle, IOMode )
import System.Posix.Internals ( FDType )
])
       CODE_WORKAROUND([[
{-
Work around renaming of GHC.Handle.openFd and change in its API.
-}
openFd :: Int -> Maybe FDType -> FilePath -> IOMode -> Bool -> Bool -> IO Handle
openFd fd x y z a b = GHC.Handle.fdToHandle' (fromIntegral fd) x b y z a
        ]]),
       AC_MSG_RESULT([failed])
       AC_MSG_ERROR([Couldnt figure out how to call GHC.Handle.openFd!])
    )
  )
)])