{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE LambdaCase #-}
module Main where

import Distribution.Simple
import Distribution.Simple.BuildPaths
import Distribution.Types.LocalBuildInfo
import Distribution.Verbosity
import Distribution.Simple.Program
import Distribution.Simple.Utils
import Distribution.Simple.Setup

import System.IO
import System.Directory
import System.FilePath
import System.Environment
import Control.Monad
import Data.Char
import GHC.ResponseFile

main :: IO ()
main = defaultMainWithHooks ghcHooks
  where
    ghcHooks = simpleUserHooks
      { postConf = \args cfg pd lbi -> do
          let verbosity = fromFlagOrDefault minBound (configVerbosity cfg)
          ghcAutogen verbosity lbi
          postConf simpleUserHooks args cfg pd lbi
      }

ghcAutogen :: Verbosity -> LocalBuildInfo -> IO ()
ghcAutogen verbosity lbi@LocalBuildInfo{..} = do
  -- Get compiler/ root directory from the cabal file
  let Just compilerRoot = takeDirectory <$> pkgDescrFile

  let platformHostFile = "GHC/Platform/Host.hs"
      platformHostPath = autogenPackageModulesDir lbi </> platformHostFile
      ghcVersionFile = "GHC/Version.hs"
      ghcVersionPath = autogenPackageModulesDir lbi </> ghcVersionFile

  -- Get compiler settings
  settings <- lookupEnv "HADRIAN_SETTINGS" >>= \case
    Just settings -> pure $ Left $ read settings
    Nothing -> do
      (ghc,withPrograms) <- requireProgram normal ghcProgram withPrograms
      Right . read <$> getProgramOutput normal ghc ["--info"]

  -- Write GHC.Platform.Host
  createDirectoryIfMissingVerbose verbosity True (takeDirectory platformHostPath)
  rewriteFileEx verbosity platformHostPath (generatePlatformHostHs settings)

  -- Write GHC.Version
  createDirectoryIfMissingVerbose verbosity True (takeDirectory ghcVersionPath)
  rewriteFileEx verbosity ghcVersionPath (generateVersionHs settings)

-- | Takes either a list of hadrian generated settings, or a list of settings from ghc --info,
-- and keys in both lists, and looks up the value in the appropriate list
getSetting :: Either [(String,String)] [(String,String)] -> String -> String -> Either String String
getSetting settings kh kr = case settings of
  Left settings -> go settings kh
  Right settings -> go settings kr
  where
    go settings k =  case lookup k settings of
      Nothing -> Left (show k ++ " not found in settings: " ++ show settings)
      Just v -> Right v

generatePlatformHostHs :: Either [(String,String)] [(String,String)] -> String
generatePlatformHostHs settings = either error id $ do
    let getSetting' = getSetting settings
    cHostPlatformArch <- getSetting' "hostPlatformArch" "target arch"
    cHostPlatformOS   <- getSetting' "hostPlatformOS"   "target os"
    return $ unlines
        [ "module GHC.Platform.Host where"
        , ""
        , "import GHC.Platform.ArchOS"
        , ""
        , "hostPlatformArch :: Arch"
        , "hostPlatformArch = " ++ cHostPlatformArch
        , ""
        , "hostPlatformOS   :: OS"
        , "hostPlatformOS   = " ++ cHostPlatformOS
        , ""
        , "hostPlatformArchOS :: ArchOS"
        , "hostPlatformArchOS = ArchOS hostPlatformArch hostPlatformOS"
        ]

generateVersionHs :: Either [(String,String)] [(String,String)] -> String
generateVersionHs settings = either error id $ do
    let getSetting' = getSetting settings
    cProjectGitCommitId <- getSetting' "cProjectGitCommitId" "Project Git commit id"
    cProjectVersion     <- getSetting' "cProjectVersion"     "Project version"
    cProjectVersionInt  <- getSetting' "cProjectVersionInt"  "Project Version Int"

    cProjectPatchLevel  <- getSetting' "cProjectPatchLevel"  "Project Patch Level"
    cProjectPatchLevel1 <- getSetting' "cProjectPatchLevel1" "Project Patch Level1"
    cProjectPatchLevel2 <- getSetting' "cProjectPatchLevel2" "Project Patch Level2"
    return $ unlines
        [ "module GHC.Version where"
        , ""
        , "import Prelude -- See Note [Why do we import Prelude here?]"
        , ""
        , "cProjectGitCommitId   :: String"
        , "cProjectGitCommitId   = " ++ show cProjectGitCommitId
        , ""
        , "cProjectVersion       :: String"
        , "cProjectVersion       = " ++ show cProjectVersion
        , ""
        , "cProjectVersionInt    :: String"
        , "cProjectVersionInt    = " ++ show cProjectVersionInt
        , ""
        , "cProjectPatchLevel    :: String"
        , "cProjectPatchLevel    = " ++ show cProjectPatchLevel
        , ""
        , "cProjectPatchLevel1   :: String"
        , "cProjectPatchLevel1   = " ++ show cProjectPatchLevel1
        , ""
        , "cProjectPatchLevel2   :: String"
        , "cProjectPatchLevel2   = " ++ show cProjectPatchLevel2
        ]