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

import Data.Char (ord)
import Data.List (intercalate)
import Numeric (showHex)
import System.Directory (createDirectoryIfMissing)
import System.Exit (ExitCode(..), die)
import System.FilePath ((</>))
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 ()

data AnyTarget = forall a. (Show a, IsTarget a) => AnyTarget a

deriving instance Show AnyTarget

useAnyTarget :: (forall a. (Show a, IsTarget a) => a -> r) -> AnyTarget -> r
useAnyTarget f (AnyTarget 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
    , exeTargetModules :: [[String]]
      -- ^ Other modules in the target
    , exeTargetFlags :: [String]
      -- ^ User-specified compiler flags
    }
  deriving (Show)

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

    targetCheckOld _ _ = 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" ++ buildDir, "-I" ++ buildDir]
            ,["-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"

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 -> '!' : showHex n ""
                   | n <= 0xFFFF -> '!' : 'u' : showHex n ""
                   | n <= 0xFFFFFF -> '!' : 'U' : showHex n ""
                   | otherwise -> error "Super-high unicode?")