{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
module Coolbal.Target (
    IsTarget(..),
    AnyTarget(..),
    ExeTarget(..),
    useAnyTarget,
) where

import Data.Binary (Binary)
import Data.Char (ord)
import Data.List (intercalate)
import Data.Time.Clock (UTCTime)
import GHC.Generics (Generic)
import Numeric (showHex)
import System.Directory (createDirectoryIfMissing, doesFileExist, getModificationTime)
import System.Exit (ExitCode(..), die, exitWith)
import System.FilePath ((</>))
import System.IO.Error (catchIOError)
import System.Process (rawSystem)

import Coolbal.Util


class IsTarget a where
    -- | The name of the target.
    targetName :: a -> String

    -- | The name of the target, qualified with a cabal-style prefix indicating the kind of target.
    targetNameQualified :: a -> String

    -- | The name of the target, qualified with a cabal-style prefix indicating
    -- the kind of target, except that the ':' is rendered as a '-'.
    targetNameQualifiedFilename :: a -> FilePath
    targetNameQualifiedFilename tg = case break (== ':') (targetNameQualified tg) of
        (pre, ':' : post) -> pre ++ '-' : post
        _ -> error "targetNameQualifiedFilename: unexpected form of targetNameQualified"

    -- | Check whether the target must be recompiled due to changes on disk.
    -- Argument is the root directory of the project.
    targetCheckOld :: FilePath -> a -> IO Bool

    -- | Recompile the target. Argument is the root directory of the project.
    targetBuild :: FilePath -> a -> IO ()

    -- | If the target is an executable target, return an IO action that runs
    -- the executable with the specified arguments. The 'FilePath' is the root
    -- directory of the project.
    targetExecute :: a -> Maybe (FilePath -> [String] -> IO ())

data AnyTarget = AnyTargetExe ExeTarget
  deriving (Show, Generic)

instance Binary AnyTarget

useAnyTarget :: (forall a. (Show a, Binary a, IsTarget a) => a -> r) -> AnyTarget -> r
useAnyTarget f (AnyTargetExe x) = f x

data ExeTarget = ExeTarget
    { exeTargetName :: String
      -- ^ Target name, and name of output executable file
    , exeTargetPkgDbDir :: FilePath
      -- ^ Absolute path to the package.db directory
    , exeTargetDeps :: [String]
      -- ^ Package identifiers of dependencies (for -package-id flags)
    , exeTargetLanguage :: String
      -- ^ Haskell language (e.g. Haskell2010)
    , exeTargetMain :: FilePath
      -- ^ Main file
    , exeTargetSrcDirs :: [FilePath]
      -- ^ Source directories
    , exeTargetModules :: [[String]]
      -- ^ Other modules in the target
    , exeTargetFlags :: [String]
      -- ^ User-specified compiler flags
    }
  deriving (Show, Generic)

instance Binary ExeTarget

instance IsTarget ExeTarget where
    targetName = exeTargetName
    targetNameQualified e = "exe:" ++ targetName e

    targetCheckOld projdir tg = do
        mbinTm <- maybeModificationTime (projdir </> "dist-coolbal/bin" </> escapeFileName (exeTargetName tg))
        case mbinTm of
          Just binTm -> do
              anyNewerThan binTm (findFile' (exeTargetSrcDirs tg) (exeTargetMain tg)
                                 : [findSourceFile' (exeTargetSrcDirs tg) m | m <- exeTargetModules tg])
          Nothing ->
              return True

    targetBuild projdir tg = do
        let buildDir = projdir </> "dist-coolbal/build"
                               </> escapeFileName (targetNameQualifiedFilename tg)
            binDir = projdir </> "dist-coolbal/bin"
            binName = binDir </> escapeFileName (exeTargetName tg)
        createDirectoryIfMissing True binDir
        rawSystem "ghc" (concat
            [["--make", "-static"]
            ,concat [[flag, buildDir]
                    | flag <- ["-outputdir", "-odir", "-hidir", "-stubdir"]]
            ,["-i" ++ dir | dir <- exeTargetSrcDirs tg]
            ,["-hide-all-packages", "-Wmissing-home-modules", "-no-user-package-db"]
            ,["-package-db", exeTargetPkgDbDir tg]
            ,concat [["-package-id", dep] | dep <- exeTargetDeps tg]
            ,["-X" ++ exeTargetLanguage tg]
            ,[exeTargetMain tg]
            ,map (intercalate ".") (exeTargetModules tg)
            ,["-o", binName]
            ,exeTargetFlags tg])
          >>= checkExitCode "ghc"

    targetExecute tg = Just $ \projdir args -> do
        let filename = escapeFileName (exeTargetName tg)
        rawSystem (projdir </> "dist-coolbal/bin" </> filename) args
          >>= exitWith

checkExitCode :: String -> ExitCode -> IO ()
checkExitCode _ ExitSuccess = return ()
checkExitCode procname (ExitFailure c) =
    die (procname ++ " exited with code " ++ show c)

escapeFileName :: String -> FilePath
escapeFileName =
    -- NTFS/POSIX not allows: 0x00-0x1F 0x7F- : / " * < > ? \ |
    -- We use ! as an escape character, and hence disallow that too.
    genericEscapeString
        (\c -> let n = ord c
               in n <= 0x1F || n >= 0x7F || c `elem` ":/\"*<>?\\|!")
        (\c -> case (c, ord c) of
            ('!', _) -> "!!"
            (_, n) | n <= 0xFF -> '!' : leftPad 2 '0' (showHex n "")
                   | n <= 0xFFFF -> '!' : 'u' : leftPad 4 '0' (showHex n "")
                   | n <= 0xFFFFFF -> '!' : 'U' : leftPad 6 '0' (showHex n "")
                   | otherwise -> error "Super-high unicode?")
  where
    leftPad n c s = replicate (max 0 (n - length s)) c ++ s

maybeModificationTime' :: FilePath -> IO UTCTime
maybeModificationTime' path = maybeModificationTime path >>= \case
    Just tm -> return tm
    Nothing -> die ("File not found: '" ++ path ++ "'")

maybeModificationTime :: FilePath -> IO (Maybe UTCTime)
maybeModificationTime path = 
    catchIOError (Just <$> getModificationTime path) (\_ -> return Nothing)

findSourceFile' :: [FilePath] -> [String] -> IO FilePath
findSourceFile' ds m = findSourceFile ds m >>= \case
    Just fp -> return fp
    Nothing -> die ("Module not found in source directories: " ++ intercalate "." m)

findSourceFile :: [FilePath] -> [String] -> IO (Maybe FilePath)
findSourceFile dirs modname = findFile dirs (foldr (</>) "" modname ++ ".hs")

findFile' :: [FilePath] -> FilePath -> IO FilePath
findFile' ds fname = findFile ds fname >>= \case
    Just fp -> return fp
    Nothing -> die ("File not found in source directories: '" ++ fname ++ "'")

findFile :: [FilePath] -> FilePath -> IO (Maybe FilePath)
findFile [] _ = return Nothing
findFile (dir:ds) fname = do
    ok <- doesFileExist (dir </> fname)
    if ok then return (Just (dir </> fname))
          else findFile ds fname

anyNewerThan :: UTCTime -> [IO FilePath] -> IO Bool
anyNewerThan _ [] = return False
anyNewerThan reftm (fp:fps) = do
    fp' <- fp
    tm <- maybeModificationTime' fp'
    if tm > reftm
        then return True
        else anyNewerThan reftm fps