Config.hs

{-# LANGUAGE OverloadedStrings, Rank2Types, PatternGuards #-}
module Haste.Config (
  Config (..), AppStart, defaultConfig, stdJSLibs, startCustom, fastMultiply,
  safeMultiply, strictly32Bits, debugLib) where
import Haste.AST.PP.Opts
import Haste.AST.Syntax
import Haste.AST.Constructors
import Haste.AST.Op
import Control.Shell (replaceExtension, (</>))
import Data.ByteString.Builder
import Data.Monoid
import Haste.Environment
import Outputable (Outputable)
import Data.List (stripPrefix, nub)

type AppStart = Builder -> Builder

stdJSLibs :: [FilePath]
stdJSLibs = map (jsDir </>)  [
    "rts.js", "floatdecode.js", "stdlib.js", "endian.js", "bn.js",
    "MVar.js", "StableName.js", "Integer.js", "long.js", "md5.js", "array.js",
    "pointers.js", "cheap-unicode.js", "Handle.js", "Weak.js",
    "Foreign.js", "spt.js"
  ]

debugLib :: FilePath
debugLib = jsDir </> "debug.js"

-- | Execute the program as soon as it's loaded into memory.
--   Evaluate the result of applying main, as we might get a thunk back if
--   we're doing TCE. This is so cheap, small and non-intrusive we might
--   as well always do it this way, to simplify the config a bit.
startASAP :: AppStart
startASAP mainSym =
  mainSym <> "();"

-- | Launch the application using a custom command.
startCustom :: String -> AppStart
startCustom "onload" = startOnLoadComplete
startCustom "asap"   = startASAP
startCustom "onexec" = startASAP
startCustom str      = insertSym str

-- | Replace the first occurrence of $HASTE_MAIN with Haste's entry point
--   symbol.
insertSym :: String -> AppStart
insertSym [] _                              = stringUtf8 ""
insertSym str sym
  | Just r <- stripPrefix "$HASTE_MAIN" str = sym <> stringUtf8 r
  | (l,r) <- span (/= '$') str              = stringUtf8 l <> insertSym r sym

-- | Execute the program when the document has finished loading.
startOnLoadComplete :: AppStart
startOnLoadComplete mainSym =
  "window.onload = " <> mainSym <> ";"

-- | Int op wrapper for strictly 32 bit (|0).
strictly32Bits :: Exp -> Exp
strictly32Bits = flip (binOp BitOr) (litN 0)

-- | Safe Int multiplication.
safeMultiply :: Exp -> Exp -> Exp
safeMultiply a b = callForeign "imul" [a, b]

-- | Fast but unsafe Int multiplication.
fastMultiply :: Exp -> Exp -> Exp
fastMultiply = binOp Mul

-- | Compiler configuration.
data Config = Config {
    -- | Runtime files to dump into the JS blob.
    rtsLibs :: [FilePath],

    -- | Path to directory where system jsmods are located.
    libPaths :: [FilePath],

    -- | Write all jsmods to this path.
    targetLibPath :: FilePath,

    -- | A function that takes the main symbol as its input and outputs the
    --   code that starts the program.
    appStart :: AppStart,

    -- | Wrap the program in its own namespace?
    wrapProg :: Bool,

    -- | Options to the pretty printer.
    ppOpts :: PPOpts,

    -- | A function that takes the name of the a target as its input and
    --   outputs the name of the file its JS blob should be written to.
    outFile :: Config -> String -> String,

    -- | Link the program?
    performLink :: Bool,

    -- | Link as jslib file, instead of executable?
    linkJSLib :: Bool,

    -- | Output file name when linking jslib.
    linkJSLibFile :: Maybe FilePath,

    -- | A function to call on each Int arithmetic primop.
    wrapIntMath :: Exp -> Exp,

    -- | Operation to use for Int multiplication.
    multiplyIntOp :: Exp -> Exp -> Exp,

    -- | Be verbose about warnings, etc.?
    verbose :: Bool,

    -- | Perform optimizations over the whole program at link time?
    wholeProgramOpts :: Bool,

    -- | Perform comprehensive whole program flow analysis optimizations at
    --   link time?
    flowAnalysisOpts :: Bool,

    -- | Allow the possibility that some tail recursion may not be optimized
    --   in order to gain slightly smaller code?
    sloppyTCE :: Bool,

    -- | Turn on run-time tracing of primops?
    tracePrimops :: Bool,

    -- | Run the entire thing through Google Closure when done?
    useGoogleClosure :: Maybe FilePath,

    -- | Extra flags for Google Closure to take?
    useGoogleClosureFlags :: [String],

    -- | Any external Javascript to link into the JS bundle.
    jsExternals :: [FilePath],

    -- | Produce a skeleton HTML file containing the program rather than a
    --   JS file.
    outputHTML :: Bool,

    -- | GHC DynFlags used for STG generation.
    --   Currently only used for printing StgSyn values.
    showOutputable :: forall a. Outputable a => a -> String,

    -- | Which module contains the program's main function?
    --   Defaults to Just ("main", "Main")
    mainMod :: Maybe (String, String),

    -- | Perform optimizations.
    --   Defaults to True.
    optimize :: Bool,

    -- | Enable tail loop transformation?
    --   Defaults to True.
    enableTailLoops :: Bool,

    -- | Enable proper tailcalls?
    --   Defaults to True.
    enableProperTailcalls :: Bool,

    -- | Inline @JSLit@ values?
    --   Defaults to False.
    inlineJSPrim :: Bool,

    -- | Remove tailcalls and trampolines for tail call cycles provably
    --   shorter than @N@ calls.
    --   Defaults to 3.
    detrampolineThreshold :: Int,

    -- | Bound tail call chains at @n@ stack frames.
    --   Defaults to 10.
    tailChainBound :: Int,

    -- | Overwrite scrutinees when evaluated instead of allocating a new local.
    --   Defaults to False.
    overwriteScrutinees :: Bool,

    -- | Annotate all external symbols and JS literals with /* EXTERNAL */ in
    --   generated code.
    --   Defaults to False.
    annotateExternals :: Bool,

    -- | Annotate all non-local Haskell symbols and with their qualified
    --   names.
    --   Defaults to False.
    annotateSymbols :: Bool,

    -- | Emit @"use strict";@ declaration. Does not affect minification, but
    --   *does* affect any external JS.
    --   Defaults to True.
    useStrict :: Bool,

    -- | Use classy objects for small ADTs?
    --   Defaults to True.
    useClassyObjects :: Bool
  }

-- | Default compiler configuration.
defaultConfig :: Config
defaultConfig = Config {
    rtsLibs               = stdJSLibs,
    libPaths              = nub [jsmodUserDir, jsmodSysDir],
    targetLibPath         = ".",
    appStart              = startOnLoadComplete,
    wrapProg              = False,
    ppOpts                = defaultPPOpts,
    outFile               = \cfg f -> let ext = if outputHTML cfg
                                                  then "html"
                                                  else "js"
                                      in replaceExtension f ext,
    performLink           = True,
    linkJSLib             = False,
    linkJSLibFile         = Nothing,
    wrapIntMath           = strictly32Bits,
    multiplyIntOp         = safeMultiply,
    verbose               = False,
    wholeProgramOpts      = False,
    flowAnalysisOpts      = False,
    sloppyTCE             = False,
    tracePrimops          = False,
    useGoogleClosure      = Nothing,
    useGoogleClosureFlags = [],
    jsExternals           = [],
    outputHTML            = False,
    showOutputable        = const "No showOutputable defined in config!",
    mainMod               = Just ("main", "Main"),
    optimize              = True,
    enableTailLoops       = True,
    enableProperTailcalls = True,
    inlineJSPrim          = False,
    detrampolineThreshold = 3,
    tailChainBound        = 0,
    overwriteScrutinees   = False,
    annotateExternals     = False,
    annotateSymbols       = False,
    useStrict             = True,
    useClassyObjects      = True
  }