module SingleFileOps ( compile1
                     , run1
                     , FullBuildInfo
                     , ExtraCompileArgs(..)
                     ) where

import Control.Monad.List
import Distribution.PackageDescription
import Distribution.Simple
import Distribution.Simple.LocalBuildInfo hiding (prefix)
import Distribution.Simple.Utils
import List
import System (ExitCode)
import System.Directory (createDirectoryIfMissing)
import System.FilePath.Version_0_11

type FullBuildInfo = (LocalBuildInfo, BuildInfo)

myExtensionsToFlags :: FullBuildInfo -> [String]
myExtensionsToFlags (lbi, bi) =
  snd $ extensionsToFlags (compilerFlavor $ compiler lbi) (extensions bi)

importFlags :: FullBuildInfo -> [String]
importFlags fbi@(lbi, bi) =
  (["-i"] ++
   ["-i" ++ autogenModulesDir lbi] ++
   ["-i" ++ l | l <- nub (hsSourceDirs bi)] ++
   showPackageFlags fbi)

taggedImportFlags :: FullBuildInfo -> [BuildTag] -> [String]
taggedImportFlags fbi tags =
  let includePath = tag2Path fbi `fmap` tags
  in ["-i"] ++ ["-i" ++ i | i <- includePath] ++
     showPackageFlags fbi

showPackageFlags :: FullBuildInfo -> [String]
showPackageFlags (lbi, _) =
  concat [["-package", showPackageId pkg] | pkg <- packageDeps lbi]

type BuildTag = String

data ExtraCompileArgs = Define String (Maybe String)
                      | OtherOptions [(CompilerFlavor,[String])]

renderCompileArgs :: FullBuildInfo -> [ExtraCompileArgs] -> [String]
renderCompileArgs (lbi,_) = concatMap doRender
  where doRender (Define name Nothing) = ["-D" ++ name]
        doRender (Define name (Just value)) = ["-D" ++ name ++ "=" ++ value]
        doRender (OtherOptions options) =
          hcOptions (compilerFlavor $ compiler lbi) options

-- ghc-only HACK! TODO: Put it in Cabal's Distribution.Simple.Build.
--
-- This function assumes that all of the source's imports either have
-- already been compiled with one of the listed 'BuildTag's or are
-- available through one of the packages specified in the
-- 'FullBuildInfo'.
compile1 :: BuildTag  -- ^ This compile's output will be tagged with
                      -- this value.
         -> [BuildTag]  -- ^ This compile may depend on modules
                        -- compiled with this list of other
                        -- tags. Modules will be looked up in order,
                        -- with this compile's tag being automatically
                        -- prepended.
         -> FullBuildInfo
         -> [ExtraCompileArgs]
         -> FilePath  -- ^ Where to find the source for this compile.
         -> Int  -- ^ verbosity level
         -> IO ()
compile1 tag tagPath fbi@(lbi,_) extraArgs source verbose = do
  let odir = tag2Path fbi tag
      allTags = tag : tagPath
  createDirectoryIfMissing True odir
  rawSystemExit verbose
                (compilerPath (compiler lbi))
                (myExtensionsToFlags fbi ++
                 renderCompileArgs fbi extraArgs ++
                 (if (verbose > 4) then ["-v"] else []) ++
                 taggedImportFlags fbi allTags ++
                 ["-odir", odir, "-hidir", odir, "-c", source])


listDependencies :: FullBuildInfo -> [ExtraCompileArgs] -> String
                 -> Int -> IO [String]
listDependencies fbi@(lbi,_) extraArgs source verbose =
  withTempFile "." "d" $ \filename -> do
    rawSystemExit verbose
                  (compilerPath (compiler lbi))
                  (["-M", "-optdep-f", "-optdep" ++ filename] ++
                   myExtensionsToFlags fbi ++
                   renderCompileArgs fbi extraArgs ++
                   (if (verbose > 4) then ["-v"] else []) ++
                   importFlags fbi ++
                   [source])
    deps <- readFile filename
    return $ map head $ group $ sort $
             (\(a,b)->[a,b]) `concatMap` genGraph deps
  where
  genGraph :: String -> [(String, String)]
  genGraph file = getEdge `fmap` filter (not . isComment) (lines file)
  isComment ('#':_) = True
  isComment _ = False
  getEdge :: String -> (String, String)
  getEdge line = let (source, _:target) = break (==':') line
                 in (dropExtension source,
                     dropExtension (dropWhile (==' ') target))

link :: [BuildTag] -> FullBuildInfo -> [FilePath]
     -> FilePath -> Int -> IO ()
link tags fbi@(lbi,_) objects target verbose = do
  rawSystemExit verbose
                (compilerPath (compiler lbi))
                (["-o", target] ++
                 myExtensionsToFlags fbi ++
                 (if (verbose > 4) then ["-v"] else []) ++
                 taggedImportFlags fbi tags ++
                 objects)


-- Runs a single file which must provide a @main@ function in the
-- context of a series of tags.
run1 :: [BuildTag]  -- ^ This script may depend on modules compiled
                    -- with this list of other tags. Modules will be
                    -- looked up in order.
     -> FullBuildInfo
     -> [ExtraCompileArgs]
     -> FilePath  -- ^ Where to find the source for this compile.
     -> Int  -- ^ verbosity level
     -> IO ExitCode  -- ^ Exit code of the subprocess
run1 tagPath fbi@(lbi,_) extraArgs source verbose = do
  let tempTag = "run"
  let fullPath = tempTag : tagPath
      fileSearchPath = tag2Path fbi `fmap` fullPath
  compile1 tempTag tagPath fbi extraArgs source verbose
  dependedModules <- listDependencies fbi extraArgs source verbose
  oModules <-
    -- Assume that 'source' contained a Main module, which ghc puts at
    -- Main.o instead of in source.o.
    runListT $ do mod <- ListT $ return $ "Main" : dependedModules
                  found:_ <- liftIO $ moduleToFilePath fileSearchPath
                                                       mod
                                                       ["o"]
                  return found
  withTempFile "." "" $ \executable -> do
    link fullPath fbi oModules executable verbose
    -- The ("."</>) works around a bug in ghc-6.6's withTempFile.
    rawSystemVerbose verbose ("."</>executable) []

tag2Path :: FullBuildInfo -> BuildTag -> FilePath
tag2Path (lbi,_) tag = buildDir lbi </> tag