{-# LANGUAGE Haskell2010
    , ScopedTypeVariables
    , CPP
 #-}
{-# OPTIONS
    -Wall
    -fno-warn-missing-signatures
    -fno-warn-name-shadowing
 #-}

import Prelude hiding (catch)
import qualified Prelude as P

import Control.Exception

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" : _ -> do
            args_ <- catch (configure args buildOS) $ \exc -> do
                warn normal $
                    "Could not find a JDK. Continuing anyway.\n"
                 ++ "The error is: "
                 ++ ((show :: SomeException -> String) exc)
                return $
                    args ++ ["--extra-include-dirs=./include",
                             "--ghc-option=-optc-DFFIJNI_LIBJVM=!404!"]
            return args_
        _ -> 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 (fail "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 (fail "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
    -- default, nothing
    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