content: {-# LANGUAGE CPP, FlexibleContexts, TypeFamilies #-}
  {-
    This module takes over desugaring and typechecking foreign declarations and calls
    from GHC. foreign import javascript should be desugared differently
    from other foreign imports since we don't want Bool to de be marshalled through
    0/1 for example.
  
    Contains code adapted from DsForeign, DsCCall and TcForeign
   -}
  
  module Gen2.Foreign where
  
  import Prelude hiding ((<>))
  
  import Control.Monad
  
  import Data.Maybe
  import Data.List (unzip4, stripPrefix)
  import qualified Data.Text as T
  
  import Hooks
  import DynFlags
  
  import GHC.Hs.Extension
  import Id
  import OrdList
  import Name
  import Bag
  import CoreSyn
  import ErrUtils
  import HscTypes
  import GHC.Hs.Binds
  import GHC.Hs.Decls
  import Gen2.GHC.DsForeign (dsForeigns', dsPrimCall)
  import DsMonad
  import Encoding
  import GHC.Hs.Utils
  import TcEnv
  import TcExpr
  import TcRnTypes
  import TcForeign
  import MonadUtils
  import RdrName
  import FastString
  import ForeignCall
  import SrcLoc
  import Unique
  import PrelNames
  import PrimOp
  import MkId
  import TyCon
  import DataCon
  import Outputable
  import Coercion
  import Type
  import RepType
  import TysWiredIn
  import TysPrim
  import CoreUtils
  import MkCore
  import DsCCall
  import BasicTypes
  import CoreUnfold
  import Pair
  import Literal
  import Module
  import TcType
  import TcRnMonad
  import TcHsType
  import GHC.Platform
  import CmmType
  import DsUtils
  import CmmUtils hiding (mkIntExpr)
  
  import Compiler.Compat
  import Compiler.JMacro.Base (encodeJson)
  
  import GHC.LanguageExtensions
  
  type Binding = (Id, CoreExpr)
  
  installForeignHooks :: Bool -> DynFlags -> DynFlags
  installForeignHooks generatingJs dflags =
    dflags { hooks = f generatingJs $ hooks dflags }
      where
        f True h  = h { dsForeignsHook       = Just ghcjsDsForeigns
                      , tcForeignImportsHook = Just ghcjsTcForeignImports
                      , tcForeignExportsHook = Just ghcjsTcForeignExports
                      }
        f False h = h { dsForeignsHook       = Just ghcjsNativeDsForeigns
                      , tcForeignImportsHook = Just ghcjsNativeTcForeignImports
                      , tcForeignExportsHook = Just ghcjsNativeTcForeignExports
                      }
  {-
     desugar foreign declarations for JavaScript
  -}
  
  ghcjsDsForeigns :: [LForeignDecl GhcTc]
                  -> DsM (ForeignStubs, OrdList Binding)
  ghcjsDsForeigns []
    = return (NoStubs, nilOL)
  ghcjsDsForeigns fos = do
      fives <- mapM do_ldecl fos
      let
          (hs, cs, idss, bindss) = unzip4 fives
          fe_ids = concat idss
      return (ForeignStubs
               (vcat hs)
               (vcat cs),
              foldr (appOL . toOL) nilOL bindss)
    where
     do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl)
  
     do_decl ForeignImport { fd_name = id, fd_i_ext = co, fd_fi = spec } = do
        traceIf (text "fi start" <+> ppr id)
        let id' = unLoc id
        (bs, h, c) <- ghcjsDsFImport id' co spec
        traceIf (text "fi end" <+> ppr id)
        return (h, c, [], bs)
  
     do_decl ForeignExport { fd_name = L _ id, fd_e_ext = co
                           , fd_fe = CExport (L _ (CExportStatic _ ext_nm cconv)) _ } = do
        (h, c, _, _) <- ghcjsDsFExport id co ext_nm cconv False
        return (h, c, [id], [])
     do_decl (XForeignDecl _) = panic "dsForeigns'"
  
  ghcjsDsFExport :: Id                 -- Either the exported Id,
                                  -- or the foreign-export-dynamic constructor
            -> Coercion           -- Coercion between the Haskell type callable
                                  -- from C, and its representation type
            -> CLabelString       -- The name to export to C land
            -> CCallConv
            -> Bool               -- True => foreign export dynamic
                                  --         so invoke IO action that's hanging off
                                  --         the first argument's stable pointer
            -> DsM ( SDoc         -- contents of Module_stub.h
                   , SDoc         -- contents of Module_stub.c
                   , String       -- string describing type to pass to createAdj.
                   , Int          -- size of args to stub function
                   )
  
  ghcjsDsFExport fn_id co ext_name cconv isDyn = do
      let
         ty                              = pSnd $ coercionKind co
         (_tvs,sans_foralls)             = tcSplitForAllTys ty
         (fe_arg_tys', orig_res_ty)      = tcSplitFunTys sans_foralls
         -- We must use tcSplits here, because we want to see
         -- the (IO t) in the corner of the type!
         fe_arg_tys | isDyn     = tail fe_arg_tys'
                    | otherwise = fe_arg_tys'
  
         -- Look at the result type of the exported function, orig_res_ty
         -- If it's IO t, return         (t, True)
         -- If it's plain t, return      (t, False)
         (res_ty, is_IO_res_ty) = case tcSplitIOType_maybe orig_res_ty of
                                  -- The function already returns IO t
                                  Just (_ioTyCon, res_ty) -> (res_ty, True)
                                  -- The function returns t
                                  Nothing                 -> (orig_res_ty, False)
      dflags <- getDynFlags
      return $
        mkFExportJSBits dflags ext_name
                       (if isDyn then Nothing else Just fn_id)
                       fe_arg_tys res_ty is_IO_res_ty cconv
  
  mkFExportJSBits :: DynFlags
                 -> FastString
                 -> Maybe Id      -- Just==static, Nothing==dynamic
                 -> [Type]
                 -> Type
                 -> Bool          -- True <=> returns an IO type
                 -> CCallConv
                 -> (SDoc,
                     SDoc,
                     String,      -- the argument reps
                     Int          -- total size of arguments
                    )
  mkFExportJSBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
   = (header_bits, js_bits, type_string,
      sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- arg_info] -- all the args
           -- NB. the calculation here isn't strictly speaking correct.
           -- We have a primitive Haskell type (eg. Int#, Double#), and
           -- we want to know the size, when passed on the C stack, of
           -- the associated C type (eg. HsInt, HsDouble).  We don't have
           -- this information to hand, but we know what GHC's conventions
           -- are for passing around the primitive Haskell types, so we
           -- use that instead.  I hope the two coincide --SDM
      )
   where
    -- list the arguments to the JS function
    arg_info :: [(SDoc,           -- arg name
                  SDoc,           -- C type
                  Type,           -- Haskell type
                  CmmType)]       -- the CmmType
    arg_info  = [ let stg_type = showStgType ty in
                  (arg_cname n stg_type,
                   stg_type,
                   ty,
                   typeCmmType dflags (getPrimTyOf ty))
                | (ty,n) <- zip arg_htys [1::Int ..] ]
  
    arg_cname n stg_ty = text ('a':show n)
  
    type_string = primTyDescChar dflags res_hty : arg_type_string
  
    arg_type_string = [primTyDescChar dflags ty | (_,_,ty,_) <- arg_info]
  
    -- stuff to do with the return type of the JS function
    res_hty_is_unit = res_hty `eqType` unitTy     -- Look through any newtypes
  
    unboxResType | res_hty_is_unit = text "h$rts_getUnit"
                 | otherwise       = unpackHObj res_hty
  
    header_bits = maybe empty idTag maybe_target
    idTag i = let (tag, u) = unpkUnique (getUnique i)
              in  char tag <> int u
  
    fun_args
      | null arg_info = [] -- text "void"
      | otherwise     = map (\(nm,_ty,_,_) -> nm) arg_info
  
    fun_proto
        = -- text "async" <+>
          text "function" <+>
          (if isNothing maybe_target
           then (text "h$" <> ftext c_nm <> parens (hsep $ punctuate comma $ (text "the_stableptr"):fun_args))
           else (ftext c_nm <> parens (hsep $ punctuate comma $ fun_args)))
          
  
    fun_export
       = case maybe_target of
            Just hs_fn | Just m <- nameModule_maybe (getName hs_fn) ->
              text "h$foreignExport" <>
                          parens (
                            ftext c_nm <> comma <>
                            strlit (installedUnitIdString (toInstalledUnitId $ moduleUnitId m)) <> comma <>
                            strlit (moduleNameString (moduleName m)) <> comma <>
                            strlit (unpackFS c_nm) <> comma <>
                            strlit type_string
                          ) <> semi
            _ -> empty
  
    strlit xs = text "\"" <>
                text (T.unpack . encodeJson . T.pack $ xs) <>
                text "\""
  
    -- the target which will form the root of what we ask rts_evalIO to run
    the_cfun
       = case maybe_target of
            Nothing    -> text "h$deRefStablePtr(the_stableptr)"
            Just hs_fn -> idClosureText dflags hs_fn
  
    -- the expression we give to rts_eval
    expr_to_run :: SDoc
    expr_to_run
       = foldl appArg the_cfun arg_info
         where
            appArg acc (arg_cname, _, arg_hty, _)
               = text "h$rts_apply"
                 <> parens (acc <> comma <> mkHObj arg_hty <> parens arg_cname)
  
    -- finally, the whole darn thing
    js_bits =
      space $$
      fun_proto  $$
      vcat
       [ lbrace
       ,   text "return" <+> -- text "await" <+>
           ptext (sLit "h$rts_eval_sync_") <> parens (
                  (if is_IO_res_ty
                         then expr_to_run
                         else ptext (sLit "h$rts_toIO") <> parens expr_to_run)
                   <> comma <+> unboxResType
               ) <> semi
       , rbrace
       ] $$
       fun_export
  
  idClosureText :: DynFlags -> Id -> SDoc
  idClosureText df i
    | isExportedId i, Just m <- nameModule_maybe (getName i)
       = let modName :: String
             modName = moduleNameString (moduleName m)
             name :: String
             name    = showPpr df . localiseName . getName $ i
             pkg :: String
             pkg     = installedUnitIdString (toInstalledUnitId $ moduleUnitId m)
         in text "h$" <> text (zEncodeString $ pkg ++ ":" ++ modName ++ "." ++ name)
    | otherwise = panic "idClosureText: unknown module"
  
  ghcjsDsFImport :: Id
                 -> Coercion
                 -> ForeignImport
                 -> DsM ([Binding], SDoc, SDoc)
  ghcjsDsFImport id co (CImport cconv safety mHeader spec _) = do
      (ids, h, c) <- dsJsImport id co spec (unLoc cconv) (unLoc safety) mHeader
      return (ids, h, c)
  
  
  dsJsImport :: Id
             -> Coercion
             -> CImportSpec
             -> CCallConv
             -> Safety
             -> Maybe Header
             -> DsM ([Binding], SDoc, SDoc)
  dsJsImport id co (CLabel cid) cconv _ _ = do
     dflags <- getDynFlags
     let ty = pFst $ coercionKind co
         fod = case tyConAppTyCon_maybe (dropForAlls ty) of
               Just tycon
                | tyConUnique tycon == funPtrTyConKey ->
                   IsFunction
               _ -> IsData
     (_resTy, foRhs) <- jsResultWrapper ty
  --   ASSERT(fromJust resTy `eqType` addrPrimTy)    -- typechecker ensures this
     let rhs = foRhs (Lit (LitLabel cid stdcall_info fod))
         rhs' = Cast rhs co
         stdcall_info = fun_type_arg_stdcall_info dflags cconv ty
                        -- in
     return ([(id, rhs')], empty, empty)
  
  dsJsImport id co (CFunction target) cconv@PrimCallConv safety _
    = dsPrimCall id co (CCall (mkCCallSpec target cconv safety
                                           (panic "Missing Return PrimRep")
                                           (panic "Missing Argument PrimReps")))
  dsJsImport id co (CFunction target) cconv safety mHeader
    = dsJsCall id co (CCall (mkCCallSpec target cconv safety
                                           (panic "Missing Return PrimRep")
                                           (panic "Missing Argument PrimReps"))) mHeader
  dsJsImport id co CWrapper cconv _ _
    = dsJsFExportDynamic id co cconv
  
  -- fixme work in progress
  dsJsFExportDynamic :: Id
                   -> Coercion
                   -> CCallConv
                   -> DsM ([Binding], SDoc, SDoc)
  dsJsFExportDynamic id co0 cconv = do
      mod <- getModule
      dflags <- getDynFlags
      let fe_nm = mkFastString $ zEncodeString
              ("h$" ++ moduleStableString mod ++ "$" ++ toCName dflags id)
          -- Construct the label based on the passed id, don't use names
          -- depending on Unique. See #13807 and Note [Unique Determinism].
      cback <- newSysLocalDs arg_ty
      newStablePtrId <- dsLookupGlobalId newStablePtrName
      stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName
      let
          stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty]
          export_ty     = mkVisFunTy stable_ptr_ty arg_ty
      bindIOId <- dsLookupGlobalId bindIOName
      stbl_value <- newSysLocalDs stable_ptr_ty
      (h_code, c_code, typestring, args_size) <- ghcjsDsFExport id (mkRepReflCo export_ty) fe_nm cconv True
      let
           {-
            The arguments to the external function which will
            create a little bit of (template) code on the fly
            for allowing the (stable pointed) Haskell closure
            to be entered using an external calling convention
            (stdcall, ccall).
           -}
          adj_args      = [ mkIntLit dflags (toInteger (ccallConvToInt cconv))
                          , Var stbl_value
                          , Lit (LitLabel fe_nm mb_sz_args IsFunction)
                          , Lit (mkLitString typestring)
                          ]
            -- name of external entry point providing these services.
            -- (probably in the RTS.)
          adjustor   = fsLit "createAdjustor"
  
            -- Determine the number of bytes of arguments to the stub function,
            -- so that we can attach the '@N' suffix to its label if it is a
            -- stdcall on Windows.
          mb_sz_args = case cconv of
                          StdCallConv -> Just args_size
                          _           -> Nothing
  
      ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty])
          -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
  
      let io_app = mkLams tvs                  $
                   Lam cback                   $
                   mkApps (Var bindIOId)
                          [ Type stable_ptr_ty
                          , Type res_ty
                          , mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]
                          , Lam stbl_value ccall_adj
                          ]
  
          fed = (id `setInlineActivation` NeverActive, Cast io_app co0)
                 -- Never inline the f.e.d. function, because the litlit
                 -- might not be in scope in other modules.
  
      return ([fed], h_code, c_code)
  
   where
    ty                       = pFst (coercionKind co0)
    (tvs,sans_foralls)       = tcSplitForAllTys ty
    ([arg_ty], fn_res_ty)    = tcSplitFunTys sans_foralls
    Just (io_tc, res_ty)     = tcSplitIOType_maybe fn_res_ty
          -- Must have an IO type; hence Just
  
  toCName :: DynFlags -> Id -> String
  toCName dflags i = showSDoc dflags (pprCode CStyle (ppr (idName i)))
  
  dsJsCall :: Id -> Coercion -> ForeignCall -> Maybe Header
          -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
  dsJsCall fn_id co (CCall (CCallSpec target cconv safety _ _)) _mDeclHeader = do
      let
          ty                   = pFst $ coercionKind co
          (tv_bndrs, rho)      = tcSplitForAllVarBndrs ty
          (arg_tys, io_res_ty) = tcSplitFunTys rho
  
      args <- newSysLocalsDs arg_tys  -- no FFI levity-polymorphism
      (val_args, arg_wrappers) <- mapAndUnzipM unboxJsArg (map Var args)
  
      let
          work_arg_ids  = [v | Var v <- val_args] -- All guaranteed to be vars
  
      (ccall_result_ty, res_wrapper) <- boxJsResult io_res_ty
  
      ccall_uniq <- newUnique
      work_uniq  <- newUnique
  
      dflags <- getDynFlags
  
      let
        fcall = CCall (mkCCallSpec target cconv safety io_res_ty arg_tys)
  
      let
          -- Build the worker
          worker_ty     = mkForAllTys tv_bndrs (mkVisFunTys (map idType work_arg_ids) ccall_result_ty)
          tvs           = map binderVar tv_bndrs
          the_ccall_app = mkFCall dflags ccall_uniq fcall val_args ccall_result_ty
          work_rhs      = mkLams tvs (mkLams work_arg_ids the_ccall_app)
          work_id       = mkSysLocal (fsLit "$wccall") work_uniq worker_ty
  
          -- Build the wrapper
          work_app     = mkApps (mkVarApps (Var work_id) tvs) val_args
          wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
          wrap_rhs     = mkLams (tvs ++ args) wrapper_body
          wrap_rhs'    = Cast wrap_rhs co
          fn_id_w_inl  = fn_id `setIdUnfolding` mkInlineUnfoldingWithArity
                                                  (length args) wrap_rhs'
  
      return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], empty, empty)
  
  
  mkHObj :: Type -> SDoc
  mkHObj t = text "h$rts_mk" <> text (showFFIType t)
  
  unpackHObj :: Type -> SDoc
  unpackHObj t = text "h$rts_get" <> text (showFFIType t)
  
  showStgType :: Type -> SDoc
  showStgType t = text "Hs" <> text (showFFIType t)
  
  showFFIType :: Type -> String
  showFFIType t = getOccString (getName (typeTyCon t))
  
  typeTyCon :: Type -> TyCon
  typeTyCon ty
    -- | UnaryRep rep_ty <- repType ty
    | Just (tc, _) <- tcSplitTyConApp_maybe (unwrapType ty) -- rep_ty
    = tc
    | otherwise
    = pprPanic "Gen2.Foreign.typeTyCon" (ppr ty)
  
  
  {-
    We unbox arguments for JS calls a bit different from native code:
      - Bool is marshalled to true/false, not 0/1
      - All int types are narrowed, since JS floats have a greater range than Int32
   -}
  
  unboxJsArg :: CoreExpr                  -- The supplied argument
             -> DsM (CoreExpr,              -- To pass as the actual argument
                     CoreExpr -> CoreExpr   -- Wrapper to unbox the arg
                    )
  unboxJsArg arg
    -- Primtive types: nothing to unbox
    | isPrimitiveType arg_ty
    = return (arg, \body -> body)
  
    -- Recursive newtypes
    | Just (co, _rep_ty) <- topNormaliseNewType_maybe arg_ty
    = unboxJsArg (mkCast arg co)
  
    -- Booleans, do not convert to 0/1, only force them
    | Just tc <- tyConAppTyCon_maybe arg_ty,
      tc `hasKey` boolTyConKey
    = return (arg,
                \ body -> mkWildCase arg boolTy (exprType body) [(DEFAULT,[],body)])
  
    | Just tc <- tyConAppTyCon_maybe arg_ty,
      tc `hasKey` anyTyConKey
    = return (arg,
                \ body -> mkWildCase arg arg_ty (exprType body) [(DEFAULT,[],body)])
    -- Data types with a single constructor, which has a single, primitive-typed arg
    -- This deals with Int, Float etc; also Ptr, ForeignPtr
    | is_product_type && data_con_arity == 1
      = do case_bndr <- newSysLocalDs arg_ty
           prim_arg <- newSysLocalDs data_con_arg_ty1
           return (Var prim_arg,
                 \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,[prim_arg],body)]
                )
  
    -- Byte-arrays, both mutable and otherwise; hack warning
    -- We're looking for values of type ByteArray, MutableByteArray
    --    data ByteArray          ix = ByteArray        ix ix ByteArray#
    --    data MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s)
    | is_product_type &&
      data_con_arity == 3 &&
      isJust maybe_arg3_tycon &&
      (arg3_tycon ==  byteArrayPrimTyCon ||
       arg3_tycon ==  mutableByteArrayPrimTyCon)
    = do case_bndr <- newSysLocalDs arg_ty
         vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs data_con_arg_tys
         return (Var arr_cts_var,
                 \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,vars,body)]
                )
  
    | otherwise
    = do l <- getSrcSpanDs
         pprPanic "unboxJsArg: " (ppr l <+> ppr arg_ty)
    where
      arg_ty                                      = exprType arg
      maybe_product_type                          = splitDataProductType_maybe arg_ty
      is_product_type                             = isJust maybe_product_type
      Just (_, _, data_con, data_con_arg_tys)     = maybe_product_type
      data_con_arity                              = dataConSourceArity data_con
      (data_con_arg_ty1 : _)                      = data_con_arg_tys
  
      (_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys
      maybe_arg3_tycon               = tyConAppTyCon_maybe data_con_arg_ty3
      Just arg3_tycon                = maybe_arg3_tycon
  
  
  boxJsResult :: Type
              -> DsM (Type, CoreExpr -> CoreExpr)
  boxJsResult result_ty
    | isRuntimeRepKindedTy result_ty = panic "boxJsResult: runtime rep ty" -- fixme
  -- Takes the result of the user-level ccall:
  --      either (IO t),
  --      or maybe just t for an side-effect-free call
  -- Returns a wrapper for the primitive ccall itself, along with the
  -- type of the result of the primitive ccall.  This result type
  -- will be of the form
  --      State# RealWorld -> (# State# RealWorld, t' #)
  -- where t' is the unwrapped form of t.  If t is simply (), then
  -- the result type will be
  --      State# RealWorld -> (# State# RealWorld #)
  
  boxJsResult result_ty
    | Just (io_tycon, io_res_ty) <- tcSplitIOType_maybe result_ty
          -- isIOType_maybe handles the case where the type is a
          -- simple wrapping of IO.  E.g.
          --      newtype Wrap a = W (IO a)
          -- No coercion necessary because its a non-recursive newtype
          -- (If we wanted to handle a *recursive* newtype too, we'd need
          -- another case, and a coercion.)
          -- The result is IO t, so wrap the result in an IO constructor
    = do  { res <- jsResultWrapper io_res_ty
          ; let return_result state ans
                  = mkCoreUbxTup
                      [realWorldStatePrimTy, io_res_ty]
                      [state, ans]
  {-                = mkConApp (tupleDataCon Unboxed 2)
                             (map Type [realWorldStatePrimTy, io_res_ty]
                                ++ [state, ans]) -}
  
          ; (ccall_res_ty, the_alt) <- mk_alt return_result res
  
          ; state_id <- newSysLocalDs realWorldStatePrimTy
          ; let io_data_con = head (tyConDataCons io_tycon)
                toIOCon     = dataConWrapId io_data_con
  
                wrap the_call =
                                mkApps (Var toIOCon)
                                       [ Type io_res_ty,
                                         Lam state_id $
                                         mkWildCase (App the_call (Var state_id))
                                               ccall_res_ty
                                               (coreAltType the_alt)
                                               [the_alt]
                                       ]
  
          ; return (realWorldStatePrimTy `mkVisFunTy` ccall_res_ty, wrap) }
  
  boxJsResult result_ty
    = do -- It isn't IO, so do unsafePerformIO
         -- It's not conveniently available, so we inline it
         res <- jsResultWrapper result_ty
         (ccall_res_ty, the_alt) <- mk_alt return_result res
         let
             wrap = \ the_call -> mkWildCase (App the_call (Var realWorldPrimId))
                                             ccall_res_ty
                                             (coreAltType the_alt)
                                             [the_alt]
         return (realWorldStatePrimTy `mkVisFunTy` ccall_res_ty, wrap)
    where
      return_result _ ans = ans
  
  mk_alt :: (Expr Var -> Expr Var -> Expr Var)
         -> (Maybe Type, Expr Var -> Expr Var)
         -> DsM (Type, (AltCon, [Id], Expr Var))
  mk_alt return_result (Nothing, wrap_result)
    = do -- The ccall returns ()
         state_id <- newSysLocalDs realWorldStatePrimTy
         let
               the_rhs = return_result (Var state_id)
                                       (wrap_result $ panic "jsBoxResult")
               ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy]
               the_alt      = (DataAlt (tupleDataCon Unboxed 1), [state_id], the_rhs)
         return (ccall_res_ty, the_alt)
  
  mk_alt return_result (Just prim_res_ty, wrap_result)
                  -- The ccall returns a non-() value
    | isUnboxedTupleType prim_res_ty = do
      let
          Just ls = fmap dropRuntimeRepArgs (tyConAppArgs_maybe prim_res_ty)
          arity = 1 + length ls
      args_ids {-@(result_id:as)-} <- mapM newSysLocalDs ls
      state_id <- newSysLocalDs realWorldStatePrimTy
      let
          result_tup = -- mkCoreConApps (tupleDataCon Unboxed (length ls)) (map Type ls ++ map Var args_ids)
            mkCoreUbxTup ls (map Var args_ids)
          the_rhs = return_result (Var state_id)
                                  (wrap_result result_tup)
          ccall_res_ty = mkTupleTy Unboxed (realWorldStatePrimTy : ls)
          the_alt      = ( DataAlt (tupleDataCon Unboxed arity)
                         , (state_id : args_ids)
                         , the_rhs
                         )
      return (ccall_res_ty, the_alt)
  
    | otherwise = do
      result_id <- newSysLocalDs prim_res_ty
      state_id <- newSysLocalDs realWorldStatePrimTy
      let
          the_rhs = return_result (Var state_id)
                                  (wrap_result (Var result_id))
          ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy, prim_res_ty]
          the_alt      = (DataAlt (tupleDataCon Unboxed 2), [state_id, result_id], the_rhs)
      return (ccall_res_ty, the_alt)
  
  fun_type_arg_stdcall_info :: DynFlags -> CCallConv -> Type -> Maybe Int
  fun_type_arg_stdcall_info _ _other_conv _ = Nothing
  
  
  jsResultWrapper :: Type
                -> DsM (Maybe Type,               -- Type of the expected result, if any
                        CoreExpr -> CoreExpr)     -- Wrapper for the result
  -- resultWrapper deals with the result *value*
  -- E.g. foreign import foo :: Int -> IO T
  -- Then resultWrapper deals with marshalling the 'T' part
  jsResultWrapper result_ty
    | isRuntimeRepKindedTy result_ty = return (Nothing, id) -- fixme this seems like a hack
    -- Base case 1a: unboxed tuples
    | Just (tc, args) <- splitTyConApp_maybe result_ty
    , isUnboxedTupleTyCon tc {- && False -} = do
      let args' = dropRuntimeRepArgs args
      (tys, wrappers) <- unzip <$> mapM jsResultWrapper args'
      matched <- mapM (mapM newSysLocalDs) tys
      let tys'    = catMaybes tys
          -- arity   = length args'
          -- resCon  = tupleDataCon Unboxed (length args)
          err     = panic "jsResultWrapper: used Id with result type Nothing"
          resWrap :: CoreExpr
          resWrap = mkCoreUbxTup args' (zipWith (\w -> w . Var . fromMaybe err) wrappers matched)
            -- mkCoreConApps resCon (map Type args ++ zipWith (\w -> w . Var . fromMaybe err) wrappers matched)
      return $
        if null tys'
          then (Nothing, \_ -> resWrap)
          else let innerArity = length tys'
                   innerTy    = mkTupleTy Unboxed tys'
                   innerCon   = tupleDataCon Unboxed innerArity
                   inner :: CoreExpr -> CoreExpr
                   inner e    = mkWildCase e innerTy result_ty
                                           [( DataAlt innerCon
                                            , catMaybes matched
                                            , resWrap
                                            )]
               in (Just innerTy, inner)
  
    -- Base case 1b: primitive types
    | isPrimitiveType result_ty
    = return (Just result_ty, \e -> e)
    -- Base case 1c: boxed tuples
    -- fixme: levity args?
    | Just (tc, args) <- splitTyConApp_maybe result_ty
    , isBoxedTupleTyCon tc = do
        let args'   = dropRuntimeRepArgs args
            innerTy = mkTupleTy Unboxed args'
        (inner_res, w) <- jsResultWrapper innerTy
        matched <- mapM newSysLocalDs args'
        let inner e = mkWildCase (w e) innerTy result_ty
                                 [( DataAlt (tupleDataCon Unboxed (length args'))
                                  , matched
                                  , mkCoreTup (map Var matched)
                                  -- mkCoreConApps (tupleDataCon Boxed (length args)) (map Type args ++ map Var matched)
                                  )]
        return (inner_res, inner)
  
    -- Base case 2: the unit type ()
    | Just (tc,_) <- maybe_tc_app, tc `hasKey` unitTyConKey
    = return (Nothing, \_ -> Var unitDataConId)
  
    -- Base case 3: the boolean type
    | Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey = do
      dflags <- getDynFlags
  --    result_id <- newSysLocalDs boolTy
      ccall_uniq <- newUnique
      let forceBool e = mkJsCall dflags ccall_uniq "$r = !(!$1)" [e] boolTy
      return
       (Just intPrimTy, \e -> forceBool e)
  
    -- Base case 4: the any type
    |  Just (tc,_) <- maybe_tc_app, tc `hasKey` anyTyConKey
    = return (Just result_ty, \e -> e)
  
    -- Newtypes
    | Just (co, rep_ty) <- topNormaliseNewType_maybe result_ty
    = do (maybe_ty, wrapper) <- jsResultWrapper rep_ty
         return (maybe_ty, \e -> mkCastDs (wrapper e) (mkSymCo co))
  
    -- The type might contain foralls (eg. for dummy type arguments,
    -- referring to 'Ptr a' is legal).
    | Just (tyvar, rest) <- splitForAllTy_maybe result_ty
    = do (maybe_ty, wrapper) <- jsResultWrapper rest
         return (maybe_ty, \e -> Lam tyvar (wrapper e))
  
    -- Data types with a single constructor, which has a single arg
    -- This includes types like Ptr and ForeignPtr
    | Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) <- splitDataProductType_maybe result_ty,
      dataConSourceArity data_con == 1
    = do dflags <- getDynFlags
         let
             (unwrapped_res_ty : _) = data_con_arg_tys
             narrow_wrapper         = maybeJsNarrow dflags tycon
         (maybe_ty, wrapper) <- jsResultWrapper unwrapped_res_ty
         return
           (maybe_ty, \e -> mkApps (Var (dataConWrapId data_con))
                                   (map Type tycon_arg_tys ++ [wrapper (narrow_wrapper e)]))
  
    | otherwise
    = pprPanic "jsResultWrapper" (ppr result_ty)
    where
      maybe_tc_app = splitTyConApp_maybe result_ty
  
  -- low-level primitive JavaScript call:
  mkJsCall :: DynFlags -> Unique -> String -> [CoreExpr] -> Type -> CoreExpr
  mkJsCall dflags u tgt args t =
    mkFCall dflags u (CCall (mkCCallSpec (StaticTarget NoSourceText (mkFastString tgt)
                                                         (Just primPackageKey)
                                                         True)
                                        JavaScriptCallConv PlayRisky
                                        t
                                        (map exprType args)
                                        )) args t
  
  -- represent a primitive type as a Char, for building a string that
  -- described the foreign function type.  The types are size-dependent,
  -- e.g. 'W' is a signed 32-bit integer.
  primTyDescChar :: DynFlags -> Type -> Char
  primTyDescChar dflags ty
   | ty `eqType` unitTy = 'v'
   | ty `eqType` boolTy = 'b'
   | otherwise
   = case typePrimRep1 (getPrimTyOf ty) of
       IntRep      -> signed_word
       WordRep     -> unsigned_word
       Int64Rep    -> 'L'
       Word64Rep   -> 'l'
       AddrRep     -> 'p'
       FloatRep    -> 'f'
       DoubleRep   -> 'd'
       _           -> pprPanic "primTyDescChar" (ppr ty)
    where
      (signed_word, unsigned_word)
         | wORD_SIZE dflags == 4  = ('W','w')
         | wORD_SIZE dflags == 8  = ('L','l')
         | otherwise              = panic "primTyDescChar"
  
  cLibFFI :: Bool
  cLibFFI = False
  
  -- This function returns the primitive type associated with the boxed
  -- type argument to a foreign export (eg. Int ==> Int#).
  getPrimTyOf :: Type -> UnaryType
  getPrimTyOf ty
    | isBoolTy rep_ty = intPrimTy
    -- Except for Bool, the types we are interested in have a single constructor
    -- with a single primitive-typed argument (see TcType.legalFEArgTyCon).
    | otherwise =
    case splitDataProductType_maybe rep_ty of
       Just (_, _, _data_con, [prim_ty]) ->
  --        ASSERT(dataConSourceArity data_con == 1)
  --        ASSERT2(isUnliftedType prim_ty, ppr prim_ty)
          prim_ty
       _other -> pprPanic "DsForeign.getPrimTyOf" (ppr ty)
    where
      rep_ty = unwrapType ty
  
  -- When the result of a foreign call is smaller than the word size, we
  -- need to sign- or zero-extend the result up to the word size.  The C
  -- standard appears to say that this is the responsibility of the
  -- caller, not the callee.
  
  -- narrow int32 and word32 since JS numbers can contain more
  maybeJsNarrow :: DynFlags -> TyCon -> (CoreExpr -> CoreExpr)
  maybeJsNarrow _dflags tycon
    | tycon `hasKey` intTyConKey    = \e -> App (Var (mkPrimOpId Narrow32IntOp)) e
    | tycon `hasKey` int8TyConKey   = \e -> App (Var (mkPrimOpId Narrow8IntOp)) e
    | tycon `hasKey` int16TyConKey  = \e -> App (Var (mkPrimOpId Narrow16IntOp)) e
    | tycon `hasKey` int32TyConKey  = \e -> App (Var (mkPrimOpId Narrow32IntOp)) e
    | tycon `hasKey` wordTyConKey   = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e
    | tycon `hasKey` word8TyConKey  = \e -> App (Var (mkPrimOpId Narrow8WordOp)) e
    | tycon `hasKey` word16TyConKey = \e -> App (Var (mkPrimOpId Narrow16WordOp)) e
    | tycon `hasKey` word32TyConKey = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e
    | otherwise                     = id
  
  {-
    desugar foreign declarations for native code: replace
    all foreign import JavaScript by a CCall
    to the JavaScript handler.
  
    The JavaScript handler can be installed by calling
    `setJavaScriptHandler` (ghcjs.h) from C. The
    default handler prints an error message and terminates the
    program.
  -}
  ghcjsNativeDsForeigns :: [LForeignDecl GhcTc]
                        -> DsM (ForeignStubs, OrdList (Id, CoreExpr))
  ghcjsNativeDsForeigns fos = do
    dflags <- getDynFlags
    (stubs, ret) <- dsForeigns' (map (convertForeignDecl dflags) fos)
    case mapMaybe (importStub dflags) fos of
      [] -> return (stubs, ret)
      xs -> return (stubs `appendStubC'` vcat xs, ret)
      where
        appendStubC' NoStubs s = ForeignStubs empty (inclGhcjs $$ s)
        appendStubC' (ForeignStubs h c) s =
          ForeignStubs h (inclGhcjs $$ c $$ s)
        inclGhcjs = text "#include \"ghcjs.h\""
  
        convertForeignDecl :: DynFlags -> LForeignDecl GhcTc -> LForeignDecl GhcTc
        convertForeignDecl dflags (L l (ForeignImport c n t (CImport (L _lc JavaScriptCallConv) _safety mheader _spec txt))) =
          (L l (ForeignImport c n t (CImport (noLoc CCallConv) (noLoc PlaySafe) mheader (convertSpec dflags n) txt)))
        convertForeignDecl _dflags (L l (ForeignExport c n t (CExport (L _ (CExportStatic srcTxt lbl JavaScriptCallConv)) txt))) =
          (L l (ForeignExport c n t (CExport (noLoc (CExportStatic srcTxt lbl CCallConv)) txt)))
        convertForeignDecl _ x = x
  
        -- convertSpec :: DynFlags -> Located GhcTc -> CImportSpec
        convertSpec dflags i = CFunction (StaticTarget NoSourceText (stubName dflags (unLoc i)) Nothing True)
  
        -- stubName :: DynFlags -> Id -> FastString
        stubName dflags i = mkFastString $
          "__ghcjs_stub_" ++ zEncodeString (showSDocOneLine dflags (ppr $ idName i))
  
        importStub :: DynFlags -> LForeignDecl GhcTc -> Maybe SDoc
        importStub dflags (L _l (ForeignImport c n _t (CImport (L _ JavaScriptCallConv) (L _ safety) _mheader spec _txt))) =
          Just (mkImportStub dflags (unLoc n) c safety spec)
        importStub _ _ = Nothing
  
        mkImportStub :: DynFlags -> Id -> Coercion -> Safety -> CImportSpec -> SDoc
        mkImportStub dflags i _c s spec =
          text resTy <+> ftext (stubName dflags i) <> stubArgs <+> braces body
            where
             js :: SDoc
             js = case spec of
                    CLabel cls                         -> escapeQuoted (unpackFS cls)
                    CFunction (StaticTarget _ cls _ _) -> escapeQuoted (unpackFS cls) -- fixme source text may be better?
                    _ -> error "ghcjsNativeDsForeigns: unexpected import spec"
             safety PlayRisky         = int 0
             safety PlaySafe          = int 1
             safety PlayInterruptible = int 2
             escapeQuoted xs = doubleQuotes $ text (concatMap escapeChar xs)
               where
                 -- fixme proper escaping and handling of non-ascii characters
                 escapeChar '\\' = "\\\\"
                 escapeChar '\n' = "\\n"
                 escapeChar '\t' = "\\t"
                 escapeChar '"'  = "\\\""
                 escapeChar x    = x:[]
  
             t = idType i
             (args, res) = tcSplitFunTys . snd . tcSplitForAllTys $ t
             argNames    = map ((text "arg" <>) . int) [1..]
             (argTys, argsSig) = unzip $ map (jsTySigLit dflags False) args
             (resTy,  resSig) = jsTySigLit dflags True res
             body | resSig == 'v' = vcat [text "int res;", call]
                  | otherwise     = vcat [text resTy <+> text "res;", call, text "return res;"]
             call = text "getJavaScriptHandler()" <> parens (pprWithCommas id handlerArgs) <> semi
             handlerArgs = [js, safety s, escapeQuoted (resSig : argsSig), text "(void*)&res"]
                             ++ take (length args) argNames
             stubArgs = parens $ pprWithCommas id (zipWith (\ty n -> text ty <+> n) argTys argNames)
  
  jsTySigLit :: DynFlags -> Bool -> Type -> (String, Char)
  jsTySigLit dflags isResult t | isResult, Just (_ ,result) <- tcSplitIOType_maybe t =
                                   jsTySigLit dflags isResult result
                               | Just (_, t') <- splitForAllTy_maybe t = jsTySigLit dflags isResult t'
                               | Just (tc, _) <- splitTyConApp_maybe t = tcSig isResult tc
                               | otherwise = error $ "jsTySigLit: unexpected type: "
                                                         ++ showSDoc dflags (ppr t)
    where
             tcSig :: Bool -> TyCon -> (String, Char)
             tcSig isResult tc
               | isUnliftedTyCon tc, [tt] <- tyConPrimRep tc = prim tt -- = prim (tyConPrimRep tc)
               | Just r <- lookup (getUnique tc) boxed               = r
               | isResult && getUnique tc == unitTyConKey            = ("void", 'v')
               | isJSValTyCon dflags tc = ("StgPtr", 'r')
               | otherwise = error $ "jsTySigLit: unexpected TyCon: "
                                         ++ showSDoc dflags (ppr tc)
                where
                   -- fixme is there already a list of these somewhere else?
                   prim VoidRep  = error "jsTySigLit: VoidRep"
                   prim LiftedRep = hsPtr
                   prim UnliftedRep = hsPtr -- fixme?
                   -- prim PtrRep   = hsPtr
                   prim IntRep   = hsInt
                   prim Int8Rep  = hsInt
                   prim Int16Rep = hsInt
                   prim Int32Rep = hsInt
                   prim WordRep  = hsWord
                   prim Word8Rep = hsWord
                   prim Word16Rep = hsWord
                   prim Word32Rep = hsWord
                   prim Int64Rep  = hsInt64
                   prim Word64Rep = hsWord64
                   prim AddrRep   = hsPtr
                   prim FloatRep  = hsFloat
                   prim DoubleRep = hsDouble
                   prim (VecRep{}) = error "jsTySigLit: VecRep"
                   boxed = [ (intTyConKey,        hsInt               )
                           , (int8TyConKey,       ("StgInt8",      'b'))
                           , (int16TyConKey,      ("StgInt16",     's'))
                           , (int32TyConKey,      ("StgInt32",     'l'))
                           , (int64TyConKey,      hsInt64             )
                           , (wordTyConKey,       hsWord              )
                           , (word8TyConKey,      ("StgWord8",     'B'))
                           , (word16TyConKey,     ("StgWord16",    'S'))
                           , (word32TyConKey,     ("StgWord32",    'L'))
                           , (word64TyConKey,     hsWord64            )
                           , (floatTyConKey,      hsFloat             )
                           , (doubleTyConKey,     hsDouble            )
                           , (ptrTyConKey,        hsPtr               )
                           , (funPtrTyConKey,     hsPtr               )
                           , (charTyConKey,       ("StgChar",      'c'))
                           , (stablePtrTyConKey,  hsPtr               )
                           , (boolTyConKey,       hsInt               )
                           ]
                   hsInt    = ("StgInt",    'i')
                   hsInt64  = ("StgInt64",  'm')
                   hsWord   = ("StgWord",   'I')
                   hsWord64 = ("StgWord64", 'M')
                   hsPtr    = ("StgPtr",    'p')
                   hsFloat  = ("StgFloat",  'f')
                   hsDouble = ("StgDouble", 'd')
  
  ghcjsTcForeignImports :: [LForeignDecl GhcRn]
                        -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)
  ghcjsTcForeignImports decls
    = do { (ids, decls, gres) <- mapAndUnzip3M ghcjsTcFImport $
                                 filter isForeignImport decls
         ; return (ids, decls, unionManyBags gres) }
  
  foreignDeclCtxt :: ForeignDecl GhcRn -> SDoc
  foreignDeclCtxt fo
    = hang (ptext (sLit "When checking declaration:"))
         2 (ppr fo)
  
  ghcjsTcFImport :: LForeignDecl GhcRn
                 -> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt)
  ghcjsTcFImport (L dloc fo@(ForeignImport { fd_name = L nloc nm, fd_sig_ty = hs_ty
                                      , fd_fi = imp_decl }))
    = setSrcSpan dloc $ addErrCtxt (foreignDeclCtxt fo)  $
      do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
         ; (norm_co, norm_sig_ty, gres) <- normaliseFfiType sig_ty
         ; let
             -- Drop the foralls before inspecting the
             -- structure of the foreign type.
               (bndrs, res_ty)   = tcSplitPiTys norm_sig_ty
               arg_tys           = mapMaybe binderRelevantType_maybe bndrs
               id                = mkLocalId nm sig_ty
                   -- Use a LocalId to obey the invariant that locally-defined
                   -- things are LocalIds.  However, it does not need zonking,
                   -- (so TcHsSyn.zonkForeignExports ignores it).
  
         ; imp_decl' <- ghcjsTcCheckFIType arg_tys res_ty imp_decl
            -- Can't use sig_ty here because sig_ty :: Type and
            -- we need HsType Id hence the undefined
         ; let fi_decl = ForeignImport { fd_name = L nloc id
                                       , fd_sig_ty = undefined
                                       , fd_i_ext = mkSymCo norm_co
                                       , fd_fi = imp_decl' }
         ; return (id, L dloc fi_decl, gres) }
  ghcjsTcFImport d = pprPanic "ghcjsTcFImport" (ppr d)
  
  
  ghcjsTcCheckFIType :: [Type] -> Type -> ForeignImport -> TcM ForeignImport
  ghcjsTcCheckFIType {- sig_ty -} arg_tys res_ty (CImport lcconv@(L _ cconv) lsafety@(L _ safety) mh (CFunction target) src)
    | cconv == JavaScriptCallConv = do
        dflags <- getDynFlags
        checkForeignArgs (isGhcjsFFIArgumentTy dflags safety) arg_tys
        checkForeignRes nonIOok checkSafe (isGhcjsFFIImportResultTy dflags) res_ty
        -- checkMissingAmpersand dflags arg_tys res_ty
        case target of
            StaticTarget _ _ _ False
             | not (null arg_tys) ->
                addErrTc (text "`value' imports cannot have function types")
            _ -> return ()
        return $ CImport lcconv lsafety mh (CFunction target) src
  ghcjsTcCheckFIType {- _sig_ty -} arg_tys res_ty idecl = tcCheckFIType arg_tys res_ty idecl
  
  isGhcjsFFIArgumentTy :: DynFlags -> Safety -> Type -> Validity
  isGhcjsFFIArgumentTy dflags safety ty
    | isValid (isFFIArgumentTy dflags safety ty)                          = IsValid
    | haveGHCForeignImportPrim dflags && haveUnliftedFFITypes dflags &&
      isValid (isFFIPrimArgumentTy dflags ty)                             = IsValid
    | isGhcjsFFITy dflags ty                                              = IsValid
    | Just (tc, _) <- tcSplitTyConApp_maybe ty
    , getUnique tc == anyTyConKey && haveGHCForeignImportPrim dflags      = IsValid
    | otherwise = NotValid
        (text "JavaScript FFI argument type must be a valid CCall FFI argument type or JSVal")
  
  isGhcjsFFIImportResultTy :: DynFlags -> Type -> Validity
  isGhcjsFFIImportResultTy dflags ty
    | Just (tc, args) <- tcSplitTyConApp_maybe ty
    , isBoxedTupleTyCon tc || isUnboxedTupleTyCon tc =
        let args' = dropRuntimeRepArgs args
        in if all (isValid . check) args'
             then IsValid
             else NotValid
                (text $ "JavaScript FFI result type must be a valid CCall FFI result type or JSVal: " ++ showPpr dflags ty ++ " " ++ show (map (isValid . check) args') ++ " " ++ show (map (showPpr dflags) args'))
    | otherwise = isGhcjsFFIImportResultTy' dflags ty
      where
        check ty | Just (tc, _args) <- tcSplitTyConApp_maybe ty
                 , getUnique tc == liftedTypeKindTyConKey
                  {- || getUnique tc == unliftedTypeKindTyConKey -} = IsValid -- fixme
                 | isValid (isGhcjsFFIImportResultTy' dflags ty) = IsValid
                 | isGhcjsFFITy dflags ty = IsValid
                 | otherwise = NotValid (text $ "")
  
  
  isGhcjsFFIImportResultTy' :: DynFlags -> Type -> Validity
  isGhcjsFFIImportResultTy' dflags ty
    | isValid (isFFIImportResultTy dflags ty)                   = IsValid
  
  -- -  | xopt Opt_UnliftedFFITypes dflags && isUnboxedTupleType ty = IsValid
    | haveGHCForeignImportPrim dflags && haveUnliftedFFITypes dflags &&
      checkRepTyCon isUnliftedTyCon ty                          = IsValid
    --   isValid (isFFIPrimResultTy dflags ty)                     = IsValid
    | Just (tc, _) <- tcSplitTyConApp_maybe ty
    , haveGHCForeignImportPrim dflags && getUnique tc == anyTyConKey = IsValid
    | isGhcjsFFITy dflags ty                                    = IsValid
    | otherwise = NotValid
        (text $ "JavaScript FFI result type must be a valid CCall FFI result type or JSVal: " ++ showPpr dflags ty)
  
  haveUnliftedFFITypes :: DynFlags -> Bool
  haveUnliftedFFITypes dflags = xopt UnliftedFFITypes dflags
  
  haveGHCForeignImportPrim :: DynFlags -> Bool
  haveGHCForeignImportPrim dflags = xopt GHCForeignImportPrim dflags
  
  isGhcjsFFITy :: DynFlags -> Type -> Bool
  isGhcjsFFITy = checkNamedTy jsFfiTys
  
  isJSValTy :: DynFlags -> Type -> Bool
  isJSValTy = checkNamedTy [jsValTy]
  
  isJSValTyCon :: DynFlags -> TyCon -> Bool
  isJSValTyCon = checkNamedTyCon [jsValTy]
  
  checkNamedTy :: [(String, String, String)] -> DynFlags -> Type -> Bool
  checkNamedTy tys dflags ty = checkRepTyCon (checkNamedTyCon tys dflags) ty
  
  checkNamedTyCon :: [(String, String, String)] -> DynFlags -> TyCon -> Bool
  checkNamedTyCon tys dflags tc
    = any (\(p,m,n) -> m == mod && n == name && validPkg p pkg) tys
        where
          validPkg p ""
            | [b] <- catMaybes (map (stripPrefix "-DBOOTING_PACKAGE=")
                                    (opt_P dflags)) = p == b
          validPkg p p' = p == p'
  
          -- comparing strings is probably not too fast, perhaps search
          -- for the types first and use some cache
          n = tyConName (repTc tc)
          (pkg, mod) = case nameModule_maybe n of
                         Nothing -> ("", "")
                         Just m  -> ( modulePackageName dflags m
                                    , moduleNameString (moduleName m))
          name = occNameString (nameOccName n)
  
  repTc :: TyCon -> TyCon
  repTc = go
    where
      go :: TyCon -> TyCon
      go tc | Just (_tvs, t, _) <- unwrapNewTyCon_maybe tc =
                case splitTyConApp_maybe (dropForAlls t) of
                  Nothing       -> error "repTc: not a tycon application"
                  Just (tc', _) -> go tc'
            | otherwise = tc
  
  jsFfiTys :: [(String, String, String)]
  jsFfiTys = [jsValTy]
  
  jsValTy :: (String, String, String)
  jsValTy = ("ghcjs-prim", "GHCJS.Prim", "JSVal")
  
  -- normaliseFfiType gets run before checkRepTyCon, so we don't
  -- need to worry about looking through newtypes or type functions
  -- here; that's already been taken care of.
  checkRepTyCon :: (TyCon -> Bool) -> Type -> Bool
  checkRepTyCon check_tc ty
      | Just (tc, _) <- splitTyConApp_maybe ty
        = check_tc tc
      | otherwise
        = False
  
  ghcjsNativeTcForeignImports :: [LForeignDecl GhcRn]
                              -> TcM ([Id], [LForeignDecl GhcTcId], Bag GlobalRdrElt)
  ghcjsNativeTcForeignImports = ghcjsTcForeignImports
  
  ghcjsNativeTcForeignExports :: [LForeignDecl GhcRn]
                              -> TcM (LHsBinds GhcTcId, [LForeignDecl GhcTcId], Bag GlobalRdrElt)
  ghcjsNativeTcForeignExports = ghcjsTcForeignExports
  
  ghcjsTcForeignExports :: [LForeignDecl GhcRn]
                        -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
  -- For the (Bag GlobalRdrElt) result,
  -- see Note [Newtype constructor usage in foreign declarations]
  ghcjsTcForeignExports decls
    = foldlM combine (emptyLHsBinds, [], emptyBag) (filter isForeignExport decls)
    where
     combine (binds, fs, gres1) (L loc fe) = do
         (b, f, gres2) <- setSrcSpan loc (ghcjsTcFExport fe)
         return (b `consBag` binds, L loc f : fs, gres1 `unionBags` gres2)
  
  ghcjsTcFExport :: ForeignDecl GhcRn
            -> TcM (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt)
  ghcjsTcFExport fo@(ForeignExport { fd_name = L loc nm, fd_sig_ty = hs_ty, fd_fe = spec })
    = addErrCtxt (foreignDeclCtxt fo) $ do
  
      sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
      rhs <- tcPolyExpr (nlHsVar nm) sig_ty
  
      (norm_co, norm_sig_ty, gres) <- normaliseFfiType sig_ty
  
      spec' <- ghcjsTcCheckFEType norm_sig_ty spec
  
             -- we're exporting a function, but at a type possibly more
             -- constrained than its declared/inferred type. Hence the need
             -- to create a local binding which will call the exported function
             -- at a particular type (and, maybe, overloading).
  
  
      -- We need to give a name to the new top-level binding that
      -- is *stable* (i.e. the compiler won't change it later),
      -- because this name will be referred to by the C code stub.
      id  <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc
      return ( mkVarBind id rhs
             , ForeignExport { fd_name = L loc id
                             , fd_sig_ty = undefined
                             , fd_e_ext = norm_co, fd_fe = spec' }
             , gres)
  ghcjsTcFExport d = pprPanic "ghcjsTcFExport" (ppr d)
  
  
  ghcjsTcCheckFEType :: Type -> ForeignExport -> TcM ForeignExport
  ghcjsTcCheckFEType sig_ty (CExport (L l (CExportStatic esrc str cconv)) src) = do
  --    checkCg checkCOrAsmOrLlvm
      checkTc (isCLabelString str) (badCName str)
      cconv' <- ghcjsCheckCConv cconv
      checkForeignArgs isFFIExternalTy arg_tys
      checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty
      return (CExport (L l (CExportStatic esrc str cconv')) src)
    where
        -- Drop the foralls before inspecting n
        -- the structure of the foreign type.
      (_, t_ty) = tcSplitForAllTys sig_ty
      (arg_tys, res_ty) = tcSplitFunTys t_ty
  
  ghcjsCheckCConv :: CCallConv -> TcM CCallConv
  ghcjsCheckCConv CCallConv          = return CCallConv
  ghcjsCheckCConv CApiConv           = return CApiConv
  ghcjsCheckCConv JavaScriptCallConv = return JavaScriptCallConv
  
  ghcjsCheckCConv StdCallConv  = do dflags <- getDynFlags
                                    let platform = targetPlatform dflags
                                    if platformArch platform == ArchX86
                                      then return StdCallConv
                                      else do -- This is a warning, not an error. see #3336
                                             when (wopt Opt_WarnUnsupportedCallingConventions dflags) $
                                               addWarnTc (Reason Opt_WarnUnsupportedCallingConventions) (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall")
                                             return CCallConv
  ghcjsCheckCConv PrimCallConv = do addErrTc (text "The `prim' calling convention can only be used with `foreign import'")
                                    return PrimCallConv
  
  
  checkCg :: (HscTarget -> Maybe SDoc) -> TcM ()
  checkCg check = do
      dflags <- getDynFlags
      let target = hscTarget dflags
      case target of
        HscNothing -> return ()
        _ ->
          case check target of
            Nothing  -> return ()
            Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
  
  check :: Bool -> MsgDoc -> TcM ()
  check True _       = return ()
  check _    the_err = addErrTc the_err
  
  badCName :: CLabelString -> MsgDoc
  badCName target
    = sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")]
  
  