{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- |

-- Module      :  BuildEnv.Script

-- Description :  Tiny build script DSL

--

-- This modules provides a tiny build script DSL.

--

-- A 'BuildScript' is a series of simple build steps (process calls).

--

-- A 'BuildScript' can be executed in the 'IO' monad, using 'executeBuildScript'.

--

-- A 'BuildScript' can be turned into a shell script which can be executed

-- later, using 'script'.

module BuildEnv.Script
  ( -- * Interpreting build scripts


    -- ** Executing build scripts

    executeBuildScript

    -- ** Shell-script output

  , script

    -- * Build scripts

  , BuildScript, BuildScriptM(..)
  , emptyBuildScript, askScriptConfig
  , buildSteps

    -- ** Individual build steps

  , BuildStep(..), BuildSteps
  , step
  , callProcess, createDir
  , logMessage, reportProgress

    -- ** Configuring build scripts

  , ScriptOutput(..), ScriptConfig(..), hostRunCfg
  , EscapeVars(..), quoteArg

  ) where

-- base

import Control.Monad
  ( when )
import Data.Foldable
  ( traverse_, foldl', for_ )
import Data.IORef
  ( atomicModifyIORef' )
import Data.Monoid
  ( Ap(..) )
import Data.String
  ( IsString(..) )
import System.IO
  ( hFlush )
import qualified System.IO as System
  ( stdout )

-- directory

import System.Directory
  ( createDirectoryIfMissing )

-- text

import Data.Text
  ( Text )
import qualified Data.Text as Text

-- transformers

import Control.Monad.Trans.Reader
  ( ReaderT(..) )
import Control.Monad.Trans.Writer.CPS
  ( Writer, execWriter, tell )

-- build-env

import BuildEnv.Config
  ( Verbosity(..), Counter(..), Style(..)
  , hostStyle
  )
import BuildEnv.Path
import BuildEnv.Utils
  ( ProgPath(..), CallProcess(..), callProcessInIO )

--------------------------------------------------------------------------------

-- Build scripts: general monad setup.


-- | A build script: a list of build steps, given a 'ScriptConfig' context.

type BuildScript = BuildScriptM ()

deriving via Ap BuildScriptM ()
  instance Semigroup BuildScript
deriving via Ap BuildScriptM ()
  instance Monoid BuildScript

-- | Build script monad.

newtype BuildScriptM a =
  BuildScript
    { forall a.
BuildScriptM a -> ReaderT ScriptConfig (Writer BuildSteps) a
runBuildScript :: ReaderT ScriptConfig ( Writer BuildSteps ) a }
  deriving newtype ( (forall a b. (a -> b) -> BuildScriptM a -> BuildScriptM b)
-> (forall a b. a -> BuildScriptM b -> BuildScriptM a)
-> Functor BuildScriptM
forall a b. a -> BuildScriptM b -> BuildScriptM a
forall a b. (a -> b) -> BuildScriptM a -> BuildScriptM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> BuildScriptM a -> BuildScriptM b
fmap :: forall a b. (a -> b) -> BuildScriptM a -> BuildScriptM b
$c<$ :: forall a b. a -> BuildScriptM b -> BuildScriptM a
<$ :: forall a b. a -> BuildScriptM b -> BuildScriptM a
Functor, Functor BuildScriptM
Functor BuildScriptM =>
(forall a. a -> BuildScriptM a)
-> (forall a b.
    BuildScriptM (a -> b) -> BuildScriptM a -> BuildScriptM b)
-> (forall a b c.
    (a -> b -> c)
    -> BuildScriptM a -> BuildScriptM b -> BuildScriptM c)
-> (forall a b. BuildScriptM a -> BuildScriptM b -> BuildScriptM b)
-> (forall a b. BuildScriptM a -> BuildScriptM b -> BuildScriptM a)
-> Applicative BuildScriptM
forall a. a -> BuildScriptM a
forall a b. BuildScriptM a -> BuildScriptM b -> BuildScriptM a
forall a b. BuildScriptM a -> BuildScriptM b -> BuildScriptM b
forall a b.
BuildScriptM (a -> b) -> BuildScriptM a -> BuildScriptM b
forall a b c.
(a -> b -> c) -> BuildScriptM a -> BuildScriptM b -> BuildScriptM c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> BuildScriptM a
pure :: forall a. a -> BuildScriptM a
$c<*> :: forall a b.
BuildScriptM (a -> b) -> BuildScriptM a -> BuildScriptM b
<*> :: forall a b.
BuildScriptM (a -> b) -> BuildScriptM a -> BuildScriptM b
$cliftA2 :: forall a b c.
(a -> b -> c) -> BuildScriptM a -> BuildScriptM b -> BuildScriptM c
liftA2 :: forall a b c.
(a -> b -> c) -> BuildScriptM a -> BuildScriptM b -> BuildScriptM c
$c*> :: forall a b. BuildScriptM a -> BuildScriptM b -> BuildScriptM b
*> :: forall a b. BuildScriptM a -> BuildScriptM b -> BuildScriptM b
$c<* :: forall a b. BuildScriptM a -> BuildScriptM b -> BuildScriptM a
<* :: forall a b. BuildScriptM a -> BuildScriptM b -> BuildScriptM a
Applicative, Applicative BuildScriptM
Applicative BuildScriptM =>
(forall a b.
 BuildScriptM a -> (a -> BuildScriptM b) -> BuildScriptM b)
-> (forall a b. BuildScriptM a -> BuildScriptM b -> BuildScriptM b)
-> (forall a. a -> BuildScriptM a)
-> Monad BuildScriptM
forall a. a -> BuildScriptM a
forall a b. BuildScriptM a -> BuildScriptM b -> BuildScriptM b
forall a b.
BuildScriptM a -> (a -> BuildScriptM b) -> BuildScriptM b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b.
BuildScriptM a -> (a -> BuildScriptM b) -> BuildScriptM b
>>= :: forall a b.
BuildScriptM a -> (a -> BuildScriptM b) -> BuildScriptM b
$c>> :: forall a b. BuildScriptM a -> BuildScriptM b -> BuildScriptM b
>> :: forall a b. BuildScriptM a -> BuildScriptM b -> BuildScriptM b
$creturn :: forall a. a -> BuildScriptM a
return :: forall a. a -> BuildScriptM a
Monad )

-- | The empty build script: no build steps.

emptyBuildScript :: BuildScript
emptyBuildScript :: BuildScript
emptyBuildScript = () -> BuildScript
forall a. a -> BuildScriptM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Retrieve the 'ScriptConfig' from the 'ReaderT' environment.

askScriptConfig :: BuildScriptM ScriptConfig
askScriptConfig :: BuildScriptM ScriptConfig
askScriptConfig = ReaderT ScriptConfig (Writer BuildSteps) ScriptConfig
-> BuildScriptM ScriptConfig
forall a.
ReaderT ScriptConfig (Writer BuildSteps) a -> BuildScriptM a
BuildScript (ReaderT ScriptConfig (Writer BuildSteps) ScriptConfig
 -> BuildScriptM ScriptConfig)
-> ReaderT ScriptConfig (Writer BuildSteps) ScriptConfig
-> BuildScriptM ScriptConfig
forall a b. (a -> b) -> a -> b
$ (ScriptConfig -> Writer BuildSteps ScriptConfig)
-> ReaderT ScriptConfig (Writer BuildSteps) ScriptConfig
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ScriptConfig -> Writer BuildSteps ScriptConfig
forall a. a -> Writer BuildSteps a
forall (m :: * -> *) a. Monad m => a -> m a
return

-- | Obtain the build steps of a 'BuildScript'.

buildSteps :: ScriptConfig -> BuildScript -> BuildSteps
buildSteps :: ScriptConfig -> BuildScript -> BuildSteps
buildSteps ScriptConfig
cfg BuildScript
buildScript
  = Writer BuildSteps () -> BuildSteps
forall w a. Monoid w => Writer w a -> w
execWriter (BuildScript -> ReaderT ScriptConfig (Writer BuildSteps) ()
forall a.
BuildScriptM a -> ReaderT ScriptConfig (Writer BuildSteps) a
runBuildScript BuildScript
buildScript ReaderT ScriptConfig (Writer BuildSteps) ()
-> ScriptConfig -> Writer BuildSteps ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` ScriptConfig
cfg)

--------------------------------------------------------------------------------

-- Individual build steps


-- | A list of build steps.

type BuildSteps = [BuildStep]

-- | A build step.

data BuildStep
  -- | Call a processs with the given arguments.

  = forall dir. CallProcess ( CallProcess dir )
  -- | Create the given directory.

  | forall dir. CreateDir ( AbsolutePath ( Dir dir ) )
  -- | Log a message to @stdout@.

  | LogMessage  String
  -- | Report one unit of progress.

  | ReportProgress
      { BuildStep -> Bool
outputProgress :: Bool
        -- ^ Whether to log the progress to @stdout@.

      }

-- | Declare a build step.

step :: BuildStep -> BuildScript
step :: BuildStep -> BuildScript
step BuildStep
s = ReaderT ScriptConfig (Writer BuildSteps) () -> BuildScript
forall a.
ReaderT ScriptConfig (Writer BuildSteps) a -> BuildScriptM a
BuildScript (ReaderT ScriptConfig (Writer BuildSteps) () -> BuildScript)
-> ReaderT ScriptConfig (Writer BuildSteps) () -> BuildScript
forall a b. (a -> b) -> a -> b
$ (ScriptConfig -> Writer BuildSteps ())
-> ReaderT ScriptConfig (Writer BuildSteps) ()
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT \ ScriptConfig
_ -> BuildSteps -> Writer BuildSteps ()
forall w (m :: * -> *). (Monoid w, Monad m) => w -> WriterT w m ()
tell [BuildStep
s]

-- | Call a process with given arguments.

callProcess :: CallProcess dir -> BuildScript
callProcess :: forall dir. CallProcess dir -> BuildScript
callProcess = BuildStep -> BuildScript
step (BuildStep -> BuildScript)
-> (CallProcess dir -> BuildStep) -> CallProcess dir -> BuildScript
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallProcess dir -> BuildStep
forall dir. CallProcess dir -> BuildStep
CallProcess

-- | Create the given directory.

createDir :: AbsolutePath ( Dir dir ) -> BuildScript
createDir :: forall dir. AbsolutePath ('Dir dir) -> BuildScript
createDir = BuildStep -> BuildScript
step (BuildStep -> BuildScript)
-> (AbsolutePath ('Dir dir) -> BuildStep)
-> AbsolutePath ('Dir dir)
-> BuildScript
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbsolutePath ('Dir dir) -> BuildStep
forall dir. AbsolutePath ('Dir dir) -> BuildStep
CreateDir

-- | Log a message.

logMessage :: Verbosity -> Verbosity -> String -> BuildScript
logMessage :: Verbosity -> Verbosity -> String -> BuildScript
logMessage Verbosity
v Verbosity
msg_v String
msg
  | Verbosity
v Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
msg_v
  = BuildStep -> BuildScript
step (BuildStep -> BuildScript) -> BuildStep -> BuildScript
forall a b. (a -> b) -> a -> b
$ String -> BuildStep
LogMessage String
msg
  | Bool
otherwise
  = () -> BuildScript
forall a. a -> BuildScriptM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Report one unit of progress.

reportProgress :: Verbosity -> BuildScript
reportProgress :: Verbosity -> BuildScript
reportProgress Verbosity
v = BuildStep -> BuildScript
step ( ReportProgress { outputProgress :: Bool
outputProgress = Verbosity
v Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
> Verbosity
Quiet } )

--------------------------------------------------------------------------------

-- Configuration


-- | How to interpret the build script: run it in 'IO', or turn it

-- into a shell script?

data ScriptOutput
  -- | Run the build script in 'IO'

  = Run
  -- | Generate a shell script.

  | Shell
    { ScriptOutput -> Bool
useVariables :: !Bool
      -- ^ Replace various values with variables, so that

      -- they can be set before running the build script.

      --

      -- Values:

      --

      --  - @GHC@ and @GHC-PKG@,

      --  - fetched sources directory @SOURCES@,

      --  - @PREFIX@ and @DESTDIR@.

    }

-- | Configuration options for a 'BuildScript'.

data ScriptConfig
  = ScriptConfig
  { ScriptConfig -> ScriptOutput
scriptOutput :: !ScriptOutput
    -- ^ Whether we are outputting a shell script, so that we can know whether

    -- we should:

    --

    --  - add quotes around command-line arguments?

    --  - add @./@ to run an executable in the current working directory?


  , ScriptConfig -> SymbolicPath CWD ('Dir Project)
scriptWorkingDir :: !( SymbolicPath CWD ( Dir Project ) )
    -- ^ Working directory for the script.


  , ScriptConfig -> Style
scriptStyle :: !Style
    -- ^ Whether to use Posix or Windows style conventions. See 'Style'.


  , ScriptConfig -> Maybe Word
scriptTotal :: !( Maybe Word )
    -- ^ Optional: the total number of units we are building;

    -- used to report progress.

  }

-- | Configure a script to run on the host (in @IO@).

hostRunCfg :: SymbolicPath CWD ( Dir Project )
           -> Maybe Word -- ^ Optional: total to report progress against.

           -> ScriptConfig
hostRunCfg :: SymbolicPath CWD ('Dir Project) -> Maybe Word -> ScriptConfig
hostRunCfg SymbolicPath CWD ('Dir Project)
workDir Maybe Word
mbTotal =
  ScriptConfig
    { scriptOutput :: ScriptOutput
scriptOutput     = ScriptOutput
Run
    , scriptStyle :: Style
scriptStyle      = Style
hostStyle
    , scriptTotal :: Maybe Word
scriptTotal      = Maybe Word
mbTotal
    , scriptWorkingDir :: SymbolicPath CWD ('Dir Project)
scriptWorkingDir = SymbolicPath CWD ('Dir Project)
workDir
    }

-- | Whether to expand or escape variables in a shell script.

data EscapeVars
  -- | Allow the shell to expand variables.

  = ExpandVars
  -- | Escape variables so that the shell doesn't expand them.

  | EscapeVars
  deriving stock Int -> EscapeVars -> ShowS
[EscapeVars] -> ShowS
EscapeVars -> String
(Int -> EscapeVars -> ShowS)
-> (EscapeVars -> String)
-> ([EscapeVars] -> ShowS)
-> Show EscapeVars
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EscapeVars -> ShowS
showsPrec :: Int -> EscapeVars -> ShowS
$cshow :: EscapeVars -> String
show :: EscapeVars -> String
$cshowList :: [EscapeVars] -> ShowS
showList :: [EscapeVars] -> ShowS
Show

-- | Quote a string, to avoid spaces causing the string

-- to be interpreted as multiple arguments.

q :: ( IsString r, Monoid r ) => EscapeVars -> String -> r
q :: forall r. (IsString r, Monoid r) => EscapeVars -> String -> r
q EscapeVars
escapeVars String
t = r
"\"" r -> r -> r
forall a. Semigroup a => a -> a -> a
<> String -> r
forall a. IsString a => String -> a
fromString ( ShowS
escapeArg String
t ) r -> r -> r
forall a. Semigroup a => a -> a -> a
<> r
"\""
  where
    escapeArg :: String -> String
    escapeArg :: ShowS
escapeArg = ShowS
forall a. [a] -> [a]
reverse ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Char -> String) -> String -> ShowS
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' String -> Char -> String
escape []

    charsToEscape :: [ Char ]
    charsToEscape :: String
charsToEscape = case EscapeVars
escapeVars of
      EscapeVars
ExpandVars -> [ Char
'\\', Char
'\'', Char
'"' ]
      EscapeVars
EscapeVars -> [ Char
'\\', Char
'\'', Char
'"', Char
'$' ]

    escape :: String -> Char -> String
    escape :: String -> Char -> String
escape String
cs Char
c
      | Char
c Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
charsToEscape
      = Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:Char
'\\'Char -> ShowS
forall a. a -> [a] -> [a]
:String
cs
      | Bool
otherwise
      = Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:String
cs

-- | Quote a command-line argument, if the 'ScriptConfig' requires arguments

-- to be quoted.

--

-- No need to call this on the 'cwd' or 'prog' fields of 'CallProcess',

-- as these will be quoted by the shell-script backend no matter what.

quoteArg :: ( IsString r, Monoid r )
         => EscapeVars
         -> ScriptConfig
         -> String
         -> r
quoteArg :: forall r.
(IsString r, Monoid r) =>
EscapeVars -> ScriptConfig -> String -> r
quoteArg EscapeVars
escapeVars ( ScriptConfig { ScriptOutput
scriptOutput :: ScriptConfig -> ScriptOutput
scriptOutput :: ScriptOutput
scriptOutput } ) =
  case ScriptOutput
scriptOutput of
    ScriptOutput
Run      -> String -> r
forall a. IsString a => String -> a
fromString
    Shell {} -> EscapeVars -> String -> r
forall r. (IsString r, Monoid r) => EscapeVars -> String -> r
q EscapeVars
escapeVars

--------------------------------------------------------------------------------

-- Interpretation


------

-- IO


-- | Execute a 'BuildScript' in the 'IO' monad.

executeBuildScript :: SymbolicPath CWD ( Dir Project ) -- ^ Working directory.

                   -> Maybe Counter -- ^ Optional counter to use to report progress.

                   -> BuildScript   -- ^ The build script to execute.

                   -> IO ()
executeBuildScript :: SymbolicPath CWD ('Dir Project)
-> Maybe Counter -> BuildScript -> IO ()
executeBuildScript SymbolicPath CWD ('Dir Project)
workDir Maybe Counter
counter
  = (BuildStep -> IO ()) -> BuildSteps -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_  ( Maybe Counter -> BuildStep -> IO ()
executeBuildStep Maybe Counter
counter )
  (BuildSteps -> IO ())
-> (BuildScript -> BuildSteps) -> BuildScript -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptConfig -> BuildScript -> BuildSteps
buildSteps ( SymbolicPath CWD ('Dir Project) -> Maybe Word -> ScriptConfig
hostRunCfg SymbolicPath CWD ('Dir Project)
workDir (Maybe Word -> ScriptConfig) -> Maybe Word -> ScriptConfig
forall a b. (a -> b) -> a -> b
$ (Counter -> Word) -> Maybe Counter -> Maybe Word
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Counter -> Word
counterMax Maybe Counter
counter )

-- | Execute a single 'BuildStep' in the 'IO' monad.

executeBuildStep :: Maybe Counter
                     -- ^ Optional counter to use to report progress.

                 -> BuildStep
                 -> IO ()
executeBuildStep :: Maybe Counter -> BuildStep -> IO ()
executeBuildStep Maybe Counter
mbCounter = \case
  CallProcess CallProcess dir
cp  -> Maybe Counter -> CallProcess dir -> IO ()
forall dir.
HasCallStack =>
Maybe Counter -> CallProcess dir -> IO ()
callProcessInIO Maybe Counter
mbCounter CallProcess dir
cp
  CreateDir   AbsolutePath ('Dir dir)
dir -> Bool -> String -> IO ()
createDirectoryIfMissing Bool
True ( AbsolutePath ('Dir dir) -> String
forall (to :: FileOrDir). AbsolutePath to -> String
getAbsolutePath AbsolutePath ('Dir dir)
dir )
  LogMessage  String
msg -> do { String -> IO ()
putStrLn String
msg ; Handle -> IO ()
hFlush Handle
System.stdout }
  ReportProgress { Bool
outputProgress :: BuildStep -> Bool
outputProgress :: Bool
outputProgress } ->
    Maybe Counter -> (Counter -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Counter
mbCounter \ Counter
counter -> do
      Word
completed <-
        IORef Word -> (Word -> (Word, Word)) -> IO Word
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' ( Counter -> IORef Word
counterRef Counter
counter )
          ( \ Word
x -> let !x' :: Word
x' = Word
xWord -> Word -> Word
forall a. Num a => a -> a -> a
+Word
1 in (Word
x',Word
x') )
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
outputProgress do
        let
          txt :: String
txt = String
"## " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word -> String
forall a. Show a => a -> String
show Word
completed String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" of " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word -> String
forall a. Show a => a -> String
show ( Counter -> Word
counterMax Counter
counter ) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" ##"
          n :: Int
n = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
txt
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
          [ String
""
          , String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n Char
'#'
          , String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
txt
          , String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n Char
'#'
          , String
"" ]

----------------

-- Shell script


-- | Obtain the textual contents of a build script.

script :: ScriptConfig -> BuildScript -> Text
script :: ScriptConfig -> BuildScript -> Text
script ScriptConfig
scriptCfg BuildScript
buildScript =
  [Text] -> Text
Text.unlines ( [Text]
header [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ (BuildStep -> [Text]) -> BuildSteps -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ( ScriptConfig -> BuildStep -> [Text]
stepScript ScriptConfig
scriptCfg ) ( ScriptConfig -> BuildScript -> BuildSteps
buildSteps ScriptConfig
scriptCfg BuildScript
buildScript ) )
  where
    header, varsHelper, progressVars :: [ Text ]
    header :: [Text]
header = [ Text
"#!/bin/bash" , Text
"", Text
"set -ueo pipefail" ] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
      [Text]
varsHelper [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
logDir [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
progressVars
    varsHelper :: [Text]
varsHelper
      | Shell { Bool
useVariables :: ScriptOutput -> Bool
useVariables :: Bool
useVariables } <- ScriptConfig -> ScriptOutput
scriptOutput ScriptConfig
scriptCfg
      , Bool
useVariables
      = [Text]
variablesHelper
      | Bool
otherwise
      = []
    progressVars :: [Text]
progressVars =
      case ScriptConfig -> Maybe Word
scriptTotal ScriptConfig
scriptCfg of
        Maybe Word
Nothing -> []
        Just {} ->
          [ Text
"buildEnvProgress=0" ]
    logDir :: [Text]
logDir = [ Text
"LOGDIR=\"$PWD/logs/$(date -u +%Y-%m-%d_%H-%M-%S)\""
             , Text
"mkdir -p \"${LOGDIR}\"" ]

-- | The underlying script of a build step.

stepScript :: ScriptConfig -> BuildStep -> [ Text ]
stepScript :: ScriptConfig -> BuildStep -> [Text]
stepScript ScriptConfig
scriptCfg = \case
  CreateDir AbsolutePath ('Dir dir)
dir ->
    [ Text
"mkdir -p " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> EscapeVars -> String -> Text
forall r. (IsString r, Monoid r) => EscapeVars -> String -> r
q EscapeVars
ExpandVars ( AbsolutePath ('Dir dir) -> String
forall (to :: FileOrDir). AbsolutePath to -> String
getAbsolutePath AbsolutePath ('Dir dir)
dir ) ]
  LogMessage String
str ->
    [ Text
"echo " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> EscapeVars -> String -> Text
forall r. (IsString r, Monoid r) => EscapeVars -> String -> r
q EscapeVars
ExpandVars String
str ]
  ReportProgress { Bool
outputProgress :: BuildStep -> Bool
outputProgress :: Bool
outputProgress } ->
    case ScriptConfig -> Maybe Word
scriptTotal ScriptConfig
scriptCfg of
      Maybe Word
Nothing
        -> []
      Just Word
tot
        | Bool
outputProgress
        -> [ String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"printf \"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
txt String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\" $((++buildEnvProgress))" ]
        | Bool
otherwise
        -> [ Text
"((++buildEnvProgress))" ]
          -- Still increment the progress variable, as we use this variable

          -- to report progress upon failure.

        where
          n :: Int
n = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ Word -> String
forall a. Show a => a -> String
show Word
tot
          l :: Int
l = Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
10
          txt :: String
txt = String
"\\n " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
l Char
'#' String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\\n "
                       String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"## %0" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
n String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"d of " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word -> String
forall a. Show a => a -> String
show Word
tot String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" ##" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\\n "
                       String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
l Char
'#' String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\\n"

  CallProcess ( CP { SymbolicPath CWD ('Dir dir)
cwd :: forall dir. CallProcess dir -> SymbolicPath CWD ('Dir dir)
cwd :: SymbolicPath CWD ('Dir dir)
cwd, [String]
extraPATH :: [String]
extraPATH :: forall dir. CallProcess dir -> [String]
extraPATH, [(String, String)]
extraEnvVars :: [(String, String)]
extraEnvVars :: forall dir. CallProcess dir -> [(String, String)]
extraEnvVars, ProgPath dir
prog :: forall dir. CallProcess dir -> ProgPath dir
prog :: ProgPath dir
prog, [String]
args :: [String]
args :: forall dir. CallProcess dir -> [String]
args, Maybe (AbsolutePath 'File)
logBasePath :: Maybe (AbsolutePath 'File)
logBasePath :: forall dir. CallProcess dir -> Maybe (AbsolutePath 'File)
logBasePath } ) ->
    -- NB: we ignore the semaphore, as the build scripts we produce

    -- are inherently sequential.

    [Text]
logCommand [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
    [ Text
"( cd " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> EscapeVars -> String -> Text
forall r. (IsString r, Monoid r) => EscapeVars -> String -> r
q EscapeVars
ExpandVars ( SymbolicPath CWD ('Dir dir) -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
getSymbolicPath SymbolicPath CWD ('Dir dir)
cwd ) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ; \\" ]
    [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
mbUpdatePath
    [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ ((String, String) -> Text) -> [(String, String)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> Text
mkEnvVar [(String, String)]
extraEnvVars
    [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
    [ Text
"  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cmd Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pipeToLogs Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" )"
    , Text
resVar Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"=$?"
    , Text
"if [ \"${" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
resVar Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"}\" -eq 0 ]"
    , Text
"then true"
    , Text
"else"
    , Text
"  echo -e " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
        Text
"\"callProcess failed with non-zero exit code. Command:\\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
        Text
"  > " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
unquote Text
cmd Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
        Text
"  CWD = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
unquote ( EscapeVars -> String -> Text
forall r. (IsString r, Monoid r) => EscapeVars -> String -> r
q EscapeVars
ExpandVars ( SymbolicPath CWD ('Dir dir) -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
getSymbolicPath SymbolicPath CWD ('Dir dir)
cwd ) ) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
logErr
    ]
    [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
progressReport
    [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
logMsg
    [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
    [ Text
"  exit \"${" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
resVar Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"}\""
    , Text
"fi" ]
    where
      progPath :: FilePath
      progPath :: String
progPath = case ProgPath dir
prog of
        AbsPath AbsolutePath 'File
p -> AbsolutePath 'File -> String
forall (to :: FileOrDir). AbsolutePath to -> String
getAbsolutePath AbsolutePath 'File
p
        RelPath SymbolicPath dir 'File
p -> SymbolicPath dir 'File -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
getSymbolicPath SymbolicPath dir 'File
p
      cmd :: Text
      cmd :: Text
cmd = EscapeVars -> String -> Text
forall r. (IsString r, Monoid r) => EscapeVars -> String -> r
q EscapeVars
ExpandVars String
progPath Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
Text.unwords ((String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
Text.pack [String]
args)
        --                 (1)                                  (2)

        --

        -- (1)

        --   In shell scripts, we always change directory before running the

        --   program. As the program path is either absolute or relative to @cwd@,

        --   we don't need to modify the program path.

        --

        -- (2)

        --   Don't quote the arguments: arguments which needed quoting will have

        --   been quoted using the 'quoteArg' function.

        --

        --   This allows users to pass multiple arguments using variables:

        --

        --   > myArgs="arg1 arg2 arg3"

        --   > Setup configure $myArgs

        --

        --   by passing @$myArgs@ as a @Setup configure@ argument.

      resVar :: Text
      resVar :: Text
resVar = Text
"buildEnvLastExitCode"
      mbUpdatePath :: [Text]
      mbUpdatePath :: [Text]
mbUpdatePath
        | [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
extraPATH
        = []
        | Bool
otherwise
        = [  Text
"  export PATH=$PATH:"
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
":" ( (String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
Text.pack [String]
extraPATH ) -- (already quoted)

          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ; \\" ]

      mkEnvVar :: (String, String) -> Text
      mkEnvVar :: (String, String) -> Text
mkEnvVar (String
var,String
val) = Text
"  export "
                        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack String
var
                        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack String
val Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ; \\"
                                   -- (already quoted)


      logCommand, logMsg :: [Text]
      pipeToLogs, logErr :: Text
      ([Text]
logCommand, Text
pipeToLogs, Text
logErr, [Text]
logMsg) =
        case Maybe (AbsolutePath 'File)
logBasePath of
          Maybe (AbsolutePath 'File)
Nothing      -> ( [], Text
"", Text
" >&2", [] )
          Just AbsolutePath 'File
logPath ->
            let stdoutFile, stderrFile :: Text
                stdoutFile :: Text
stdoutFile = EscapeVars -> String -> Text
forall r. (IsString r, Monoid r) => EscapeVars -> String -> r
q EscapeVars
ExpandVars ( AbsolutePath 'File -> String
forall (to :: FileOrDir). AbsolutePath to -> String
getAbsolutePath AbsolutePath 'File
logPath String -> ShowS
forall p. FileLike p => p -> String -> p
<.> String
"stdout" )
                stderrFile :: Text
stderrFile = EscapeVars -> String -> Text
forall r. (IsString r, Monoid r) => EscapeVars -> String -> r
q EscapeVars
ExpandVars ( AbsolutePath 'File -> String
forall (to :: FileOrDir). AbsolutePath to -> String
getAbsolutePath AbsolutePath 'File
logPath String -> ShowS
forall p. FileLike p => p -> String -> p
<.> String
"stderr" )
            in ( [ Text
"echo \"> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
unquote Text
cmd Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" >> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
stdoutFile ]
               , Text
" 2>&1 >" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
stdoutFile Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" | tee -a " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
stderrFile
                  -- Write stdout to the stdout log file.

                  -- Write stderr both to the terminal and to the stderr log file.

               , Text
" | tee -a " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
stderrFile Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" >&2"
               , [ Text
"  echo \"Logs are available at: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
unquote ( EscapeVars -> String -> Text
forall r. (IsString r, Monoid r) => EscapeVars -> String -> r
q EscapeVars
ExpandVars ( AbsolutePath 'File -> String
forall (to :: FileOrDir). AbsolutePath to -> String
getAbsolutePath AbsolutePath 'File
logPath String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
".{stdout,stderr}" ) ) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\"" ] )

      progressReport :: [Text]
      progressReport :: [Text]
progressReport =
        case ScriptConfig -> Maybe Word
scriptTotal ScriptConfig
scriptCfg of
          Maybe Word
Nothing  -> []
          Just Word
tot ->
            [ Text
"  echo \"After ${buildEnvProgress} of " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Word -> String
forall a. Show a => a -> String
show Word
tot) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\"" ]

unquote :: Text -> Text
unquote :: Text -> Text
unquote = (Char -> Bool) -> Text -> Text
Text.filter ( Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\"') )

----

-- Helper to check that environment variables are set as expected.


-- | All the environment variables that a shell script using variables

-- expects to be set.

allVars :: [ Text ]
allVars :: [Text]
allVars = [ Text
"GHC", Text
"GHCPKG", Text
"SOURCES", Text
"PREFIX", Text
"DESTDIR" ]

-- | A preamble that checks the required environment variables are defined.

variablesHelper :: [ Text ]
variablesHelper :: [Text]
variablesHelper =
    [ Text
"", Text
"echo \"Checking that required environment variables are set.\"" ]
    [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ (Text -> [Text]) -> [Text] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Text -> [Text]
variableHelper [Text]
allVars
    [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [ Text
"" ]

-- | Check that the given environment variable is defined, giving an error

-- message if it isn't (to avoid an error cascade).

variableHelper :: Text -> [ Text ]
variableHelper :: Text -> [Text]
variableHelper Text
varName =
  [ Text
"if [ -z ${" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
varName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"} ]"
  , Text
"then"
  , Text
"  echo \"Environment variable " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
varName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" not set.\""
  , Text
"  echo \"When using --variables, the build script expects the following environment variables to be set:\""
  , Text
"  echo \"  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", " [Text]
allVars Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".\""
  , Text
"  exit 1"
  , Text
"fi" ]