{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE MultiWayIf  #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.StgToJS.Linker.Utils
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Jeffrey Young  <jeffrey.young@iohk.io>
--                Luite Stegeman <luite.stegeman@iohk.io>
--                Sylvain Henry  <sylvain.henry@iohk.io>
--                Josh Meredith  <josh.meredith@iohk.io>
-- Stability   :  experimental
--
-- Various utilies used in the JS Linker
--
-----------------------------------------------------------------------------

module GHC.StgToJS.Linker.Utils
  ( getOptionsFromJsFile
  , JSOption(..)
  , jsExeFileName
  , getInstalledPackageLibDirs
  , getInstalledPackageHsLibs
  , commonCppDefs
  )
where

import           System.FilePath
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as Char8
import           Data.ByteString (ByteString)

import          GHC.Driver.Session

import          GHC.Data.ShortText
import          GHC.Unit.State
import          GHC.Unit.Types

import          GHC.StgToJS.Types

import           Prelude
import GHC.Platform
import Data.List (isPrefixOf)
import System.IO
import Data.Char (isSpace)
import qualified Control.Exception as Exception

-- | Retrieve library directories provided by the @UnitId@ in @UnitState@
getInstalledPackageLibDirs :: UnitState -> UnitId -> [ShortText]
getInstalledPackageLibDirs :: UnitState -> UnitId -> [ShortText]
getInstalledPackageLibDirs UnitState
us = [ShortText]
-> (GenericUnitInfo
      PackageId
      PackageName
      UnitId
      ModuleName
      (GenModule (GenUnit UnitId))
    -> [ShortText])
-> Maybe
     (GenericUnitInfo
        PackageId
        PackageName
        UnitId
        ModuleName
        (GenModule (GenUnit UnitId)))
-> [ShortText]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [ShortText]
forall a. Monoid a => a
mempty GenericUnitInfo
  PackageId
  PackageName
  UnitId
  ModuleName
  (GenModule (GenUnit UnitId))
-> [ShortText]
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitLibraryDirs (Maybe
   (GenericUnitInfo
      PackageId
      PackageName
      UnitId
      ModuleName
      (GenModule (GenUnit UnitId)))
 -> [ShortText])
-> (UnitId
    -> Maybe
         (GenericUnitInfo
            PackageId
            PackageName
            UnitId
            ModuleName
            (GenModule (GenUnit UnitId))))
-> UnitId
-> [ShortText]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitState
-> UnitId
-> Maybe
     (GenericUnitInfo
        PackageId
        PackageName
        UnitId
        ModuleName
        (GenModule (GenUnit UnitId)))
lookupUnitId UnitState
us

-- | Retrieve the names of the libraries provided by @UnitId@
getInstalledPackageHsLibs :: UnitState -> UnitId -> [ShortText]
getInstalledPackageHsLibs :: UnitState -> UnitId -> [ShortText]
getInstalledPackageHsLibs UnitState
us = [ShortText]
-> (GenericUnitInfo
      PackageId
      PackageName
      UnitId
      ModuleName
      (GenModule (GenUnit UnitId))
    -> [ShortText])
-> Maybe
     (GenericUnitInfo
        PackageId
        PackageName
        UnitId
        ModuleName
        (GenModule (GenUnit UnitId)))
-> [ShortText]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [ShortText]
forall a. Monoid a => a
mempty GenericUnitInfo
  PackageId
  PackageName
  UnitId
  ModuleName
  (GenModule (GenUnit UnitId))
-> [ShortText]
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitLibraries (Maybe
   (GenericUnitInfo
      PackageId
      PackageName
      UnitId
      ModuleName
      (GenModule (GenUnit UnitId)))
 -> [ShortText])
-> (UnitId
    -> Maybe
         (GenericUnitInfo
            PackageId
            PackageName
            UnitId
            ModuleName
            (GenModule (GenUnit UnitId))))
-> UnitId
-> [ShortText]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitState
-> UnitId
-> Maybe
     (GenericUnitInfo
        PackageId
        PackageName
        UnitId
        ModuleName
        (GenModule (GenUnit UnitId)))
lookupUnitId UnitState
us

-- | A constant holding the JavaScript executable Filename extension
jsexeExtension :: String
jsexeExtension :: [Char]
jsexeExtension = [Char]
"jsexe"

-- | CPP definitions that are inserted into every .pp file
commonCppDefs :: Bool -> ByteString
commonCppDefs :: Bool -> ByteString
commonCppDefs Bool
profiling = case Bool
profiling of
  Bool
True  -> ByteString
commonCppDefs_profiled
  Bool
False -> ByteString
commonCppDefs_vanilla

-- | CPP definitions for normal operation and profiling. Use CAFs for
-- commonCppDefs_* so that they are shared for every CPP file
commonCppDefs_vanilla, commonCppDefs_profiled :: ByteString
commonCppDefs_vanilla :: ByteString
commonCppDefs_vanilla  = Bool -> ByteString
genCommonCppDefs Bool
False
commonCppDefs_profiled :: ByteString
commonCppDefs_profiled = Bool -> ByteString
genCommonCppDefs Bool
True

-- | Generate CPP Definitions depending on a profiled or normal build. This
-- occurs at link time.
genCommonCppDefs :: Bool -> ByteString
genCommonCppDefs :: Bool -> ByteString
genCommonCppDefs Bool
profiling = [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat
  [
  -- constants
    let mk_int_def :: [Char] -> a -> ByteString
mk_int_def [Char]
n a
v   = ByteString
"#define " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> [Char] -> ByteString
Char8.pack [Char]
n ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" (" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> [Char] -> ByteString
Char8.pack (a -> [Char]
forall a. Show a => a -> [Char]
show a
v) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
")\n"
        -- generate "#define CLOSURE_TYPE_xyz (num)" defines
        mk_closure_def :: ClosureType -> ByteString
mk_closure_def ClosureType
t = [Char] -> Int -> ByteString
forall {a}. Show a => [Char] -> a -> ByteString
mk_int_def (ClosureType -> [Char]
ctJsName ClosureType
t) (ClosureType -> Int
ctNum ClosureType
t)
        closure_defs :: [ByteString]
closure_defs     = (ClosureType -> ByteString) -> [ClosureType] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map ClosureType -> ByteString
mk_closure_def [ClosureType
forall a. Bounded a => a
minBound..ClosureType
forall a. Bounded a => a
maxBound]
        -- generate "#define THREAD_xyz_xyz (num)" defines
        mk_thread_def :: ThreadStatus -> ByteString
mk_thread_def ThreadStatus
t  = [Char] -> Int -> ByteString
forall {a}. Show a => [Char] -> a -> ByteString
mk_int_def (ThreadStatus -> [Char]
threadStatusJsName ThreadStatus
t) (ThreadStatus -> Int
threadStatusNum ThreadStatus
t)
        thread_defs :: [ByteString]
thread_defs      = (ThreadStatus -> ByteString) -> [ThreadStatus] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map ThreadStatus -> ByteString
mk_thread_def [ThreadStatus
forall a. Bounded a => a
minBound..ThreadStatus
forall a. Bounded a => a
maxBound]
    in [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat ([ByteString]
closure_defs [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [ByteString]
thread_defs)

  -- low-level heap object manipulation macros
  , if Bool
profiling
      then [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat
        [ ByteString
"#define MK_TUP2(x1,x2)                           (h$c2(h$ghczmprimZCGHCziTupleziPrimziZLz2cUZR_con_e,(x1),(x2),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n"
        , ByteString
"#define MK_TUP3(x1,x2,x3)                        (h$c3(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUZR_con_e,(x1),(x2),(x3),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n"
        , ByteString
"#define MK_TUP4(x1,x2,x3,x4)                     (h$c4(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n"
        , ByteString
"#define MK_TUP5(x1,x2,x3,x4,x5)                  (h$c5(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n"
        , ByteString
"#define MK_TUP6(x1,x2,x3,x4,x5,x6)               (h$c6(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n"
        , ByteString
"#define MK_TUP7(x1,x2,x3,x4,x5,x6,x7)            (h$c7(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n"
        , ByteString
"#define MK_TUP8(x1,x2,x3,x4,x5,x6,x7,x8)         (h$c8(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n"
        , ByteString
"#define MK_TUP9(x1,x2,x3,x4,x5,x6,x7,x8,x9)      (h$c9(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8),(x9),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n"
        , ByteString
"#define MK_TUP10(x1,x2,x3,x4,x5,x6,x7,x8,x9,x10) (h$c10(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8),(x9),(x10),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n"
        ]
      else [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat
        [ ByteString
"#define MK_TUP2(x1,x2)                           (h$c2(h$ghczmprimZCGHCziTupleziPrimziZLz2cUZR_con_e,(x1),(x2)))\n"
        , ByteString
"#define MK_TUP3(x1,x2,x3)                        (h$c3(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUZR_con_e,(x1),(x2),(x3)))\n"
        , ByteString
"#define MK_TUP4(x1,x2,x3,x4)                     (h$c4(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4)))\n"
        , ByteString
"#define MK_TUP5(x1,x2,x3,x4,x5)                  (h$c5(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5)))\n"
        , ByteString
"#define MK_TUP6(x1,x2,x3,x4,x5,x6)               (h$c6(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6)))\n"
        , ByteString
"#define MK_TUP7(x1,x2,x3,x4,x5,x6,x7)            (h$c7(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7)))\n"
        , ByteString
"#define MK_TUP8(x1,x2,x3,x4,x5,x6,x7,x8)         (h$c8(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8)))\n"
        , ByteString
"#define MK_TUP9(x1,x2,x3,x4,x5,x6,x7,x8,x9)      (h$c9(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8),(x9)))\n"
        , ByteString
"#define MK_TUP10(x1,x2,x3,x4,x5,x6,x7,x8,x9,x10) (h$c10(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8),(x9),(x10)))\n"
        ]

  , ByteString
"#define TUP2_1(x) ((x).d1)\n"
  , ByteString
"#define TUP2_2(x) ((x).d2)\n"

  -- GHCJS.Prim.JSVal
  , if Bool
profiling
      then ByteString
"#define MK_JSVAL(x) (h$c1(h$baseZCGHCziJSziPrimziJSVal_con_e, (x), h$CCS_SYSTEM))\n"
      else ByteString
"#define MK_JSVAL(x) (h$c1(h$baseZCGHCziJSziPrimziJSVal_con_e, (x)))\n"
  ,  ByteString
"#define JSVAL_VAL(x) ((x).d1)\n"

  -- GHCJS.Prim.JSException
  , if Bool
profiling
      then ByteString
"#define MK_JSEXCEPTION(msg,hsMsg) (h$c2(h$baseZCGHCziJSziPrimziJSException_con_e,(msg),(hsMsg),h$CCS_SYSTEM))\n"
      else ByteString
"#define MK_JSEXCEPTION(msg,hsMsg) (h$c2(h$baseZCGHCziJSziPrimziJSException_con_e,(msg),(hsMsg)))\n"

  -- Exception dictionary for JSException
  , ByteString
"#define HS_JSEXCEPTION_EXCEPTION h$baseZCGHCziJSziPrimzizdfExceptionJSException\n"

  -- SomeException
  , if Bool
profiling
      then ByteString
"#define MK_SOMEEXCEPTION(dict,except) (h$c2(h$baseZCGHCziExceptionziTypeziSomeException_con_e,(dict),(except),h$CCS_SYSTEM))\n"
      else ByteString
"#define MK_SOMEEXCEPTION(dict,except) (h$c2(h$baseZCGHCziExceptionziTypeziSomeException_con_e,(dict),(except)))\n"

  -- GHC.Ptr.Ptr
  , if Bool
profiling
      then ByteString
"#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset), h$CCS_SYSTEM))\n"
      else ByteString
"#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset)))\n"

  -- Data.Maybe.Maybe
  , ByteString
"#define HS_NOTHING h$baseZCGHCziMaybeziNothing\n"
  , ByteString
"#define IS_NOTHING(cl) ((cl).f === h$baseZCGHCziMaybeziNothing_con_e)\n"
  , ByteString
"#define IS_JUST(cl) ((cl).f === h$baseZCGHCziMaybeziJust_con_e)\n"
  , ByteString
"#define JUST_VAL(jj) ((jj).d1)\n"
  -- "#define HS_NOTHING h$nothing\n"
  , if Bool
profiling
      then ByteString
"#define MK_JUST(val) (h$c1(h$baseZCGHCziMaybeziJust_con_e, (val), h$CCS_SYSTEM))\n"
      else ByteString
"#define MK_JUST(val) (h$c1(h$baseZCGHCziMaybeziJust_con_e, (val)))\n"

  -- Data.List
  , ByteString
"#define HS_NIL h$ghczmprimZCGHCziTypesziZMZN\n"
  , ByteString
"#define HS_NIL_CON h$ghczmprimZCGHCziTypesziZMZN_con_e\n"
  , ByteString
"#define IS_CONS(cl) ((cl).f === h$ghczmprimZCGHCziTypesziZC_con_e)\n"
  , ByteString
"#define IS_NIL(cl) ((cl).f === h$ghczmprimZCGHCziTypesziZMZN_con_e)\n"
  , ByteString
"#define CONS_HEAD(cl) ((cl).d1)\n"
  , ByteString
"#define CONS_TAIL(cl) ((cl).d2)\n"
  , if Bool
profiling
      then [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat
        [ ByteString
"#define MK_CONS(head,tail) (h$c2(h$ghczmprimZCGHCziTypesziZC_con_e, (head), (tail), h$CCS_SYSTEM))\n"
        , ByteString
"#define MK_CONS_CC(head,tail,cc) (h$c2(h$ghczmprimZCGHCziTypesziZC_con_e, (head), (tail), (cc)))\n"
        ]
      else [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat
        [ ByteString
"#define MK_CONS(head,tail) (h$c2(h$ghczmprimZCGHCziTypesziZC_con_e, (head), (tail)))\n"
        , ByteString
"#define MK_CONS_CC(head,tail,cc) (h$c2(h$ghczmprimZCGHCziTypesziZC_con_e, (head), (tail)))\n"
        ]

  -- Data.Text
  , ByteString
"#define DATA_TEXT_ARRAY(x) ((x).d1)\n"
  , ByteString
"#define DATA_TEXT_OFFSET(x) ((x).d2.d1)\n"
  , ByteString
"#define DATA_TEXT_LENGTH(x) ((x).d2.d2)\n"

  -- Data.Text.Lazy
  , ByteString
"#define LAZY_TEXT_IS_CHUNK(x) ((x).f.a === 2)\n"
  , ByteString
"#define LAZY_TEXT_IS_NIL(x) ((x).f.a === 1)\n"
  , ByteString
"#define LAZY_TEXT_CHUNK_HEAD(x) ((x))\n"
  , ByteString
"#define LAZY_TEXT_CHUNK_TAIL(x) ((x).d2.d3)\n"

  -- black holes
  -- can we skip the indirection for black holes?
  , ByteString
"#define IS_BLACKHOLE(x) (typeof (x) === 'object' && (x) && (x).f && (x).f.t === CLOSURE_TYPE_BLACKHOLE)\n"
  , ByteString
"#define BLACKHOLE_TID(bh) ((bh).d1)\n"
  , ByteString
"#define SET_BLACKHOLE_TID(bh,tid) ((bh).d1 = (tid))\n"
  , ByteString
"#define BLACKHOLE_QUEUE(bh) ((bh).d2)\n"
  , ByteString
"#define SET_BLACKHOLE_QUEUE(bh,val) ((bh).d2 = (val))\n"

  -- resumable thunks
  , ByteString
"#define MAKE_RESUMABLE(closure,stack) { (closure).f = h$resume_e; (closure).d1 = (stack), (closure).d2 = null; }\n"

  -- general deconstruction
  , ByteString
"#define IS_THUNK(x) ((x).f.t === CLOSURE_TYPE_THUNK)\n"
  , ByteString
"#define CONSTR_TAG(x) ((x).f.a)\n"

  -- retrieve a numeric value that's possibly stored as an indirection
  , ByteString
"#define IS_WRAPPED_NUMBER(val) ((typeof(val)==='object')&&(val).f === h$unbox_e)\n"
  , ByteString
"#define UNWRAP_NUMBER(val) ((typeof(val) === 'number')?(val):(val).d1)\n"

  -- generic lazy values
  , if Bool
profiling
      then [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat
        [ ByteString
"#define MK_LAZY(fun) (h$c1(h$lazy_e, (fun), h$CCS_SYSTEM))\n"
        , ByteString
"#define MK_LAZY_CC(fun,cc) (h$c1(h$lazy_e, (fun), (cc)))\n"
        ]
      else [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat
        [ ByteString
"#define MK_LAZY(fun) (h$c1(h$lazy_e, (fun)))\n"
        , ByteString
"#define MK_LAZY_CC(fun,cc) (h$c1(h$lazy_e, (fun)))\n"
        ]

  -- generic data constructors and selectors
  , if Bool
profiling
      then [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat
        [ ByteString
"#define MK_DATA1_1(val) (h$c1(h$data1_e, (val), h$CCS_SYSTEM))\n"
        , ByteString
"#define MK_DATA1_2(val1,val2) (h$c2(h$data1_e, (val1), (val2), h$CCS_SYSTEM))\n"
        , ByteString
"#define MK_DATA2_1(val) (h$c1(h$data2_e, (val), h$CCS_SYSTEM))\n"
        , ByteString
"#define MK_DATA2_2(val1,val2) (h$c2(h$data1_e, (val1), (val2), h$CCS_SYSTEM))\n"
        , ByteString
"#define MK_SELECT1(val) (h$c1(h$select1_e, (val), h$CCS_SYSTEM))\n"
        , ByteString
"#define MK_SELECT2(val) (h$c1(h$select2_e, (val), h$CCS_SYSTEM))\n"
        , ByteString
"#define MK_AP1(fun,val) (h$c2(h$ap1_e, (fun), (val), h$CCS_SYSTEM))\n"
        , ByteString
"#define MK_AP2(fun,val1,val2) (h$c3(h$ap2_e, (fun), (val1), (val2), h$CCS_SYSTEM))\n"
        , ByteString
"#define MK_AP3(fun,val1,val2,val3) (h$c4(h$ap3_e, (fun), (val1), (val2), (val3), h$CCS_SYSTEM))\n"
        ]
      else [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat
        [ ByteString
"#define MK_DATA1_1(val) (h$c1(h$data1_e, (val)))\n"
        , ByteString
"#define MK_DATA1_2(val1,val2) (h$c2(h$data1_e, (val1), (val2)))\n"
        , ByteString
"#define MK_DATA2_1(val) (h$c1(h$data2_e, (val)))\n"
        , ByteString
"#define MK_DATA2_2(val1,val2) (h$c2(h$data2_e, (val1), (val2)))\n"
        , ByteString
"#define MK_SELECT1(val) (h$c1(h$select1_e, (val)))\n"
        , ByteString
"#define MK_SELECT2(val) (h$c1(h$select2_e, (val)))\n"
        , ByteString
"#define MK_AP1(fun,val) (h$c2(h$ap1_e,(fun),(val)))\n"
        , ByteString
"#define MK_AP2(fun,val1,val2) (h$c3(h$ap2_e,(fun),(val1),(val2)))\n"
        , ByteString
"#define MK_AP3(fun,val1,val2,val3) (h$c4(h$ap3_e, (fun), (val1), (val2), (val3)))\n"
        ]

  -- unboxed tuple returns
  -- , "#define RETURN_UBX_TUP1(x) return x;\n"
  , ByteString
"#define RETURN_UBX_TUP2(x1,x2) { h$ret1 = (x2); return (x1); }\n"
  , ByteString
"#define RETURN_UBX_TUP3(x1,x2,x3) { h$ret1 = (x2); h$ret2 = (x3); return (x1); }\n"
  , ByteString
"#define RETURN_UBX_TUP4(x1,x2,x3,x4) { h$ret1 = (x2); h$ret2 = (x3); h$ret3 = (x4); return (x1); }\n"
  , ByteString
"#define RETURN_UBX_TUP5(x1,x2,x3,x4,x5) { h$ret1 = (x2); h$ret2 = (x3); h$ret3 = (x4); h$ret4 = (x5); return (x1); }\n"
  , ByteString
"#define RETURN_UBX_TUP6(x1,x2,x3,x4,x5,x6) { h$ret1 = (x2); h$ret2 = (x3); h$ret3 = (x4); h$ret4 = (x5); h$ret5 = (x6); return (x1); }\n"
  , ByteString
"#define RETURN_UBX_TUP7(x1,x2,x3,x4,x5,x6,x7) { h$ret1 = (x2); h$ret2 = (x3); h$ret3 = (x4); h$ret4 = (x5); h$ret5 = (x6); h$ret6 = (x7); return (x1); }\n"
  , ByteString
"#define RETURN_UBX_TUP8(x1,x2,x3,x4,x5,x6,x7,x8) { h$ret1 = (x2); h$ret2 = (x3); h$ret3 = (x4); h$ret4 = (x5); h$ret5 = (x6); h$ret6 = (x7); h$ret7 = (x8); return (x1); }\n"
  , ByteString
"#define RETURN_UBX_TUP9(x1,x2,x3,x4,x5,x6,x7,x8,x9) { h$ret1 = (x2); h$ret2 = (x3); h$ret3 = (x4); h$ret4 = (x5); h$ret5 = (x6); h$ret6 = (x7); h$ret7 = (x8); h$ret8 = (x9); return (x1); }\n"
  , ByteString
"#define RETURN_UBX_TUP10(x1,x2,x3,x4,x5,x6,x7,x8,x9,x10) { h$ret1 = (x2); h$ret2 = (x3); h$ret3 = (x4); h$ret4 = (x5); h$ret5 = (x6); h$ret6 = (x7); h$ret7 = (x8); h$ret8 = (x9); h$ret9 = (x10); return (x1); }\n"

  , ByteString
"#define CALL_UBX_TUP2(r1,r2,c) { (r1) = (c); (r2) = h$ret1; }\n"
  , ByteString
"#define CALL_UBX_TUP3(r1,r2,r3,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; }\n"
  , ByteString
"#define CALL_UBX_TUP4(r1,r2,r3,r4,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; (r4) = h$ret3; }\n"
  , ByteString
"#define CALL_UBX_TUP5(r1,r2,r3,r4,r5,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; (r4) = h$ret3; (r5) = h$ret4; }\n"
  , ByteString
"#define CALL_UBX_TUP6(r1,r2,r3,r4,r5,r6,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; (r4) = h$ret3; (r5) = h$ret4; (r6) = h$ret5; }\n"
  , ByteString
"#define CALL_UBX_TUP7(r1,r2,r3,r4,r5,r6,r7,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; (r4) = h$ret3; (r5) = h$ret4; (r6) = h$ret5; (r7) = h$ret6; }\n"
  , ByteString
"#define CALL_UBX_TUP8(r1,r2,r3,r4,r5,r6,r7,r8,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; (r4) = h$ret3; (r5) = h$ret4; (r6) = h$ret5; (r7) = h$ret6; (r8) = h$ret7; }\n"
  , ByteString
"#define CALL_UBX_TUP9(r1,r2,r3,r4,r5,r6,r7,r8,r9,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; (r4) = h$ret3; (r5) = h$ret4; (r6) = h$ret5; (r7) = h$ret6; (r8) = h$ret7; (r9) = h$ret8; }\n"
  , ByteString
"#define CALL_UBX_TUP10(r1,r2,r3,r4,r5,r6,r7,r8,r9,r10,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; (r4) = h$ret3; (r5) = h$ret4; (r6) = h$ret5; (r7) = h$ret6; (r8) = h$ret7; (r9) = h$ret8; (r10) = h$ret9; }\n"
  ]

-- | Construct the Filename for the "binary" of Haskell code compiled to
-- JavaScript.
jsExeFileName :: DynFlags -> FilePath
jsExeFileName :: DynFlags -> [Char]
jsExeFileName DynFlags
dflags
  | Just [Char]
s <- DynFlags -> Maybe [Char]
outputFile_ DynFlags
dflags =
      -- unmunge the extension
      let s' :: [Char]
s' = [Char] -> [Char] -> [Char]
forall {a}. Eq a => [a] -> [a] -> [a]
dropPrefix [Char]
"js_" (Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop Int
1 ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
takeExtension [Char]
s)
      in if [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
Prelude.null [Char]
s'
           then [Char] -> [Char]
dropExtension [Char]
s [Char] -> [Char] -> [Char]
<.> [Char]
jsexeExtension
           else [Char] -> [Char]
dropExtension [Char]
s [Char] -> [Char] -> [Char]
<.> [Char]
s'
  | Bool
otherwise =
      if Platform -> OS
platformOS (DynFlags -> Platform
targetPlatform DynFlags
dflags) OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSMinGW32
           then [Char]
"main.jsexe"
           else [Char]
"a.jsexe"
  where
    dropPrefix :: [a] -> [a] -> [a]
dropPrefix [a]
prefix [a]
xs
      | [a]
prefix [a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [a]
xs = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
prefix) [a]
xs
      | Bool
otherwise              = [a]
xs


-- | Parse option pragma in JS file
getOptionsFromJsFile :: FilePath      -- ^ Input file
                     -> IO [JSOption] -- ^ Parsed options, if any.
getOptionsFromJsFile :: [Char] -> IO [JSOption]
getOptionsFromJsFile [Char]
filename
    = IO Handle
-> (Handle -> IO ()) -> (Handle -> IO [JSOption]) -> IO [JSOption]
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Exception.bracket
              ([Char] -> IOMode -> IO Handle
openBinaryFile [Char]
filename IOMode
ReadMode)
              Handle -> IO ()
hClose
              Handle -> IO [JSOption]
getJsOptions

data JSOption = CPP deriving (JSOption -> JSOption -> Bool
(JSOption -> JSOption -> Bool)
-> (JSOption -> JSOption -> Bool) -> Eq JSOption
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: JSOption -> JSOption -> Bool
== :: JSOption -> JSOption -> Bool
$c/= :: JSOption -> JSOption -> Bool
/= :: JSOption -> JSOption -> Bool
Eq, Eq JSOption
Eq JSOption =>
(JSOption -> JSOption -> Ordering)
-> (JSOption -> JSOption -> Bool)
-> (JSOption -> JSOption -> Bool)
-> (JSOption -> JSOption -> Bool)
-> (JSOption -> JSOption -> Bool)
-> (JSOption -> JSOption -> JSOption)
-> (JSOption -> JSOption -> JSOption)
-> Ord JSOption
JSOption -> JSOption -> Bool
JSOption -> JSOption -> Ordering
JSOption -> JSOption -> JSOption
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: JSOption -> JSOption -> Ordering
compare :: JSOption -> JSOption -> Ordering
$c< :: JSOption -> JSOption -> Bool
< :: JSOption -> JSOption -> Bool
$c<= :: JSOption -> JSOption -> Bool
<= :: JSOption -> JSOption -> Bool
$c> :: JSOption -> JSOption -> Bool
> :: JSOption -> JSOption -> Bool
$c>= :: JSOption -> JSOption -> Bool
>= :: JSOption -> JSOption -> Bool
$cmax :: JSOption -> JSOption -> JSOption
max :: JSOption -> JSOption -> JSOption
$cmin :: JSOption -> JSOption -> JSOption
min :: JSOption -> JSOption -> JSOption
Ord)

getJsOptions :: Handle -> IO [JSOption]
getJsOptions :: Handle -> IO [JSOption]
getJsOptions Handle
handle = do
  Handle -> TextEncoding -> IO ()
hSetEncoding Handle
handle TextEncoding
utf8
  ByteString
prefix' <- Handle -> Int -> IO ByteString
B.hGet Handle
handle Int
prefixLen
  if ByteString
prefix ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
prefix'
  then [Char] -> [JSOption]
parseJsOptions ([Char] -> [JSOption]) -> IO [Char] -> IO [JSOption]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO [Char]
hGetLine Handle
handle
  else [JSOption] -> IO [JSOption]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
 where
  prefix :: B.ByteString
  prefix :: ByteString
prefix = ByteString
"//#OPTIONS:"
  prefixLen :: Int
prefixLen = ByteString -> Int
B.length ByteString
prefix

parseJsOptions :: String -> [JSOption]
parseJsOptions :: [Char] -> [JSOption]
parseJsOptions [Char]
xs = [Char] -> [JSOption]
go [Char]
xs
  where
    trim :: [Char] -> [Char]
trim = [Char] -> [Char]
forall a. [a] -> [a]
reverse ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
forall a. [a] -> [a]
reverse ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace
    go :: [Char] -> [JSOption]
go [] = []
    go [Char]
xs = let ([Char]
tok, [Char]
rest) = (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',') [Char]
xs
                tok' :: [Char]
tok' = [Char] -> [Char]
trim [Char]
tok
                rest' :: [Char]
rest' = Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop Int
1 [Char]
rest
            in  if | [Char]
tok' [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"CPP" -> JSOption
CPP JSOption -> [JSOption] -> [JSOption]
forall a. a -> [a] -> [a]
: [Char] -> [JSOption]
go [Char]
rest'
                   | Bool
otherwise     -> [Char] -> [JSOption]
go [Char]
rest'