{-# OPTIONS_GHC -O0 #-}

{-# LANGUAGE ExtendedDefaultRules,

OverloadedStrings,

ScopedTypeVariables,

TemplateHaskell,

LambdaCase,

FlexibleInstances,

DeriveDataTypeable,

GeneralizedNewtypeDeriving,

NoMonomorphismRestriction,

FlexibleContexts,

RankNTypes,

TupleSections

#-}

module Main (main) where

import Prelude

hiding (elem, mapM, mapM_, any, all, concat, concatMap)

import qualified Distribution.Simple.Utils as Cabal

import qualified Distribution.Verbosity as Cabal

import qualified Codec.Archive.Tar as Tar

import qualified Codec.Archive.Tar.Entry as Tar

import Control.Applicative

import qualified Control.Exception as Ex

import Control.Lens hiding ((<.>))

import Control.Monad.Reader (MonadReader, ReaderT(..), ask )

import Control.Monad.State

import qualified Data.Aeson as Aeson

import qualified Data.ByteString as B

import qualified Data.ByteString.Lazy as BL

import Data.Data

import Data.Data.Lens

import Data.Foldable

import qualified Data.HashMap.Strict as HM

import Data.List (intercalate, transpose)

import Data.Maybe

import Data.Text (Text)

import qualified Data.Text as T

import qualified Data.Text.IO as T

import qualified Data.Vector as V

import Data.Yaml ((.:))

import qualified Data.Yaml as Yaml

import GHC.IO.Encoding

(setLocaleEncoding, setForeignEncoding, utf8)

import Options.Applicative hiding (info)

import qualified Options.Applicative as O

import System.Directory

import System.Environment (lookupEnv, setEnv)

import System.Environment.Executable (getExecutablePath)

import System.Exit

(exitSuccess, exitFailure, ExitCode(..))

import qualified System.FilePath as FP

import System.FilePath -- hiding ((<.>), (</>))

import System.IO

(hPutStrLn, hSetBuffering, stderr, stdout, BufferMode(..), hClose)

import System.PosixCompat.Files (setFileMode)

import System.Process (readCreateProcess, createProcess, waitForProcess, {-CreateProcess(..),-} proc)

import Compiler.GhcjsProgram (printVersion)

import qualified Compiler.Info as Info

import qualified Compiler.Utils as Utils

import Compiler.Settings (NodeSettings(..))

import System.IO.Error (isDoesNotExistError)

import Compiler.Platform (isWindows)

default (Text)

newtype Verbosity = Verbosity Int deriving (Eq, Ord, Data, Typeable)

trace, info, warn, err :: Verbosity

trace = Verbosity 3

info = Verbosity 2

warn = Verbosity 1

err = Verbosity 0

data BootSettings = BootSettings

{ _bsShowVersion :: Bool -- ^show the version and exit

, _bsDebug :: Bool {- ^build debug version of the libraries

, _bsProf :: Bool -- ^build profiling version of the libraries

, _bsHaddock :: Bool -- ^build documentation

, _bsVerbosity :: Verbosity -- ^verbosity level 0..3, 2 is default

, _bsWithCabal :: Maybe Text {- ^location of cabal (cabal-install)

-- , _bsBindir :: Maybe Text -- ^ bin directory to install GHCJS programs

-- , _bsLibexecDir :: Maybe Text -- ^ location of GHCJS executables

-- , _bsGhcjsLibdir :: Maybe Text -- ^ location to install GHCJS boot libraries

, _bsWithEmsdk :: Maybe Text

, _bsWithGhc :: Maybe Text {- ^location of GHC compiler (must have a

, _bsWithNode :: Maybe Text -- ^location of the node.js program

, _bsWithNodePath :: Maybe Text -- ^ NODE_PATH to use when running node.js Template Haskell or REPL

-- (if unspecified, GHCJS uses bundled packages)

, _bsNodeExtraArgs :: Maybe Text -- ^ extra node arguments

, _bsSourceDir :: Maybe Text -- ^source directory (can be a tar file)

} deriving (Ord, Eq, Data, Typeable)

data BootStages = BootStages

{ _bstStage1a :: Stage

, _bstStage1b :: Stage

, _bstCabal :: Package {- ^installed between 1b and 2,

, _bstGhcjsPrim :: Package -- ^installed between 1a and 1b

} deriving (Data, Typeable)

type Stage = [Package]

type Package = Text {- ^just the package name/location, unversioned

data BootLocations = BootLocations

{ _blSourceDir :: FilePath

, _blBuildDir :: FilePath

, _blGhcjsTopDir :: FilePath

, _blGlobalDB :: FilePath -- ^global package database

-- , _blLibexecDir :: FilePath

, _blEmsdk :: FilePath

} deriving (Data, Typeable, Show)

data Program = Program

{ _pgmName :: Text -- ^program name for messages

, _pgmSearch :: Text {- ^name searched for when configuring the

, _pgmVersion :: Maybe Text -- ^version if known

, _pgmLoc :: Maybe FilePath -- ^absolute path to the program

, _pgmArgs :: [Text] -- ^extra arguments to pass to the program

} deriving (Data, Typeable, Show)

-- | configured programs, fail early if any of the required programs is missing

data BootPrograms = BootPrograms { _bpGhc :: Program

, _bpCabal :: Program

, _bpNode :: Program

} deriving (Data, Typeable, Show)

data BootEnv = BootEnv { _beSettings :: BootSettings

, _beLocations :: BootLocations

, _bePrograms :: BootPrograms

, _beStages :: BootStages

}

data BootConfigFile = BootConfigFile BootStages BootPrograms

deriving (Data, Typeable)

makeLenses ''Program

makeLenses ''BootSettings

makeLenses ''BootLocations

makeLenses ''BootPrograms

makeLenses ''BootStages

makeLenses ''BootEnv

main :: IO ()

main = do

settings <- execParser optParser'

when (settings ^. bsShowVersion) (printVersion >> exitSuccess)

hSetBuffering stdout LineBuffering

setLocaleEncoding utf8

setForeignEncoding utf8

env <- initBootEnv settings

printBootEnvSummary False env

r <- runReaderT ((actions >> pure Nothing)

`catchAny` (pure . Just)) env

maybe exitSuccess Ex.throwIO r

where

actions :: B ()

actions = do

e <- ask

liftIO $ setEnv "GHC_CHARENC" "UTF-8"

cleanCache

prepareLibDir

let base = libDir (e ^. beLocations)

liftIO $ setEnv "CFLAGS" ("-I" <> (base </> "include"))

installStage1

installCabal

when (e ^. beSettings . bsHaddock) buildDocIndex

liftIO . printBootEnvSummary True =<< ask

instance Yaml.FromJSON BootPrograms where

parseJSON (Yaml.Object v) = BootPrograms

<$> v ..: "ghc"

<*> v ..: "cabal"

<*> v ..: "node"

where

o ..: p = ((\t -> Program p t Nothing Nothing []) <$> o .: p) <|>

(withArgs p =<< o .: p)

withArgs :: Text -> Yaml.Value -> Yaml.Parser Program

withArgs p (Yaml.Object o) | [(k,v)] <- HM.toList o =

Program p k Nothing Nothing <$> Yaml.parseJSON v

withArgs _ _ =

mempty

parseJSON _ = mempty

instance Yaml.FromJSON BootStages where

parseJSON (Yaml.Object v) = BootStages

<$> v ..: "stage1a"

<*> v ..: "stage1b"

<*> v .: "cabal"

<*> v .: "ghcjs-prim"

where

o ..: p = pkgs =<< o .: p

pkgs (Yaml.String t) =

pure [t]

pkgs (Yaml.Array v) =

concat <$> mapM pkgs (V.toList v)

pkgs __ =

mempty

parseJSON _ = mempty

instance Yaml.FromJSON BootConfigFile where

parseJSON (Yaml.Object v) = BootConfigFile

<$> v .: "packages" <*> v .: "programs"

parseJSON _ = mempty

optParser' :: ParserInfo BootSettings

optParser' =

O.info (helper <*> optParser)

(fullDesc <>

header "GHCJS booter, build base libraries for the compiler" <>

progDesc description)

description :: String

description = unlines

[ "ghcjs-boot builds an initial set of libraries for GHCJS."

]

optParser :: Parser BootSettings

optParser =

BootSettings

<$> switch

(long "version" <>

help "show the ghcjs-boot version")

<*> switch

(long "debug" <>

short 'd' <>

help "build debug libraries with extra checks")

<*> (fmap not . switch)

(long "no-prof" <>

help "don't generate profiling version of the libraries")

<*> (fmap not . switch)

(long "no-haddock" <>

help "don't generate documentation")

<*> (fmap Verbosity . option auto)

(long "verbosity" <>

short 'v' <>

value 2 <>

help "verbose output")

<*> (optional . fmap T.pack . strOption)

(long "with-cabal" <> metavar "PROGRAM" <>

help "cabal program to use")

<*> (optional . fmap T.pack . strOption)

(long "with-emsdk" <>

metavar "DIR" <>

help "location of Emscripten SDK")

<*> (optional . fmap T.pack . strOption)

(long "with-ghc" <>

metavar "PROGRAM" <>

help "ghc program to use")

<*> (optional . fmap T.pack . strOption)

(long "with-node" <>

metavar "PROGRAM" <>

help "node.js program to use")

<*> (optional . fmap T.pack . strOption)

(long "with-node-path" <> metavar "PATH" <>

help "value of NODE_PATH environment variable when running Template Haskell or GHCJSi")

<*> (optional . fmap T.pack . strOption)

(long "extra-node-args" <> metavar "ARGS" <>

help "extra arguments to pass to node.js")

<*> (optional . fmap T.pack . strOption)

(long "source-dir" <>

short 's' <>

metavar "DIR" <>

help "location of GHCJS library sources")

initPackageDB :: B ()

initPackageDB = do

msg info "creating package databases"

initDB "--global" <^> beLocations . blGlobalDB

where

initDB dbName db = do

rm_rf db

ghcjs_pkg_ ["init", T.pack db] `catchAny_` return ()

ghcjs_pkg_ ["recache", dbName]

cleanCache :: B ()

cleanCache =

liftIO Info.getUserCacheDir >>= \case

Just p -> rm_rf p `catchAny_` return ()

Nothing -> return ()

prepareLibDir :: B ()

prepareLibDir = do

msg info "preparing GHCJS library directory"

locs <- view beLocations

pgms <- view bePrograms

liftIO $ print (locs, pgms)

ver <- liftIO $ ghcjsVersion pgms

let globalDB = locs ^. blGlobalDB

ghcjsLib = libDir locs

ghcjsTop = locs ^. blGhcjsTopDir

rtsConfFile = "rts.conf"

wrapperSrcDir = (locs ^. blSourceDir) </> "input" </> "wrappers"

wenv = WrapperEnv { weTopDir = T.pack (libDir locs)

, weBinDir = T.pack ((locs ^. blGhcjsTopDir) </> "bin")

, weLibexecDir = T.pack (libDir locs </> "bin")

, weVersion = ver

, weGhcVersion = ver

, weEmsdk = T.pack (locs ^. blEmsdk)

}

rtsConf <- replacePlaceholders wenv <$>

liftIO (T.readFile ((locs ^. blSourceDir) </> "input" </> "rts" <.> "conf"))

mkdir_p (ghcjsLib </> "bin")

msg info "copying GHCJS executables"

-- copy the executables from the package to the libraries directory

-- (the executables in the package have been prefixed with `private-ghcjs-`

-- as a workaround for cabal-install incorrectly generating symlinks for

-- private executables)

let cpExe name = do

let srcName = ghcjsTop </> "bin" </> exe (T.unpack $ "private-ghcjs-" <> name)

tgtName = ghcjsLib </> "bin" </> exe (T.unpack name)

cp srcName tgtName

liftIO . Cabal.setFileExecutable $ tgtName

mapM_ cpExe [ "unlit", "run" ]

when isWindows (mapM_ cpExe ["touchy", "wrapper"])

msg info "creating emscripten wrapper"

liftIO $ copyWrapper "emcc"

Nothing

wenv

(ghcjsLib </> "bin")

wrapperSrcDir

(ghcjsLib </> "bin")

msg info "adding RTS package"

initPackageDB

liftIO $ T.writeFile (globalDB </> rtsConfFile) rtsConf

ghcjs_pkg_ ["recache", "--global", "--no-user-package-db"]

cp_r ((locs ^. blSourceDir) </> "shims") (ghcjsLib </> "shims")

cp_r ((locs ^. blSourceDir) </> "data") ghcjsLib

liftIO . T.writeFile (ghcjsLib </> "settings") =<< generateSettings

-- workaround for hardcoded check of mingw dir in ghc when building on Windows

when isWindows (mkdir_p $ ghcjsTop </> "mingw")

prepareNodeJs

unless isWindows $ do

let runSh = ghcjsLib </> "run" <.> "sh"

liftIO (T.writeFile runSh "#!/bin/sh\nCOMMAND=$1\nshift\n\"$COMMAND\" \"$@\"\n")

liftIO (Cabal.setFileExecutable =<< makeAbsolute runSh)

-- make an empty object file for

subLib $ do

liftIO (T.writeFile "empty.c" "")

ghc_ ["-c", "empty.c"]

msg info "RTS prepared"

generateSettings :: B Text

generateSettings = do

emsdk <- view (beLocations . blEmsdk)

-- do we also need emar, emranlib?

let opts :: [(String, String)]

opts = [("GCC extra via C opts", " -fwrapv -fno-builtin"),

("C compiler command", emsdk </> "upstream" </> "bin" </> "clang" {-"asmjs-none-gcc"-} {-T.unpack emccProgram-}),

("C compiler flags", ""),

("C++ compiler flags",""),

("C compiler link flags", " "),

("C compiler supports -no-pie", "NO"),

("Haskell CPP command", emsdk </> "upstream" </> "bin" </> "clang"),

("Haskell CPP flags","-E -undef -traditional -Wno-invalid-pp-token -Wno-unicode -Wno-trigraphs"),

("ld command", "ld"),

("ld flags", ""),

("ld supports compact unwind", "YES"),

("ld supports build-id", "NO"),

("ld supports filelist", "YES"),

("ld is GNU ld", "NO"),

("Merge objects command", "ld.gold"),

("Merge objects flags", "-r"),

("ar command", emsdk </> "upstream" </> "emscripten" </> "emar"),

("ar flags", "qcls"),

("ar supports at file", "NO"),

("ranlib command", emsdk </> "upstream" </> "emscripten" </> "emranlib"),

("otool command", "otool"),

("install_name_tool command", "install_name_tool"),

("touch command", if isWindows then "$topdir/bin/touchy.exe" else "touch"),

("dllwrap command", "/bin/false"),

("windres command", "/bin/false"),

("libtool command", "libtool"),

("unlit command", "$topdir/bin/unlit"),

("cross compiling", "YES"),

("target os", "OSUnknown"),

("target arch", "ArchJavaScript"),

("target platform string", T.unpack ghcjsTriple),

("Target platform", T.unpack ghcjsTriple),

("target word size", "4"),

("target has GNU nonexec stack", "NO"),

("target has .ident directive", "YES"),

("target has subsections via symbols", "YES"),

("target has RTS linker", "YES"),

("integer library", "integer-gmp"),

("Unregisterised", "YES"),

("LLVM target", T.unpack ghcjsTriple),

("LLVM llc command", "llc"),

("LLVM opt command", "opt"),

("LLVM clang command", "clang"),

("Tables next to code","YES"),

("Use interpreter","YES"),

("Use native code generator","YES"),

("Support SMP","NO"),

("RTS ways","l debug debug_p"),

("Leading underscore","NO"),

("Use LibFFI","NO"),

("Use Threads","YES"),

("Use Debugging","NO"),

("RTS expects libdw","NO"),

("Support parallel --make","YES"),

("Support reexported-modules","YES"),

("Support thinning and renaming package flags","YES"),

("Support Backpack","YES"),

("Requires unified installed package IDs","YES"),

("Uses package keys","YES"),

("Uses unit IDs","YES")

]

pure $ T.pack ("[" ++ intercalate ",\n" (map show opts) ++ "\n]")

prepareNodeJs :: B ()

prepareNodeJs = do

ghcjsLib <- libDir <$> view beLocations

buildDir <- view (beLocations . blBuildDir)

nodeProgram <- view (bePrograms . bpNode . pgmLoc . to (maybe "-" T.pack))

mbNodePath <- view (beSettings . bsWithNodePath)

extraArgs <- view (beSettings . bsNodeExtraArgs)

-- If no setting for NODE_PATH is specified, we use the libraries bundled

-- with the ghcjs-boot submodule. We must run "npm rebuild" to build

-- any sytem-specific components.

when (isNothing mbNodePath) $ do

subLib (mkdir_p "ghcjs-node")

liftIO $ unpackTar False

True

ghcjsLib

(buildDir </> "ghcjs-node.tar")

subLib' "ghcjs-node" $ npm_ ["rebuild"]

-- write nodeSettings.json file

let nodeSettings = NodeSettings

{ nodeProgram = T.unpack nodeProgram

, nodePath = mbNodePath

, nodeExtraArgs = maybeToList extraArgs

, nodeKeepAliveMaxMem = 536870912

}

liftIO $ BL.writeFile (T.unpack . T.pack $ ghcjsLib </> "nodeSettings.json")

(Aeson.encode $ Aeson.toJSON nodeSettings)

exe :: FilePath -> FilePath

exe = bool isWindows (<.>"exe") id

buildDocIndex :: B ()

buildDocIndex = subTop' "doc" $ do

haddockFiles <- findWhen (return . isExtensionOf "haddock") "."

haddock_ $ ["--gen-contents"

,"--gen-index"

, "-o"

, "html"

, "--title=GHCJS Libraries"

] ++

map (\p -> "--read-interface=../" <>

T.pack (takeDirectory p) <>

"," <>

T.pack p)

haddockFiles

installCabal :: B ()

installCabal = subBuild $ do

msg info "installing Cabal library"

preparePackage "Cabal"

buildCabalPackage "Cabal"

installGhcjsPrim :: B ()

installGhcjsPrim = do

msg info "installing ghcjs-prim"

preparePackage "ghcjs-prim"

buildCabalPackage "ghcjs-prim"

installGhcjsTh :: B ()

installGhcjsTh = do

msg info "installing ghcjs-th"

preparePackage "ghcjs-th"

buildCabalPackage "ghcjs-th"

installStage1 :: B ()

installStage1 = subBuild $ do

buildCabalPackage "ghc-prim"

mapM_ installPackage =<< stagePackages bstStage1a

installGhcjsPrim

mapM_ installPackage =<< stagePackages bstStage1b

installGhcjsTh

resolveWiredInPackages

where

installPackage pkg = do

msg info ("installing package " <> pkg)

preparePackage pkg

buildCabalPackage pkg

resolveWiredInPackages :: B ()

resolveWiredInPackages = subLib $ do

wips <- readBinary ("wiredinpkgs" <.> "yaml")

case Yaml.decodeEither' wips of

Left err -> failWith $

"error parsing wired-in packages file wiredinpkgs.yaml\n" <> T.pack (show err)

Right pkgs -> do

pkgs' <- forM pkgs $ \p ->

(p,) . T.strip <$> ghcjs_pkg [ "--simple-output"

, "field"

, p

, "key"

]

liftIO (T.writeFile ("wiredinkeys" <.> "yaml") (

T.unlines ("# resolved wired-in packages" :

map (\(p,k) -> p <> ": " <> k) pkgs')))

preparePackage :: Package -> B ()

preparePackage pkg

| "./" `T.isPrefixOf` pkg || "../" `T.isPrefixOf` pkg = sub $ do

msg trace ("preparing package " <> pkg)

cd (T.unpack pkg)

rm_rf "dist"

| otherwise = return ()

-- | subshell in path relative to build dir

subBuild :: B a -> B a

subBuild a = sub (view (beLocations . blBuildDir) >>= cd >> a)

-- | subshell in path relative to top installation dir

subTop' :: FilePath -> B a -> B a

subTop' p a = subTop (cd p >> a)

subTop :: B a -> B a

subTop a = sub (view (beLocations . blGhcjsTopDir) >>= cd >> a)

subLib' :: FilePath -> B a -> B a

subLib' p a = subLib (cd p >> a)

subLib :: B a -> B a

subLib a = sub ((libDir <$> view beLocations) >>= cd >> a)

unpackTar :: Bool -- ^strip the first directory component?

-> Bool -- ^preserve symbolic links?

-> Prelude.FilePath -- ^destination to unpack to

-> Prelude.FilePath -- ^the tar file

-> IO ()

unpackTar stripFirst preserveSymlinks dest tarFile = do

createDirectoryIfMissing True dest

entries <- Tar.read . BL.fromStrict <$> B.readFile tarFile

void $ Tar.foldEntries (\e -> (>>=checkExtract e))

(return Nothing)

(\e -> failWith $ "error unpacking tar: " <> showT e)

entries

where

failSec e msg = failWith $ "tar security check, " <>

msg <>

": " <>

T.pack (Tar.entryPath e)

checkExtract e Nothing

| (p:_) <- FP.splitDirectories (Tar.entryPath e)

= checkExtract e (Just p)

| otherwise = failSec e $

"no path"

checkExtract e je@(Just expected)

| FP.isAbsolute ep = failSec e $

"absolute path"

| elem ".." epd = failSec e $

"'..' in path"

| listToMaybe epd /= je &&

isSupportedEntry (Tar.entryContent e) = failSec e $

"tar bomb, expected path component: " <> T.pack expected

| otherwise = do

(extractEntry e $ dest FP.</>

(FP.joinPath

(drop (if stripFirst then 1 else 0) epd)))

return je

where ep = Tar.entryPath e

epd = FP.splitDirectories ep

isSupportedEntry Tar.NormalFile{} = True

isSupportedEntry Tar.Directory{} = True

isSupportedEntry _ = False

extractEntry :: Tar.Entry -> Prelude.FilePath -> IO ()

extractEntry e tgt

| Tar.NormalFile bs _size <- Tar.entryContent e = do

createDirectoryIfMissing True (FP.dropFileName tgt)

BL.writeFile tgt bs

setPermissions (Tar.entryPermissions e) tgt

| Tar.Directory <- Tar.entryContent e = do

createDirectoryIfMissing True tgt

setPermissions (Tar.entryPermissions e) tgt

| Tar.SymbolicLink _linkTgt <- Tar.entryContent e

, preserveSymlinks =

createDirectoryIfMissing True (FP.dropFileName tgt)

| otherwise = hPutStrLn stderr $

"ignoring unexpected entry type in tar. " <>

"only normal files and directories (no links) " <>

"are supported:\n " <> tgt

setPermissions mode tgt = do

absTgt <- makeAbsolute tgt

setFileMode absTgt mode

run_inplace :: Text -> [Text] -> B Text

run_inplace pgm args = do

ghcjsTop <- view (beLocations . blGhcjsTopDir)

run'' (ghcjsTop </> "bin" </> T.unpack pgm) "" args

run_inplace_ :: Text -> [Text] -> B ()

run_inplace_ pgm args = do

ghcjsTop <- view (beLocations . blGhcjsTopDir)

run''_ (ghcjsTop </> "bin" </> T.unpack pgm) args

ghc_ :: [Text] -> B ()

ghc_ = runE_ bpGhc

ghcjs_pkg :: [Text] -> B Text

ghcjs_pkg = run_inplace "ghcjs-pkg"

ghcjs_pkg_ :: [Text] -> B ()

ghcjs_pkg_ = run_inplace_ "ghcjs-pkg"

haddock_ :: [Text] -> B ()

haddock_ = run_inplace_ "haddock"

npm_ :: [Text] -> B ()

npm_ args = do

nodePgm <- view (bePrograms . bpNode)

case nodePgm ^. pgmLoc of

Nothing -> failWith "nodejs program not configured when trying to run npm"

Just loc ->

if isWindows

then do

sysRoot <- fromMaybe "C:\\WINDOWS" <$> liftIO (Utils.getEnvMay "SYSTEMROOT")

let cmdLoc = sysRoot </> "system32" </> "cmd" <.> "exe"

npmLoc = FP.takeDirectory loc </> "npm" <.> "cmd"

run''_ cmdLoc ("/C" : T.pack npmLoc : args)

else do

let npmLoc = FP.takeDirectory loc </> "npm"

run''_ npmLoc args

runE_ :: ((Program -> Const Program Program)

-> BootPrograms -> Const Program BootPrograms)

-> [Text] -> B ()

runE_ g a = view (bePrograms . g) >>= \p -> run_ p a

customSetupPackages :: [Text]

customSetupPackages = [ "ghc-prim" ]

cabalConfigureFlags :: B [Text]

cabalConfigureFlags = do

debug <- view (beSettings . bsDebug)

v <- view (beSettings . bsVerbosity)

instDir <- libDir <$> view beLocations

prof <- view (beSettings . bsProf)

locs <- view beLocations

let binDir = (locs ^. blGhcjsTopDir) </> "bin"

privateBinDir = instDir </> "bin"

return $ [ "--global"

, "--ghcjs"

, "--builddir", "dist"

, "--with-compiler", (T.pack $ binDir </> "ghcjs")

, "--with-hc-pkg", (T.pack $ binDir </> "ghcjs-pkg")

, "--with-haddock", (T.pack $ binDir </> "haddock")

, "--with-gcc", (T.pack $ privateBinDir </> "emcc")

, "--prefix", T.pack (locs ^. blGhcjsTopDir)

, "--configure-option", "--host=js-unknown-ghcjs"

, "--ghcjs-options=-fwrite-ide-info"

, "--enable-debug-info"

, "--disable-library-stripping"

, "--disable-executable-stripping"

, "-fghci"

, bool prof

"--enable-profiling"

"--disable-profiling"

] ++

-- don't slow down Windows builds too much,

-- on other platforms we get this more

-- or less for free, thanks to dynamic-too

bool isWindows [] ["--enable-shared"] ++

catMaybes [ bj debug "--ghcjs-options=-debug"

, bj (v > info) "-v2"

]

buildCabalPackage :: Text -> B ()

buildCabalPackage pkg = subBuild $ do

cd ("pkg" </> T.unpack pkg) -- hopefully correct

-- build custom setup if necessary

msg info ("configuring package: " <> pkg)

configureFlags <- cabalConfigureFlags

haddock <- view (beSettings . bsHaddock)

-- configure / build

liftIO $ setEnv "GHCJS_BOOTING" "1"

case pkg `elem` customSetupPackages of

True -> do

{-

ghc <- requirePgmLoc =<< view (bePrograms . bpGhc)

run''_ ghc ["Setup.hs"]

let setup args = run''_ "./Setup" args

setup ("configure" : configureFlags)

setup ["build"]

when haddock (setup ["haddock"])

setup ["copy"]

setup ["register"]

_ -> do

cmd <- requirePgmLoc =<< view (bePrograms . bpCabal)

let setup args = run''_ cmd args

setup ("v1-configure" : configureFlags)

setup ["v1-build"]

when haddock (setup ["v1-haddock"])

setup ["v1-copy"]

setup ["v1-register"]

stagePackages :: Getter BootStages Stage -> B [Package]

stagePackages l = view (beStages . l)

failWith :: MonadIO m => Text -> m a

failWith err = liftIO (T.putStrLn ("fatal: " <> err) >> exitFailure)

initBootEnv :: BootSettings -> IO BootEnv

initBootEnv bs = do

BootConfigFile stgs pgms1 <- readBootConfigFile bs

pgms2 <- configureBootPrograms bs pgms1

locs <- configureBootLocations bs pgms2

-- installWrappers ((locs ^. blGhcjsTopDir) </> "bin") locs pgms2

return (BootEnv bs locs pgms2 stgs)

ghcjsTriple :: Text

ghcjsTriple = "js-unknown-ghcjs"

ghcjsVersion :: BootPrograms -> IO Text

ghcjsVersion _ = pure (T.pack Info.getCompilerVersion)

libSubDir :: FilePath

libSubDir = "lib"

libDir :: BootLocations -> FilePath

libDir locs = (locs ^. blGhcjsTopDir) </> libSubDir

data WrapperEnv = WrapperEnv { weTopDir :: Text

, weBinDir :: Text

, weLibexecDir :: Text

, weVersion :: Text

, weGhcVersion :: Text

, weEmsdk :: Text

} deriving (Show)

copyWrapper :: Text

-> Maybe Text

-> WrapperEnv

-> FilePath

-> FilePath

-> FilePath

-> IO ()

copyWrapper = if isWindows then copyWrapperW else copyWrapperU

copyWrapperW :: Text

-> Maybe Text

-> WrapperEnv

-> FilePath

-> FilePath

-> FilePath

-> IO ()

copyWrapperW programName mbVer env libexecDir wrapperSrcDir binDir = do

createDirectoryIfMissing False binDir

Cabal.installExecutableFile verbosity srcExe tgtExe

whenVer (Cabal.installExecutableFile verbosity srcExe tgtExeVersioned)

options <- replacePlaceholders env <$> T.readFile (wrapperSrcDir </> T.unpack programName <.> "exe" <.> "options")

createDirectoryIfMissing False binDir

Cabal.withTempFile binDir "ghcjs-options-XXXXXX.tmp" $ \tmp h -> do

T.hPutStr h options

hClose h

Cabal.installOrdinaryFile verbosity tmp tgtOptions

whenVer (Cabal.installOrdinaryFile verbosity tmp tgtOptionsVersioned)

where

verbosity = Cabal.verbose

whenVer x = when (isJust mbVer) x

srcExe = libexecDir </> "wrapper" <.> "exe"

tgtPrefix = binDir </> T.unpack programName

tgtPrefixVersioned = binDir </> T.unpack (programName <> "-" <> ver)

tgtExe = tgtPrefix <.> "exe"

tgtOptions = tgtExe <.> "options"

tgtExeVersioned = tgtPrefixVersioned <.> "exe"

tgtOptionsVersioned = tgtExeVersioned <.> "options"

ver = fromMaybe "0.0.0" mbVer

copyWrapperU :: Text

-> Maybe Text

-> WrapperEnv

-> FilePath

-> FilePath

-> FilePath

-> IO ()

copyWrapperU programName mbVer env libexecDir wrapperSrcDir binDir = do

putStrLn ("installing wrapper for: " ++ show (programName, mbVer, libexecDir, wrapperSrcDir, binDir))

createDirectoryIfMissing False binDir

wrapperScript <- replacePlaceholders env <$> T.readFile (wrapperSrcDir </> T.unpack programName <.> "sh")

Cabal.withTempFile binDir "ghcjs-wrapper-XXXXXX.tmp" $

(\tmp h -> do T.hPutStr h wrapperScript

hClose h

Cabal.installExecutableFile Cabal.normal tmp (binDir </> tgt))

when (isJust mbVer) (linkFileU Cabal.normal binDir tgt tgtPlain)

where

tgtPlain = T.unpack programName

tgt = maybe tgtPlain

(\ver -> T.unpack (programName <> "-" <> ver))

mbVer

linkFileU :: Cabal.Verbosity -> FilePath -> FilePath -> FilePath -> IO ()

linkFileU _v workingDir src dest = do

-- putStrLn ("link file: " ++ show (workingDir, src, dest))

let ignoreDoesNotExist :: IOError -> IO ()

ignoreDoesNotExist e | isDoesNotExistError e = return ()

| otherwise = Ex.throw e

removeFile (workingDir </> dest) `Ex.catch` ignoreDoesNotExist

wd <- getCurrentDirectory

setCurrentDirectory workingDir

createFileLink src dest

setCurrentDirectory wd

-- | replace placeholders in a wrapper script or options file

replacePlaceholders :: WrapperEnv -> Text -> Text

replacePlaceholders env xs =

foldl (\ys (p,r) -> T.replace p (r env) ys) xs

[ ("{topdir}", weTopDir)

, ("{bindir}", weBinDir)

, ("{libexecdir}", weLibexecDir)

, ("{version}", weVersion)

, ("{ghcversion}", weGhcVersion)

, ("{emsdk}", weEmsdk)

]

configureEmsdkDir :: BootSettings

-> IO FilePath

configureEmsdkDir bs

| Just dir <- bs ^. bsWithEmsdk = pure (T.unpack dir)

| otherwise = do

e <- lookupEnv "EMSDK"

case e of

Just edir -> pure edir

_ -> do

mbEmccExe <- findExecutable "emcc"

case mbEmccExe of

Just emccExe ->

{- if we found the `emcc' executable, we just assume

let emccDirParts = FP.splitPath (FP.takeDirectory emccExe)

in pure (concat . reverse . drop 2 . reverse $ emccDirParts)

_ -> notFound

where

notFound = failWith "emscripten emsdk not found (use --with-emsdk)"

-- | configure the locations

configureBootLocations :: BootSettings

-> BootPrograms

-> IO BootLocations

configureBootLocations bs _pgms = do

-- take the location of the ghcjs-boot program and configure the

-- installation directory relative to that

bootPath <- getExecutablePath

ghcjsTopDir <- canonicalizePath (FP.dropFileName bootPath </> "..")

let ghcjsLibDir = ghcjsTopDir </> libSubDir

globalDB = ghcjsLibDir </> "package.conf.d"

-- the source directory is specified by the user

sourceDir <- bootSourceDir bs

buildDir <- prepareBuildDir sourceDir ghcjsLibDir

emsdkDir <- configureEmsdkDir bs

pure $ BootLocations sourceDir

buildDir

ghcjsTopDir

globalDB

emsdkDir

prepareBuildDir :: Prelude.FilePath

-> Prelude.FilePath

-> IO Prelude.FilePath

prepareBuildDir srcDir ghcjsLibDir = do

e <- doesFileExist srcDir

if e then do let bootDir = ghcjsLibDir FP.</> "boot"

bootExists <- doesDirectoryExist bootDir

when bootExists (removeDirectoryRecursive bootDir)

unpackTar False False ghcjsLibDir srcDir

pure bootDir

else do

d <- doesDirectoryExist srcDir

if d then do

e <- doesFileExist (srcDir FP.</> "boot" FP.<.> "yaml")