content: {-|
  Module      : IRTS.JavaScript.Codegen
  Description : The JavaScript common code generator.
  
  License     : BSD3
  Maintainer  : The Idris Community.
  -}
  {-# LANGUAGE CPP, OverloadedStrings #-}
  
  module IRTS.JavaScript.Codegen( codegenJs
                                , CGConf(..)
                                , CGStats(..)
                                ) where
  
  import Idris.Core.TT
  import IRTS.CodegenCommon
  import IRTS.Exports
  import IRTS.JavaScript.AST
  import IRTS.JavaScript.LangTransforms
  import IRTS.JavaScript.Name
  import IRTS.JavaScript.PrimOp
  import IRTS.JavaScript.Specialize
  import IRTS.Lang
  import IRTS.System
  
  import Control.Monad
  import Control.Monad.Trans.State
  import Data.Generics.Uniplate.Data
  import Data.List
  import Data.Map.Strict (Map)
  import qualified Data.Map.Strict as Map
  import Data.Set (Set)
  import qualified Data.Set as Set
  import Data.Text (Text)
  import qualified Data.Text as T
  import qualified Data.Text.IO as TIO
  import System.Directory (doesFileExist)
  import System.Environment
  import System.FilePath
  
  -- | Code generation stats hold information about the generated user
  -- code. Based on that information we add additional code to make
  -- things work.
  data CGStats = CGStats { usedBigInt :: Bool
                         , partialApplications :: Set Partial
                         , hiddenClasses :: Set HiddenClass
                         }
  
  #if (MIN_VERSION_base(4,11,0))
  instance Semigroup CGStats where
      (<>) = mappend
  #endif
  
  -- If we generate code for two declarations we want to merge their code
  -- generation stats.
  instance Monoid CGStats where
    mempty = CGStats { partialApplications = Set.empty
                     , hiddenClasses = Set.empty
                     , usedBigInt = False
                     }
    mappend x y = CGStats { partialApplications = partialApplications x `Set.union` partialApplications y
                          , hiddenClasses = hiddenClasses x `Set.union` hiddenClasses y
                          , usedBigInt = usedBigInt x || usedBigInt y
                          }
  
  
  data CGConf = CGConf { header :: Text
                       , footer :: Text
                       , jsbnPath :: String
                       , extraRunTime :: String
                       }
  
  
  getInclude :: FilePath -> IO Text
  getInclude p =
    do
      libs <- getIdrisLibDir
      let libPath = libs </> p
      exitsInLib <- doesFileExist libPath
      if exitsInLib then
        TIO.readFile libPath
        else TIO.readFile p
  
  getIncludes :: [FilePath] -> IO Text
  getIncludes l = do
    incs <- mapM getInclude l
    return $ T.intercalate "\n\n" incs
  
  includeLibs :: [String] -> String
  includeLibs =
    let
      repl '\\' = '_'
      repl '/' = '_'
      repl '.' = '_'
      repl '-' = '_'
      repl c   = c
    in
      concatMap (\lib -> "var " ++ (repl <$> lib) ++ " = require(\"" ++ lib ++"\");\n")
  
  isYes :: Maybe String -> Bool
  isYes (Just "Y") = True
  isYes (Just "y") = True
  isYes _ = False
  
  makeExportDecls :: Map Name LDecl -> ExportIFace -> [Text]
  makeExportDecls defs (Export _ _ e) =
    concatMap makeExport e
    where
      uncurryF name argTy (Just args) retTy =
        if length argTy == length args then
            case (retTy, length args) of
              (FIO _, 0) -> T.concat ["function(){return ", name, "()()}"]
              _ -> name
          else T.concat [ "function(){ return "
                        , name
                        , ".apply(this, Array.prototype.slice.call(arguments, 0,", T.pack $ show $ length args,"))"
                        , T.concat $ map (\x -> T.concat ["(arguments[", T.pack $ show x , "])"]) [length args .. (length argTy - 1)]
                        , "}"
                        ]
      uncurryF name argTy Nothing retTy = name
  
      makeExport (ExportData _) =
        []
      makeExport (ExportFun name (FStr exportname) retTy argTy) =
        [T.concat [ T.pack $ exportname
                  ,  ": "
                  , uncurryF (jsName name) argTy (getArgList' name defs) retTy
                  ]
        ]
  
  codegenJs :: CGConf -> CodeGenerator
  codegenJs conf ci =
    do
      debug <- isYes <$> lookupEnv "IDRISJS_DEBUG"
      let defs' = Map.fromList $ liftDecls ci
      let defs = globlToCon defs'
      let iface = interfaces ci
      let used = if iface then
                    Map.elems $ removeDeadCode defs (getExpNames $ exportDecls ci)
                    else Map.elems $ removeDeadCode defs [sMN 0 "runMain"]
      when debug $ do
          writeFile (outputFile ci ++ ".LDeclsDebug") $ (unlines $ intersperse "" $ map show used) ++ "\n\n\n"
          putStrLn $ "Finished calculating used"
  
      let (out, stats) = doCodegen defs used
  
      path <- getIdrisJSRTSDir
      jsbn <- if usedBigInt stats
                then TIO.readFile $ path </> jsbnPath conf
                else return ""
  
      runtimeCommon <- TIO.readFile $ path </> "Runtime-common.js"
      extraRT <- TIO.readFile $ path </> (extraRunTime conf)
  
      includes <- getIncludes $ includes ci
      let libs = T.pack $ includeLibs $ compileLibs ci
      TIO.writeFile (outputFile ci) $ T.concat [ header conf
                                               , "\"use strict\";\n\n"
                                               , "(function(){\n\n"
                                               -- rts
                                               , runtimeCommon, "\n"
                                               , extraRT, "\n"
                                               , jsbn, "\n"
                                               -- external libraries
                                               , includes, "\n"
                                               , libs, "\n"
                                               -- user code
                                               , doPartials (partialApplications stats), "\n"
                                               , doHiddenClasses (hiddenClasses stats), "\n"
                                               , out, "\n"
                                               , if iface then T.concat ["module.exports = {\n", T.intercalate ",\n" $ concatMap (makeExportDecls defs) (exportDecls ci), "\n};\n"]
                                                    else jsName (sMN 0 "runMain") `T.append` "();\n"
                                               , "}.call(this))"
                                               , footer conf
                                               ]
  
  doPartials :: Set Partial -> Text
  doPartials x =
    T.intercalate "\n" (map f $ Set.toList x)
    where
        f p@(Partial n i j) =
          let vars1 = map (T.pack . ("x"++) . show) [1..i]
              vars2 = map (T.pack . ("x"++) . show) [(i+1)..j]
          in jsStmt2Text $
               JsFun (jsNamePartial p) vars1 $ JsReturn $
                 jsCurryLam vars2 (jsAppN (jsName n) (map JsVar (vars1 ++ vars2)) )
  
  doHiddenClasses :: Set HiddenClass -> Text
  doHiddenClasses x =
    T.intercalate "\n" (map f $ Set.toList x)
    where
        f p@(HiddenClass n id 0) = jsStmt2Text $ JsDecConst (jsNameHiddenClass p) $ JsObj [("type", JsInt id)]
        f p@(HiddenClass n id arity) =
          let vars = map dataPartName $ take arity [1..]
          in jsStmt2Text $
               JsFun (jsNameHiddenClass p) vars $ JsSeq (JsSet (JsProp JsThis "type") (JsInt id)) $ seqJs
                 $ map (\tv -> JsSet (JsProp JsThis tv) (JsVar tv)) vars
  
  
  -- | Generate code for each declaration and collect stats.
  -- LFunctions are turned into JS function declarations. They are
  -- preceded by a comment that gives their name. Constructor
  -- declarations are ignored.
  doCodegen :: Map Name LDecl -> [LDecl] -> (Text, CGStats)
  doCodegen defs = foldMap (doCodegenDecl defs)
    where
      doCodegenDecl :: Map Name LDecl -> LDecl -> (Text, CGStats)
      doCodegenDecl defs (LFun _ name args def) =
        let (ast, stats) = cgFun defs name args def
            fnComment = jsStmt2Text (JsComment $ T.pack $ show name)
        in (T.concat [fnComment, "\n", jsStmt2Text ast, "\n"], stats)
      doCodegenDecl defs (LConstructor n i sz) = ("", mempty)
  
  
  seqJs :: [JsStmt] -> JsStmt
  seqJs [] = JsEmpty
  seqJs (x:xs) = JsSeq x (seqJs xs)
  
  
  data CGBodyState = CGBodyState { defs :: Map Name LDecl
                                 , lastIntName :: Int
                                 , reWrittenNames :: Map.Map Name JsExpr
                                 , currentFnNameAndArgs :: (Text, [Text])
                                 , usedArgsTailCallOptim :: Set (Text, Text)
                                 , isTailRec :: Bool
                                 , usedITBig :: Bool
                                 , partialApps :: Set Partial
                                 , hiddenCls :: Set HiddenClass
                                 }
  
  getNewCGName :: State CGBodyState Text
  getNewCGName =
    do
      st <- get
      let v = lastIntName st + 1
      put $ st {lastIntName = v}
      return $ jsNameGenerated v
  
  addPartial :: Partial -> State CGBodyState ()
  addPartial p =
    modify (\s -> s {partialApps = Set.insert p (partialApps s) })
  
  addHiddenClass :: HiddenClass -> State CGBodyState ()
  addHiddenClass p =
    modify (\s -> s {hiddenCls = Set.insert p (hiddenCls s) })
  
  addUsedArgsTailCallOptim :: Set (Text, Text) -> State CGBodyState ()
  addUsedArgsTailCallOptim p =
    modify (\s -> s {usedArgsTailCallOptim = Set.union p (usedArgsTailCallOptim s) })
  
  getConsId :: Name -> State CGBodyState (Int, Int)
  getConsId n =
      do
        st <- get
        case Map.lookup n (defs st) of
          Just (LConstructor _ conId arity) -> pure (conId, arity)
          _ -> error $ "Internal JS Backend error " ++ showCG n ++ " is not a constructor."
  
  getArgList' :: Name -> Map Name LDecl -> Maybe [Name]
  getArgList' n defs =
      case Map.lookup n defs of
        Just (LFun _ _ a _) -> Just a
        _ -> Nothing
  
  getArgList :: Name -> State CGBodyState (Maybe [Name])
  getArgList n =
    do
      st <- get
      pure $ getArgList' n (defs st)
  
  data BodyResTarget = ReturnBT
                     | DecBT Text
                     | SetBT Text
                     | DecConstBT Text
                     | GetExpBT
  
  cgFun :: Map Name LDecl -> Name -> [Name] -> LExp -> (JsStmt, CGStats)
  cgFun dfs n args def = do
    let fnName = jsName n
    let argNames = map jsName args
    let ((decs, res),st) = runState
                            (cgBody ReturnBT def)
                            (CGBodyState { defs = dfs
                                         , lastIntName = 0
                                         , reWrittenNames = Map.empty
                                         , currentFnNameAndArgs = (fnName, argNames)
                                         , usedArgsTailCallOptim = Set.empty
                                         , isTailRec = False
                                         , usedITBig = False
                                         , partialApps = Set.empty
                                         , hiddenCls = Set.empty
                                         }
                            )
    let body = if isTailRec st then JsSeq (declareUsedOptimArgs $ usedArgsTailCallOptim st) (JsForever ((seqJs decs) `JsSeq` res)) else (seqJs decs) `JsSeq` res
    let fn = JsFun fnName argNames body
    let state' = CGStats { partialApplications = partialApps st
                         , hiddenClasses = hiddenCls st
                         , usedBigInt = usedITBig st
                         }
    (fn, state')
  
  addRT :: BodyResTarget -> JsExpr -> JsStmt
  addRT ReturnBT x = JsReturn x
  addRT (DecBT n) x = JsDecLet n x
  addRT (DecConstBT n) x = JsDecConst n x
  addRT (SetBT n) x = JsSet (JsVar n) x
  addRT GetExpBT x = JsExprStmt x
  
  declareUsedOptimArgs :: Set (Text, Text) -> JsStmt
  declareUsedOptimArgs x = seqJs $ map (\(x,y) -> JsDecLet x (JsVar y) ) (Set.toList x)
  
  tailCallOptimRefreshArgs :: [(Text, JsExpr)] -> Set Text -> ((JsStmt, JsStmt), Set (Text, Text))
  tailCallOptimRefreshArgs [] s = ((JsEmpty, JsEmpty), Set.empty)
  tailCallOptimRefreshArgs ((n,x):r) s =
    let ((y1,y2), y3) = tailCallOptimRefreshArgs r (Set.insert n s) --
    in if Set.null $ (Set.fromList [ z | z <- universeBi x ]) `Set.intersection` s then
        ((y1, jsSetVar n x `JsSeq` y2), y3)
        else
          let n' = jsTailCallOptimName n
          in ((jsSetVar n' x `JsSeq` y1, jsSetVar n (JsVar n') `JsSeq` y2), Set.insert (n',n) y3)
  
  cgName :: Name -> State CGBodyState JsExpr
  cgName b = do
    st <- get
    case Map.lookup b (reWrittenNames st) of
      Just e -> pure e
      _ -> pure $ JsVar $ jsName b
  
  cgBody :: BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
  cgBody rt expr =
    case expr of
      (LCase _ (LOp oper [x, y]) [LConstCase (I 0) (LCon _ _ ff []), LDefaultCase (LCon _ _ tt [])])
        | (ff == qualifyN "Prelude.Bool" "False" &&
           tt == qualifyN "Prelude.Bool" "True") ->
          case (Map.lookup oper primDB) of
            Just (needBI, pti, c) | pti == PTBool -> do
              z <- mapM (cgBody GetExpBT) [x, y]
              when needBI setUsedITBig
              let res = jsPrimCoerce pti PTBool $ c $ map (jsStmt2Expr . snd) z
              pure $ (concat $ map fst z, addRT rt res)
            _ -> cgBody' rt expr
      (LCase _ e [LConCase _ n _ (LCon _ _ tt []), LDefaultCase (LCon _ _ ff [])])
        | (ff == qualifyN "Prelude.Bool" "False" &&
           tt == qualifyN "Prelude.Bool" "True") -> do
             (d, v) <- cgBody GetExpBT e
             test <- formConTest n (jsStmt2Expr v)
             pure $ (d, addRT rt $ JsUniOp (T.pack "!") $ JsUniOp (T.pack "!") test)
      (LCase _ e [LConCase _ n _ (LCon _ _ tt []), LConCase _ _ _ (LCon _ _ ff [])])
        | (ff == qualifyN "Prelude.Bool" "False" &&
           tt == qualifyN "Prelude.Bool" "True") -> do
             (d, v) <- cgBody GetExpBT e
             test <- formConTest n (jsStmt2Expr v)
             pure $ (d, addRT rt $ JsUniOp (T.pack "!") $ JsUniOp (T.pack "!") test)
      (LCase _ e [LConCase _ n _ (LCon _ _ ff []), LDefaultCase (LCon _ _ tt [])])
        | (ff == qualifyN "Prelude.Bool" "False" &&
           tt == qualifyN "Prelude.Bool" "True") -> do
             (d, v) <- cgBody GetExpBT e
             test <- formConTest n (jsStmt2Expr v)
             pure $ (d, addRT rt $ JsUniOp (T.pack "!") test)
      (LCase _ e [LConCase _ n _ (LCon _ _ ff []), LConCase _ _ _ (LCon _ _ tt [])])
        | (ff == qualifyN "Prelude.Bool" "False" &&
           tt == qualifyN "Prelude.Bool" "True") -> do
             (d, v) <- cgBody GetExpBT e
             test <- formConTest n (jsStmt2Expr v)
             pure $ (d, addRT rt $ JsUniOp (T.pack "!") test)
      (LCase f e [LConCase nf ff [] alt, LConCase nt tt [] conseq])
        | (ff == qualifyN "Prelude.Bool" "False" &&
           tt == qualifyN "Prelude.Bool" "True") ->
          cgBody' rt $ LCase f e [LConCase nt tt [] conseq, LConCase nf ff [] alt]
      expr -> cgBody' rt expr
  
  cgBody' :: BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
  cgBody' rt (LV n) =
    do
      argsFn <- getArgList n
      case argsFn of
        Just a -> cgBody' rt (LApp False (LV n) [])
        Nothing -> do
          n' <- cgName n
          pure $ ([], addRT rt n')
  cgBody' rt (LApp tailcall (LV fn) args) =
    do
      let fname = jsName fn
      st <- get
      let (currFn, argN) = currentFnNameAndArgs st
      z <- mapM (cgBody GetExpBT) args
      let argVals = map (jsStmt2Expr . snd) z
      let preDecs = concat $ map fst z
      case (fname == currFn && (length args) == (length argN), rt) of
        (True, ReturnBT) ->
          do
            modify (\x-> x {isTailRec = True})
            let ((y1,y2), y3) = tailCallOptimRefreshArgs (zip argN argVals) Set.empty
            addUsedArgsTailCallOptim y3
            pure (preDecs, y1 `JsSeq` y2)
        _ -> do
          app <- formApp fn argVals
          pure (preDecs, addRT rt app)
  
  cgBody' rt (LForce (LLazyApp n args)) = cgBody rt (LApp False (LV n) args)
  cgBody' rt (LLazyApp n args) =
    do
      (d,v) <- cgBody ReturnBT (LApp False (LV n) args)
      pure ([], addRT rt $ jsLazy $ jsStmt2Expr $ JsSeq (seqJs d) v)
  cgBody' rt (LForce e) =
    do
      (d,v) <- cgBody GetExpBT e
      pure (d, addRT rt $ JsForce $ jsStmt2Expr v)
  cgBody' rt (LLet n v sc) =
    do
      (d1, v1) <- cgBody (DecConstBT $ jsName n) v
      (d2, v2) <- cgBody rt sc
      pure $ ((d1 ++ v1 : d2), v2)
  cgBody' rt (LProj e i) =
    do
      (d, v) <- cgBody GetExpBT e
      pure $ (d, addRT rt $ JsArrayProj (JsInt $ i+1) $ jsStmt2Expr v)
  cgBody' rt (LCon _  conId n args) =
    do
      z <- mapM (cgBody GetExpBT) args
      con <- formCon n (map (jsStmt2Expr . snd) z)
      pure $ (concat $ map fst z, addRT rt con)
  cgBody' rt (LCase _ e alts) = do
    (d, v) <- cgBody GetExpBT e
    resName <- getNewCGName
    (decSw, entry) <-
      case (all altHasNoProj alts && length alts <= 2, v) of
        (True, _) -> pure (JsEmpty, jsStmt2Expr v)
        (False, JsExprStmt (JsVar n)) -> pure (JsEmpty, jsStmt2Expr v)
        _ -> do
          swName <- getNewCGName
          pure (JsDecConst swName $ jsStmt2Expr v, JsVar swName)
    sw' <- cgIfTree rt resName entry alts
    let sw =
          case sw' of
            (Just x) -> x
            Nothing -> JsExprStmt JsNull
    case rt of
      ReturnBT -> pure (d ++ [decSw], sw)
      (DecBT nvar) -> pure (d ++ [decSw, JsDecLet nvar JsNull], sw)
      (DecConstBT nvar) -> pure (d ++ [decSw, JsDecLet nvar JsNull], sw)
      (SetBT nvar) -> pure (d ++ [decSw], sw)
      GetExpBT ->
        pure
          (d ++ [decSw, JsDecLet resName JsNull, sw], JsExprStmt $ JsVar resName)
  cgBody' rt (LConst c) =
    do
       cst <- cgConst c
       pure ([], (addRT rt) $ cst)
  cgBody' rt (LOp op args) =
    do
      z <- mapM (cgBody GetExpBT) args
      res <- cgOp op (map (jsStmt2Expr . snd) z)
      pure $ (concat $ map fst z, addRT rt $ res)
  cgBody' rt LNothing = pure ([], addRT rt JsNull)
  cgBody' rt (LError x) = pure ([], JsError $ JsStr x)
  cgBody' rt x@(LForeign dres (FStr code) args ) =
    do
      z <- mapM (cgBody GetExpBT) (map snd args)
      jsArgs <- sequence $ map cgForeignArg (zip (map fst args) (map (jsStmt2Expr . snd) z))
      jsDres <- cgForeignRes dres $ JsForeign (T.pack code) jsArgs
      pure $ (concat $ map fst z, addRT rt $ jsDres)
  cgBody' _ x = error $ "Instruction " ++ show x ++ " not compilable yet"
  
  altsRT :: Text -> BodyResTarget -> BodyResTarget
  altsRT rn ReturnBT = ReturnBT
  altsRT rn (DecBT n) = SetBT n
  altsRT rn (SetBT n) = SetBT n
  altsRT rn (DecConstBT n) = SetBT n
  altsRT rn GetExpBT = SetBT rn
  
  altHasNoProj :: LAlt -> Bool
  altHasNoProj (LConCase _ _ args _) = args == []
  altHasNoProj _ = True
  
  formApp :: Name -> [JsExpr] -> State CGBodyState JsExpr
  formApp fn argVals = case specialCall fn of
    Just (arity, g) | arity == length argVals -> pure $ g argVals
    _ -> do
      argsFn <- getArgList fn
      fname <- cgName fn
      case argsFn of
        Nothing -> pure $ jsCurryApp fname argVals
        Just agFn -> do
          let lenAgFn = length agFn
          let lenArgs = length argVals
          case compare lenAgFn lenArgs of
            EQ -> pure $ JsApp fname argVals
            LT -> pure $ jsCurryApp (JsApp fname (take lenAgFn argVals)) (drop lenAgFn argVals)
            GT -> do
              let part = Partial fn lenArgs lenAgFn
              addPartial part
              pure $ jsAppN (jsNamePartial part) argVals
  
  formCon :: Name -> [JsExpr] -> State CGBodyState JsExpr
  formCon n args = do
    case specialCased n of
      Just (ctor, test, match) -> pure $ ctor args
      Nothing -> do
        (conId, arity) <- getConsId n
        let hc = HiddenClass n conId arity
        addHiddenClass hc
        pure $ if (arity > 0)
          then JsNew (JsVar $ jsNameHiddenClass hc) args
          else JsVar $ jsNameHiddenClass hc
  
  formConTest :: Name -> JsExpr -> State CGBodyState JsExpr
  formConTest n x = do
    case specialCased n of
      Just (ctor, test, match) -> pure $ test x
      Nothing -> do
        (conId, arity) <- getConsId n
        pure $ JsBinOp "===" (JsProp x (T.pack "type")) (JsInt conId)
        -- if (arity > 0)
        --   then pure $ JsBinOp "===" (JsProp x (T.pack "type")) (JsInt conId)
        --   else pure $ JsBinOp "===" x (JsInt conId)
  
  formProj :: Name -> JsExpr -> Int -> JsExpr
  formProj n v i =
    case specialCased n of
      Just (ctor, test, proj) -> proj v i
      Nothing -> JsProp v (dataPartName i)
  
  smartif :: JsExpr -> JsStmt -> Maybe JsStmt -> JsStmt
  smartif cond conseq (Just alt) = JsIf cond conseq (Just alt)
  smartif cond conseq Nothing = conseq
  
  formConstTest :: JsExpr -> Const -> State CGBodyState JsExpr
  formConstTest scrvar t = case t of
    BI _ -> do
      t' <- cgConst t
      cgOp' PTBool (LEq (ATInt ITBig)) [scrvar, t']
    _ -> do
      t' <- cgConst t
      pure $ JsBinOp "===" scrvar t'
  
  cgIfTree :: BodyResTarget
           -> Text
           -> JsExpr
           -> [LAlt]
           -> State CGBodyState (Maybe JsStmt)
  cgIfTree _ _ _ [] = pure Nothing
  cgIfTree rt resName scrvar ((LConstCase t exp):r) = do
    (d, v) <- cgBody (altsRT resName rt) exp
    alternatives <- cgIfTree rt resName scrvar r
    test <- formConstTest scrvar t
    pure $ Just $
      smartif test (JsSeq (seqJs d) v) alternatives
  cgIfTree rt resName scrvar ((LDefaultCase exp):r) = do
    (d, v) <- cgBody (altsRT resName rt) exp
    pure $ Just $ JsSeq (seqJs d) v
  cgIfTree rt resName scrvar ((LConCase _ n args exp):r) = do
    alternatives <- cgIfTree rt resName scrvar r
    test <- formConTest n scrvar
    st <- get
    let rwn = reWrittenNames st
    put $
      st
      { reWrittenNames =
          foldl
            (\m (n, j) -> Map.insert n (formProj n scrvar j) m)
            rwn
            (zip args [1 ..])
      }
    (d, v) <- cgBody (altsRT resName rt) exp
    st1 <- get
    put $ st1 {reWrittenNames = rwn}
    let branchBody = JsSeq (seqJs d) v
    pure $ Just $ smartif test branchBody alternatives
  
  
  cgForeignArg :: (FDesc, JsExpr) -> State CGBodyState JsExpr
  cgForeignArg (FApp (UN "JS_IntT") _, v) = pure v
  cgForeignArg (FCon (UN "JS_Str"), v) = pure v
  cgForeignArg (FCon (UN "JS_Ptr"), v) = pure v
  cgForeignArg (FCon (UN "JS_Unit"), v) = pure v
  cgForeignArg (FCon (UN "JS_Float"), v) = pure v
  cgForeignArg (FApp (UN "JS_FnT") [_,FApp (UN "JS_Fn") [_,_, a, FApp (UN "JS_FnBase") [_,b]]], f) =
    pure f
  cgForeignArg (FApp (UN "JS_FnT") [_,FApp (UN "JS_Fn") [_,_, a, FApp (UN "JS_FnIO") [_,_, b]]], f) =
    do
      jsx <- cgForeignArg (a, JsVar "x")
      jsres <- cgForeignRes b $ jsCurryApp (jsCurryApp f [jsx]) [JsNull]
      pure $ JsLambda ["x"] $ JsReturn jsres
  cgForeignArg (desc, _) =
    do
      st <- get
      error $ "Foreign arg type " ++ show desc ++ " not supported. While generating function " ++ (show $ fst $ currentFnNameAndArgs st)
  
  cgForeignRes :: FDesc -> JsExpr -> State CGBodyState JsExpr
  cgForeignRes (FApp (UN "JS_IntT") _) x = pure x
  cgForeignRes (FCon (UN "JS_Unit")) x = pure x
  cgForeignRes (FCon (UN "JS_Str")) x = pure x
  cgForeignRes (FCon (UN "JS_Ptr")) x = pure x
  cgForeignRes (FCon (UN "JS_Float")) x = pure x
  cgForeignRes desc val =
    do
      st <- get
      error $ "Foreign return type " ++ show desc ++ " not supported. While generating function " ++ (show $ fst $ currentFnNameAndArgs st)
  
  setUsedITBig :: State CGBodyState ()
  setUsedITBig =   modify (\s -> s {usedITBig = True})
  
  
  cgConst :: Const -> State CGBodyState JsExpr
  cgConst (I i) = pure $ JsInt i
  cgConst (BI i) =
    do
      setUsedITBig
      pure $ JsForeign "new $JSRTS.jsbn.BigInteger(%0)" [JsStr $ show i]
  cgConst (Ch c) = pure $ JsStr [c]
  cgConst (Str s) = pure $ JsStr s
  cgConst (Fl f) = pure $ JsDouble f
  cgConst (B8 x) = pure $ JsForeign (T.pack $ show x ++ " & 0xFF") []
  cgConst (B16 x) = pure $ JsForeign (T.pack $ show x ++ " & 0xFFFF") []
  cgConst (B32 x) = pure $ JsForeign (T.pack $ show x ++ "|0" ) []
  cgConst (B64 x) =
    do
      setUsedITBig
      pure $ JsForeign "new $JSRTS.jsbn.BigInteger(%0).and(new $JSRTS.jsbn.BigInteger(%1))" [JsStr $ show x, JsStr $ show 0xFFFFFFFFFFFFFFFF]
  cgConst x | isTypeConst x = pure $ JsInt 0
  cgConst x = error $ "Constant " ++ show x ++ " not compilable yet"
  
  cgOp :: PrimFn -> [JsExpr] -> State CGBodyState JsExpr
  cgOp = cgOp' PTAny
  
  cgOp' :: JsPrimTy -> PrimFn -> [JsExpr] -> State CGBodyState JsExpr
  cgOp' pt (LExternal name) _ | name == sUN "prim__null" = pure JsNull
  cgOp' pt (LExternal name) [l,r] | name == sUN "prim__eqPtr" = pure $ JsBinOp "==" l r
  cgOp' pt op exps = case Map.lookup op primDB of
    Just (useBigInt, pti, combinator) -> do
      when useBigInt setUsedITBig
      pure $ jsPrimCoerce pti pt $ combinator exps
    Nothing -> error ("Operator " ++ show (op, exps) ++ " not implemented")
  