{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns        #-}

-- | Get information on modules, expressions, and identifiers
module GHCi.UI.Info
    ( ModInfo(..)
    , SpanInfo(..)
    , spanInfoFromRealSrcSpan
    , collectInfo
    , findLoc
    , findNameUses
    , findType
    , getModInfo
    ) where

import           Control.Exception
import           Control.Monad
import           Control.Monad.Trans.Class
import           Control.Monad.Trans.Except
import           Control.Monad.Trans.Maybe
import           Data.Data
import           Data.Function
import           Data.List
import           Data.Map.Strict   (Map)
import qualified Data.Map.Strict   as M
import           Data.Maybe
import           Data.Time
import           Prelude           hiding (mod,(<>))
import           System.Directory

import qualified CoreUtils
import           Desugar
import           DynFlags (HasDynFlags(..))
import           FastString
import           GHC
import           GhcMonad
import           Name
import           NameSet
import           Outputable
import           SrcLoc
import           TcHsSyn
import           Var

-- | Info about a module. This information is generated every time a
-- module is loaded.
data ModInfo = ModInfo
    { modinfoSummary    :: !ModSummary
      -- ^ Summary generated by GHC. Can be used to access more
      -- information about the module.
    , modinfoSpans      :: [SpanInfo]
      -- ^ Generated set of information about all spans in the
      -- module that correspond to some kind of identifier for
      -- which there will be type info and/or location info.
    , modinfoInfo       :: !ModuleInfo
      -- ^ Again, useful from GHC for accessing information
      -- (exports, instances, scope) from a module.
    , modinfoLastUpdate :: !UTCTime
      -- ^ The timestamp of the file used to generate this record.
    }

-- | Type of some span of source code. Most of these fields are
-- unboxed but Haddock doesn't show that.
data SpanInfo = SpanInfo
    { spaninfoSrcSpan   :: {-# UNPACK #-} !RealSrcSpan
      -- ^ The span we associate information with
    , spaninfoType      :: !(Maybe Type)
      -- ^ The 'Type' associated with the span
    , spaninfoVar       :: !(Maybe Id)
      -- ^ The actual 'Var' associated with the span, if
      -- any. This can be useful for accessing a variety of
      -- information about the identifier such as module,
      -- locality, definition location, etc.
    }

-- | Test whether second span is contained in (or equal to) first span.
-- This is basically 'containsSpan' for 'SpanInfo'
containsSpanInfo :: SpanInfo -> SpanInfo -> Bool
containsSpanInfo = containsSpan `on` spaninfoSrcSpan

-- | Filter all 'SpanInfo' which are contained in 'SpanInfo'
spaninfosWithin :: [SpanInfo] -> SpanInfo -> [SpanInfo]
spaninfosWithin spans' si = filter (si `containsSpanInfo`) spans'

-- | Construct a 'SpanInfo' from a 'RealSrcSpan' and optionally a
-- 'Type' and an 'Id' (for 'spaninfoType' and 'spaninfoVar'
-- respectively)
spanInfoFromRealSrcSpan :: RealSrcSpan -> Maybe Type -> Maybe Id -> SpanInfo
spanInfoFromRealSrcSpan spn mty mvar =
    SpanInfo spn mty mvar

-- | Convenience wrapper around 'spanInfoFromRealSrcSpan' which needs
-- only a 'RealSrcSpan'
spanInfoFromRealSrcSpan' :: RealSrcSpan -> SpanInfo
spanInfoFromRealSrcSpan' s = spanInfoFromRealSrcSpan s Nothing Nothing

-- | Convenience wrapper around 'srcSpanFile' which results in a 'FilePath'
srcSpanFilePath :: RealSrcSpan -> FilePath
srcSpanFilePath = unpackFS . srcSpanFile

-- | Try to find the location of the given identifier at the given
-- position in the module.
findLoc :: GhcMonad m
        => Map ModuleName ModInfo
        -> RealSrcSpan
        -> String
        -> ExceptT SDoc m (ModInfo,Name,SrcSpan)
findLoc infos span0 string = do
    name  <- maybeToExceptT "Couldn't guess that module name. Does it exist?" $
             guessModule infos (srcSpanFilePath span0)

    info  <- maybeToExceptT "No module info for current file! Try loading it?" $
             MaybeT $ pure $ M.lookup name infos

    name' <- findName infos span0 info string

    case getSrcSpan name' of
        UnhelpfulSpan{} -> do
            throwE ("Found a name, but no location information." <+>
                    "The module is:" <+>
                    maybe "<unknown>" (ppr . moduleName)
                          (nameModule_maybe name'))

        span' -> return (info,name',span')

-- | Find any uses of the given identifier in the codebase.
findNameUses :: (GhcMonad m)
             => Map ModuleName ModInfo
             -> RealSrcSpan
             -> String
             -> ExceptT SDoc m [SrcSpan]
findNameUses infos span0 string =
    locToSpans <$> findLoc infos span0 string
  where
    locToSpans (modinfo,name',span') =
        stripSurrounding (span' : map toSrcSpan spans)
      where
        toSrcSpan = RealSrcSpan . spaninfoSrcSpan
        spans = filter ((== Just name') . fmap getName . spaninfoVar)
                       (modinfoSpans modinfo)

-- | Filter out redundant spans which surround/contain other spans.
stripSurrounding :: [SrcSpan] -> [SrcSpan]
stripSurrounding xs = filter (not . isRedundant) xs
  where
    isRedundant x = any (x `strictlyContains`) xs

    (RealSrcSpan s1) `strictlyContains` (RealSrcSpan s2)
         = s1 /= s2 && s1 `containsSpan` s2
    _                `strictlyContains` _ = False

-- | Try to resolve the name located at the given position, or
-- otherwise resolve based on the current module's scope.
findName :: GhcMonad m
         => Map ModuleName ModInfo
         -> RealSrcSpan
         -> ModInfo
         -> String
         -> ExceptT SDoc m Name
findName infos span0 mi string =
    case resolveName (modinfoSpans mi) (spanInfoFromRealSrcSpan' span0) of
      Nothing -> tryExternalModuleResolution
      Just name ->
        case getSrcSpan name of
          UnhelpfulSpan {} -> tryExternalModuleResolution
          RealSrcSpan   {} -> return (getName name)
  where
    tryExternalModuleResolution =
      case find (matchName $ mkFastString string)
                (fromMaybe [] (modInfoTopLevelScope (modinfoInfo mi))) of
        Nothing -> throwE "Couldn't resolve to any modules."
        Just imported -> resolveNameFromModule infos imported

    matchName :: FastString -> Name -> Bool
    matchName str name =
      str ==
      occNameFS (getOccName name)

-- | Try to resolve the name from another (loaded) module's exports.
resolveNameFromModule :: GhcMonad m
                      => Map ModuleName ModInfo
                      -> Name
                      -> ExceptT SDoc m Name
resolveNameFromModule infos name = do
     modL <- maybe (throwE $ "No module for" <+> ppr name) return $
             nameModule_maybe name

     info <- maybe (throwE (ppr (moduleUnitId modL) <> ":" <>
                            ppr modL)) return $
             M.lookup (moduleName modL) infos

     maybe (throwE "No matching export in any local modules.") return $
         find (matchName name) (modInfoExports (modinfoInfo info))
  where
    matchName :: Name -> Name -> Bool
    matchName x y = occNameFS (getOccName x) ==
                    occNameFS (getOccName y)

-- | Try to resolve the type display from the given span.
resolveName :: [SpanInfo] -> SpanInfo -> Maybe Var
resolveName spans' si = listToMaybe $ mapMaybe spaninfoVar $
                        reverse spans' `spaninfosWithin` si

-- | Try to find the type of the given span.
findType :: GhcMonad m
         => Map ModuleName ModInfo
         -> RealSrcSpan
         -> String
         -> ExceptT SDoc m (ModInfo, Type)
findType infos span0 string = do
    name  <- maybeToExceptT "Couldn't guess that module name. Does it exist?" $
             guessModule infos (srcSpanFilePath span0)

    info  <- maybeToExceptT "No module info for current file! Try loading it?" $
             MaybeT $ pure $ M.lookup name infos

    case resolveType (modinfoSpans info) (spanInfoFromRealSrcSpan' span0) of
        Nothing -> (,) info <$> lift (exprType TM_Inst string)
        Just ty -> return (info, ty)
  where
    -- | Try to resolve the type display from the given span.
    resolveType :: [SpanInfo] -> SpanInfo -> Maybe Type
    resolveType spans' si = listToMaybe $ mapMaybe spaninfoType $
                            reverse spans' `spaninfosWithin` si

-- | Guess a module name from a file path.
guessModule :: GhcMonad m
            => Map ModuleName ModInfo -> FilePath -> MaybeT m ModuleName
guessModule infos fp = do
    target <- lift $ guessTarget fp Nothing
    case targetId target of
        TargetModule mn  -> return mn
        TargetFile fp' _ -> guessModule' fp'
  where
    guessModule' :: GhcMonad m => FilePath -> MaybeT m ModuleName
    guessModule' fp' = case findModByFp fp' of
        Just mn -> return mn
        Nothing -> do
            fp'' <- liftIO (makeRelativeToCurrentDirectory fp')

            target' <- lift $ guessTarget fp'' Nothing
            case targetId target' of
                TargetModule mn -> return mn
                _               -> MaybeT . pure $ findModByFp fp''

    findModByFp :: FilePath -> Maybe ModuleName
    findModByFp fp' = fst <$> find ((Just fp' ==) . mifp) (M.toList infos)
      where
        mifp :: (ModuleName, ModInfo) -> Maybe FilePath
        mifp = ml_hs_file . ms_location . modinfoSummary . snd

-- | Collect type info data for the loaded modules.
collectInfo :: (GhcMonad m) => Map ModuleName ModInfo -> [ModuleName]
               -> m (Map ModuleName ModInfo)
collectInfo ms loaded = do
    df <- getDynFlags
    liftIO (filterM cacheInvalid loaded) >>= \case
        [] -> return ms
        invalidated -> do
            liftIO (putStrLn ("Collecting type info for " ++
                              show (length invalidated) ++
                              " module(s) ... "))

            foldM (go df) ms invalidated
  where
    go df m name = do { info <- getModInfo name; return (M.insert name info m) }
                   `gcatch`
                   (\(e :: SomeException) -> do
                         liftIO $ putStrLn
                                $ showSDocForUser df alwaysQualify
                                $ "Error while getting type info from" <+>
                                  ppr name <> ":" <+> text (show e)
                         return m)

    cacheInvalid name = case M.lookup name ms of
        Nothing -> return True
        Just mi -> do
            let fp = srcFilePath (modinfoSummary mi)
                last' = modinfoLastUpdate mi
            current <- getModificationTime fp
            exists <- doesFileExist fp
            if exists
                then return $ current /= last'
                else return True

-- | Get the source file path from a ModSummary.
-- If the .hs file is missing, and the .o file exists,
-- we return the .o file path.
srcFilePath :: ModSummary -> FilePath
srcFilePath modSum = fromMaybe obj_fp src_fp
    where
        src_fp = ml_hs_file ms_loc
        obj_fp = ml_obj_file ms_loc
        ms_loc = ms_location modSum

-- | Get info about the module: summary, types, etc.
getModInfo :: (GhcMonad m) => ModuleName -> m ModInfo
getModInfo name = do
    m <- getModSummary name
    p <- parseModule m
    typechecked <- typecheckModule p
    allTypes <- processAllTypeCheckedModule typechecked
    let i = tm_checked_module_info typechecked
    ts <- liftIO $ getModificationTime $ srcFilePath m
    return (ModInfo m allTypes i ts)

-- | Get ALL source spans in the module.
processAllTypeCheckedModule :: forall m . GhcMonad m => TypecheckedModule
                            -> m [SpanInfo]
processAllTypeCheckedModule tcm = do
    bts <- mapM getTypeLHsBind $ listifyAllSpans tcs
    ets <- mapM getTypeLHsExpr $ listifyAllSpans tcs
    pts <- mapM getTypeLPat    $ listifyAllSpans tcs
    return $ mapMaybe toSpanInfo
           $ sortBy cmpSpan
           $ catMaybes (bts ++ ets ++ pts)
  where
    tcs = tm_typechecked_source tcm

    -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsBind's
    getTypeLHsBind :: LHsBind GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))
    getTypeLHsBind (dL->L _spn FunBind{fun_id = pid,fun_matches = MG _ _ _})
        = pure $ Just (Just (unLoc pid),getLoc pid,varType (unLoc pid))
    getTypeLHsBind _ = pure Nothing

    -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsExpr's
    getTypeLHsExpr :: LHsExpr GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))
    getTypeLHsExpr e = do
        hs_env  <- getSession
        (_,mbe) <- liftIO $ deSugarExpr hs_env e
        return $ fmap (\expr -> (mid, getLoc e, CoreUtils.exprType expr)) mbe
      where
        mid :: Maybe Id
        mid | HsVar _ (dL->L _ i) <- unwrapVar (unLoc e) = Just i
            | otherwise                                  = Nothing

        unwrapVar (HsWrap _ _ var) = var
        unwrapVar e'               = e'

    -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LPats's
    getTypeLPat :: LPat GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))
    getTypeLPat (dL->L spn pat) =
        pure (Just (getMaybeId pat,spn,hsPatType pat))
      where
        getMaybeId (VarPat _ (dL->L _ vid)) = Just vid
        getMaybeId _                        = Nothing

    -- | Get ALL source spans in the source.
    listifyAllSpans :: (HasSrcSpan a , Typeable a) => TypecheckedSource -> [a]
    listifyAllSpans = everythingAllSpans (++) [] ([] `mkQ` (\x -> [x | p x]))
      where
        p (dL->L spn _) = isGoodSrcSpan spn

    -- | Variant of @syb@'s @everything@ (which summarises all nodes
    -- in top-down, left-to-right order) with a stop-condition on 'NameSet's
    everythingAllSpans :: (r -> r -> r) -> r -> GenericQ r -> GenericQ r
    everythingAllSpans k z f x
      | (False `mkQ` (const True :: NameSet -> Bool)) x = z
      | otherwise = foldl k (f x) (gmapQ (everythingAllSpans k z f) x)

    cmpSpan (_,a,_) (_,b,_)
      | a `isSubspanOf` b = LT
      | b `isSubspanOf` a = GT
      | otherwise         = EQ

    -- | Pretty print the types into a 'SpanInfo'.
    toSpanInfo :: (Maybe Id,SrcSpan,Type) -> Maybe SpanInfo
    toSpanInfo (n,RealSrcSpan spn,typ)
        = Just $ spanInfoFromRealSrcSpan spn (Just typ) n
    toSpanInfo _ = Nothing

-- helper stolen from @syb@ package
type GenericQ r = forall a. Data a => a -> r

mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
(r `mkQ` br) a = maybe r br (cast a)


{-# LANGUAGE CPP, FlexibleInstances, UnboxedTuples, MagicHash #-}
{-# OPTIONS_GHC -fno-cse -fno-warn-orphans #-}
-- -fno-cse is needed for GLOBAL_VAR's to behave properly

-----------------------------------------------------------------------------
--
-- Monadery code used in InteractiveUI
--
-- (c) The GHC Team 2005-2006
--
-----------------------------------------------------------------------------

module GHCi.UI.Monad (
        GHCi(..), startGHCi,
        GHCiState(..), GhciMonad(..),
        GHCiOption(..), isOptionSet, setOption, unsetOption,
        Command(..), CommandResult(..), cmdSuccess,
        PromptFunction,
        BreakLocation(..),
        TickArray,
        getDynFlags,

        runStmt, runDecls, runDecls', resume, recordBreak, revertCAFs,
        ActionStats(..), runAndPrintStats, runWithStats, printStats,

        printForUserNeverQualify, printForUserModInfo,
        printForUser, printForUserPartWay, prettyLocations,

        compileGHCiExpr,
        initInterpBuffering,
        turnOffBuffering, turnOffBuffering_,
        flushInterpBuffers,
        mkEvalWrapper
    ) where

#include "HsVersions.h"

import GHCi.UI.Info (ModInfo)
import qualified GHC
import GhcMonad         hiding (liftIO)
import Outputable       hiding (printForUser, printForUserPartWay)
import qualified Outputable
import DynFlags
import FastString
import HscTypes
import SrcLoc
import Module
import GHCi
import GHCi.RemoteTypes
import HsSyn (ImportDecl, GhcPs, GhciLStmt, LHsDecl)
import Util

import Exception
import Numeric
import Data.Array
import Data.IORef
import Data.Time
import System.Environment
import System.IO
import Control.Monad
import Prelude hiding ((<>))

import System.Console.Haskeline (CompletionFunc, InputT)
import qualified System.Console.Haskeline as Haskeline
import Control.Monad.Trans.Class
import Control.Monad.IO.Class
import Data.Map.Strict (Map)
import qualified GHC.LanguageExtensions as LangExt

-----------------------------------------------------------------------------
-- GHCi monad

data GHCiState = GHCiState
     {
        progname       :: String,
        args           :: [String],
        evalWrapper    :: ForeignHValue, -- ^ of type @IO a -> IO a@
        prompt         :: PromptFunction,
        prompt_cont    :: PromptFunction,
        editor         :: String,
        stop           :: String,
        options        :: [GHCiOption],
        line_number    :: !Int,         -- ^ input line
        break_ctr      :: !Int,
        breaks         :: ![(Int, BreakLocation)],
        tickarrays     :: ModuleEnv TickArray,
            -- ^ 'tickarrays' caches the 'TickArray' for loaded modules,
            -- so that we don't rebuild it each time the user sets
            -- a breakpoint.
        ghci_commands  :: [Command],
            -- ^ available ghci commands
        ghci_macros    :: [Command],
            -- ^ user-defined macros
        last_command   :: Maybe Command,
            -- ^ @:@ at the GHCi prompt repeats the last command, so we
            -- remember it here
        cmd_wrapper    :: InputT GHCi CommandResult -> InputT GHCi (Maybe Bool),
            -- ^ The command wrapper is run for each command or statement.
            -- The 'Bool' value denotes whether the command is successful and
            -- 'Nothing' means to exit GHCi.
        cmdqueue       :: [String],

        remembered_ctx :: [InteractiveImport],
            -- ^ The imports that the user has asked for, via import
            -- declarations and :module commands.  This list is
            -- persistent over :reloads (but any imports for modules
            -- that are not loaded are temporarily ignored).  After a
            -- :load, all the home-package imports are stripped from
            -- this list.
            --
            -- See bugs #2049, #1873, #1360

        transient_ctx  :: [InteractiveImport],
            -- ^ An import added automatically after a :load, usually of
            -- the most recently compiled module.  May be empty if
            -- there are no modules loaded.  This list is replaced by
            -- :load, :reload, and :add.  In between it may be modified
            -- by :module.

        extra_imports  :: [ImportDecl GhcPs],
            -- ^ These are "always-on" imports, added to the
            -- context regardless of what other imports we have.
            -- This is useful for adding imports that are required
            -- by setGHCiMonad.  Be careful adding things here:
            -- you can create ambiguities if these imports overlap
            -- with other things in scope.
            --
            -- NB. although this is not currently used by GHCi itself,
            -- it was added to support other front-ends that are based
            -- on the GHCi code.  Potentially we could also expose
            -- this functionality via GHCi commands.

        prelude_imports :: [ImportDecl GhcPs],
            -- ^ These imports are added to the context when
            -- -XImplicitPrelude is on and we don't have a *-module
            -- in the context.  They can also be overridden by another
            -- import for the same module, e.g.
            -- "import Prelude hiding (map)"

        ghc_e :: Bool, -- ^ True if this is 'ghc -e' (or runghc)

        short_help :: String,
            -- ^ help text to display to a user
        long_help  :: String,
        lastErrorLocations :: IORef [(FastString, Int)],

        mod_infos  :: !(Map ModuleName ModInfo),

        flushStdHandles :: ForeignHValue,
            -- ^ @hFlush stdout; hFlush stderr@ in the interpreter
        noBuffering :: ForeignHValue
            -- ^ @hSetBuffering NoBuffering@ for stdin/stdout/stderr
     }

type TickArray = Array Int [(GHC.BreakIndex,RealSrcSpan)]

-- | A GHCi command
data Command
   = Command
   { cmdName           :: String
     -- ^ Name of GHCi command (e.g. "exit")
   , cmdAction         :: String -> InputT GHCi Bool
     -- ^ The 'Bool' value denotes whether to exit GHCi
   , cmdHidden         :: Bool
     -- ^ Commands which are excluded from default completion
     -- and @:help@ summary. This is usually set for commands not
     -- useful for interactive use but rather for IDEs.
   , cmdCompletionFunc :: CompletionFunc GHCi
     -- ^ 'CompletionFunc' for arguments
   }

data CommandResult
   = CommandComplete
   { cmdInput :: String
   , cmdResult :: Either SomeException (Maybe Bool)
   , cmdStats :: ActionStats
   }
   | CommandIncomplete
     -- ^ Unterminated multiline command
   deriving Show

cmdSuccess :: Haskeline.MonadException m => CommandResult -> m (Maybe Bool)
cmdSuccess CommandComplete{ cmdResult = Left e } = liftIO $ throwIO e
cmdSuccess CommandComplete{ cmdResult = Right r } = return r
cmdSuccess CommandIncomplete = return $ Just True

type PromptFunction = [String]
                   -> Int
                   -> GHCi SDoc

data GHCiOption
        = ShowTiming            -- show time/allocs after evaluation
        | ShowType              -- show the type of expressions
        | RevertCAFs            -- revert CAFs after every evaluation
        | Multiline             -- use multiline commands
        | CollectInfo           -- collect and cache information about
                                -- modules after load
        deriving Eq

data BreakLocation
   = BreakLocation
   { breakModule :: !GHC.Module
   , breakLoc    :: !SrcSpan
   , breakTick   :: {-# UNPACK #-} !Int
   , onBreakCmd  :: String
   }

instance Eq BreakLocation where
  loc1 == loc2 = breakModule loc1 == breakModule loc2 &&
                 breakTick loc1   == breakTick loc2

prettyLocations :: [(Int, BreakLocation)] -> SDoc
prettyLocations []   = text "No active breakpoints."
prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs

instance Outputable BreakLocation where
   ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+>
                if null (onBreakCmd loc)
                   then Outputable.empty
                   else doubleQuotes (text (onBreakCmd loc))

recordBreak
  :: GhciMonad m => BreakLocation -> m (Bool{- was already present -}, Int)
recordBreak brkLoc = do
   st <- getGHCiState
   let oldActiveBreaks = breaks st
   -- don't store the same break point twice
   case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of
     (nm:_) -> return (True, nm)
     [] -> do
      let oldCounter = break_ctr st
          newCounter = oldCounter + 1
      setGHCiState $ st { break_ctr = newCounter,
                          breaks = (oldCounter, brkLoc) : oldActiveBreaks
                        }
      return (False, oldCounter)

newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a }

reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a
reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s

startGHCi :: GHCi a -> GHCiState -> Ghc a
startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref

instance Functor GHCi where
    fmap = liftM

instance Applicative GHCi where
    pure a = GHCi $ \_ -> pure a
    (<*>) = ap

instance Monad GHCi where
  (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \a -> unGHCi (k a) s

class GhcMonad m => GhciMonad m where
  getGHCiState    :: m GHCiState
  setGHCiState    :: GHCiState -> m ()
  modifyGHCiState :: (GHCiState -> GHCiState) -> m ()
  reifyGHCi       :: ((Session, IORef GHCiState) -> IO a) -> m a

instance GhciMonad GHCi where
  getGHCiState      = GHCi $ \r -> liftIO $ readIORef r
  setGHCiState s    = GHCi $ \r -> liftIO $ writeIORef r s
  modifyGHCiState f = GHCi $ \r -> liftIO $ modifyIORef r f
  reifyGHCi f       = GHCi $ \r -> reifyGhc $ \s -> f (s, r)

instance GhciMonad (InputT GHCi) where
  getGHCiState    = lift getGHCiState
  setGHCiState    = lift . setGHCiState
  modifyGHCiState = lift . modifyGHCiState
  reifyGHCi       = lift . reifyGHCi

liftGhc :: Ghc a -> GHCi a
liftGhc m = GHCi $ \_ -> m

instance MonadIO GHCi where
  liftIO = liftGhc . liftIO

instance HasDynFlags GHCi where
  getDynFlags = getSessionDynFlags

instance GhcMonad GHCi where
  setSession s' = liftGhc $ setSession s'
  getSession    = liftGhc $ getSession

instance HasDynFlags (InputT GHCi) where
  getDynFlags = lift getDynFlags

instance GhcMonad (InputT GHCi) where
  setSession = lift . setSession
  getSession = lift getSession

instance ExceptionMonad GHCi where
  gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r)
  gmask f =
      GHCi $ \s -> gmask $ \io_restore ->
                             let
                                g_restore (GHCi m) = GHCi $ \s' -> io_restore (m s')
                             in
                                unGHCi (f g_restore) s

instance Haskeline.MonadException Ghc where
  controlIO f = Ghc $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let
                    run' = Haskeline.RunIO (fmap (Ghc . const) . run . flip unGhc s)
                    in fmap (flip unGhc s) $ f run'

instance Haskeline.MonadException GHCi where
  controlIO f = GHCi $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let
                    run' = Haskeline.RunIO (fmap (GHCi . const) . run . flip unGHCi s)
                    in fmap (flip unGHCi s) $ f run'

instance ExceptionMonad (InputT GHCi) where
  gcatch = Haskeline.catch
  gmask f = Haskeline.liftIOOp gmask (f . Haskeline.liftIOOp_)

isOptionSet :: GhciMonad m => GHCiOption -> m Bool
isOptionSet opt
 = do st <- getGHCiState
      return (opt `elem` options st)

setOption :: GhciMonad m => GHCiOption -> m ()
setOption opt
 = do st <- getGHCiState
      setGHCiState (st{ options = opt : filter (/= opt) (options st) })

unsetOption :: GhciMonad m => GHCiOption -> m ()
unsetOption opt
 = do st <- getGHCiState
      setGHCiState (st{ options = filter (/= opt) (options st) })

printForUserNeverQualify :: GhcMonad m => SDoc -> m ()
printForUserNeverQualify doc = do
  dflags <- getDynFlags
  liftIO $ Outputable.printForUser dflags stdout neverQualify doc

printForUserModInfo :: GhcMonad m => GHC.ModuleInfo -> SDoc -> m ()
printForUserModInfo info doc = do
  dflags <- getDynFlags
  mUnqual <- GHC.mkPrintUnqualifiedForModule info
  unqual <- maybe GHC.getPrintUnqual return mUnqual
  liftIO $ Outputable.printForUser dflags stdout unqual doc

printForUser :: GhcMonad m => SDoc -> m ()
printForUser doc = do
  unqual <- GHC.getPrintUnqual
  dflags <- getDynFlags
  liftIO $ Outputable.printForUser dflags stdout unqual doc

printForUserPartWay :: GhcMonad m => SDoc -> m ()
printForUserPartWay doc = do
  unqual <- GHC.getPrintUnqual
  dflags <- getDynFlags
  liftIO $ Outputable.printForUserPartWay dflags stdout (pprUserLength dflags) unqual doc

-- | Run a single Haskell expression
runStmt
  :: GhciMonad m
  => GhciLStmt GhcPs -> String -> GHC.SingleStep -> m (Maybe GHC.ExecResult)
runStmt stmt stmt_text step = do
  st <- getGHCiState
  GHC.handleSourceError (\e -> do GHC.printException e; return Nothing) $ do
    let opts = GHC.execOptions
                  { GHC.execSourceFile = progname st
                  , GHC.execLineNumber = line_number st
                  , GHC.execSingleStep = step
                  , GHC.execWrap = \fhv -> EvalApp (EvalThis (evalWrapper st))
                                                   (EvalThis fhv) }
    Just <$> GHC.execStmt' stmt stmt_text opts

runDecls :: GhciMonad m => String -> m (Maybe [GHC.Name])
runDecls decls = do
  st <- getGHCiState
  reifyGHCi $ \x ->
    withProgName (progname st) $
    withArgs (args st) $
      reflectGHCi x $ do
        GHC.handleSourceError (\e -> do GHC.printException e;
                                        return Nothing) $ do
          r <- GHC.runDeclsWithLocation (progname st) (line_number st) decls
          return (Just r)

runDecls' :: GhciMonad m => [LHsDecl GhcPs] -> m (Maybe [GHC.Name])
runDecls' decls = do
  st <- getGHCiState
  reifyGHCi $ \x ->
    withProgName (progname st) $
    withArgs (args st) $
    reflectGHCi x $
      GHC.handleSourceError
        (\e -> do GHC.printException e;
                  return Nothing)
        (Just <$> GHC.runParsedDecls decls)

resume :: GhciMonad m => (SrcSpan -> Bool) -> GHC.SingleStep -> m GHC.ExecResult
resume canLogSpan step = do
  st <- getGHCiState
  reifyGHCi $ \x ->
    withProgName (progname st) $
    withArgs (args st) $
      reflectGHCi x $ do
        GHC.resumeExec canLogSpan step

-- --------------------------------------------------------------------------
-- timing & statistics

data ActionStats = ActionStats
  { actionAllocs :: Maybe Integer
  , actionElapsedTime :: Double
  } deriving Show

runAndPrintStats
  :: GhciMonad m
  => (a -> Maybe Integer)
  -> m a
  -> m (ActionStats, Either SomeException a)
runAndPrintStats getAllocs action = do
  result <- runWithStats getAllocs action
  case result of
    (stats, Right{}) -> do
      showTiming <- isOptionSet ShowTiming
      when showTiming $ do
        dflags  <- getDynFlags
        liftIO $ printStats dflags stats
    _ -> return ()
  return result

runWithStats
  :: ExceptionMonad m
  => (a -> Maybe Integer) -> m a -> m (ActionStats, Either SomeException a)
runWithStats getAllocs action = do
  t0 <- liftIO getCurrentTime
  result <- gtry action
  let allocs = either (const Nothing) getAllocs result
  t1 <- liftIO getCurrentTime
  let elapsedTime = realToFrac $ t1 `diffUTCTime` t0
  return (ActionStats allocs elapsedTime, result)

printStats :: DynFlags -> ActionStats -> IO ()
printStats dflags ActionStats{actionAllocs = mallocs, actionElapsedTime = secs}
   = do let secs_str = showFFloat (Just 2) secs
        putStrLn (showSDoc dflags (
                 parens (text (secs_str "") <+> text "secs" <> comma <+>
                         case mallocs of
                           Nothing -> empty
                           Just allocs ->
                             text (separateThousands allocs) <+> text "bytes")))
  where
    separateThousands n = reverse . sep . reverse . show $ n
      where sep n'
              | n' `lengthAtMost` 3 = n'
              | otherwise           = take 3 n' ++ "," ++ sep (drop 3 n')

-----------------------------------------------------------------------------
-- reverting CAFs

revertCAFs :: GhciMonad m => m ()
revertCAFs = do
  hsc_env <- GHC.getSession
  liftIO $ iservCmd hsc_env RtsRevertCAFs
  s <- getGHCiState
  when (not (ghc_e s)) turnOffBuffering
     -- Have to turn off buffering again, because we just
     -- reverted stdout, stderr & stdin to their defaults.

-----------------------------------------------------------------------------
-- To flush buffers for the *interpreted* computation we need
-- to refer to *its* stdout/stderr handles

-- | Compile "hFlush stdout; hFlush stderr" once, so we can use it repeatedly
initInterpBuffering :: Ghc (ForeignHValue, ForeignHValue)
initInterpBuffering = do
  nobuf <- compileGHCiExpr $
   "do { System.IO.hSetBuffering System.IO.stdin System.IO.NoBuffering; " ++
       " System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering; " ++
       " System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering }"
  flush <- compileGHCiExpr $
   "do { System.IO.hFlush System.IO.stdout; " ++
       " System.IO.hFlush System.IO.stderr }"
  return (nobuf, flush)

-- | Invoke "hFlush stdout; hFlush stderr" in the interpreter
flushInterpBuffers :: GhciMonad m => m ()
flushInterpBuffers = do
  st <- getGHCiState
  hsc_env <- GHC.getSession
  liftIO $ evalIO hsc_env (flushStdHandles st)

-- | Turn off buffering for stdin, stdout, and stderr in the interpreter
turnOffBuffering :: GhciMonad m => m ()
turnOffBuffering = do
  st <- getGHCiState
  turnOffBuffering_ (noBuffering st)

turnOffBuffering_ :: GhcMonad m => ForeignHValue -> m ()
turnOffBuffering_ fhv = do
  hsc_env <- getSession
  liftIO $ evalIO hsc_env fhv

mkEvalWrapper :: GhcMonad m => String -> [String] ->  m ForeignHValue
mkEvalWrapper progname args =
  compileGHCiExpr $
    "\\m -> System.Environment.withProgName " ++ show progname ++
    "(System.Environment.withArgs " ++ show args ++ " m)"

compileGHCiExpr :: GhcMonad m => String -> m ForeignHValue
compileGHCiExpr expr =
  withTempSession mkTempSession $ GHC.compileExprRemote expr
  where
    mkTempSession hsc_env = hsc_env
      { hsc_dflags = (hsc_dflags hsc_env) {
        -- Running GHCi's internal expression is incompatible with -XSafe.
          -- We temporarily disable any Safe Haskell settings while running
          -- GHCi internal expressions. (see #12509)
        safeHaskell = Sf_None
      }
        -- RebindableSyntax can wreak havoc with GHCi in several ways
          -- (see #13385 and #14342 for examples), so we temporarily
          -- disable it too.
          `xopt_unset` LangExt.RebindableSyntax
          -- We heavily depend on -fimplicit-import-qualified to compile expr
          -- with fully qualified names without imports.
          `gopt_set` Opt_ImplicitImportQualified
      }


-----------------------------------------------------------------------------
--
-- GHCi's :ctags and :etags commands
--
-- (c) The GHC Team 2005-2007
--
-----------------------------------------------------------------------------

{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
module GHCi.UI.Tags (
  createCTagsWithLineNumbersCmd,
  createCTagsWithRegExesCmd,
  createETagsFileCmd
) where

import Exception
import GHC
import GHCi.UI.Monad
import Outputable

-- ToDo: figure out whether we need these, and put something appropriate
-- into the GHC API instead
import Name (nameOccName)
import OccName (pprOccName)
import ConLike
import MonadUtils

import Control.Monad
import Data.Function
import Data.List
import Data.Maybe
import Data.Ord
import DriverPhases
import Panic
import Prelude
import System.Directory
import System.IO
import System.IO.Error

-----------------------------------------------------------------------------
-- create tags file for currently loaded modules.

createCTagsWithLineNumbersCmd, createCTagsWithRegExesCmd,
  createETagsFileCmd :: String -> GHCi ()

createCTagsWithLineNumbersCmd ""   =
  ghciCreateTagsFile CTagsWithLineNumbers "tags"
createCTagsWithLineNumbersCmd file =
  ghciCreateTagsFile CTagsWithLineNumbers file

createCTagsWithRegExesCmd ""   =
  ghciCreateTagsFile CTagsWithRegExes "tags"
createCTagsWithRegExesCmd file =
  ghciCreateTagsFile CTagsWithRegExes file

createETagsFileCmd ""    = ghciCreateTagsFile ETags "TAGS"
createETagsFileCmd file  = ghciCreateTagsFile ETags file

data TagsKind = ETags | CTagsWithLineNumbers | CTagsWithRegExes

ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
ghciCreateTagsFile kind file = do
  createTagsFile kind file

-- ToDo:
--      - remove restriction that all modules must be interpreted
--        (problem: we don't know source locations for entities unless
--        we compiled the module.
--
--      - extract createTagsFile so it can be used from the command-line
--        (probably need to fix first problem before this is useful).
--
createTagsFile :: TagsKind -> FilePath -> GHCi ()
createTagsFile tagskind tagsFile = do
  graph <- GHC.getModuleGraph
  mtags <- mapM listModuleTags (map GHC.ms_mod $ GHC.mgModSummaries graph)
  either_res <- liftIO $ collateAndWriteTags tagskind tagsFile $ concat mtags
  case either_res of
    Left e  -> liftIO $ hPutStrLn stderr $ ioeGetErrorString e
    Right _ -> return ()

listModuleTags :: GHC.Module -> GHCi [TagInfo]
listModuleTags m = do
  is_interpreted <- GHC.moduleIsInterpreted m
  -- should we just skip these?
  when (not is_interpreted) $
    let mName = GHC.moduleNameString (GHC.moduleName m) in
    throwGhcException (CmdLineError ("module '" ++ mName ++ "' is not interpreted"))
  mbModInfo <- GHC.getModuleInfo m
  case mbModInfo of
    Nothing -> return []
    Just mInfo -> do
       dflags <- getDynFlags
       mb_print_unqual <- GHC.mkPrintUnqualifiedForModule mInfo
       let unqual = fromMaybe GHC.alwaysQualify mb_print_unqual
       let names = fromMaybe [] $GHC.modInfoTopLevelScope mInfo
       let localNames = filter ((m==) . nameModule) names
       mbTyThings <- mapM GHC.lookupName localNames
       return $! [ tagInfo dflags unqual exported kind name realLoc
                     | tyThing <- catMaybes mbTyThings
                     , let name = getName tyThing
                     , let exported = GHC.modInfoIsExportedName mInfo name
                     , let kind = tyThing2TagKind tyThing
                     , let loc = srcSpanStart (nameSrcSpan name)
                     , RealSrcLoc realLoc <- [loc]
                     ]

  where
    tyThing2TagKind (AnId _)                 = 'v'
    tyThing2TagKind (AConLike RealDataCon{}) = 'd'
    tyThing2TagKind (AConLike PatSynCon{})   = 'p'
    tyThing2TagKind (ATyCon _)               = 't'
    tyThing2TagKind (ACoAxiom _)             = 'x'

data TagInfo = TagInfo
  { tagExported :: Bool -- is tag exported
  , tagKind :: Char   -- tag kind
  , tagName :: String -- tag name
  , tagFile :: String -- file name
  , tagLine :: Int    -- line number
  , tagCol :: Int     -- column number
  , tagSrcInfo :: Maybe (String,Integer)  -- source code line and char offset
  }

-- get tag info, for later translation into Vim or Emacs style
tagInfo :: DynFlags -> PrintUnqualified -> Bool -> Char -> Name -> RealSrcLoc
        -> TagInfo
tagInfo dflags unqual exported kind name loc
    = TagInfo exported kind
        (showSDocForUser dflags unqual $ pprOccName (nameOccName name))
        (showSDocForUser dflags unqual $ ftext (srcLocFile loc))
        (srcLocLine loc) (srcLocCol loc) Nothing

-- throw an exception when someone tries to overwrite existing source file (fix for #10989)
writeTagsSafely :: FilePath -> String -> IO ()
writeTagsSafely file str = do
    dfe <- doesFileExist file
    if dfe && isSourceFilename file
        then throwGhcException (CmdLineError (file ++ " is existing source file. " ++
             "Please specify another file name to store tags data"))
        else writeFile file str

collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
-- ctags style with the Ex expression being just the line number, Vim et al
collateAndWriteTags CTagsWithLineNumbers file tagInfos = do
  let tags = unlines $ sort $ map showCTag tagInfos
  tryIO (writeTagsSafely file tags)

-- ctags style with the Ex expression being a regex searching the line, Vim et al
collateAndWriteTags CTagsWithRegExes file tagInfos = do -- ctags style, Vim et al
  tagInfoGroups <- makeTagGroupsWithSrcInfo tagInfos
  let tags = unlines $ sort $ map showCTag $concat tagInfoGroups
  tryIO (writeTagsSafely file tags)

collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
  tagInfoGroups <- makeTagGroupsWithSrcInfo $filter tagExported tagInfos
  let tagGroups = map processGroup tagInfoGroups
  tryIO (writeTagsSafely file $ concat tagGroups)

  where
    processGroup [] = throwGhcException (CmdLineError "empty tag file group??")
    processGroup group@(tagInfo:_) =
      let tags = unlines $ map showETag group in
      "\x0c\n" ++ tagFile tagInfo ++ "," ++ show (length tags) ++ "\n" ++ tags

makeTagGroupsWithSrcInfo :: [TagInfo] -> IO [[TagInfo]]
makeTagGroupsWithSrcInfo tagInfos = do
  let groups = groupBy ((==) `on` tagFile) $ sortBy (comparing tagFile) tagInfos
  mapM addTagSrcInfo groups

  where
    addTagSrcInfo [] = throwGhcException (CmdLineError "empty tag file group??")
    addTagSrcInfo group@(tagInfo:_) = do
      file <- readFile $tagFile tagInfo
      let sortedGroup = sortBy (comparing tagLine) group
      return $ perFile sortedGroup 1 0 $ lines file

    perFile allTags@(tag:tags) cnt pos allLs@(l:ls)
     | tagLine tag > cnt =
         perFile allTags (cnt+1) (pos+fromIntegral(length l)) ls
     | tagLine tag == cnt =
         tag{ tagSrcInfo = Just(l,pos) } : perFile tags cnt pos allLs
    perFile _ _ _ _ = []

-- ctags format, for Vim et al
showCTag :: TagInfo -> String
showCTag ti =
  tagName ti ++ "\t" ++ tagFile ti ++ "\t" ++ tagCmd ++ ";\"\t" ++
    tagKind ti : ( if tagExported ti then "" else "\tfile:" )

  where
    tagCmd =
      case tagSrcInfo ti of
        Nothing -> show $tagLine ti
        Just (srcLine,_) -> "/^"++ foldr escapeSlashes [] srcLine ++"$/"

      where
        escapeSlashes '/' r = '\\' : '/' : r
        escapeSlashes '\\' r = '\\' : '\\' : r
        escapeSlashes c r = c : r

-- etags format, for Emacs/XEmacs
showETag :: TagInfo -> String
showETag TagInfo{ tagName = tag, tagLine = lineNo, tagCol = colNo,
                  tagSrcInfo = Just (srcLine,charPos) }
    =  take (colNo - 1) srcLine ++ tag
    ++ "\x7f" ++ tag
    ++ "\x01" ++ show lineNo
    ++ "," ++ show charPos
showETag _ = throwGhcException (CmdLineError "missing source file info in showETag")


module Base (
    -- * General utilities
    module Control.Applicative,
    module Control.Monad.Extra,
    module Data.List.Extra,
    module Data.Maybe,
    module Data.Semigroup,
    module Hadrian.Utilities,

    -- * Shake
    module Development.Shake,
    module Development.Shake.Classes,
    module Development.Shake.FilePath,
    module Development.Shake.Util,

    -- * Basic data types
    module Hadrian.Package,
    module Stage,
    module Way,

    -- * Files
    configH, ghcVersionH,

    -- * Paths
    hadrianPath, configPath, configFile, sourcePath, shakeFilesDir,
    generatedDir, generatedPath, stageBinPath, stageLibPath, templateHscPath,
    ghcDeps, includesDependencies, haddockDeps, relativePackageDbPath,
    packageDbPath, packageDbStamp, mingwStamp,
    ) where

import Control.Applicative
import Control.Monad.Extra
import Control.Monad.Reader
import Data.List.Extra
import Data.Maybe
import Data.Semigroup
import Development.Shake hiding (unit, (*>), Normal)
import Development.Shake.Classes
import Development.Shake.FilePath
import Development.Shake.Util
import Hadrian.Oracles.DirectoryContents
import Hadrian.Utilities
import Hadrian.Package

import Stage
import Way

-- | Hadrian lives in the 'hadrianPath' directory of the GHC tree.
hadrianPath :: FilePath
hadrianPath = "hadrian"

-- TODO: Move this to build directory?
-- | Path to system configuration files, such as 'configFile'.
configPath :: FilePath
configPath = hadrianPath -/- "cfg"

-- | Path to the system configuration file generated by the @configure@ script.
configFile :: FilePath
configFile = configPath -/- "system.config"

-- | Path to source files of the build system, e.g. this file is located at
-- @sourcePath -/- "Base.hs"@. We use this to track some of the source files.
sourcePath :: FilePath
sourcePath = hadrianPath -/- "src"

-- TODO: Change @mk/config.h@ to @shake-build/cfg/config.h@.
-- | Path to the generated @mk/config.h@ file.
configH :: FilePath
configH = "mk/config.h"

ghcVersionH :: Action FilePath
ghcVersionH = generatedPath <&> (-/- "ghcversion.h")

-- | The directory in 'buildRoot' containing the Shake database and other
-- auxiliary files generated by Hadrian.
shakeFilesDir :: FilePath
shakeFilesDir = "hadrian"

-- | The directory in 'buildRoot' containing generated source files that are not
-- package-specific, e.g. @ghcplatform.h@.
generatedDir :: FilePath
generatedDir = "generated"

generatedPath :: Action FilePath
generatedPath = buildRoot <&> (-/- generatedDir)

-- | Path to the package database for a given build stage, relative to the build
-- root.
relativePackageDbPath :: Stage -> FilePath
relativePackageDbPath stage = stageString stage -/- "lib/package.conf.d"

-- | Path to the package database used in a given 'Stage', including
--   the build root.
packageDbPath :: Stage -> Action FilePath
packageDbPath stage = buildRoot <&> (-/- relativePackageDbPath stage)

-- | We use a stamp file to track the existence of a package database.
packageDbStamp :: FilePath
packageDbStamp = ".stamp"

-- | @bin@ directory for the given 'Stage' (including the build root)
stageBinPath :: Stage -> Action FilePath
stageBinPath stage = buildRoot <&> (-/- stageString stage -/- "bin")

-- | @lib@ directory for the given 'Stage' (including the build root)
stageLibPath :: Stage -> Action FilePath
stageLibPath stage = buildRoot <&> (-/- stageString stage -/- "lib")

-- | Files the GHC binary depends on.
ghcDeps :: Stage -> Action [FilePath]
ghcDeps stage = mapM (\f -> stageLibPath stage <&> (-/- f))
    [ "ghc-usage.txt"
    , "ghci-usage.txt"
    , "llvm-targets"
    , "llvm-passes"
    , "platformConstants"
    , "settings" ]

includesDependencies :: Action [FilePath]
includesDependencies = do
    path <- generatedPath
    return $ (path -/-) <$> [ "ghcautoconf.h", "ghcplatform.h", "ghcversion.h" ]

-- | Files the `haddock` binary depends on
haddockDeps :: Stage -> Action [FilePath]
haddockDeps stage = do
    let resdir = "utils/haddock/haddock-api/resources"
    latexResources <- directoryContents matchAll (resdir -/- "latex")
    htmlResources  <- directoryContents matchAll (resdir -/- "html")

    haddockLib <- stageLibPath stage
    return $ [ haddockLib -/- makeRelative resdir f
             | f <- latexResources ++ htmlResources ]

-- ref: utils/hsc2hs/ghc.mk
-- | Path to 'hsc2hs' template.
templateHscPath :: Stage -> Action FilePath
templateHscPath stage = stageLibPath stage <&> (-/- "template-hsc.h")

-- | We use this stamp file to track whether we've moved the mingw toolchain
--   under the build root (to make it accessible to the GHCs we build on
--   Windows). See "Rules.Program".
mingwStamp :: FilePath
mingwStamp = "mingw" -/- ".stamp"


{-# LANGUAGE InstanceSigs #-}
module Builder (
    -- * Data types
    ArMode (..), CcMode (..), ConfigurationInfo (..), GhcMode (..),
    GhcPkgMode (..), HaddockMode (..), SphinxMode (..), TarMode (..),
    Builder (..),

    -- * Builder properties
    builderProvenance, systemBuilderPath, builderPath, isSpecified, needBuilder,
    runBuilder, runBuilderWith, runBuilderWithCmdOptions, getBuilderPath,
    builderEnvironment,

    -- * Ad hoc builder invocation
    applyPatch
    ) where

import Development.Shake.Classes
import GHC.Generics
import qualified Hadrian.Builder as H
import Hadrian.Builder hiding (Builder)
import Hadrian.Builder.Ar
import Hadrian.Builder.Sphinx
import Hadrian.Builder.Tar
import Hadrian.Oracles.Path
import Hadrian.Oracles.TextFile
import Hadrian.Utilities

import Base
import Context
import Oracles.Flag
import Oracles.Setting
import Packages

-- | C compiler can be used in two different modes:
-- * Compile or preprocess a source file.
-- * Extract source dependencies by passing @-MM@ command line argument.
data CcMode = CompileC | FindCDependencies deriving (Eq, Generic, Show)

instance Binary   CcMode
instance Hashable CcMode
instance NFData   CcMode

-- | GHC can be used in four different modes:
-- * Compile a Haskell source file.
-- * Compile a C source file.
-- * Extract source dependencies by passing @-M@ command line argument.
-- * Link object files & static libraries into an executable.
data GhcMode = CompileHs | CompileCWithGhc | FindHsDependencies | LinkHs
    deriving (Eq, Generic, Show)

instance Binary   GhcMode
instance Hashable GhcMode
instance NFData   GhcMode

-- | To configure a package we need two pieces of information, which we choose
-- to record separately for convenience.
--
-- * Command line arguments to be passed to the setup script.
--
-- * Package configuration flags that enable/disable certain package features.
--   Here is an example from "Settings.Packages":
--
--   > package rts
--   >   ? builder (Cabal Flags)
--   >   ? any (wayUnit Profiling) rtsWays
--   >   ? arg "profiling"
--
--   This instructs package configuration functions (such as 'configurePackage')
--   to enable the @profiling@ Cabal flag when processing @rts.cabal@ and
--   building RTS with profiling information.
data ConfigurationInfo = Setup | Flags deriving (Eq, Generic, Show)

instance Binary   ConfigurationInfo
instance Hashable ConfigurationInfo
instance NFData   ConfigurationInfo

-- TODO: Do we really need all these modes? Why do we need 'Dependencies'? We
-- can extract dependencies using the Cabal library. Note: we used to also have
-- the @Init@ mode for initialising a new package database but we've deleted it.
-- | 'GhcPkg' can initialise a package database and register packages in it.
data GhcPkgMode = Copy         -- ^ Copy a package from one database to another.
                | Dependencies -- ^ Compute package dependencies.
                | Unregister   -- ^ Unregister a package.
                | Update       -- ^ Update a package.
                deriving (Eq, Generic, Show)

instance Binary   GhcPkgMode
instance Hashable GhcPkgMode
instance NFData   GhcPkgMode

-- | Haddock can be used in two different modes:
-- * Generate documentation for a single package
-- * Generate an index page for a collection of packages
data HaddockMode = BuildPackage | BuildIndex deriving (Eq, Generic, Show)

instance Binary   HaddockMode
instance Hashable HaddockMode
instance NFData   HaddockMode

-- | A 'Builder' is a (usually external) command invoked in a separate process
-- via 'cmd'. Here are some examples:
-- * 'Alex' is a lexical analyser generator that builds @Lexer.hs@ from @Lexer.x@.
-- * 'Ghc' 'Stage0' is the bootstrapping Haskell compiler used in 'Stage0'.
-- * 'Ghc' @StageN@ (N > 0) is the GHC built in stage (N - 1) and used in @StageN@.
--
-- The 'Cabal' builder is unusual in that it does not correspond to an external
-- program but instead relies on the Cabal library for package configuration.
data Builder = Alex
             | Ar ArMode Stage
             | Autoreconf FilePath
             | DeriveConstants
             | Cabal ConfigurationInfo Stage
             | Cc CcMode Stage
             | Configure FilePath
             | GenApply
             | GenPrimopCode
             | Ghc GhcMode Stage
             | GhcPkg GhcPkgMode Stage
             | Haddock HaddockMode
             | Happy
             | Hpc
             | Hp2Ps
             | HsCpp
             | Hsc2Hs Stage
             | Ld Stage
             | Make FilePath
             | Nm
             | Objdump
             | Patch
             | Perl
             | Python
             | Ranlib
             | RunTest
             | Sphinx SphinxMode
             | Tar TarMode
             | Unlit
             | Xelatex
             deriving (Eq, Generic, Show)

instance Binary   Builder
instance Hashable Builder
instance NFData   Builder

-- | Some builders are built by this very build system, in which case
-- 'builderProvenance' returns the corresponding build 'Context' (which includes
-- 'Stage' and GHC 'Package').
builderProvenance :: Builder -> Maybe Context
builderProvenance = \case
    DeriveConstants  -> context Stage0 deriveConstants
    GenApply         -> context Stage0 genapply
    GenPrimopCode    -> context Stage0 genprimopcode
    Ghc _ Stage0     -> Nothing
    Ghc _ stage      -> context (pred stage) ghc
    GhcPkg _ Stage0  -> Nothing
    GhcPkg _ s       -> context (pred s) ghcPkg
    Haddock _        -> context Stage1 haddock
    Hpc              -> context Stage1 hpcBin
    Hp2Ps            -> context Stage0 hp2ps
    Hsc2Hs _         -> context Stage0 hsc2hs
    Unlit            -> context Stage0 unlit
    _                -> Nothing
  where
    context s p = Just $ vanillaContext s p

instance H.Builder Builder where
    builderPath :: Builder -> Action FilePath
    builderPath builder = case builderProvenance builder of
        Nothing      -> systemBuilderPath builder
        Just context -> programPath context

    runtimeDependencies :: Builder -> Action [FilePath]
    runtimeDependencies = \case
        Autoreconf dir -> return [dir -/- "configure.ac"]
        Configure  dir -> return [dir -/- "configure"]

        Ghc _ Stage0 -> generatedGhcDependencies Stage0
        Ghc _ stage -> do
            root <- buildRoot
            win <- windowsHost
            touchyPath <- programPath (vanillaContext Stage0 touchy)
            unlitPath  <- builderPath Unlit
            ghcdeps <- ghcDeps stage
            ghcgens <- generatedGhcDependencies stage
            return $ [ unlitPath ]
                  ++ ghcdeps
                  ++ ghcgens
                  ++ [ touchyPath | win ]
                  ++ [ root -/- mingwStamp | win ]
                     -- proxy for the entire mingw toolchain that
                     -- we have in inplace/mingw initially, and then at
                     -- root -/- mingw.

        Hsc2Hs stage -> (\p -> [p]) <$> templateHscPath stage
        Make dir  -> return [dir -/- "Makefile"]
        Haddock _ -> haddockDeps Stage1  -- Haddock currently runs in Stage1
        _         -> return []

    -- query the builder for some information.
    -- contrast this with runBuilderWith, which returns @Action ()@
    -- this returns the @stdout@ from running the builder.
    -- For now this only implements asking @ghc-pkg@ about package
    -- dependencies.
    askBuilderWith :: Builder -> BuildInfo -> Action String
    askBuilderWith builder BuildInfo {..} = case builder of
        GhcPkg Dependencies _ -> do
            let input  = fromSingleton msgIn buildInputs
                msgIn  = "[askBuilder] Exactly one input file expected."
            needBuilder builder
            path <- H.builderPath builder
            need [path]
            Stdout stdout <- cmd [path] ["--no-user-package-db", "field", input, "depends"]
            return stdout
        _ -> error $ "Builder " ++ show builder ++ " can not be asked!"

    runBuilderWith :: Builder -> BuildInfo -> Action ()
    runBuilderWith builder BuildInfo {..} = do
        path <- builderPath builder
        withResources buildResources $ do
            verbosity <- getVerbosity
            let input  = fromSingleton msgIn buildInputs
                msgIn  = "[runBuilderWith] Exactly one input file expected."
                output = fromSingleton msgOut buildOutputs
                msgOut = "[runBuilderWith] Exactly one output file expected."
                -- Suppress stdout depending on the Shake's verbosity setting.
                echo = EchoStdout (verbosity >= Loud)
                -- Capture stdout and write it to the output file.
                captureStdout = do
                    Stdout stdout <- cmd [path] buildArgs
                    writeFileChanged output stdout
            case builder of
                Ar Pack _ -> do
                    useTempFile <- flag ArSupportsAtFile
                    if useTempFile then runAr                path buildArgs
                                   else runArWithoutTempFile path buildArgs

                Ar Unpack _ -> cmd echo [Cwd output] [path] buildArgs

                Autoreconf dir -> cmd echo [Cwd dir] [path] buildArgs
                Configure  dir -> do
                    -- Inject /bin/bash into `libtool`, instead of /bin/sh,
                    -- otherwise Windows breaks. TODO: Figure out why.
                    bash <- bashPath
                    let env = AddEnv "CONFIG_SHELL" bash
                    cmd echo env [Cwd dir] ["sh", path] buildOptions buildArgs

                HsCpp    -> captureStdout
                GenApply -> captureStdout

                GenPrimopCode -> do
                    stdin <- readFile' input
                    Stdout stdout <- cmd (Stdin stdin) [path] buildArgs
                    writeFileChanged output stdout

                Make dir -> cmd echo path ["-C", dir] buildArgs

                Xelatex -> do
                    unit $ cmd [Cwd output] [path]        buildArgs
                    unit $ cmd [Cwd output] [path]        buildArgs
                    unit $ cmd [Cwd output] [path]        buildArgs
                    unit $ cmd [Cwd output] ["makeindex"] (input -<.> "idx")
                    unit $ cmd [Cwd output] [path]        buildArgs
                    unit $ cmd [Cwd output] [path]        buildArgs

                GhcPkg Copy _ -> do
                    Stdout pkgDesc <- cmd [path]
                      [ "--expand-pkgroot"
                      , "--no-user-package-db"
                      , "describe"
                      , input -- the package name
                      ]
                    cmd (Stdin pkgDesc) [path] (buildArgs ++ ["-"])

                GhcPkg Unregister _ -> do
                    Exit _ <- cmd echo [path] (buildArgs ++ [input])
                    return ()

                _  -> cmd echo [path] buildArgs

-- TODO: Some builders are required only on certain platforms. For example,
-- 'Objdump' is only required on OpenBSD and AIX. Add support for platform
-- specific optional builders as soon as we can reliably test this feature.
-- See https://github.com/snowleopard/hadrian/issues/211.
isOptional :: Builder -> Bool
isOptional = \case
    Objdump  -> True
    _        -> False

-- | Determine the location of a system 'Builder'.
systemBuilderPath :: Builder -> Action FilePath
systemBuilderPath builder = case builder of
    Alex            -> fromKey "alex"
    Ar _ Stage0     -> fromKey "system-ar"
    Ar _ _          -> fromKey "ar"
    Autoreconf _    -> stripExe =<< fromKey "autoreconf"
    Cc  _  Stage0   -> fromKey "system-cc"
    Cc  _  _        -> fromKey "cc"
    -- We can't ask configure for the path to configure!
    Configure _     -> return "configure"
    Ghc _  Stage0   -> fromKey "system-ghc"
    GhcPkg _ Stage0 -> fromKey "system-ghc-pkg"
    Happy           -> fromKey "happy"
    HsCpp           -> fromKey "hs-cpp"
    Ld _            -> fromKey "ld"
    Make _          -> fromKey "make"
    Nm              -> fromKey "nm"
    Objdump         -> fromKey "objdump"
    Patch           -> fromKey "patch"
    Perl            -> fromKey "perl"
    Python          -> fromKey "python"
    Ranlib          -> fromKey "ranlib"
    RunTest         -> fromKey "python"
    Sphinx _        -> fromKey "sphinx-build"
    Tar _           -> fromKey "tar"
    Xelatex         -> fromKey "xelatex"
    _               -> error $ "No entry for " ++ show builder ++ inCfg
  where
    inCfg = " in " ++ quote configFile ++ " file."
    fromKey key = do
        let unpack = fromMaybe . error $ "Cannot find path to builder "
                ++ quote key ++ inCfg ++ " Did you skip configure?"
        path <- unpack <$> lookupValue configFile key
        if null path
        then do
            unless (isOptional builder) . error $ "Non optional builder "
                ++ quote key ++ " is not specified" ++ inCfg
            return "" -- TODO: Use a safe interface.
        else do
            win <- windowsHost
            fullPath <- lookupInPath path
            case (win, hasExtension fullPath) of
                (False, _    ) -> return fullPath
                (True , True ) -> fixAbsolutePathOnWindows fullPath
                (True , False) -> fixAbsolutePathOnWindows fullPath <&> (<.> exe)

    -- Without this function, on Windows we can observe a bad builder path
    -- for 'autoreconf'. If the relevant system.config field is set to
    -- /usr/bin/autoreconf in the file, the path that we read
    -- is C:/msys64/usr/bin/autoreconf.exe. A standard msys2 set up happens
    -- to have an executable named 'autoreconf' there, without the 'exe'
    -- extension. Hence this function.
    stripExe s = do
        let sNoExt = dropExtension s
        exists <- doesFileExist s
        if exists then return s else return sNoExt

-- | Was the path to a given system 'Builder' specified in configuration files?
isSpecified :: Builder -> Action Bool
isSpecified = fmap (not . null) . systemBuilderPath

-- | Apply a patch by executing the 'Patch' builder in a given directory.
applyPatch :: FilePath -> FilePath -> Action ()
applyPatch dir patch = do
    let file = dir -/- patch
    needBuilder Patch
    path <- builderPath Patch
    putBuild $ "| Apply patch " ++ file
    quietly $ cmd [Cwd dir, FileStdin file] [path, "-p0"]


module CommandLine (
    optDescrs, cmdLineArgsMap, cmdFlavour, lookupFreeze1, cmdIntegerSimple,
    cmdProgressColour, cmdProgressInfo, cmdConfigure,
    cmdDocsArgs, lookupBuildRoot, TestArgs(..), TestSpeed(..), defaultTestArgs
    ) where

import Data.Either
import qualified Data.HashMap.Strict as Map
import Data.List.Extra
import Development.Shake hiding (Normal)
import Flavour (DocTargets, DocTarget(..))
import Hadrian.Utilities hiding (buildRoot)
import System.Console.GetOpt
import System.Environment

import qualified Data.Set as Set

data TestSpeed = Slow | Average | Fast deriving (Show, Eq)

-- | All arguments that can be passed to Hadrian via the command line.
data CommandLineArgs = CommandLineArgs
    { configure      :: Bool
    , flavour        :: Maybe String
    , freeze1        :: Bool
    , integerSimple  :: Bool
    , progressColour :: UseColour
    , progressInfo   :: ProgressInfo
    , buildRoot      :: BuildRoot
    , testArgs       :: TestArgs
    , docTargets     :: DocTargets }
    deriving (Eq, Show)

-- | Default values for 'CommandLineArgs'.
defaultCommandLineArgs :: CommandLineArgs
defaultCommandLineArgs = CommandLineArgs
    { configure      = False
    , flavour        = Nothing
    , freeze1        = False
    , integerSimple  = False
    , progressColour = Auto
    , progressInfo   = Brief
    , buildRoot      = BuildRoot "_build"
    , testArgs       = defaultTestArgs
    , docTargets     = Set.fromList [minBound..maxBound] }

-- | These arguments are used by the `test` target.
data TestArgs = TestArgs
    { testCompiler   :: String
    , testConfigFile :: String
    , testConfigs    :: [String]
    , testJUnit      :: Maybe FilePath
    , testOnly       :: [String]
    , testOnlyPerf   :: Bool
    , testSkipPerf   :: Bool
    , testSpeed      :: TestSpeed
    , testSummary    :: Maybe FilePath
    , testVerbosity  :: Maybe String
    , testWays       :: [String] }
    deriving (Eq, Show)

-- | Default value for `TestArgs`.
defaultTestArgs :: TestArgs
defaultTestArgs = TestArgs
    { testCompiler   = "stage2"
    , testConfigFile = "testsuite/config/ghc"
    , testConfigs    = []
    , testJUnit      = Nothing
    , testOnly       = []
    , testOnlyPerf   = False
    , testSkipPerf   = False
    , testSpeed      = Fast
    , testSummary    = Nothing
    , testVerbosity  = Nothing
    , testWays       = [] }

readConfigure :: Either String (CommandLineArgs -> CommandLineArgs)
readConfigure = Right $ \flags -> flags { configure = True }

readFlavour :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
readFlavour ms = Right $ \flags -> flags { flavour = lower <$> ms }

readBuildRoot :: Maybe FilePath -> Either String (CommandLineArgs -> CommandLineArgs)
readBuildRoot ms =
    maybe (Left "Cannot parse build-root") (Right . set) (go =<< ms)
  where
    go :: String -> Maybe BuildRoot
    go = Just . BuildRoot
    set :: BuildRoot -> CommandLineArgs -> CommandLineArgs
    set flag flags = flags { buildRoot = flag }

readFreeze1 :: Either String (CommandLineArgs -> CommandLineArgs)
readFreeze1 = Right $ \flags -> flags { freeze1 = True }

readIntegerSimple :: Either String (CommandLineArgs -> CommandLineArgs)
readIntegerSimple = Right $ \flags -> flags { integerSimple = True }

readProgressColour :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
readProgressColour ms =
    maybe (Left "Cannot parse progress-colour") (Right . set) (go =<< lower <$> ms)
  where
    go :: String -> Maybe UseColour
    go "never"   = Just Never
    go "auto"    = Just Auto
    go "always"  = Just Always
    go _         = Nothing
    set :: UseColour -> CommandLineArgs -> CommandLineArgs
    set flag flags = flags { progressColour = flag }

readProgressInfo :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
readProgressInfo ms =
    maybe (Left "Cannot parse progress-info") (Right . set) (go =<< lower <$> ms)
  where
    go :: String -> Maybe ProgressInfo
    go "none"    = Just None
    go "brief"   = Just Brief
    go "normal"  = Just Normal
    go "unicorn" = Just Unicorn
    go _         = Nothing
    set :: ProgressInfo -> CommandLineArgs -> CommandLineArgs
    set flag flags = flags { progressInfo = flag }

readTestCompiler :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
readTestCompiler compiler = maybe (Left "Cannot parse compiler") (Right . set) compiler
  where
     set compiler  = \flags -> flags { testArgs = (testArgs flags) { testCompiler = compiler } }

readTestConfig :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
readTestConfig config =
    case config of
         Nothing -> Right id
         Just conf -> Right $ \flags ->
                        let configs = conf : testConfigs (testArgs flags)
                        in flags { testArgs = (testArgs flags) { testConfigs = configs } }

readTestConfigFile :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
readTestConfigFile filepath =
    maybe (Left "Cannot parse test-speed") (Right . set) filepath
  where
    set filepath flags =  flags { testArgs = (testArgs flags) { testConfigFile = filepath } }

readTestJUnit :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
readTestJUnit filepath = Right $ \flags -> flags { testArgs = (testArgs flags) { testJUnit = filepath } }

readTestOnly :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
readTestOnly tests = Right $ \flags ->
  flags { testArgs = (testArgs flags) { testOnly = tests' } }

  where tests' = maybe [] words tests

readTestOnlyPerf :: Either String (CommandLineArgs -> CommandLineArgs)
readTestOnlyPerf = Right $ \flags -> flags { testArgs = (testArgs flags) { testOnlyPerf = True } }

readTestSkipPerf :: Either String (CommandLineArgs -> CommandLineArgs)
readTestSkipPerf = Right $ \flags -> flags { testArgs = (testArgs flags) { testSkipPerf = True } }

readTestSpeed :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
readTestSpeed ms =
    maybe (Left "Cannot parse test-speed") (Right . set) (go =<< lower <$> ms)
  where
    go :: String -> Maybe TestSpeed
    go "fast"    = Just Fast
    go "slow"    = Just Slow
    go "average" = Just Average
    go _         = Nothing
    set :: TestSpeed -> CommandLineArgs -> CommandLineArgs
    set flag flags = flags { testArgs = (testArgs flags) {testSpeed = flag} }

readTestSummary :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
readTestSummary filepath = Right $ \flags -> flags { testArgs = (testArgs flags) { testJUnit = filepath } }

readTestVerbose :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
readTestVerbose verbose = Right $ \flags -> flags { testArgs = (testArgs flags) { testVerbosity = verbose } }

readTestWay :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
readTestWay way =
    case way of
        Nothing -> Right id
        Just way -> Right $ \flags ->
            let newWays = way : testWays (testArgs flags)
            in flags { testArgs = (testArgs flags) {testWays = newWays} }

readDocsArg :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
readDocsArg ms = maybe (Left "Cannot parse docs argument") (Right . set) (go =<< ms)

  where
    go :: String -> Maybe (DocTargets -> DocTargets)
    go "none"           = Just (const Set.empty)
    go "no-haddocks"    = Just (Set.delete Haddocks)
    go "no-sphinx-html" = Just (Set.delete SphinxHTML)
    go "no-sphinx-pdfs" = Just (Set.delete SphinxPDFs)
    go "no-sphinx-man"  = Just (Set.delete SphinxMan)
    go "no-sphinx"      = Just (Set.delete SphinxHTML
                              . Set.delete SphinxPDFs
                              . Set.delete SphinxMan)
    go _                = Nothing

    set :: (DocTargets -> DocTargets) -> CommandLineArgs -> CommandLineArgs
    set tweakTargets flags = flags
      { docTargets = tweakTargets (docTargets flags) }

-- | Standard 'OptDescr' descriptions of Hadrian's command line arguments.
optDescrs :: [OptDescr (Either String (CommandLineArgs -> CommandLineArgs))]
optDescrs =
    [ Option ['c'] ["configure"] (NoArg readConfigure)
      "Run the boot and configure scripts (if you do not want to run them manually)."
    , Option ['o'] ["build-root"] (OptArg readBuildRoot "BUILD_ROOT")
      "Where to store build artifacts. (Default _build)."
    , Option [] ["flavour"] (OptArg readFlavour "FLAVOUR")
      "Build flavour (Default, Devel1, Devel2, Perf, Prof, Quick or Quickest)."
    , Option [] ["freeze1"] (NoArg readFreeze1)
      "Freeze Stage1 GHC."
    , Option [] ["integer-simple"] (NoArg readIntegerSimple)
      "Build GHC with integer-simple library."
    , Option [] ["progress-colour"] (OptArg readProgressColour "MODE")
      "Use colours in progress info (Never, Auto or Always)."
    , Option [] ["progress-info"] (OptArg readProgressInfo "STYLE")
      "Progress info style (None, Brief, Normal or Unicorn)."
    , Option [] ["docs"] (OptArg readDocsArg "TARGET")
      "Strip down docs targets (none, no-haddocks, no-sphinx[-{html, pdfs, man}]."
    , Option [] ["test-compiler"] (OptArg readTestCompiler "TEST_COMPILER")
      "Use given compiler [Default=stage2]."
    , Option [] ["test-config-file"] (OptArg readTestConfigFile "CONFIG_FILE")
      "configuration file for testsuite. Default=testsuite/config/ghc"
    , Option [] ["config"] (OptArg readTestConfig "EXTRA_TEST_CONFIG")
      "Configurations to run test, in key=value format."
    , Option [] ["summary-junit"] (OptArg readTestJUnit "TEST_SUMMARY_JUNIT")
      "Output testsuite summary in JUnit format."
    , Option [] ["only"] (OptArg readTestOnly "TESTS")
      "Test cases to run."
    , Option [] ["only-perf"] (NoArg readTestOnlyPerf)
      "Only run performance tests."
    , Option [] ["skip-perf"] (NoArg readTestSkipPerf)
      "Skip performance tests."
    , Option [] ["test-speed"] (OptArg readTestSpeed "SPEED")
      "fast, slow or normal. Normal by default"
    , Option [] ["summary"] (OptArg readTestSummary "TEST_SUMMARY")
      "Where to output the test summary file."
    , Option [] ["test-verbose"] (OptArg readTestVerbose "TEST_VERBOSE")
      "A verbosity value between 0 and 5. 0 is silent, 4 and higher activates extra output."
    , Option [] ["test-way"] (OptArg readTestWay "TEST_WAY")
      "only run these ways" ]

-- | A type-indexed map containing Hadrian command line arguments to be passed
-- to Shake via 'shakeExtra'.
cmdLineArgsMap :: IO (Map.HashMap TypeRep Dynamic)
cmdLineArgsMap = do
    (opts, _, _) <- getOpt Permute optDescrs <$> getArgs
    let args = foldl (flip id) defaultCommandLineArgs (rights opts)
    return $ insertExtra (progressColour args) -- Accessed by Hadrian.Utilities
           $ insertExtra (progressInfo   args) -- Accessed by Hadrian.Utilities
           $ insertExtra (buildRoot      args) -- Accessed by Hadrian.Utilities
           $ insertExtra (testArgs       args) -- Accessed by Settings.Builders.RunTest
           $ insertExtra args Map.empty

cmdLineArgs :: Action CommandLineArgs
cmdLineArgs = userSetting defaultCommandLineArgs

cmdConfigure :: Action Bool
cmdConfigure = configure <$> cmdLineArgs

cmdFlavour :: Action (Maybe String)
cmdFlavour = flavour <$> cmdLineArgs

lookupBuildRoot :: Map.HashMap TypeRep Dynamic -> BuildRoot
lookupBuildRoot = buildRoot . lookupExtra defaultCommandLineArgs

lookupFreeze1 :: Map.HashMap TypeRep Dynamic -> Bool
lookupFreeze1 = freeze1 . lookupExtra defaultCommandLineArgs

cmdIntegerSimple :: Action Bool
cmdIntegerSimple = integerSimple <$> cmdLineArgs

cmdProgressColour :: Action UseColour
cmdProgressColour = progressColour <$> cmdLineArgs

cmdProgressInfo :: Action ProgressInfo
cmdProgressInfo = progressInfo <$> cmdLineArgs

cmdDocsArgs :: Action DocTargets
cmdDocsArgs = docTargets <$> cmdLineArgs


module Context (
    -- * Context
    Context (..), vanillaContext, stageContext,

    -- * Expressions
    getStage, getPackage, getWay, getStagedSettingList, getBuildPath,

    -- * Paths
    contextDir, buildPath, buildDir, pkgInplaceConfig, pkgSetupConfigFile,
    pkgHaddockFile, pkgLibraryFile, pkgGhciLibraryFile, pkgConfFile, objectPath,
    contextPath, getContextPath, libPath, distDir
    ) where

import Base
import Context.Path
import Context.Type
import Hadrian.Expression
import Hadrian.Haskell.Cabal
import Oracles.Setting

-- | Most targets are built only one way, hence the notion of 'vanillaContext'.
vanillaContext :: Stage -> Package -> Context
vanillaContext s p = Context s p vanilla

-- | Partial context with undefined 'Package' field. Useful for 'Packages'
-- expressions that only read the environment and current 'Stage'.
stageContext :: Stage -> Context
stageContext s = vanillaContext s $ error "stageContext: package not set"

-- | Get the 'Stage' of the current 'Context'.
getStage :: Expr Context b Stage
getStage = stage <$> getContext

-- | Get the 'Package' of the current 'Context'.
getPackage :: Expr Context b Package
getPackage = package <$> getContext

-- | Get the 'Way' of the current 'Context'.
getWay :: Expr Context b Way
getWay = way <$> getContext

-- | Get a list of configuration settings for the current stage.
getStagedSettingList :: (Stage -> SettingList) -> Args Context b
getStagedSettingList f = getSettingList . f =<< getStage

-- | Path to the directory containg the final artifact in a given 'Context'.
libPath :: Context -> Action FilePath
libPath Context {..} = buildRoot <&> (-/- (stageString stage -/- "lib"))

-- | Get the directory name for binary distribution files
-- @<arch>-<os>-ghc-<version>@.
--
-- We preform some renaming to accomodate Cabal's slightly different naming
-- conventions (see 'cabalOsString' and 'cabalArchString').
distDir :: Action FilePath
distDir = do
    version        <- setting ProjectVersion
    hostOs         <- cabalOsString <$> setting BuildOs
    hostArch       <- cabalArchString <$> setting BuildArch
    return $ hostArch ++ "-" ++ hostOs ++ "-ghc-" ++ version

pkgFile :: Context -> String -> String -> Action FilePath
pkgFile context@Context {..} prefix suffix = do
    path <- buildPath context
    pid  <- pkgIdentifier package
    return $ path -/- prefix ++ pid ++ suffix

-- | Path to inplace package configuration file of a given 'Context'.
pkgInplaceConfig :: Context -> Action FilePath
pkgInplaceConfig context = contextPath context <&> (-/- "inplace-pkg-config")

-- | Path to the @setup-config@ of a given 'Context'.
pkgSetupConfigFile :: Context -> Action FilePath
pkgSetupConfigFile context = contextPath context <&> (-/- "setup-config")

-- | Path to the haddock file of a given 'Context', e.g.:
-- @_build/stage1/libraries/array/doc/html/array/array.haddock@.
pkgHaddockFile :: Context -> Action FilePath
pkgHaddockFile Context {..} = do
    root <- buildRoot
    let name = pkgName package
    return $ root -/- "docs/html/libraries" -/- name -/- name <.> "haddock"

-- | Path to the library file of a given 'Context', e.g.:
-- @_build/stage1/libraries/array/build/libHSarray-0.5.1.0.a@.
pkgLibraryFile :: Context -> Action FilePath
pkgLibraryFile context@Context {..} = do
    extension <- libsuf way
    pkgFile context "libHS" extension

-- | Path to the GHCi library file of a given 'Context', e.g.:
-- @_build/stage1/libraries/array/build/HSarray-0.5.1.0.o@.
pkgGhciLibraryFile :: Context -> Action FilePath
pkgGhciLibraryFile context@Context {..} = do
    let extension = "" <.> osuf way
    pkgFile context "HS" extension

-- | Path to the configuration file of a given 'Context'.
pkgConfFile :: Context -> Action FilePath
pkgConfFile Context {..} = do
    pid  <- pkgIdentifier package
    dbPath <- packageDbPath stage
    return $ dbPath -/- pid <.> "conf"

-- | Given a 'Context' and a 'FilePath' to a source file, compute the 'FilePath'
-- to its object file. For example:
-- * "Task.c"                              -> "_build/stage1/rts/Task.thr_o"
-- * "_build/stage1/rts/cmm/AutoApply.cmm" -> "_build/stage1/rts/cmm/AutoApply.o"
objectPath :: Context -> FilePath -> Action FilePath
objectPath context@Context {..} src = do
    isGenerated <- isGeneratedSource src
    path        <- buildPath context
    let extension = drop 1 $ takeExtension src
        obj       = src -<.> osuf way
        result | isGenerated          = obj
               | "*hs*" ?== extension = path -/- obj
               | otherwise            = path -/- extension -/- obj
    return result


module Environment (setupEnvironment) where

import System.Environment

-- | The build system invokes many external builders whose behaviour is
-- influenced by the environment variables. We need to modify some of them
-- for better robustness of the build system.
setupEnvironment :: IO ()
setupEnvironment = do
    -- Cabal refuses to work when GHC_PACKAGE_PATH is set (e.g. by Stack)
    unsetEnv "GHC_PACKAGE_PATH"

    -- cabal new-exec sets GHC_ENVIRONMENT, it needs to be unset for GHC
    -- invocations to work properly
    unsetEnv "GHC_ENVIRONMENT"

    -- in MinGW if PWD is set to a Windows "C:\\" style path then configure
    -- `pwd` will return the Windows path, and then modifying $PATH will fail.
    -- See https://github.com/snowleopard/hadrian/issues/189 for details.
    unsetEnv "PWD"


module Expression (
    -- * Expressions
    Expr, Predicate, Args, Ways,

    -- ** Construction and modification
    expr, exprIO, arg, remove,

    -- ** Predicates
    (?), stage, stage0, stage1, stage2, notStage0, package, notPackage,
    libraryPackage, builder, way, input, inputs, output, outputs,

    -- ** Evaluation
    interpret, interpretInContext,

    -- * Convenient accessors
    getBuildRoot, getContext, getOutputs, getInputs,
    getInput, getOutput, getContextData,

    -- * Re-exports
    module Base,
    module Builder,
    module Context,
    ) where

import Base
import Builder
import Context hiding (stage, package, way)
import Expression.Type
import Hadrian.Expression hiding (Expr, Predicate, Args)
import Hadrian.Haskell.Cabal.Type
import Hadrian.Oracles.Cabal

-- | Get values from a configured cabal stage.
getContextData :: (ContextData -> a) -> Expr a
getContextData key = do
    contextData <- expr . readContextData =<< getContext
    return $ key contextData

-- | Is the build currently in the provided stage?
stage :: Stage -> Predicate
stage s = (s ==) <$> getStage

-- | Is a particular package being built?
package :: Package -> Predicate
package p = (p ==) <$> getPackage

-- | This type class allows the user to construct both precise builder
-- predicates, such as @builder (Ghc CompileHs Stage1)@, as well as predicates
-- covering a set of similar builders. For example, @builder (Ghc CompileHs)@
-- matches any stage, and @builder Ghc@ matches any stage and any GHC mode.
class BuilderPredicate a where
    -- | Is a particular builder being used?
    builder :: a -> Predicate

instance BuilderPredicate Builder where
    builder b = (b ==) <$> getBuilder

instance BuilderPredicate a => BuilderPredicate (Stage -> a) where
    builder f = builder . f =<< getStage

instance BuilderPredicate a => BuilderPredicate (CcMode -> a) where
    builder f = do
        b <- getBuilder
        case b of
            Cc  c _ -> builder (f c)
            _       -> return False

instance BuilderPredicate a => BuilderPredicate (GhcMode -> a) where
    builder f = do
        b <- getBuilder
        case b of
            Ghc c _ -> builder (f c)
            _       -> return False

instance BuilderPredicate a => BuilderPredicate (FilePath -> a) where
    builder f = do
        b <- getBuilder
        case b of
            Configure path -> builder (f path)
            _              -> return False

-- | Is the current build 'Way' equal to a certain value?
way :: Way -> Predicate
way w = (w ==) <$> getWay

-- | Is the build currently in stage 0?
stage0 :: Predicate
stage0 = stage Stage0

-- | Is the build currently in stage 1?
stage1 :: Predicate
stage1 = stage Stage1

-- | Is the build currently in stage 2?
stage2 :: Predicate
stage2 = stage Stage2

-- | Is the build /not/ in stage 0 right now?
notStage0 :: Predicate
notStage0 = notM stage0

-- | Is a certain package /not/ built right now?
notPackage :: Package -> Predicate
notPackage = notM . package

-- | Is a library package currently being built?
libraryPackage :: Predicate
libraryPackage = isLibrary <$> getPackage


module Flavour
  ( Flavour (..), werror
  , DocTargets, DocTarget(..)
  ) where

import Expression
import Data.Set (Set)

-- Please update doc/{flavours.md, user-settings.md} when changing this file.
-- | 'Flavour' is a collection of build settings that fully define a GHC build.
-- Note the following type semantics:
-- * @Bool@: a plain Boolean flag whose value is known at compile time.
-- * @Action Bool@: a flag whose value can depend on the build environment.
-- * @Predicate@: a flag whose value can depend on the build environment and
-- on the current build target.
data Flavour = Flavour {
    -- | Flavour name, to select this flavour from command line.
    name :: String,
    -- | Use these command line arguments.
    args :: Args,
    -- | Build these packages.
    packages :: Stage -> Action [Package],
    -- | Either 'integerGmp' or 'integerSimple'.
    integerLibrary :: Action Package,
    -- | Build libraries these ways.
    libraryWays :: Ways,
    -- | Build RTS these ways.
    rtsWays :: Ways,
    -- | Build dynamic GHC programs.
    dynamicGhcPrograms :: Action Bool,
    -- | Enable GHCi debugger.
    ghciWithDebugger :: Bool,
    -- | Build profiled GHC.
    ghcProfiled :: Bool,
    -- | Build GHC with debug information.
    ghcDebugged :: Bool,
    -- | Whether to build docs and which ones
    --   (haddocks, user manual, haddock manual)
    ghcDocs :: Action DocTargets }

-- | A set of documentation targets
type DocTargets = Set DocTarget

-- | Documentation targets
--
--   While we can't reasonably expose settings or CLI options
--   to selectively disable, say, base's haddocks, we can offer
--   a less fine-grained choice:
--
--   - haddocks for libraries
--   - non-haddock html pages (e.g GHC's user manual)
--   - PDF documents (e.g haddock's manual)
--   - man pages (GHC's)
--
--   The main goal being to have easy ways to do away with the need
--   for e.g @sphinx-build@ or @xelatex@ and associated packages
--   while still being able to build a(n almost) complete binary
--   distribution.
data DocTarget = Haddocks | SphinxHTML | SphinxPDFs | SphinxMan
  deriving (Eq, Ord, Show, Bounded, Enum)

-- | Turn on -Werror for packages built with the stage1 compiler.
-- It mimics the CI settings so is useful to turn on when developing.
werror :: Flavour -> Flavour
werror fl = fl { args = args fl <> (builder Ghc ? notStage0 ? arg "-Werror") }


module Main (main) where

import Development.Shake
import Hadrian.Expression
import Hadrian.Utilities

import qualified Base
import qualified CommandLine
import qualified Environment
import qualified Rules
import qualified Rules.Clean
import qualified Rules.Documentation
import qualified Rules.Nofib
import qualified Rules.SourceDist
import qualified Rules.Selftest
import qualified Rules.Test
import qualified UserSettings

main :: IO ()
main = do
    -- Provide access to command line arguments and some user settings through
    -- Shake's type-indexed map 'shakeExtra'.
    argsMap <- CommandLine.cmdLineArgsMap
    let extra = insertExtra UserSettings.buildProgressColour
              $ insertExtra UserSettings.successColour
              $ insertExtra (VerboseCommand UserSettings.verboseCommand) argsMap

        BuildRoot buildRoot = CommandLine.lookupBuildRoot argsMap

        rebuild = [ (RebuildLater, buildRoot -/- "stage0//*")
                  | CommandLine.lookupFreeze1 argsMap ]

        options :: ShakeOptions
        options = shakeOptions
            { shakeChange   = ChangeModtimeAndDigest
            , shakeFiles    = buildRoot -/- Base.shakeFilesDir
            , shakeProgress = progressSimple
            , shakeRebuild  = rebuild
            , shakeTimings  = True
            , shakeExtra    = extra }

        rules :: Rules ()
        rules = do
            Rules.buildRules
            Rules.Documentation.documentationRules
            Rules.Clean.cleanRules
            Rules.Nofib.nofibRules
            Rules.oracleRules
            Rules.Selftest.selftestRules
            Rules.SourceDist.sourceDistRules
            Rules.Test.testRules
            Rules.topLevelTargets

    shakeArgsWith options CommandLine.optDescrs $ \_ targets -> do
        Environment.setupEnvironment
        return . Just $ if null targets
                        then rules
                        else want targets >> withoutActions rules


{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
module Packages (
    -- * GHC packages
    array, base, binary, bytestring, cabal, checkApiAnnotations, checkPpr,
    compareSizes, compiler, containers, deepseq, deriveConstants, directory,
    filepath, genapply, genprimopcode, ghc, ghcBoot, ghcBootTh, ghcCompact,
    ghcHeap, ghci, ghcPkg, ghcPrim, haddock, haskeline,
    hsc2hs, hp2ps, hpc, hpcBin, integerGmp, integerSimple, iserv, libffi,
    libiserv, mtl, parsec, pretty, primitive, process, rts, runGhc,
    stm, templateHaskell, terminfo, text, time, timeout, touchy, transformers,
    unlit, unix, win32, xhtml, ghcPackages, isGhcPackage,

    -- * Package information
    programName, nonHsMainPackage, autogenPath, programPath, timeoutPath,
    rtsContext, rtsBuildPath, libffiBuildPath, libffiLibraryName,
    generatedGhcDependencies, ensureConfigured
    ) where

import Hadrian.Package
import Hadrian.Utilities

import Base
import Context
import Oracles.Flag
import Oracles.Setting

-- | These are all GHC packages we know about. Build rules will be generated for
-- all of them. However, not all of these packages will be built. For example,
-- package 'win32' is built only on Windows. @GHC.defaultPackages@ defines
-- default conditions for building each package. Users can add their own
-- packages and modify build default build conditions in "UserSettings".
ghcPackages :: [Package]
ghcPackages =
    [ array, base, binary, bytestring, cabal, checkPpr, checkApiAnnotations
    , compareSizes, compiler, containers, deepseq, deriveConstants, directory
    , filepath, genapply, genprimopcode, ghc, ghcBoot, ghcBootTh, ghcCompact
    , ghcHeap, ghci, ghcPkg, ghcPrim, haddock, haskeline, hsc2hs, hp2ps
    , hpc, hpcBin, integerGmp, integerSimple, iserv, libffi, libiserv, mtl
    , parsec, pretty, process, rts, runGhc, stm, templateHaskell
    , terminfo, text, time, touchy, transformers, unlit, unix, win32, xhtml
    , timeout ]

-- TODO: Optimise by switching to sets of packages.
isGhcPackage :: Package -> Bool
isGhcPackage = (`elem` ghcPackages)

-- | Package definitions, see 'Package'.
array               = lib  "array"
base                = lib  "base"
binary              = lib  "binary"
bytestring          = lib  "bytestring"
cabal               = lib  "Cabal"           `setPath` "libraries/Cabal/Cabal"
checkApiAnnotations = util "check-api-annotations"
checkPpr            = util "check-ppr"
compareSizes        = util "compareSizes"    `setPath` "utils/compare_sizes"
compiler            = top  "ghc"             `setPath` "compiler"
containers          = lib  "containers"
deepseq             = lib  "deepseq"
deriveConstants     = util "deriveConstants"
directory           = lib  "directory"
filepath            = lib  "filepath"
genapply            = util "genapply"
genprimopcode       = util "genprimopcode"
ghc                 = prg  "ghc-bin"         `setPath` "ghc"
ghcBoot             = lib  "ghc-boot"
ghcBootTh           = lib  "ghc-boot-th"
ghcCompact          = lib  "ghc-compact"
ghcHeap             = lib  "ghc-heap"
ghci                = lib  "ghci"
ghcPkg              = util "ghc-pkg"
ghcPrim             = lib  "ghc-prim"
haddock             = util "haddock"
haskeline           = lib  "haskeline"
hsc2hs              = util "hsc2hs"
hp2ps               = util "hp2ps"
hpc                 = lib  "hpc"
hpcBin              = util "hpc-bin"         `setPath` "utils/hpc"
integerGmp          = lib  "integer-gmp"
integerSimple       = lib  "integer-simple"
iserv               = util "iserv"
libffi              = top  "libffi"
libiserv            = lib  "libiserv"
mtl                 = lib  "mtl"
parsec              = lib  "parsec"
pretty              = lib  "pretty"
primitive           = lib  "primitive"
process             = lib  "process"
rts                 = top  "rts"
runGhc              = util "runghc"
stm                 = lib  "stm"
templateHaskell     = lib  "template-haskell"
terminfo            = lib  "terminfo"
text                = lib  "text"
time                = lib  "time"
timeout             = util "timeout"         `setPath` "testsuite/timeout"
touchy              = util "touchy"
transformers        = lib  "transformers"
unlit               = util "unlit"
unix                = lib  "unix"
win32               = lib  "Win32"
xhtml               = lib  "xhtml"

-- | Construct a library package, e.g. @array@.
lib :: PackageName -> Package
lib name = library name ("libraries" -/- name)

-- | Construct a top-level library package, e.g. @compiler@.
top :: PackageName -> Package
top name = library name name

-- | Construct a top-level program package, e.g. @ghc@.
prg :: PackageName -> Package
prg name = program name name

-- | Construct a utility package, e.g. @haddock@.
util :: PackageName -> Package
util name = program name ("utils" -/- name)

-- | Amend a package path if it doesn't conform to a typical pattern.
setPath :: Package -> FilePath -> Package
setPath pkg path = pkg { pkgPath = path }

-- | Given a 'Context', compute the name of the program that is built in it
-- assuming that the corresponding package's type is 'Program'. For example, GHC
-- built in 'Stage0' is called @ghc-stage1@. If the given package is a
-- 'Library', the function simply returns its name.
programName :: Context -> Action String
programName Context {..} = do
    cross <- flag CrossCompiling
    targetPlatform <- setting TargetPlatformFull
    let prefix = if cross then targetPlatform ++ "-" else ""
    -- TODO: Can we extract this information from Cabal files?
    -- Alp: We could, but then the iserv package would have to
    --      use Cabal conditionals + a 'profiling' flag
    --      to declare the executable name, and I'm not sure
    --      this is allowed (or desired for that matter).
    return $ prefix ++ case package of
                              p | p == ghc    -> "ghc"
                                | p == hpcBin -> "hpc"
                                | p == iserv  -> "ghc-iserv" ++ concat [
                                    if wayUnit' `wayUnit` way
                                        then suffix
                                        else ""
                                    | (wayUnit', suffix) <- [
                                        (Profiling, "-prof"),
                                        (Dynamic,   "-dyn")
                                    ]]
                              _ -> pkgName package

-- | The 'FilePath' to a program executable in a given 'Context'.
programPath :: Context -> Action FilePath
programPath context@Context {..} = do
    -- TODO: The @touchy@ utility lives in the @lib/bin@ directory instead of
    -- @bin@, which is likely just a historical accident that should be fixed.
    -- See: https://github.com/snowleopard/hadrian/issues/570
    -- Likewise for @iserv@ and @unlit@.
    name <- programName context
    path <- if package `elem` [iserv, touchy, unlit]
              then stageLibPath stage <&> (-/- "bin")
              else stageBinPath stage
    return $ path -/- name <.> exe

-- TODO: Move @timeout@ to the @util@ directory and build in a more standard
-- location like other programs used only by the testsuite.
timeoutPath :: FilePath
timeoutPath = "testsuite/timeout/install-inplace/bin/timeout" <.> exe

-- TODO: Can we extract this information from Cabal files?
-- | Some program packages should not be linked with Haskell main function.
nonHsMainPackage :: Package -> Bool
nonHsMainPackage = (`elem` [ghc, hp2ps, iserv, touchy, unlit])

-- TODO: Combine this with 'programName'.
-- | Path to the @autogen@ directory generated by 'buildAutogenFiles'.
autogenPath :: Context -> Action FilePath
autogenPath context@Context {..}
    | isLibrary package = autogen "build"
    | package == ghc    = autogen "build/ghc"
    | package == hpcBin = autogen "build/hpc"
    | otherwise         = autogen $ "build" -/- pkgName package
  where
    autogen dir = contextPath context <&> (-/- dir -/- "autogen")

-- | Make sure a given context has already been fully configured. The
-- implementation simply calls 'need' on the context's @autogen/cabal_macros.h@
-- file, which triggers 'configurePackage' and 'buildAutogenFiles'. Why this
-- indirection? Going via @autogen/cabal_macros.h@ allows us to cache the
-- configuration steps, i.e. not to repeat them if they have already been done.
ensureConfigured :: Context -> Action ()
ensureConfigured context = do
    autogen <- autogenPath context
    need [autogen -/- "cabal_macros.h"]

-- | RTS is considered a Stage1 package. This determines RTS build directory.
rtsContext :: Stage -> Context
rtsContext stage = vanillaContext stage rts

-- | Path to the RTS build directory.
rtsBuildPath :: Stage -> Action FilePath
rtsBuildPath stage = buildPath (rtsContext stage)

-- | Build directory for in-tree 'libffi' library.
libffiBuildPath :: Stage -> Action FilePath
libffiBuildPath stage = buildPath $ Context
    stage
    libffi
    (error "libffiBuildPath: way not set.")

-- | Name of the 'libffi' library.
libffiLibraryName :: Action FilePath
libffiLibraryName = do
    useSystemFfi <- flag UseSystemFfi
    windows      <- windowsHost
    return $ case (useSystemFfi, windows) of
        (True , False) -> "ffi"
        (False, False) -> "Cffi"
        (_    , True ) -> "Cffi-6"

-- | Generated header files required by GHC in runtime.
generatedGhcDependencies :: Stage -> Action [FilePath]
generatedGhcDependencies stage = do
    let context = vanillaContext stage compiler
    bh <- buildPath   context <&> (-/- "ghc_boot_platform.h")
    ch <- contextPath context <&> (-/- "ghc_boot_platform.h")
    is <- includesDependencies
    return $ is ++ [bh, ch]