{-# LANGUAGE Haskell2010
, ScopedTypeVariables
, CPP
#-}
{-# OPTIONS
-Wall
-fno-warn-missing-signatures
-fno-warn-name-shadowing
#-}
import Prelude
import qualified Prelude as P
import Data.List
import Distribution.PackageDescription
import Distribution.System
import Distribution.Simple
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.PreProcess
import Distribution.Simple.Utils
import Distribution.Verbosity
import System.Environment
import System.Directory
import System.FilePath
import Text.Printf
import Language.Preprocessor.Cpphs
#if linux_HOST_OS == 1 || darwin_HOST_OS == 1
import System.Posix.Files
#endif
main = do
args <- getArgs
args' <- case args of
"configure" : _ -> configure args buildOS
_ -> return args
let hooks = simpleUserHooks {
hookedPreProcessors = [ ("tpl", transformTpl)
, ("hss", transformHss)
, ("cpphs", transformCpphs) ]
}
defaultMainWithHooksArgs hooks args'
transformCpphs :: BuildInfo -> LocalBuildInfo -> PreProcessor
transformCpphs _ _ = PreProcessor True $ \(inDir, inFile) (outDir, outFile) _ -> do
source <- readFile (inDir </> inFile)
_ <- printf "Preprocessing (CPPHS) %s -> %s\n"
(inDir </> inFile) (outDir </> outFile)
let options = defaultCpphsOptions {
boolopts = (defaultBoolOptions { ansi = True })
}
runCpphs options (inDir </> inFile) source
>>= writeFile (outDir </> outFile)
transformTpl :: BuildInfo -> LocalBuildInfo -> PreProcessor
transformTpl _ _ = PreProcessor True $ \(inDir, inFile) (outDir, outFile) _ -> do
let (baseDir, _) = splitFileName (inDir </> inFile)
template <- readFile (inDir </> inFile)
let (templateFile, params) = read (filter (/= '\n') template)
:: (String, [(String, String)])
_ <- printf "Preprocessing (TPL) %s -> %s (using %s)\n"
(inDir </> inFile) (outDir </> outFile) templateFile
template <- readFile (baseDir ++ templateFile)
writeFile (outDir </> outFile) (processTpl params template)
processTpl params xss = case xss of
('%':xs) -> let (var, (_:rest)) = break (== '%') xs
in maybe "" id (lookup var params) ++ processTpl params rest
(x:xs) -> x : processTpl params xs
"" -> ""
transformHss :: BuildInfo -> LocalBuildInfo -> PreProcessor
-- ^ Transforms a *.hss file containing TriString-literals ("""triString""")
-- into an ordinary *.hs file.
transformHss _ _ = PreProcessor True $ \(inDir, inFile) (outDir, outFile) _ -> do
source <- readFile (inDir </> inFile)
_ <- printf "Preprocessing (HSS) %s -> %s\n"
(inDir </> inFile) (outDir </> outFile)
writeFile (outDir </> outFile) (doProcessHss inFile source)
-- | The actual processing of 'transformHss'. No advanced method of parsing
-- have been used in order to reduce the dependencies of the Setup script
-- and to now blow it up by a whole combinator library or auto generated code.
--
-- Every triString is replaced by the concatenation of ordinary haskell
-- strings. Code embedded in curly braces (introduced by a hash sign) is
-- embedded literally. LINE pragmas keep the line numbers consistent.
doProcessHss file = processHss (1 :: Int)
where
processHss n xs = case xs of
('"':'"':'"':xs) -> triString n xs
('{':'-':xs) -> '{' : '-' : comment n (1 :: Int) xs
('"':xs) -> '"' : string n xs
('\n':xs) -> '\n' : processHss (succ n) xs
(x:xs) -> x : processHss n xs
"" -> ""
where
triString n xs = case breakIt xs of
(str, xs) -> concat [ "((\\_ -> let { __ = "
, "\n{-# LINE ", show n, " ", show file, " #-}\n"
, sanitizeIt (mkTriString str)
, "\n{-# LINE ", show n', " ", show file, " #-}\n"
, "} in __) undefined)"
, processHss n' xs ]
where n' = n + length (filter (== '\n') str)
breakIt xs = case xs of
('"':'"':'"':xs) -> ("", xs)
(x:xs) -> case breakIt xs of (y, ys) -> (x : y, ys)
"" -> ("", "")
sanitizeIt xs = case xs of
('\\':'\\':'n':xs) -> sanitizeIt xs
(x:xs) -> x : sanitizeIt xs
"" -> ""
mkTriString xs = "concat [\"" ++ process string ++ "\"]"
where
string = concat $ intersperse "\\n" lines
process xs = case xs of
('#':'{':xs) -> case break (== '}') xs of
(ls, (_:rs)) -> "\", (" ++ ls ++ "), \"" ++ process rs
_ -> error "could not match closing curly brace"
('"':xs) -> '\\' : '"' : process xs
(x:xs) -> x : process xs
[] -> []
lines = case P.lines xs of
("":lines) -> map (dedent (indent lines)) lines
(line:[]) -> [line]
lines@(_:lines') -> map (dedent (indent lines')) lines
[] -> []
indent xs = case xs of
[] -> 0
_ -> minimum $ map (length . takeWhile (== ' ')) xs
dedent n line = case splitAt n line of
(ls, rs) -> dropWhile (== ' ') ls ++ rs
comment l 1 ('-':'}':xs) = '-' : '}' : processHss l xs
comment l n xs = case xs of
('{':'-':xs) -> '{' : '-' : comment l (succ n) xs
('-':'}':xs) -> '-' : '}' : comment l (pred n) xs
('\n':xs) -> '\n' : comment (succ l) n xs
(x:xs) -> x : comment l n xs
"" -> ""
string l xs = case xs of
('\\':'"':xs) -> '\\' : '"' : string l xs
('"':xs) -> '"' : processHss l xs
(x:xs) -> x : string l xs
"" -> ""
configure args OSX = do
-- In Mac OS X there is the tool /usr/libexec/java_home which tells
-- us where JRE and JDK are installed.
javaHome <- findFirstFile id ["/usr/libexec/java_home"]
>>= maybe (die "Could not determine JAVA_HOME using /usr/libexec/java_home - is there a JDK installed?")
return
>>= (\cmd -> rawSystemStdout silent cmd [])
>>= return . head . lines
libjvmPath <- getEnvironment >>= return . lookup "FFIJNI_LIBJVM"
>>= maybe (return $ javaHome ++ "/jre/lib/server/libjvm.dylib") return
notice normal $ "JAVA_HOME=" ++ javaHome
notice normal $ "FFIJNI_LIBJVM=" ++ libjvmPath
return $ args ++ ["--extra-include-dirs=" ++ javaHome ++ "/include",
"--extra-include-dirs=" ++ javaHome ++ "/include/darwin",
"--ghc-option=-optc-DFFIJNI_LIBJVM=" ++ libjvmPath]
configure args Linux = do
-- In Linux we find out where javac lives and resolve all
-- symlinks until we find the JDK home.
javaHome <- findExecutable "javac"
>>= maybe (die "Could not determine path to javac.") return
>>= resolve >>= return . takeDirectory . takeDirectory
rawSystemExit normal "javac" ["GetProperty.java"]
javaArch <- rawSystemStdout normal "java" ["GetProperty", "os.arch"]
>>= return . head . lines
libjvmPath <- getEnvironment >>= return . lookup "FFIJNI_LIBJVM"
>>= maybe (return $ javaHome ++ "/jre/lib/" ++ javaArch ++ "/server/libjvm.so") return
notice normal $ "JAVA_HOME=" ++ javaHome
notice normal $ "FFIJNI_LIBJVM=" ++ libjvmPath
return $ args ++ ["--extra-include-dirs=" ++ javaHome ++ "/include",
"--extra-include-dirs=" ++ javaHome ++ "/include/linux",
"--ghc-option=-optc-DFFIJNI_LIBJVM=" ++ libjvmPath]
configure args Windows = do
-- The strategy for finding a JDK in Windows is rather simplistic.
-- Typically the JDK is installed in %ProgramFiles%/Java, so we look
-- into that directory for directories starting with @jdk@. We choose
-- the one with the highest version number (that's what sort is for).
programFiles <- getEnv "ProgramFiles"
javaHome <- getDirectoryContents (programFiles ++ "\\Java")
>>= return . (programFiles ++) . ("\\Java\\" ++) . last . sort . filter ("jdk" `isPrefixOf`)
libjvmPath <- getEnvironment >>= return . lookup "FFIJNI_LIBJVM"
>>= maybe (return $ javaHome ++ "\\jre\\bin\\server\\jvm.dll") return
>>= return . replace '\\' '/'
notice normal $ "JAVA_HOME=" ++ javaHome
notice normal $ "FFIJNI_LIBJVM=" ++ libjvmPath
return $ args ++ ["--extra-include-dirs=" ++ javaHome ++ "/include",
"--extra-include-dirs=" ++ javaHome ++ "/include/win32",
"--ghc-option=-optc-DFFIJNI_LIBJVM=" ++ libjvmPath]
configure args _ = do
return args
replace :: Char -> Char -> String -> String
replace needle replacement haystack = case haystack of
(x:xs) -> (if x == needle then replacement else x) : replace needle replacement xs
[] -> []
resolve :: FilePath -> IO FilePath
#if linux_HOST_OS == 1 || darwin_HOST_OS == 1
resolve filePath = do
stat <- getSymbolicLinkStatus filePath
if isSymbolicLink stat
then readSymbolicLink filePath >>= resolve
else return filePath
#else
-- in Windows there are no Symlinks, thus resolve does nothing.
resolve = return
#endif