{-|
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 { CGStats -> Bool
usedBigInt :: Bool
                       , CGStats -> Set Partial
partialApplications :: Set Partial
                       , CGStats -> Set HiddenClass
hiddenClasses :: Set HiddenClass
                       }

#if (MIN_VERSION_base(4,11,0))
instance Semigroup CGStats where
    <> :: CGStats -> CGStats -> CGStats
(<>) = CGStats -> CGStats -> CGStats
forall a. Monoid a => a -> a -> a
mappend
#endif

-- If we generate code for two declarations we want to merge their code
-- generation stats.
instance Monoid CGStats where
  mempty :: CGStats
mempty = CGStats { partialApplications :: Set Partial
partialApplications = Set Partial
forall a. Set a
Set.empty
                   , hiddenClasses :: Set HiddenClass
hiddenClasses = Set HiddenClass
forall a. Set a
Set.empty
                   , usedBigInt :: Bool
usedBigInt = Bool
False
                   }
  mappend :: CGStats -> CGStats -> CGStats
mappend CGStats
x CGStats
y = CGStats { partialApplications :: Set Partial
partialApplications = CGStats -> Set Partial
partialApplications CGStats
x Set Partial -> Set Partial -> Set Partial
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` CGStats -> Set Partial
partialApplications CGStats
y
                        , hiddenClasses :: Set HiddenClass
hiddenClasses = CGStats -> Set HiddenClass
hiddenClasses CGStats
x Set HiddenClass -> Set HiddenClass -> Set HiddenClass
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` CGStats -> Set HiddenClass
hiddenClasses CGStats
y
                        , usedBigInt :: Bool
usedBigInt = CGStats -> Bool
usedBigInt CGStats
x Bool -> Bool -> Bool
|| CGStats -> Bool
usedBigInt CGStats
y
                        }


data CGConf = CGConf { CGConf -> Text
header :: Text
                     , CGConf -> Text
footer :: Text
                     , CGConf -> [Char]
jsbnPath :: String
                     , CGConf -> [Char]
extraRunTime :: String
                     }


getInclude :: FilePath -> IO Text
getInclude :: [Char] -> IO Text
getInclude [Char]
p =
  do
    libs <- IO [Char]
getIdrisLibDir
    let libPath = [Char]
libs [Char] -> [Char] -> [Char]
</> [Char]
p
    exitsInLib <- doesFileExist libPath
    if exitsInLib then
      TIO.readFile libPath
      else TIO.readFile p

getIncludes :: [FilePath] -> IO Text
getIncludes :: [[Char]] -> IO Text
getIncludes [[Char]]
l = do
  incs <- ([Char] -> IO Text) -> [[Char]] -> IO [Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM [Char] -> IO Text
getInclude [[Char]]
l
  return $ T.intercalate "\n\n" incs

includeLibs :: [String] -> String
includeLibs :: [[Char]] -> [Char]
includeLibs =
  let
    repl :: Char -> Char
repl Char
'\\' = Char
'_'
    repl Char
'/' = Char
'_'
    repl Char
'.' = Char
'_'
    repl Char
'-' = Char
'_'
    repl Char
c   = Char
c
  in
    ([Char] -> [Char]) -> [[Char]] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\[Char]
lib -> [Char]
"var " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Char -> Char
repl (Char -> Char) -> [Char] -> [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char]
lib) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" = require(\"" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
lib [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"\");\n")

isYes :: Maybe String -> Bool
isYes :: Maybe [Char] -> Bool
isYes (Just [Char]
"Y") = Bool
True
isYes (Just [Char]
"y") = Bool
True
isYes Maybe [Char]
_ = Bool
False

makeExportDecls :: Map Name LDecl -> ExportIFace -> [Text]
makeExportDecls :: Map Name LDecl -> ExportIFace -> [Text]
makeExportDecls Map Name LDecl
defs (Export Name
_ [Char]
_ [Export]
e) =
  (Export -> [Text]) -> [Export] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Export -> [Text]
makeExport [Export]
e
  where
    uncurryF :: Text -> t a -> Maybe (t a) -> FDesc -> Text
uncurryF Text
name t a
argTy (Just t a
args) FDesc
retTy =
      if t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
argTy Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
args then
          case (FDesc
retTy, t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
args) of
            (FIO FDesc
_, Int
0) -> [Text] -> Text
T.concat [Text
"function(){return ", Text
name, Text
"()()}"]
            (FDesc, Int)
_ -> Text
name
        else [Text] -> Text
T.concat [ Text
"function(){ return "
                      , Text
name
                      , Text
".apply(this, Array.prototype.slice.call(arguments, 0,", [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Int -> [Char]
forall a. Show a => a -> [Char]
show (Int -> [Char]) -> Int -> [Char]
forall a b. (a -> b) -> a -> b
$ t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
args,Text
"))"
                      , [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Int -> Text) -> [Int] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
x -> [Text] -> Text
T.concat [Text
"(arguments[", [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
x , Text
"])"]) [t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
args .. (t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
argTy Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)]
                      , Text
"}"
                      ]
    uncurryF Text
name t a
argTy Maybe (t a)
Nothing FDesc
retTy = Text
name

    makeExport :: Export -> [Text]
makeExport (ExportData FDesc
_) =
      []
    makeExport (ExportFun Name
name (FStr [Char]
exportname) FDesc
retTy [FDesc]
argTy) =
      [[Text] -> Text
T.concat [ [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char]
exportname
                ,  Text
": "
                , Text -> [FDesc] -> Maybe [Name] -> FDesc -> Text
forall {t :: * -> *} {t :: * -> *} {a} {a}.
(Foldable t, Foldable t) =>
Text -> t a -> Maybe (t a) -> FDesc -> Text
uncurryF (Name -> Text
jsName Name
name) [FDesc]
argTy (Name -> Map Name LDecl -> Maybe [Name]
getArgList' Name
name Map Name LDecl
defs) FDesc
retTy
                ]
      ]

codegenJs :: CGConf -> CodeGenerator
codegenJs :: CGConf -> CodeGenerator
codegenJs CGConf
conf CodegenInfo
ci =
  do
    debug <- Maybe [Char] -> Bool
isYes (Maybe [Char] -> Bool) -> IO (Maybe [Char]) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"IDRISJS_DEBUG"
    let defs' = [(Name, LDecl)] -> Map Name LDecl
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, LDecl)] -> Map Name LDecl)
-> [(Name, LDecl)] -> Map Name LDecl
forall a b. (a -> b) -> a -> b
$ CodegenInfo -> [(Name, LDecl)]
liftDecls CodegenInfo
ci
    let defs = Map Name LDecl -> Map Name LDecl
globlToCon Map Name LDecl
defs'
    let iface = CodegenInfo -> Bool
interfaces CodegenInfo
ci
    let used = if Bool
iface then
                  Map Name LDecl -> [LDecl]
forall k a. Map k a -> [a]
Map.elems (Map Name LDecl -> [LDecl]) -> Map Name LDecl -> [LDecl]
forall a b. (a -> b) -> a -> b
$ Map Name LDecl -> [Name] -> Map Name LDecl
removeDeadCode Map Name LDecl
defs ([ExportIFace] -> [Name]
getExpNames ([ExportIFace] -> [Name]) -> [ExportIFace] -> [Name]
forall a b. (a -> b) -> a -> b
$ CodegenInfo -> [ExportIFace]
exportDecls CodegenInfo
ci)
                  else Map Name LDecl -> [LDecl]
forall k a. Map k a -> [a]
Map.elems (Map Name LDecl -> [LDecl]) -> Map Name LDecl -> [LDecl]
forall a b. (a -> b) -> a -> b
$ Map Name LDecl -> [Name] -> Map Name LDecl
removeDeadCode Map Name LDecl
defs [Int -> [Char] -> Name
sMN Int
0 [Char]
"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 = [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
includeLibs ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ CodegenInfo -> [[Char]]
compileLibs CodegenInfo
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 :: Set Partial -> Text
doPartials Set Partial
x =
  Text -> [Text] -> Text
T.intercalate Text
"\n" ((Partial -> Text) -> [Partial] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Partial -> Text
f ([Partial] -> [Text]) -> [Partial] -> [Text]
forall a b. (a -> b) -> a -> b
$ Set Partial -> [Partial]
forall a. Set a -> [a]
Set.toList Set Partial
x)
  where
      f :: Partial -> Text
f p :: Partial
p@(Partial Name
n Int
i Int
j) =
        let vars1 :: [Text]
vars1 = (Int -> Text) -> [Int] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> Text
T.pack ([Char] -> Text) -> (Int -> [Char]) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"x"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([Char] -> [Char]) -> (Int -> [Char]) -> Int -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char]
forall a. Show a => a -> [Char]
show) [Int
1..Int
i]
            vars2 :: [Text]
vars2 = (Int -> Text) -> [Int] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> Text
T.pack ([Char] -> Text) -> (Int -> [Char]) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"x"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([Char] -> [Char]) -> (Int -> [Char]) -> Int -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char]
forall a. Show a => a -> [Char]
show) [(Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)..Int
j]
        in JsStmt -> Text
jsStmt2Text (JsStmt -> Text) -> JsStmt -> Text
forall a b. (a -> b) -> a -> b
$
             Text -> [Text] -> JsStmt -> JsStmt
JsFun (Partial -> Text
jsNamePartial Partial
p) [Text]
vars1 (JsStmt -> JsStmt) -> JsStmt -> JsStmt
forall a b. (a -> b) -> a -> b
$ JsExpr -> JsStmt
JsReturn (JsExpr -> JsStmt) -> JsExpr -> JsStmt
forall a b. (a -> b) -> a -> b
$
               [Text] -> JsExpr -> JsExpr
jsCurryLam [Text]
vars2 (Text -> [JsExpr] -> JsExpr
jsAppN (Name -> Text
jsName Name
n) ((Text -> JsExpr) -> [Text] -> [JsExpr]
forall a b. (a -> b) -> [a] -> [b]
map Text -> JsExpr
JsVar ([Text]
vars1 [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
vars2)) )

doHiddenClasses :: Set HiddenClass -> Text
doHiddenClasses :: Set HiddenClass -> Text
doHiddenClasses Set HiddenClass
x =
  Text -> [Text] -> Text
T.intercalate Text
"\n" ((HiddenClass -> Text) -> [HiddenClass] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map HiddenClass -> Text
f ([HiddenClass] -> [Text]) -> [HiddenClass] -> [Text]
forall a b. (a -> b) -> a -> b
$ Set HiddenClass -> [HiddenClass]
forall a. Set a -> [a]
Set.toList Set HiddenClass
x)
  where
      f :: HiddenClass -> Text
f p :: HiddenClass
p@(HiddenClass Name
n Int
id Int
0) = JsStmt -> Text
jsStmt2Text (JsStmt -> Text) -> JsStmt -> Text
forall a b. (a -> b) -> a -> b
$ Text -> JsExpr -> JsStmt
JsDecConst (HiddenClass -> Text
jsNameHiddenClass HiddenClass
p) (JsExpr -> JsStmt) -> JsExpr -> JsStmt
forall a b. (a -> b) -> a -> b
$ [(Text, JsExpr)] -> JsExpr
JsObj [(Text
"type", Int -> JsExpr
JsInt Int
id)]
      f p :: HiddenClass
p@(HiddenClass Name
n Int
id Int
arity) =
        let vars :: [Text]
vars = (Int -> Text) -> [Int] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Text
dataPartName ([Int] -> [Text]) -> [Int] -> [Text]
forall a b. (a -> b) -> a -> b
$ Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
arity [Int
1..]
        in JsStmt -> Text
jsStmt2Text (JsStmt -> Text) -> JsStmt -> Text
forall a b. (a -> b) -> a -> b
$
             Text -> [Text] -> JsStmt -> JsStmt
JsFun (HiddenClass -> Text
jsNameHiddenClass HiddenClass
p) [Text]
vars (JsStmt -> JsStmt) -> JsStmt -> JsStmt
forall a b. (a -> b) -> a -> b
$ JsStmt -> JsStmt -> JsStmt
JsSeq (JsExpr -> JsExpr -> JsStmt
JsSet (JsExpr -> Text -> JsExpr
JsProp JsExpr
JsThis Text
"type") (Int -> JsExpr
JsInt Int
id)) (JsStmt -> JsStmt) -> JsStmt -> JsStmt
forall a b. (a -> b) -> a -> b
$ [JsStmt] -> JsStmt
seqJs
               ([JsStmt] -> JsStmt) -> [JsStmt] -> JsStmt
forall a b. (a -> b) -> a -> b
$ (Text -> JsStmt) -> [Text] -> [JsStmt]
forall a b. (a -> b) -> [a] -> [b]
map (\Text
tv -> JsExpr -> JsExpr -> JsStmt
JsSet (JsExpr -> Text -> JsExpr
JsProp JsExpr
JsThis Text
tv) (Text -> JsExpr
JsVar Text
tv)) [Text]
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 :: Map Name LDecl -> [LDecl] -> (Text, CGStats)
doCodegen Map Name LDecl
defs = (LDecl -> (Text, CGStats)) -> [LDecl] -> (Text, CGStats)
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Map Name LDecl -> LDecl -> (Text, CGStats)
doCodegenDecl Map Name LDecl
defs)
  where
    doCodegenDecl :: Map Name LDecl -> LDecl -> (Text, CGStats)
    doCodegenDecl :: Map Name LDecl -> LDecl -> (Text, CGStats)
doCodegenDecl Map Name LDecl
defs (LFun [LOpt]
_ Name
name [Name]
args LExp
def) =
      let (JsStmt
ast, CGStats
stats) = Map Name LDecl -> Name -> [Name] -> LExp -> (JsStmt, CGStats)
cgFun Map Name LDecl
defs Name
name [Name]
args LExp
def
          fnComment :: Text
fnComment = JsStmt -> Text
jsStmt2Text (Text -> JsStmt
JsComment (Text -> JsStmt) -> Text -> JsStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Name -> [Char]
forall a. Show a => a -> [Char]
show Name
name)
      in ([Text] -> Text
T.concat [Text
fnComment, Text
"\n", JsStmt -> Text
jsStmt2Text JsStmt
ast, Text
"\n"], CGStats
stats)
    doCodegenDecl Map Name LDecl
defs (LConstructor Name
n Int
i Int
sz) = (Text
"", CGStats
forall a. Monoid a => a
mempty)


seqJs :: [JsStmt] -> JsStmt
seqJs :: [JsStmt] -> JsStmt
seqJs [] = JsStmt
JsEmpty
seqJs (JsStmt
x:[JsStmt]
xs) = JsStmt -> JsStmt -> JsStmt
JsSeq JsStmt
x ([JsStmt] -> JsStmt
seqJs [JsStmt]
xs)


data CGBodyState = CGBodyState { CGBodyState -> Map Name LDecl
defs :: Map Name LDecl
                               , CGBodyState -> Int
lastIntName :: Int
                               , CGBodyState -> Map Name JsExpr
reWrittenNames :: Map.Map Name JsExpr
                               , CGBodyState -> (Text, [Text])
currentFnNameAndArgs :: (Text, [Text])
                               , CGBodyState -> Set (Text, Text)
usedArgsTailCallOptim :: Set (Text, Text)
                               , CGBodyState -> Bool
isTailRec :: Bool
                               , CGBodyState -> Bool
usedITBig :: Bool
                               , CGBodyState -> Set Partial
partialApps :: Set Partial
                               , CGBodyState -> Set HiddenClass
hiddenCls :: Set HiddenClass
                               }

getNewCGName :: State CGBodyState Text
getNewCGName :: State CGBodyState Text
getNewCGName =
  do
    st <- StateT CGBodyState Identity CGBodyState
forall (m :: * -> *) s. Monad m => StateT s m s
get
    let v = CGBodyState -> Int
lastIntName CGBodyState
st Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
    put $ st {lastIntName = v}
    return $ jsNameGenerated v

addPartial :: Partial -> State CGBodyState ()
addPartial :: Partial -> StateT CGBodyState Identity ()
addPartial Partial
p =
  (CGBodyState -> CGBodyState) -> StateT CGBodyState Identity ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (\CGBodyState
s -> CGBodyState
s {partialApps = Set.insert p (partialApps s) })

addHiddenClass :: HiddenClass -> State CGBodyState ()
addHiddenClass :: HiddenClass -> StateT CGBodyState Identity ()
addHiddenClass HiddenClass
p =
  (CGBodyState -> CGBodyState) -> StateT CGBodyState Identity ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (\CGBodyState
s -> CGBodyState
s {hiddenCls = Set.insert p (hiddenCls s) })

addUsedArgsTailCallOptim :: Set (Text, Text) -> State CGBodyState ()
addUsedArgsTailCallOptim :: Set (Text, Text) -> StateT CGBodyState Identity ()
addUsedArgsTailCallOptim Set (Text, Text)
p =
  (CGBodyState -> CGBodyState) -> StateT CGBodyState Identity ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (\CGBodyState
s -> CGBodyState
s {usedArgsTailCallOptim = Set.union p (usedArgsTailCallOptim s) })

getConsId :: Name -> State CGBodyState (Int, Int)
getConsId :: Name -> State CGBodyState (Int, Int)
getConsId Name
n =
    do
      st <- StateT CGBodyState Identity CGBodyState
forall (m :: * -> *) s. Monad m => StateT s m s
get
      case Map.lookup n (defs st) of
        Just (LConstructor Name
_ Int
conId Int
arity) -> (Int, Int) -> State CGBodyState (Int, Int)
forall a. a -> StateT CGBodyState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
conId, Int
arity)
        Maybe LDecl
_ -> [Char] -> State CGBodyState (Int, Int)
forall a. HasCallStack => [Char] -> a
error ([Char] -> State CGBodyState (Int, Int))
-> [Char] -> State CGBodyState (Int, Int)
forall a b. (a -> b) -> a -> b
$ [Char]
"Internal JS Backend error " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
showCG Name
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" is not a constructor."

getArgList' :: Name -> Map Name LDecl -> Maybe [Name]
getArgList' :: Name -> Map Name LDecl -> Maybe [Name]
getArgList' Name
n Map Name LDecl
defs =
    case Name -> Map Name LDecl -> Maybe LDecl
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
n Map Name LDecl
defs of
      Just (LFun [LOpt]
_ Name
_ [Name]
a LExp
_) -> [Name] -> Maybe [Name]
forall a. a -> Maybe a
Just [Name]
a
      Maybe LDecl
_ -> Maybe [Name]
forall a. Maybe a
Nothing

getArgList :: Name -> State CGBodyState (Maybe [Name])
getArgList :: Name -> State CGBodyState (Maybe [Name])
getArgList Name
n =
  do
    st <- StateT CGBodyState Identity CGBodyState
forall (m :: * -> *) s. Monad m => StateT s m s
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 :: Map Name LDecl -> Name -> [Name] -> LExp -> (JsStmt, CGStats)
cgFun Map Name LDecl
dfs Name
n [Name]
args LExp
def = do
  let fnName :: Text
fnName = Name -> Text
jsName Name
n
  let argNames :: [Text]
argNames = (Name -> Text) -> [Name] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Text
jsName [Name]
args
  let (([JsStmt]
decs, JsStmt
res),CGBodyState
st) = State CGBodyState ([JsStmt], JsStmt)
-> CGBodyState -> (([JsStmt], JsStmt), CGBodyState)
forall s a. State s a -> s -> (a, s)
runState
                          (BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
cgBody BodyResTarget
ReturnBT LExp
def)
                          (CGBodyState { defs :: Map Name LDecl
defs = Map Name LDecl
dfs
                                       , lastIntName :: Int
lastIntName = Int
0
                                       , reWrittenNames :: Map Name JsExpr
reWrittenNames = Map Name JsExpr
forall k a. Map k a
Map.empty
                                       , currentFnNameAndArgs :: (Text, [Text])
currentFnNameAndArgs = (Text
fnName, [Text]
argNames)
                                       , usedArgsTailCallOptim :: Set (Text, Text)
usedArgsTailCallOptim = Set (Text, Text)
forall a. Set a
Set.empty
                                       , isTailRec :: Bool
isTailRec = Bool
False
                                       , usedITBig :: Bool
usedITBig = Bool
False
                                       , partialApps :: Set Partial
partialApps = Set Partial
forall a. Set a
Set.empty
                                       , hiddenCls :: Set HiddenClass
hiddenCls = Set HiddenClass
forall a. Set a
Set.empty
                                       }
                          )
  let body :: JsStmt
body = if CGBodyState -> Bool
isTailRec CGBodyState
st then JsStmt -> JsStmt -> JsStmt
JsSeq (Set (Text, Text) -> JsStmt
declareUsedOptimArgs (Set (Text, Text) -> JsStmt) -> Set (Text, Text) -> JsStmt
forall a b. (a -> b) -> a -> b
$ CGBodyState -> Set (Text, Text)
usedArgsTailCallOptim CGBodyState
st) (JsStmt -> JsStmt
JsForever (([JsStmt] -> JsStmt
seqJs [JsStmt]
decs) JsStmt -> JsStmt -> JsStmt
`JsSeq` JsStmt
res)) else ([JsStmt] -> JsStmt
seqJs [JsStmt]
decs) JsStmt -> JsStmt -> JsStmt
`JsSeq` JsStmt
res
  let fn :: JsStmt
fn = Text -> [Text] -> JsStmt -> JsStmt
JsFun Text
fnName [Text]
argNames JsStmt
body
  let state' :: CGStats
state' = CGStats { partialApplications :: Set Partial
partialApplications = CGBodyState -> Set Partial
partialApps CGBodyState
st
                       , hiddenClasses :: Set HiddenClass
hiddenClasses = CGBodyState -> Set HiddenClass
hiddenCls CGBodyState
st
                       , usedBigInt :: Bool
usedBigInt = CGBodyState -> Bool
usedITBig CGBodyState
st
                       }
  (JsStmt
fn, CGStats
state')

addRT :: BodyResTarget -> JsExpr -> JsStmt
addRT :: BodyResTarget -> JsExpr -> JsStmt
addRT BodyResTarget
ReturnBT JsExpr
x = JsExpr -> JsStmt
JsReturn JsExpr
x
addRT (DecBT Text
n) JsExpr
x = Text -> JsExpr -> JsStmt
JsDecLet Text
n JsExpr
x
addRT (DecConstBT Text
n) JsExpr
x = Text -> JsExpr -> JsStmt
JsDecConst Text
n JsExpr
x
addRT (SetBT Text
n) JsExpr
x = JsExpr -> JsExpr -> JsStmt
JsSet (Text -> JsExpr
JsVar Text
n) JsExpr
x
addRT BodyResTarget
GetExpBT JsExpr
x = JsExpr -> JsStmt
JsExprStmt JsExpr
x

declareUsedOptimArgs :: Set (Text, Text) -> JsStmt
declareUsedOptimArgs :: Set (Text, Text) -> JsStmt
declareUsedOptimArgs Set (Text, Text)
x = [JsStmt] -> JsStmt
seqJs ([JsStmt] -> JsStmt) -> [JsStmt] -> JsStmt
forall a b. (a -> b) -> a -> b
$ ((Text, Text) -> JsStmt) -> [(Text, Text)] -> [JsStmt]
forall a b. (a -> b) -> [a] -> [b]
map (\(Text
x,Text
y) -> Text -> JsExpr -> JsStmt
JsDecLet Text
x (Text -> JsExpr
JsVar Text
y) ) (Set (Text, Text) -> [(Text, Text)]
forall a. Set a -> [a]
Set.toList Set (Text, Text)
x)

tailCallOptimRefreshArgs :: [(Text, JsExpr)] -> Set Text -> ((JsStmt, JsStmt), Set (Text, Text))
tailCallOptimRefreshArgs :: [(Text, JsExpr)]
-> Set Text -> ((JsStmt, JsStmt), Set (Text, Text))
tailCallOptimRefreshArgs [] Set Text
s = ((JsStmt
JsEmpty, JsStmt
JsEmpty), Set (Text, Text)
forall a. Set a
Set.empty)
tailCallOptimRefreshArgs ((Text
n,JsExpr
x):[(Text, JsExpr)]
r) Set Text
s =
  let ((JsStmt
y1,JsStmt
y2), Set (Text, Text)
y3) = [(Text, JsExpr)]
-> Set Text -> ((JsStmt, JsStmt), Set (Text, Text))
tailCallOptimRefreshArgs [(Text, JsExpr)]
r (Text -> Set Text -> Set Text
forall a. Ord a => a -> Set a -> Set a
Set.insert Text
n Set Text
s) --
  in if Set Text -> Bool
forall a. Set a -> Bool
Set.null (Set Text -> Bool) -> Set Text -> Bool
forall a b. (a -> b) -> a -> b
$ ([Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList [ Text
z | Text
z <- JsExpr -> [Text]
forall from to. Biplate from to => from -> [to]
universeBi JsExpr
x ]) Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection` Set Text
s then
      ((JsStmt
y1, Text -> JsExpr -> JsStmt
jsSetVar Text
n JsExpr
x JsStmt -> JsStmt -> JsStmt
`JsSeq` JsStmt
y2), Set (Text, Text)
y3)
      else
        let n' :: Text
n' = Text -> Text
jsTailCallOptimName Text
n
        in ((Text -> JsExpr -> JsStmt
jsSetVar Text
n' JsExpr
x JsStmt -> JsStmt -> JsStmt
`JsSeq` JsStmt
y1, Text -> JsExpr -> JsStmt
jsSetVar Text
n (Text -> JsExpr
JsVar Text
n') JsStmt -> JsStmt -> JsStmt
`JsSeq` JsStmt
y2), (Text, Text) -> Set (Text, Text) -> Set (Text, Text)
forall a. Ord a => a -> Set a -> Set a
Set.insert (Text
n',Text
n) Set (Text, Text)
y3)

cgName :: Name -> State CGBodyState JsExpr
cgName :: Name -> State CGBodyState JsExpr
cgName Name
b = do
  st <- StateT CGBodyState Identity CGBodyState
forall (m :: * -> *) s. Monad m => StateT s m s
get
  case Map.lookup b (reWrittenNames st) of
    Just JsExpr
e -> JsExpr -> State CGBodyState JsExpr
forall a. a -> StateT CGBodyState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JsExpr
e
    Maybe JsExpr
_ -> JsExpr -> State CGBodyState JsExpr
forall a. a -> StateT CGBodyState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JsExpr -> State CGBodyState JsExpr)
-> JsExpr -> State CGBodyState JsExpr
forall a b. (a -> b) -> a -> b
$ Text -> JsExpr
JsVar (Text -> JsExpr) -> Text -> JsExpr
forall a b. (a -> b) -> a -> b
$ Name -> Text
jsName Name
b

cgBody :: BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
cgBody :: BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
cgBody BodyResTarget
rt LExp
expr =
  case LExp
expr of
    (LCase CaseType
_ (LOp PrimFn
oper [LExp
x, LExp
y]) [LConstCase (I Int
0) (LCon Maybe Name
_ Int
_ Name
ff []), LDefaultCase (LCon Maybe Name
_ Int
_ Name
tt [])])
      | (Name
ff Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> [Char] -> Name
qualifyN [Char]
"Prelude.Bool" [Char]
"False" Bool -> Bool -> Bool
&&
         Name
tt Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> [Char] -> Name
qualifyN [Char]
"Prelude.Bool" [Char]
"True") ->
        case (PrimFn -> Map PrimFn PrimDec -> Maybe PrimDec
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PrimFn
oper Map PrimFn PrimDec
primDB) of
          Just (Bool
needBI, JsPrimTy
pti, [JsExpr] -> JsExpr
c) | JsPrimTy
pti JsPrimTy -> JsPrimTy -> Bool
forall a. Eq a => a -> a -> Bool
== JsPrimTy
PTBool -> do
            z <- (LExp -> State CGBodyState ([JsStmt], JsStmt))
-> [LExp] -> StateT CGBodyState Identity [([JsStmt], JsStmt)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
cgBody BodyResTarget
GetExpBT) [LExp
x, LExp
y]
            when needBI setUsedITBig
            let res = JsPrimTy -> JsPrimTy -> JsExpr -> JsExpr
jsPrimCoerce JsPrimTy
pti JsPrimTy
PTBool (JsExpr -> JsExpr) -> JsExpr -> JsExpr
forall a b. (a -> b) -> a -> b
$ [JsExpr] -> JsExpr
c ([JsExpr] -> JsExpr) -> [JsExpr] -> JsExpr
forall a b. (a -> b) -> a -> b
$ (([JsStmt], JsStmt) -> JsExpr) -> [([JsStmt], JsStmt)] -> [JsExpr]
forall a b. (a -> b) -> [a] -> [b]
map (JsStmt -> JsExpr
jsStmt2Expr (JsStmt -> JsExpr)
-> (([JsStmt], JsStmt) -> JsStmt) -> ([JsStmt], JsStmt) -> JsExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([JsStmt], JsStmt) -> JsStmt
forall a b. (a, b) -> b
snd) [([JsStmt], JsStmt)]
z
            pure $ (concat $ map fst z, addRT rt res)
          Maybe PrimDec
_ -> BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
cgBody' BodyResTarget
rt LExp
expr
    (LCase CaseType
_ LExp
e [LConCase Int
_ Name
n [Name]
_ (LCon Maybe Name
_ Int
_ Name
tt []), LDefaultCase (LCon Maybe Name
_ Int
_ Name
ff [])])
      | (Name
ff Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> [Char] -> Name
qualifyN [Char]
"Prelude.Bool" [Char]
"False" Bool -> Bool -> Bool
&&
         Name
tt Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> [Char] -> Name
qualifyN [Char]
"Prelude.Bool" [Char]
"True") -> do
           (d, v) <- BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
cgBody BodyResTarget
GetExpBT LExp
e
           test <- formConTest n (jsStmt2Expr v)
           pure $ (d, addRT rt $ JsUniOp (T.pack "!") $ JsUniOp (T.pack "!") test)
    (LCase CaseType
_ LExp
e [LConCase Int
_ Name
n [Name]
_ (LCon Maybe Name
_ Int
_ Name
tt []), LConCase Int
_ Name
_ [Name]
_ (LCon Maybe Name
_ Int
_ Name
ff [])])
      | (Name
ff Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> [Char] -> Name
qualifyN [Char]
"Prelude.Bool" [Char]
"False" Bool -> Bool -> Bool
&&
         Name
tt Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> [Char] -> Name
qualifyN [Char]
"Prelude.Bool" [Char]
"True") -> do
           (d, v) <- BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
cgBody BodyResTarget
GetExpBT LExp
e
           test <- formConTest n (jsStmt2Expr v)
           pure $ (d, addRT rt $ JsUniOp (T.pack "!") $ JsUniOp (T.pack "!") test)
    (LCase CaseType
_ LExp
e [LConCase Int
_ Name
n [Name]
_ (LCon Maybe Name
_ Int
_ Name
ff []), LDefaultCase (LCon Maybe Name
_ Int
_ Name
tt [])])
      | (Name
ff Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> [Char] -> Name
qualifyN [Char]
"Prelude.Bool" [Char]
"False" Bool -> Bool -> Bool
&&
         Name
tt Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> [Char] -> Name
qualifyN [Char]
"Prelude.Bool" [Char]
"True") -> do
           (d, v) <- BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
cgBody BodyResTarget
GetExpBT LExp
e
           test <- formConTest n (jsStmt2Expr v)
           pure $ (d, addRT rt $ JsUniOp (T.pack "!") test)
    (LCase CaseType
_ LExp
e [LConCase Int
_ Name
n [Name]
_ (LCon Maybe Name
_ Int
_ Name
ff []), LConCase Int
_ Name
_ [Name]
_ (LCon Maybe Name
_ Int
_ Name
tt [])])
      | (Name
ff Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> [Char] -> Name
qualifyN [Char]
"Prelude.Bool" [Char]
"False" Bool -> Bool -> Bool
&&
         Name
tt Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> [Char] -> Name
qualifyN [Char]
"Prelude.Bool" [Char]
"True") -> do
           (d, v) <- BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
cgBody BodyResTarget
GetExpBT LExp
e
           test <- formConTest n (jsStmt2Expr v)
           pure $ (d, addRT rt $ JsUniOp (T.pack "!") test)
    (LCase CaseType
f LExp
e [LConCase Int
nf Name
ff [] LExp
alt, LConCase Int
nt Name
tt [] LExp
conseq])
      | (Name
ff Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> [Char] -> Name
qualifyN [Char]
"Prelude.Bool" [Char]
"False" Bool -> Bool -> Bool
&&
         Name
tt Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> [Char] -> Name
qualifyN [Char]
"Prelude.Bool" [Char]
"True") ->
        BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
cgBody' BodyResTarget
rt (LExp -> State CGBodyState ([JsStmt], JsStmt))
-> LExp -> State CGBodyState ([JsStmt], JsStmt)
forall a b. (a -> b) -> a -> b
$ CaseType -> LExp -> [LAlt] -> LExp
LCase CaseType
f LExp
e [Int -> Name -> [Name] -> LExp -> LAlt
forall e. Int -> Name -> [Name] -> e -> LAlt' e
LConCase Int
nt Name
tt [] LExp
conseq, Int -> Name -> [Name] -> LExp -> LAlt
forall e. Int -> Name -> [Name] -> e -> LAlt' e
LConCase Int
nf Name
ff [] LExp
alt]
    LExp
expr -> BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
cgBody' BodyResTarget
rt LExp
expr

cgBody' :: BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
cgBody' :: BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
cgBody' BodyResTarget
rt (LV Name
n) =
  do
    argsFn <- Name -> State CGBodyState (Maybe [Name])
getArgList Name
n
    case argsFn of
      Just [Name]
a -> BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
cgBody' BodyResTarget
rt (Bool -> LExp -> [LExp] -> LExp
LApp Bool
False (Name -> LExp
LV Name
n) [])
      Maybe [Name]
Nothing -> do
        n' <- Name -> State CGBodyState JsExpr
cgName Name
n
        pure $ ([], addRT rt n')
cgBody' BodyResTarget
rt (LApp Bool
tailcall (LV Name
fn) [LExp]
args) =
  do
    let fname :: Text
fname = Name -> Text
jsName Name
fn
    st <- StateT CGBodyState Identity CGBodyState
forall (m :: * -> *) s. Monad m => StateT s m s
get
    let (currFn, argN) = currentFnNameAndArgs st
    z <- mapM (cgBody GetExpBT) args
    let argVals = (([JsStmt], JsStmt) -> JsExpr) -> [([JsStmt], JsStmt)] -> [JsExpr]
forall a b. (a -> b) -> [a] -> [b]
map (JsStmt -> JsExpr
jsStmt2Expr (JsStmt -> JsExpr)
-> (([JsStmt], JsStmt) -> JsStmt) -> ([JsStmt], JsStmt) -> JsExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([JsStmt], JsStmt) -> JsStmt
forall a b. (a, b) -> b
snd) [([JsStmt], JsStmt)]
z
    let preDecs = [[JsStmt]] -> [JsStmt]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[JsStmt]] -> [JsStmt]) -> [[JsStmt]] -> [JsStmt]
forall a b. (a -> b) -> a -> b
$ (([JsStmt], JsStmt) -> [JsStmt])
-> [([JsStmt], JsStmt)] -> [[JsStmt]]
forall a b. (a -> b) -> [a] -> [b]
map ([JsStmt], JsStmt) -> [JsStmt]
forall a b. (a, b) -> a
fst [([JsStmt], JsStmt)]
z
    case (fname == currFn && (length args) == (length argN), rt) of
      (Bool
True, BodyResTarget
ReturnBT) ->
        do
          (CGBodyState -> CGBodyState) -> StateT CGBodyState Identity ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (\CGBodyState
x-> CGBodyState
x {isTailRec = True})
          let ((JsStmt
y1,JsStmt
y2), Set (Text, Text)
y3) = [(Text, JsExpr)]
-> Set Text -> ((JsStmt, JsStmt), Set (Text, Text))
tailCallOptimRefreshArgs ([Text] -> [JsExpr] -> [(Text, JsExpr)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
argN [JsExpr]
argVals) Set Text
forall a. Set a
Set.empty
          Set (Text, Text) -> StateT CGBodyState Identity ()
addUsedArgsTailCallOptim Set (Text, Text)
y3
          ([JsStmt], JsStmt) -> State CGBodyState ([JsStmt], JsStmt)
forall a. a -> StateT CGBodyState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([JsStmt]
preDecs, JsStmt
y1 JsStmt -> JsStmt -> JsStmt
`JsSeq` JsStmt
y2)
      (Bool, BodyResTarget)
_ -> do
        app <- Name -> [JsExpr] -> State CGBodyState JsExpr
formApp Name
fn [JsExpr]
argVals
        pure (preDecs, addRT rt app)

cgBody' BodyResTarget
rt (LForce (LLazyApp Name
n [LExp]
args)) = BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
cgBody BodyResTarget
rt (Bool -> LExp -> [LExp] -> LExp
LApp Bool
False (Name -> LExp
LV Name
n) [LExp]
args)
cgBody' BodyResTarget
rt (LLazyApp Name
n [LExp]
args) =
  do
    (d,v) <- BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
cgBody BodyResTarget
ReturnBT (Bool -> LExp -> [LExp] -> LExp
LApp Bool
False (Name -> LExp
LV Name
n) [LExp]
args)
    pure ([], addRT rt $ jsLazy $ jsStmt2Expr $ JsSeq (seqJs d) v)
cgBody' BodyResTarget
rt (LForce LExp
e) =
  do
    (d,v) <- BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
cgBody BodyResTarget
GetExpBT LExp
e
    pure (d, addRT rt $ JsForce $ jsStmt2Expr v)
cgBody' BodyResTarget
rt (LLet Name
n LExp
v LExp
sc) =
  do
    (d1, v1) <- BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
cgBody (Text -> BodyResTarget
DecConstBT (Text -> BodyResTarget) -> Text -> BodyResTarget
forall a b. (a -> b) -> a -> b
$ Name -> Text
jsName Name
n) LExp
v
    (d2, v2) <- cgBody rt sc
    pure $ ((d1 ++ v1 : d2), v2)
cgBody' BodyResTarget
rt (LProj LExp
e Int
i) =
  do
    (d, v) <- BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
cgBody BodyResTarget
GetExpBT LExp
e
    pure $ (d, addRT rt $ JsArrayProj (JsInt $ i+1) $ jsStmt2Expr v)
cgBody' BodyResTarget
rt (LCon Maybe Name
_  Int
conId Name
n [LExp]
args) =
  do
    z <- (LExp -> State CGBodyState ([JsStmt], JsStmt))
-> [LExp] -> StateT CGBodyState Identity [([JsStmt], JsStmt)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
cgBody BodyResTarget
GetExpBT) [LExp]
args
    con <- formCon n (map (jsStmt2Expr . snd) z)
    pure $ (concat $ map fst z, addRT rt con)
cgBody' BodyResTarget
rt (LCase CaseType
_ LExp
e [LAlt]
alts) = do
  (d, v) <- BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
cgBody BodyResTarget
GetExpBT LExp
e
  resName <- getNewCGName
  (decSw, entry) <-
    case (all altHasNoProj alts && length alts <= 2, v) of
      (Bool
True, JsStmt
_) -> (JsStmt, JsExpr) -> StateT CGBodyState Identity (JsStmt, JsExpr)
forall a. a -> StateT CGBodyState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JsStmt
JsEmpty, JsStmt -> JsExpr
jsStmt2Expr JsStmt
v)
      (Bool
False, JsExprStmt (JsVar Text
n)) -> (JsStmt, JsExpr) -> StateT CGBodyState Identity (JsStmt, JsExpr)
forall a. a -> StateT CGBodyState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JsStmt
JsEmpty, JsStmt -> JsExpr
jsStmt2Expr JsStmt
v)
      (Bool, JsStmt)
_ -> do
        swName <- State CGBodyState Text
getNewCGName
        pure (JsDecConst swName $ jsStmt2Expr v, JsVar swName)
  sw' <- cgIfTree rt resName entry alts
  let sw =
        case Maybe JsStmt
sw' of
          (Just JsStmt
x) -> JsStmt
x
          Maybe JsStmt
Nothing -> JsExpr -> JsStmt
JsExprStmt JsExpr
JsNull
  case rt of
    BodyResTarget
ReturnBT -> ([JsStmt], JsStmt) -> State CGBodyState ([JsStmt], JsStmt)
forall a. a -> StateT CGBodyState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([JsStmt]
d [JsStmt] -> [JsStmt] -> [JsStmt]
forall a. [a] -> [a] -> [a]
++ [JsStmt
decSw], JsStmt
sw)
    (DecBT Text
nvar) -> ([JsStmt], JsStmt) -> State CGBodyState ([JsStmt], JsStmt)
forall a. a -> StateT CGBodyState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([JsStmt]
d [JsStmt] -> [JsStmt] -> [JsStmt]
forall a. [a] -> [a] -> [a]
++ [JsStmt
decSw, Text -> JsExpr -> JsStmt
JsDecLet Text
nvar JsExpr
JsNull], JsStmt
sw)
    (DecConstBT Text
nvar) -> ([JsStmt], JsStmt) -> State CGBodyState ([JsStmt], JsStmt)
forall a. a -> StateT CGBodyState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([JsStmt]
d [JsStmt] -> [JsStmt] -> [JsStmt]
forall a. [a] -> [a] -> [a]
++ [JsStmt
decSw, Text -> JsExpr -> JsStmt
JsDecLet Text
nvar JsExpr
JsNull], JsStmt
sw)
    (SetBT Text
nvar) -> ([JsStmt], JsStmt) -> State CGBodyState ([JsStmt], JsStmt)
forall a. a -> StateT CGBodyState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([JsStmt]
d [JsStmt] -> [JsStmt] -> [JsStmt]
forall a. [a] -> [a] -> [a]
++ [JsStmt
decSw], JsStmt
sw)
    BodyResTarget
GetExpBT ->
      ([JsStmt], JsStmt) -> State CGBodyState ([JsStmt], JsStmt)
forall a. a -> StateT CGBodyState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ([JsStmt]
d [JsStmt] -> [JsStmt] -> [JsStmt]
forall a. [a] -> [a] -> [a]
++ [JsStmt
decSw, Text -> JsExpr -> JsStmt
JsDecLet Text
resName JsExpr
JsNull, JsStmt
sw], JsExpr -> JsStmt
JsExprStmt (JsExpr -> JsStmt) -> JsExpr -> JsStmt
forall a b. (a -> b) -> a -> b
$ Text -> JsExpr
JsVar Text
resName)
cgBody' BodyResTarget
rt (LConst Const
c) =
  do
     cst <- Const -> State CGBodyState JsExpr
cgConst Const
c
     pure ([], (addRT rt) $ cst)
cgBody' BodyResTarget
rt (LOp PrimFn
op [LExp]
args) =
  do
    z <- (LExp -> State CGBodyState ([JsStmt], JsStmt))
-> [LExp] -> StateT CGBodyState Identity [([JsStmt], JsStmt)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
cgBody BodyResTarget
GetExpBT) [LExp]
args
    res <- cgOp op (map (jsStmt2Expr . snd) z)
    pure $ (concat $ map fst z, addRT rt $ res)
cgBody' BodyResTarget
rt LExp
LNothing = ([JsStmt], JsStmt) -> State CGBodyState ([JsStmt], JsStmt)
forall a. a -> StateT CGBodyState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], BodyResTarget -> JsExpr -> JsStmt
addRT BodyResTarget
rt JsExpr
JsNull)
cgBody' BodyResTarget
rt (LError [Char]
x) = ([JsStmt], JsStmt) -> State CGBodyState ([JsStmt], JsStmt)
forall a. a -> StateT CGBodyState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], JsExpr -> JsStmt
JsError (JsExpr -> JsStmt) -> JsExpr -> JsStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> JsExpr
JsStr [Char]
x)
cgBody' BodyResTarget
rt x :: LExp
x@(LForeign FDesc
dres (FStr [Char]
code) [(FDesc, LExp)]
args ) =
  do
    z <- (LExp -> State CGBodyState ([JsStmt], JsStmt))
-> [LExp] -> StateT CGBodyState Identity [([JsStmt], JsStmt)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
cgBody BodyResTarget
GetExpBT) (((FDesc, LExp) -> LExp) -> [(FDesc, LExp)] -> [LExp]
forall a b. (a -> b) -> [a] -> [b]
map (FDesc, LExp) -> LExp
forall a b. (a, b) -> b
snd [(FDesc, LExp)]
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' BodyResTarget
_ LExp
x = [Char] -> State CGBodyState ([JsStmt], JsStmt)
forall a. HasCallStack => [Char] -> a
error ([Char] -> State CGBodyState ([JsStmt], JsStmt))
-> [Char] -> State CGBodyState ([JsStmt], JsStmt)
forall a b. (a -> b) -> a -> b
$ [Char]
"Instruction " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ LExp -> [Char]
forall a. Show a => a -> [Char]
show LExp
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" not compilable yet"

altsRT :: Text -> BodyResTarget -> BodyResTarget
altsRT :: Text -> BodyResTarget -> BodyResTarget
altsRT Text
rn BodyResTarget
ReturnBT = BodyResTarget
ReturnBT
altsRT Text
rn (DecBT Text
n) = Text -> BodyResTarget
SetBT Text
n
altsRT Text
rn (SetBT Text
n) = Text -> BodyResTarget
SetBT Text
n
altsRT Text
rn (DecConstBT Text
n) = Text -> BodyResTarget
SetBT Text
n
altsRT Text
rn BodyResTarget
GetExpBT = Text -> BodyResTarget
SetBT Text
rn

altHasNoProj :: LAlt -> Bool
altHasNoProj :: LAlt -> Bool
altHasNoProj (LConCase Int
_ Name
_ [Name]
args LExp
_) = [Name]
args [Name] -> [Name] -> Bool
forall a. Eq a => a -> a -> Bool
== []
altHasNoProj LAlt
_ = Bool
True

formApp :: Name -> [JsExpr] -> State CGBodyState JsExpr
formApp :: Name -> [JsExpr] -> State CGBodyState JsExpr
formApp Name
fn [JsExpr]
argVals = case Name -> Maybe SSig
specialCall Name
fn of
  Just (Int
arity, [JsExpr] -> JsExpr
g) | Int
arity Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [JsExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [JsExpr]
argVals -> JsExpr -> State CGBodyState JsExpr
forall a. a -> StateT CGBodyState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JsExpr -> State CGBodyState JsExpr)
-> JsExpr -> State CGBodyState JsExpr
forall a b. (a -> b) -> a -> b
$ [JsExpr] -> JsExpr
g [JsExpr]
argVals
  Maybe SSig
_ -> do
    argsFn <- Name -> State CGBodyState (Maybe [Name])
getArgList Name
fn
    fname <- cgName fn
    case argsFn of
      Maybe [Name]
Nothing -> JsExpr -> State CGBodyState JsExpr
forall a. a -> StateT CGBodyState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JsExpr -> State CGBodyState JsExpr)
-> JsExpr -> State CGBodyState JsExpr
forall a b. (a -> b) -> a -> b
$ JsExpr -> [JsExpr] -> JsExpr
jsCurryApp JsExpr
fname [JsExpr]
argVals
      Just [Name]
agFn -> do
        let lenAgFn :: Int
lenAgFn = [Name] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
agFn
        let lenArgs :: Int
lenArgs = [JsExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [JsExpr]
argVals
        case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
lenAgFn Int
lenArgs of
          Ordering
EQ -> JsExpr -> State CGBodyState JsExpr
forall a. a -> StateT CGBodyState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JsExpr -> State CGBodyState JsExpr)
-> JsExpr -> State CGBodyState JsExpr
forall a b. (a -> b) -> a -> b
$ JsExpr -> [JsExpr] -> JsExpr
JsApp JsExpr
fname [JsExpr]
argVals
          Ordering
LT -> JsExpr -> State CGBodyState JsExpr
forall a. a -> StateT CGBodyState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JsExpr -> State CGBodyState JsExpr)
-> JsExpr -> State CGBodyState JsExpr
forall a b. (a -> b) -> a -> b
$ JsExpr -> [JsExpr] -> JsExpr
jsCurryApp (JsExpr -> [JsExpr] -> JsExpr
JsApp JsExpr
fname (Int -> [JsExpr] -> [JsExpr]
forall a. Int -> [a] -> [a]
take Int
lenAgFn [JsExpr]
argVals)) (Int -> [JsExpr] -> [JsExpr]
forall a. Int -> [a] -> [a]
drop Int
lenAgFn [JsExpr]
argVals)
          Ordering
GT -> do
            let part :: Partial
part = Name -> Int -> Int -> Partial
Partial Name
fn Int
lenArgs Int
lenAgFn
            Partial -> StateT CGBodyState Identity ()
addPartial Partial
part
            JsExpr -> State CGBodyState JsExpr
forall a. a -> StateT CGBodyState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JsExpr -> State CGBodyState JsExpr)
-> JsExpr -> State CGBodyState JsExpr
forall a b. (a -> b) -> a -> b
$ Text -> [JsExpr] -> JsExpr
jsAppN (Partial -> Text
jsNamePartial Partial
part) [JsExpr]
argVals

formCon :: Name -> [JsExpr] -> State CGBodyState JsExpr
formCon :: Name -> [JsExpr] -> State CGBodyState JsExpr
formCon Name
n [JsExpr]
args = do
  case Name -> Maybe ([JsExpr] -> JsExpr, JsExpr -> JsExpr, SProj)
specialCased Name
n of
    Just ([JsExpr] -> JsExpr
ctor, JsExpr -> JsExpr
test, SProj
match) -> JsExpr -> State CGBodyState JsExpr
forall a. a -> StateT CGBodyState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JsExpr -> State CGBodyState JsExpr)
-> JsExpr -> State CGBodyState JsExpr
forall a b. (a -> b) -> a -> b
$ [JsExpr] -> JsExpr
ctor [JsExpr]
args
    Maybe ([JsExpr] -> JsExpr, JsExpr -> JsExpr, SProj)
Nothing -> do
      (conId, arity) <- Name -> State CGBodyState (Int, Int)
getConsId Name
n
      let hc = Name -> Int -> Int -> HiddenClass
HiddenClass Name
n Int
conId Int
arity
      addHiddenClass hc
      pure $ if (arity > 0)
        then JsNew (JsVar $ jsNameHiddenClass hc) args
        else JsVar $ jsNameHiddenClass hc

formConTest :: Name -> JsExpr -> State CGBodyState JsExpr
formConTest :: Name -> JsExpr -> State CGBodyState JsExpr
formConTest Name
n JsExpr
x = do
  case Name -> Maybe ([JsExpr] -> JsExpr, JsExpr -> JsExpr, SProj)
specialCased Name
n of
    Just ([JsExpr] -> JsExpr
ctor, JsExpr -> JsExpr
test, SProj
match) -> JsExpr -> State CGBodyState JsExpr
forall a. a -> StateT CGBodyState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JsExpr -> State CGBodyState JsExpr)
-> JsExpr -> State CGBodyState JsExpr
forall a b. (a -> b) -> a -> b
$ JsExpr -> JsExpr
test JsExpr
x
    Maybe ([JsExpr] -> JsExpr, JsExpr -> JsExpr, SProj)
Nothing -> do
      (conId, arity) <- Name -> State CGBodyState (Int, Int)
getConsId Name
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 :: Name -> SProj
formProj Name
n JsExpr
v Int
i =
  case Name -> Maybe ([JsExpr] -> JsExpr, JsExpr -> JsExpr, SProj)
specialCased Name
n of
    Just ([JsExpr] -> JsExpr
ctor, JsExpr -> JsExpr
test, SProj
proj) -> SProj
proj JsExpr
v Int
i
    Maybe ([JsExpr] -> JsExpr, JsExpr -> JsExpr, SProj)
Nothing -> JsExpr -> Text -> JsExpr
JsProp JsExpr
v (Int -> Text
dataPartName Int
i)

smartif :: JsExpr -> JsStmt -> Maybe JsStmt -> JsStmt
smartif :: JsExpr -> JsStmt -> Maybe JsStmt -> JsStmt
smartif JsExpr
cond JsStmt
conseq (Just JsStmt
alt) = JsExpr -> JsStmt -> Maybe JsStmt -> JsStmt
JsIf JsExpr
cond JsStmt
conseq (JsStmt -> Maybe JsStmt
forall a. a -> Maybe a
Just JsStmt
alt)
smartif JsExpr
cond JsStmt
conseq Maybe JsStmt
Nothing = JsStmt
conseq

formConstTest :: JsExpr -> Const -> State CGBodyState JsExpr
formConstTest :: JsExpr -> Const -> State CGBodyState JsExpr
formConstTest JsExpr
scrvar Const
t = case Const
t of
  BI Integer
_ -> do
    t' <- Const -> State CGBodyState JsExpr
cgConst Const
t
    cgOp' PTBool (LEq (ATInt ITBig)) [scrvar, t']
  Const
_ -> do
    t' <- Const -> State CGBodyState JsExpr
cgConst Const
t
    pure $ JsBinOp "===" scrvar t'

cgIfTree :: BodyResTarget
         -> Text
         -> JsExpr
         -> [LAlt]
         -> State CGBodyState (Maybe JsStmt)
cgIfTree :: BodyResTarget
-> Text -> JsExpr -> [LAlt] -> State CGBodyState (Maybe JsStmt)
cgIfTree BodyResTarget
_ Text
_ JsExpr
_ [] = Maybe JsStmt -> State CGBodyState (Maybe JsStmt)
forall a. a -> StateT CGBodyState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe JsStmt
forall a. Maybe a
Nothing
cgIfTree BodyResTarget
rt Text
resName JsExpr
scrvar ((LConstCase Const
t LExp
exp):[LAlt]
r) = do
  (d, v) <- BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
cgBody (Text -> BodyResTarget -> BodyResTarget
altsRT Text
resName BodyResTarget
rt) LExp
exp
  alternatives <- cgIfTree rt resName scrvar r
  test <- formConstTest scrvar t
  pure $ Just $
    smartif test (JsSeq (seqJs d) v) alternatives
cgIfTree BodyResTarget
rt Text
resName JsExpr
scrvar ((LDefaultCase LExp
exp):[LAlt]
r) = do
  (d, v) <- BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
cgBody (Text -> BodyResTarget -> BodyResTarget
altsRT Text
resName BodyResTarget
rt) LExp
exp
  pure $ Just $ JsSeq (seqJs d) v
cgIfTree BodyResTarget
rt Text
resName JsExpr
scrvar ((LConCase Int
_ Name
n [Name]
args LExp
exp):[LAlt]
r) = do
  alternatives <- BodyResTarget
-> Text -> JsExpr -> [LAlt] -> State CGBodyState (Maybe JsStmt)
cgIfTree BodyResTarget
rt Text
resName JsExpr
scrvar [LAlt]
r
  test <- formConTest n scrvar
  st <- get
  let rwn = CGBodyState -> Map Name JsExpr
reWrittenNames CGBodyState
st
  put $
    st
    { reWrittenNames =
        foldl
          (\Map Name JsExpr
m (Name
n, Int
j) -> Name -> JsExpr -> Map Name JsExpr -> Map Name JsExpr
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
n (Name -> SProj
formProj Name
n JsExpr
scrvar Int
j) Map Name JsExpr
m)
          rwn
          (zip args [1 ..])
    }
  (d, v) <- cgBody (altsRT resName rt) exp
  st1 <- get
  put $ st1 {reWrittenNames = rwn}
  let branchBody = JsStmt -> JsStmt -> JsStmt
JsSeq ([JsStmt] -> JsStmt
seqJs [JsStmt]
d) JsStmt
v
  pure $ Just $ smartif test branchBody alternatives


cgForeignArg :: (FDesc, JsExpr) -> State CGBodyState JsExpr
cgForeignArg :: (FDesc, JsExpr) -> State CGBodyState JsExpr
cgForeignArg (FApp (UN Text
"JS_IntT") [FDesc]
_, JsExpr
v) = JsExpr -> State CGBodyState JsExpr
forall a. a -> StateT CGBodyState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JsExpr
v
cgForeignArg (FCon (UN Text
"JS_Str"), JsExpr
v) = JsExpr -> State CGBodyState JsExpr
forall a. a -> StateT CGBodyState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JsExpr
v
cgForeignArg (FCon (UN Text
"JS_Ptr"), JsExpr
v) = JsExpr -> State CGBodyState JsExpr
forall a. a -> StateT CGBodyState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JsExpr
v
cgForeignArg (FCon (UN Text
"JS_Unit"), JsExpr
v) = JsExpr -> State CGBodyState JsExpr
forall a. a -> StateT CGBodyState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JsExpr
v
cgForeignArg (FCon (UN Text
"JS_Float"), JsExpr
v) = JsExpr -> State CGBodyState JsExpr
forall a. a -> StateT CGBodyState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JsExpr
v
cgForeignArg (FApp (UN Text
"JS_FnT") [FDesc
_,FApp (UN Text
"JS_Fn") [FDesc
_,FDesc
_, FDesc
a, FApp (UN Text
"JS_FnBase") [FDesc
_,FDesc
b]]], JsExpr
f) =
  JsExpr -> State CGBodyState JsExpr
forall a. a -> StateT CGBodyState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JsExpr
f
cgForeignArg (FApp (UN Text
"JS_FnT") [FDesc
_,FApp (UN Text
"JS_Fn") [FDesc
_,FDesc
_, FDesc
a, FApp (UN Text
"JS_FnIO") [FDesc
_,FDesc
_, FDesc
b]]], JsExpr
f) =
  do
    jsx <- (FDesc, JsExpr) -> State CGBodyState JsExpr
cgForeignArg (FDesc
a, Text -> JsExpr
JsVar Text
"x")
    jsres <- cgForeignRes b $ jsCurryApp (jsCurryApp f [jsx]) [JsNull]
    pure $ JsLambda ["x"] $ JsReturn jsres
cgForeignArg (FDesc
desc, JsExpr
_) =
  do
    st <- StateT CGBodyState Identity CGBodyState
forall (m :: * -> *) s. Monad m => StateT s m s
get
    error $ "Foreign arg type " ++ show desc ++ " not supported. While generating function " ++ (show $ fst $ currentFnNameAndArgs st)

cgForeignRes :: FDesc -> JsExpr -> State CGBodyState JsExpr
cgForeignRes :: FDesc -> JsExpr -> State CGBodyState JsExpr
cgForeignRes (FApp (UN Text
"JS_IntT") [FDesc]
_) JsExpr
x = JsExpr -> State CGBodyState JsExpr
forall a. a -> StateT CGBodyState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JsExpr
x
cgForeignRes (FCon (UN Text
"JS_Unit")) JsExpr
x = JsExpr -> State CGBodyState JsExpr
forall a. a -> StateT CGBodyState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JsExpr
x
cgForeignRes (FCon (UN Text
"JS_Str")) JsExpr
x = JsExpr -> State CGBodyState JsExpr
forall a. a -> StateT CGBodyState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JsExpr
x
cgForeignRes (FCon (UN Text
"JS_Ptr")) JsExpr
x = JsExpr -> State CGBodyState JsExpr
forall a. a -> StateT CGBodyState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JsExpr
x
cgForeignRes (FCon (UN Text
"JS_Float")) JsExpr
x = JsExpr -> State CGBodyState JsExpr
forall a. a -> StateT CGBodyState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JsExpr
x
cgForeignRes FDesc
desc JsExpr
val =
  do
    st <- StateT CGBodyState Identity CGBodyState
forall (m :: * -> *) s. Monad m => StateT s m s
get
    error $ "Foreign return type " ++ show desc ++ " not supported. While generating function " ++ (show $ fst $ currentFnNameAndArgs st)

setUsedITBig :: State CGBodyState ()
setUsedITBig :: StateT CGBodyState Identity ()
setUsedITBig =   (CGBodyState -> CGBodyState) -> StateT CGBodyState Identity ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (\CGBodyState
s -> CGBodyState
s {usedITBig = True})


cgConst :: Const -> State CGBodyState JsExpr
cgConst :: Const -> State CGBodyState JsExpr
cgConst (I Int
i) = JsExpr -> State CGBodyState JsExpr
forall a. a -> StateT CGBodyState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JsExpr -> State CGBodyState JsExpr)
-> JsExpr -> State CGBodyState JsExpr
forall a b. (a -> b) -> a -> b
$ Int -> JsExpr
JsInt Int
i
cgConst (BI Integer
i) =
  do
    StateT CGBodyState Identity ()
setUsedITBig
    JsExpr -> State CGBodyState JsExpr
forall a. a -> StateT CGBodyState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JsExpr -> State CGBodyState JsExpr)
-> JsExpr -> State CGBodyState JsExpr
forall a b. (a -> b) -> a -> b
$ Text -> [JsExpr] -> JsExpr
JsForeign Text
"new $JSRTS.jsbn.BigInteger(%0)" [[Char] -> JsExpr
JsStr ([Char] -> JsExpr) -> [Char] -> JsExpr
forall a b. (a -> b) -> a -> b
$ Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
i]
cgConst (Ch Char
c) = JsExpr -> State CGBodyState JsExpr
forall a. a -> StateT CGBodyState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JsExpr -> State CGBodyState JsExpr)
-> JsExpr -> State CGBodyState JsExpr
forall a b. (a -> b) -> a -> b
$ [Char] -> JsExpr
JsStr [Char
c]
cgConst (Str [Char]
s) = JsExpr -> State CGBodyState JsExpr
forall a. a -> StateT CGBodyState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JsExpr -> State CGBodyState JsExpr)
-> JsExpr -> State CGBodyState JsExpr
forall a b. (a -> b) -> a -> b
$ [Char] -> JsExpr
JsStr [Char]
s
cgConst (Fl Double
f) = JsExpr -> State CGBodyState JsExpr
forall a. a -> StateT CGBodyState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JsExpr -> State CGBodyState JsExpr)
-> JsExpr -> State CGBodyState JsExpr
forall a b. (a -> b) -> a -> b
$ Double -> JsExpr
JsDouble Double
f
cgConst (B8 Word8
x) = JsExpr -> State CGBodyState JsExpr
forall a. a -> StateT CGBodyState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JsExpr -> State CGBodyState JsExpr)
-> JsExpr -> State CGBodyState JsExpr
forall a b. (a -> b) -> a -> b
$ Text -> [JsExpr] -> JsExpr
JsForeign ([Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Word8 -> [Char]
forall a. Show a => a -> [Char]
show Word8
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" & 0xFF") []
cgConst (B16 Word16
x) = JsExpr -> State CGBodyState JsExpr
forall a. a -> StateT CGBodyState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JsExpr -> State CGBodyState JsExpr)
-> JsExpr -> State CGBodyState JsExpr
forall a b. (a -> b) -> a -> b
$ Text -> [JsExpr] -> JsExpr
JsForeign ([Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Word16 -> [Char]
forall a. Show a => a -> [Char]
show Word16
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" & 0xFFFF") []
cgConst (B32 Word32
x) = JsExpr -> State CGBodyState JsExpr
forall a. a -> StateT CGBodyState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JsExpr -> State CGBodyState JsExpr)
-> JsExpr -> State CGBodyState JsExpr
forall a b. (a -> b) -> a -> b
$ Text -> [JsExpr] -> JsExpr
JsForeign ([Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Word32 -> [Char]
forall a. Show a => a -> [Char]
show Word32
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"|0" ) []
cgConst (B64 Word64
x) =
  do
    StateT CGBodyState Identity ()
setUsedITBig
    JsExpr -> State CGBodyState JsExpr
forall a. a -> StateT CGBodyState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JsExpr -> State CGBodyState JsExpr)
-> JsExpr -> State CGBodyState JsExpr
forall a b. (a -> b) -> a -> b
$ Text -> [JsExpr] -> JsExpr
JsForeign Text
"new $JSRTS.jsbn.BigInteger(%0).and(new $JSRTS.jsbn.BigInteger(%1))" [[Char] -> JsExpr
JsStr ([Char] -> JsExpr) -> [Char] -> JsExpr
forall a b. (a -> b) -> a -> b
$ Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
x, [Char] -> JsExpr
JsStr ([Char] -> JsExpr) -> [Char] -> JsExpr
forall a b. (a -> b) -> a -> b
$ Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
0xFFFFFFFFFFFFFFFF]
cgConst Const
x | Const -> Bool
isTypeConst Const
x = JsExpr -> State CGBodyState JsExpr
forall a. a -> StateT CGBodyState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JsExpr -> State CGBodyState JsExpr)
-> JsExpr -> State CGBodyState JsExpr
forall a b. (a -> b) -> a -> b
$ Int -> JsExpr
JsInt Int
0
cgConst Const
x = [Char] -> State CGBodyState JsExpr
forall a. HasCallStack => [Char] -> a
error ([Char] -> State CGBodyState JsExpr)
-> [Char] -> State CGBodyState JsExpr
forall a b. (a -> b) -> a -> b
$ [Char]
"Constant " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Const -> [Char]
forall a. Show a => a -> [Char]
show Const
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" not compilable yet"

cgOp :: PrimFn -> [JsExpr] -> State CGBodyState JsExpr
cgOp :: PrimFn -> [JsExpr] -> State CGBodyState JsExpr
cgOp = JsPrimTy -> PrimFn -> [JsExpr] -> State CGBodyState JsExpr
cgOp' JsPrimTy
PTAny

cgOp' :: JsPrimTy -> PrimFn -> [JsExpr] -> State CGBodyState JsExpr
cgOp' :: JsPrimTy -> PrimFn -> [JsExpr] -> State CGBodyState JsExpr
cgOp' JsPrimTy
pt (LExternal Name
name) [JsExpr]
_ | Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> Name
sUN [Char]
"prim__null" = JsExpr -> State CGBodyState JsExpr
forall a. a -> StateT CGBodyState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JsExpr
JsNull
cgOp' JsPrimTy
pt (LExternal Name
name) [JsExpr
l,JsExpr
r] | Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> Name
sUN [Char]
"prim__eqPtr" = JsExpr -> State CGBodyState JsExpr
forall a. a -> StateT CGBodyState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JsExpr -> State CGBodyState JsExpr)
-> JsExpr -> State CGBodyState JsExpr
forall a b. (a -> b) -> a -> b
$ Text -> JsExpr -> JsExpr -> JsExpr
JsBinOp Text
"==" JsExpr
l JsExpr
r
cgOp' JsPrimTy
pt PrimFn
op [JsExpr]
exps = case PrimFn -> Map PrimFn PrimDec -> Maybe PrimDec
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PrimFn
op Map PrimFn PrimDec
primDB of
  Just (Bool
useBigInt, JsPrimTy
pti, [JsExpr] -> JsExpr
combinator) -> do
    Bool
-> StateT CGBodyState Identity () -> StateT CGBodyState Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
useBigInt StateT CGBodyState Identity ()
setUsedITBig
    JsExpr -> State CGBodyState JsExpr
forall a. a -> StateT CGBodyState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JsExpr -> State CGBodyState JsExpr)
-> JsExpr -> State CGBodyState JsExpr
forall a b. (a -> b) -> a -> b
$ JsPrimTy -> JsPrimTy -> JsExpr -> JsExpr
jsPrimCoerce JsPrimTy
pti JsPrimTy
pt (JsExpr -> JsExpr) -> JsExpr -> JsExpr
forall a b. (a -> b) -> a -> b
$ [JsExpr] -> JsExpr
combinator [JsExpr]
exps
  Maybe PrimDec
Nothing -> [Char] -> State CGBodyState JsExpr
forall a. HasCallStack => [Char] -> a
error ([Char]
"Operator " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (PrimFn, [JsExpr]) -> [Char]
forall a. Show a => a -> [Char]
show (PrimFn
op, [JsExpr]
exps) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" not implemented")