{-|
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.Applicative (pure, (<$>))
import Control.Monad
import Control.Monad.Trans.State
import Data.Foldable (foldMap)
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 :: Bool -> Set Partial -> Set HiddenClass -> CGStats
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 x :: CGStats
x y :: CGStats
y = CGStats :: Bool -> Set Partial -> Set HiddenClass -> CGStats
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 -> String
jsbnPath :: String
                     , CGConf -> String
extraRunTime :: String
                     }


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

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

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

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

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

    makeExport :: Export -> [Text]
makeExport (ExportData _) =
      []
    makeExport (ExportFun name :: Name
name (FStr exportname :: String
exportname) retTy :: FDesc
retTy argTy :: [FDesc]
argTy) =
      [[Text] -> Text
T.concat [ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
exportname
                ,  ": "
                , 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 conf :: CGConf
conf ci :: CodegenInfo
ci =
  do
    Bool
debug <- Maybe String -> Bool
isYes (Maybe String -> Bool) -> IO (Maybe String) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv "IDRISJS_DEBUG"
    let defs' :: Map Name LDecl
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
defs = Map Name LDecl -> Map Name LDecl
globlToCon Map Name LDecl
defs'
    let iface :: Bool
iface = CodegenInfo -> Bool
interfaces CodegenInfo
ci
    let used :: [LDecl]
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 -> String -> Name
sMN 0 "runMain"]
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        String -> String -> IO ()
writeFile (CodegenInfo -> String
outputFile CodegenInfo
ci String -> String -> String
forall a. [a] -> [a] -> [a]
++ ".LDeclsDebug") (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ ([String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse "" ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (LDecl -> String) -> [LDecl] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map LDecl -> String
forall a. Show a => a -> String
show [LDecl]
used) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\n\n\n"
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Finished calculating used"

    let (out :: Text
out, stats :: CGStats
stats) = Map Name LDecl -> [LDecl] -> (Text, CGStats)
doCodegen Map Name LDecl
defs [LDecl]
used

    String
path <- IO String
getIdrisJSRTSDir
    Text
jsbn <- if CGStats -> Bool
usedBigInt CGStats
stats
              then String -> IO Text
TIO.readFile (String -> IO Text) -> String -> IO Text
forall a b. (a -> b) -> a -> b
$ String
path String -> String -> String
</> CGConf -> String
jsbnPath CGConf
conf
              else Text -> IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return ""

    Text
runtimeCommon <- String -> IO Text
TIO.readFile (String -> IO Text) -> String -> IO Text
forall a b. (a -> b) -> a -> b
$ String
path String -> String -> String
</> "Runtime-common.js"
    Text
extraRT <- String -> IO Text
TIO.readFile (String -> IO Text) -> String -> IO Text
forall a b. (a -> b) -> a -> b
$ String
path String -> String -> String
</> (CGConf -> String
extraRunTime CGConf
conf)

    Text
includes <- [String] -> IO Text
getIncludes ([String] -> IO Text) -> [String] -> IO Text
forall a b. (a -> b) -> a -> b
$ CodegenInfo -> [String]
includes CodegenInfo
ci
    let libs :: Text
libs = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ [String] -> String
includeLibs ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ CodegenInfo -> [String]
compileLibs CodegenInfo
ci
    String -> Text -> IO ()
TIO.writeFile (CodegenInfo -> String
outputFile CodegenInfo
ci) (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [ CGConf -> Text
header CGConf
conf
                                             , "\"use strict\";\n\n"
                                             , "(function(){\n\n"
                                             -- rts
                                             , Text
runtimeCommon, "\n"
                                             , Text
extraRT, "\n"
                                             , Text
jsbn, "\n"
                                             -- external libraries
                                             , Text
includes, "\n"
                                             , Text
libs, "\n"
                                             -- user code
                                             , Set Partial -> Text
doPartials (CGStats -> Set Partial
partialApplications CGStats
stats), "\n"
                                             , Set HiddenClass -> Text
doHiddenClasses (CGStats -> Set HiddenClass
hiddenClasses CGStats
stats), "\n"
                                             , Text
out, "\n"
                                             , if Bool
iface then [Text] -> Text
T.concat ["module.exports = {\n", Text -> [Text] -> Text
T.intercalate ",\n" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (ExportIFace -> [Text]) -> [ExportIFace] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Map Name LDecl -> ExportIFace -> [Text]
makeExportDecls Map Name LDecl
defs) (CodegenInfo -> [ExportIFace]
exportDecls CodegenInfo
ci), "\n};\n"]
                                                  else Name -> Text
jsName (Int -> String -> Name
sMN 0 "runMain") Text -> Text -> Text
`T.append` "();\n"
                                             , "}.call(this))"
                                             , CGConf -> Text
footer CGConf
conf
                                             ]

doPartials :: Set Partial -> Text
doPartials :: Set Partial -> Text
doPartials x :: Set Partial
x =
  Text -> [Text] -> Text
T.intercalate "\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 n :: Name
n i :: Int
i j :: Int
j) =
        let vars1 :: [Text]
vars1 = (Int -> Text) -> [Int] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
T.pack (String -> Text) -> (Int -> String) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ("x"String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) [1..Int
i]
            vars2 :: [Text]
vars2 = (Int -> Text) -> [Int] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
T.pack (String -> Text) -> (Int -> String) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ("x"String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) [(Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+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 x :: Set HiddenClass
x =
  Text -> [Text] -> Text
T.intercalate "\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 n :: Name
n id :: Int
id 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 [("type", Int -> JsExpr
JsInt Int
id)]
      f p :: HiddenClass
p@(HiddenClass n :: Name
n id :: Int
id arity :: 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 [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 "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 (\tv :: 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 defs :: Map Name LDecl
defs = (LDecl -> (Text, CGStats)) -> [LDecl] -> (Text, CGStats)
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 defs :: Map Name LDecl
defs (LFun _ name :: Name
name args :: [Name]
args def :: LExp
def) =
      let (ast :: JsStmt
ast, stats :: 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
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Name -> String
forall a. Show a => a -> String
show Name
name)
      in ([Text] -> Text
T.concat [Text
fnComment, "\n", JsStmt -> Text
jsStmt2Text JsStmt
ast, "\n"], CGStats
stats)
    doCodegenDecl defs :: Map Name LDecl
defs (LConstructor n :: Name
n i :: Int
i sz :: Int
sz) = ("", CGStats
forall a. Monoid a => a
mempty)


seqJs :: [JsStmt] -> JsStmt
seqJs :: [JsStmt] -> JsStmt
seqJs [] = JsStmt
JsEmpty
seqJs (x :: JsStmt
x:xs :: [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
    CGBodyState
st <- StateT CGBodyState Identity CGBodyState
forall (m :: * -> *) s. Monad m => StateT s m s
get
    let v :: Int
v = CGBodyState -> Int
lastIntName CGBodyState
st Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
    CGBodyState -> StateT CGBodyState Identity ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (CGBodyState -> StateT CGBodyState Identity ())
-> CGBodyState -> StateT CGBodyState Identity ()
forall a b. (a -> b) -> a -> b
$ CGBodyState
st {lastIntName :: Int
lastIntName = Int
v}
    Text -> State CGBodyState Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> State CGBodyState Text) -> Text -> State CGBodyState Text
forall a b. (a -> b) -> a -> b
$ Int -> Text
jsNameGenerated Int
v

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

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

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

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

getArgList' :: Name -> Map Name LDecl -> Maybe [Name]
getArgList' :: Name -> Map Name LDecl -> Maybe [Name]
getArgList' n :: Name
n defs :: 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 _ _ a :: [Name]
a _) -> [Name] -> Maybe [Name]
forall a. a -> Maybe a
Just [Name]
a
      _ -> Maybe [Name]
forall a. Maybe a
Nothing

getArgList :: Name -> State CGBodyState (Maybe [Name])
getArgList :: Name -> State CGBodyState (Maybe [Name])
getArgList n :: Name
n =
  do
    CGBodyState
st <- StateT CGBodyState Identity CGBodyState
forall (m :: * -> *) s. Monad m => StateT s m s
get
    Maybe [Name] -> State CGBodyState (Maybe [Name])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe [Name] -> State CGBodyState (Maybe [Name]))
-> Maybe [Name] -> State CGBodyState (Maybe [Name])
forall a b. (a -> b) -> a -> b
$ Name -> Map Name LDecl -> Maybe [Name]
getArgList' Name
n (CGBodyState -> Map Name LDecl
defs CGBodyState
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 dfs :: Map Name LDecl
dfs n :: Name
n args :: [Name]
args def :: 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 ((decs :: [JsStmt]
decs, res :: JsStmt
res),st :: 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 :: Map Name LDecl
-> Int
-> Map Name JsExpr
-> (Text, [Text])
-> Set (Text, Text)
-> Bool
-> Bool
-> Set Partial
-> Set HiddenClass
-> CGBodyState
CGBodyState { defs :: Map Name LDecl
defs = Map Name LDecl
dfs
                                       , lastIntName :: Int
lastIntName = 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 :: Bool -> Set Partial -> Set HiddenClass -> CGStats
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 ReturnBT x :: JsExpr
x = JsExpr -> JsStmt
JsReturn JsExpr
x
addRT (DecBT n :: Text
n) x :: JsExpr
x = Text -> JsExpr -> JsStmt
JsDecLet Text
n JsExpr
x
addRT (DecConstBT n :: Text
n) x :: JsExpr
x = Text -> JsExpr -> JsStmt
JsDecConst Text
n JsExpr
x
addRT (SetBT n :: Text
n) x :: JsExpr
x = JsExpr -> JsExpr -> JsStmt
JsSet (Text -> JsExpr
JsVar Text
n) JsExpr
x
addRT GetExpBT x :: JsExpr
x = JsExpr -> JsStmt
JsExprStmt JsExpr
x

declareUsedOptimArgs :: Set (Text, Text) -> JsStmt
declareUsedOptimArgs :: Set (Text, Text) -> JsStmt
declareUsedOptimArgs x :: 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 (\(x :: Text
x,y :: 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 [] s :: Set Text
s = ((JsStmt
JsEmpty, JsStmt
JsEmpty), Set (Text, Text)
forall a. Set a
Set.empty)
tailCallOptimRefreshArgs ((n :: Text
n,x :: JsExpr
x):r :: [(Text, JsExpr)]
r) s :: Set Text
s =
  let ((y1 :: JsStmt
y1,y2 :: JsStmt
y2), y3 :: 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 b :: Name
b = do
  CGBodyState
st <- StateT CGBodyState Identity CGBodyState
forall (m :: * -> *) s. Monad m => StateT s m s
get
  case Name -> Map Name JsExpr -> Maybe JsExpr
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
b (CGBodyState -> Map Name JsExpr
reWrittenNames CGBodyState
st) of
    Just e :: JsExpr
e -> JsExpr -> State CGBodyState JsExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure JsExpr
e
    _ -> JsExpr -> State CGBodyState JsExpr
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 rt :: BodyResTarget
rt expr :: LExp
expr =
  case LExp
expr of
    (LCase _ (LOp oper :: PrimFn
oper [x :: LExp
x, y :: LExp
y]) [LConstCase (I 0) (LCon _ _ ff :: Name
ff []), LDefaultCase (LCon _ _ tt :: Name
tt [])])
      | (Name
ff Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> String -> Name
qualifyN "Prelude.Bool" "False" Bool -> Bool -> Bool
&&
         Name
tt Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> String -> Name
qualifyN "Prelude.Bool" "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 (needBI :: Bool
needBI, pti :: JsPrimTy
pti, c :: [JsExpr] -> JsExpr
c) | JsPrimTy
pti JsPrimTy -> JsPrimTy -> Bool
forall a. Eq a => a -> a -> Bool
== JsPrimTy
PTBool -> do
            [([JsStmt], JsStmt)]
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)
mapM (BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
cgBody BodyResTarget
GetExpBT) [LExp
x, LExp
y]
            Bool
-> StateT CGBodyState Identity () -> StateT CGBodyState Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needBI StateT CGBodyState Identity ()
setUsedITBig
            let res :: JsExpr
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
            ([JsStmt], JsStmt) -> State CGBodyState ([JsStmt], JsStmt)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([JsStmt], JsStmt) -> State CGBodyState ([JsStmt], JsStmt))
-> ([JsStmt], JsStmt) -> State CGBodyState ([JsStmt], JsStmt)
forall a b. (a -> b) -> a -> b
$ ([[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, BodyResTarget -> JsExpr -> JsStmt
addRT BodyResTarget
rt JsExpr
res)
          _ -> BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
cgBody' BodyResTarget
rt LExp
expr
    (LCase _ e :: LExp
e [LConCase _ n :: Name
n _ (LCon _ _ tt :: Name
tt []), LDefaultCase (LCon _ _ ff :: Name
ff [])])
      | (Name
ff Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> String -> Name
qualifyN "Prelude.Bool" "False" Bool -> Bool -> Bool
&&
         Name
tt Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> String -> Name
qualifyN "Prelude.Bool" "True") -> do
           (d :: [JsStmt]
d, v :: JsStmt
v) <- BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
cgBody BodyResTarget
GetExpBT LExp
e
           JsExpr
test <- Name -> JsExpr -> State CGBodyState JsExpr
formConTest Name
n (JsStmt -> JsExpr
jsStmt2Expr JsStmt
v)
           ([JsStmt], JsStmt) -> State CGBodyState ([JsStmt], JsStmt)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([JsStmt], JsStmt) -> State CGBodyState ([JsStmt], JsStmt))
-> ([JsStmt], JsStmt) -> State CGBodyState ([JsStmt], JsStmt)
forall a b. (a -> b) -> a -> b
$ ([JsStmt]
d, BodyResTarget -> JsExpr -> JsStmt
addRT BodyResTarget
rt (JsExpr -> JsStmt) -> JsExpr -> JsStmt
forall a b. (a -> b) -> a -> b
$ Text -> JsExpr -> JsExpr
JsUniOp (String -> Text
T.pack "!") (JsExpr -> JsExpr) -> JsExpr -> JsExpr
forall a b. (a -> b) -> a -> b
$ Text -> JsExpr -> JsExpr
JsUniOp (String -> Text
T.pack "!") JsExpr
test)
    (LCase _ e :: LExp
e [LConCase _ n :: Name
n _ (LCon _ _ tt :: Name
tt []), LConCase _ _ _ (LCon _ _ ff :: Name
ff [])])
      | (Name
ff Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> String -> Name
qualifyN "Prelude.Bool" "False" Bool -> Bool -> Bool
&&
         Name
tt Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> String -> Name
qualifyN "Prelude.Bool" "True") -> do
           (d :: [JsStmt]
d, v :: JsStmt
v) <- BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
cgBody BodyResTarget
GetExpBT LExp
e
           JsExpr
test <- Name -> JsExpr -> State CGBodyState JsExpr
formConTest Name
n (JsStmt -> JsExpr
jsStmt2Expr JsStmt
v)
           ([JsStmt], JsStmt) -> State CGBodyState ([JsStmt], JsStmt)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([JsStmt], JsStmt) -> State CGBodyState ([JsStmt], JsStmt))
-> ([JsStmt], JsStmt) -> State CGBodyState ([JsStmt], JsStmt)
forall a b. (a -> b) -> a -> b
$ ([JsStmt]
d, BodyResTarget -> JsExpr -> JsStmt
addRT BodyResTarget
rt (JsExpr -> JsStmt) -> JsExpr -> JsStmt
forall a b. (a -> b) -> a -> b
$ Text -> JsExpr -> JsExpr
JsUniOp (String -> Text
T.pack "!") (JsExpr -> JsExpr) -> JsExpr -> JsExpr
forall a b. (a -> b) -> a -> b
$ Text -> JsExpr -> JsExpr
JsUniOp (String -> Text
T.pack "!") JsExpr
test)
    (LCase _ e :: LExp
e [LConCase _ n :: Name
n _ (LCon _ _ ff :: Name
ff []), LDefaultCase (LCon _ _ tt :: Name
tt [])])
      | (Name
ff Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> String -> Name
qualifyN "Prelude.Bool" "False" Bool -> Bool -> Bool
&&
         Name
tt Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> String -> Name
qualifyN "Prelude.Bool" "True") -> do
           (d :: [JsStmt]
d, v :: JsStmt
v) <- BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
cgBody BodyResTarget
GetExpBT LExp
e
           JsExpr
test <- Name -> JsExpr -> State CGBodyState JsExpr
formConTest Name
n (JsStmt -> JsExpr
jsStmt2Expr JsStmt
v)
           ([JsStmt], JsStmt) -> State CGBodyState ([JsStmt], JsStmt)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([JsStmt], JsStmt) -> State CGBodyState ([JsStmt], JsStmt))
-> ([JsStmt], JsStmt) -> State CGBodyState ([JsStmt], JsStmt)
forall a b. (a -> b) -> a -> b
$ ([JsStmt]
d, BodyResTarget -> JsExpr -> JsStmt
addRT BodyResTarget
rt (JsExpr -> JsStmt) -> JsExpr -> JsStmt
forall a b. (a -> b) -> a -> b
$ Text -> JsExpr -> JsExpr
JsUniOp (String -> Text
T.pack "!") JsExpr
test)
    (LCase _ e :: LExp
e [LConCase _ n :: Name
n _ (LCon _ _ ff :: Name
ff []), LConCase _ _ _ (LCon _ _ tt :: Name
tt [])])
      | (Name
ff Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> String -> Name
qualifyN "Prelude.Bool" "False" Bool -> Bool -> Bool
&&
         Name
tt Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> String -> Name
qualifyN "Prelude.Bool" "True") -> do
           (d :: [JsStmt]
d, v :: JsStmt
v) <- BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
cgBody BodyResTarget
GetExpBT LExp
e
           JsExpr
test <- Name -> JsExpr -> State CGBodyState JsExpr
formConTest Name
n (JsStmt -> JsExpr
jsStmt2Expr JsStmt
v)
           ([JsStmt], JsStmt) -> State CGBodyState ([JsStmt], JsStmt)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([JsStmt], JsStmt) -> State CGBodyState ([JsStmt], JsStmt))
-> ([JsStmt], JsStmt) -> State CGBodyState ([JsStmt], JsStmt)
forall a b. (a -> b) -> a -> b
$ ([JsStmt]
d, BodyResTarget -> JsExpr -> JsStmt
addRT BodyResTarget
rt (JsExpr -> JsStmt) -> JsExpr -> JsStmt
forall a b. (a -> b) -> a -> b
$ Text -> JsExpr -> JsExpr
JsUniOp (String -> Text
T.pack "!") JsExpr
test)
    (LCase f :: CaseType
f e :: LExp
e [LConCase nf :: Int
nf ff :: Name
ff [] alt :: LExp
alt, LConCase nt :: Int
nt tt :: Name
tt [] conseq :: LExp
conseq])
      | (Name
ff Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> String -> Name
qualifyN "Prelude.Bool" "False" Bool -> Bool -> Bool
&&
         Name
tt Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> String -> Name
qualifyN "Prelude.Bool" "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]
    expr :: 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' rt :: BodyResTarget
rt (LV n :: Name
n) =
  do
    Maybe [Name]
argsFn <- Name -> State CGBodyState (Maybe [Name])
getArgList Name
n
    case Maybe [Name]
argsFn of
      Just a :: [Name]
a -> BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
cgBody' BodyResTarget
rt (Bool -> LExp -> [LExp] -> LExp
LApp Bool
False (Name -> LExp
LV Name
n) [])
      Nothing -> do
        JsExpr
n' <- Name -> State CGBodyState JsExpr
cgName Name
n
        ([JsStmt], JsStmt) -> State CGBodyState ([JsStmt], JsStmt)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([JsStmt], JsStmt) -> State CGBodyState ([JsStmt], JsStmt))
-> ([JsStmt], JsStmt) -> State CGBodyState ([JsStmt], JsStmt)
forall a b. (a -> b) -> a -> b
$ ([], BodyResTarget -> JsExpr -> JsStmt
addRT BodyResTarget
rt JsExpr
n')
cgBody' rt :: BodyResTarget
rt (LApp tailcall :: Bool
tailcall (LV fn :: Name
fn) args :: [LExp]
args) =
  do
    let fname :: Text
fname = Name -> Text
jsName Name
fn
    CGBodyState
st <- StateT CGBodyState Identity CGBodyState
forall (m :: * -> *) s. Monad m => StateT s m s
get
    let (currFn :: Text
currFn, argN :: [Text]
argN) = CGBodyState -> (Text, [Text])
currentFnNameAndArgs CGBodyState
st
    [([JsStmt], JsStmt)]
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)
mapM (BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
cgBody BodyResTarget
GetExpBT) [LExp]
args
    let argVals :: [JsExpr]
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]
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 (Text
fname Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
currFn Bool -> Bool -> Bool
&& ([LExp] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LExp]
args) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== ([Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
argN), BodyResTarget
rt) of
      (True, ReturnBT) ->
        do
          (CGBodyState -> CGBodyState) -> StateT CGBodyState Identity ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (\x :: CGBodyState
x-> CGBodyState
x {isTailRec :: Bool
isTailRec = Bool
True})
          let ((y1 :: JsStmt
y1,y2 :: JsStmt
y2), y3 :: 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 (f :: * -> *) a. Applicative f => a -> f a
pure ([JsStmt]
preDecs, JsStmt
y1 JsStmt -> JsStmt -> JsStmt
`JsSeq` JsStmt
y2)
      _ -> do
        JsExpr
app <- Name -> [JsExpr] -> State CGBodyState JsExpr
formApp Name
fn [JsExpr]
argVals
        ([JsStmt], JsStmt) -> State CGBodyState ([JsStmt], JsStmt)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([JsStmt]
preDecs, BodyResTarget -> JsExpr -> JsStmt
addRT BodyResTarget
rt JsExpr
app)

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

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

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

formApp :: Name -> [JsExpr] -> State CGBodyState JsExpr
formApp :: Name -> [JsExpr] -> State CGBodyState JsExpr
formApp fn :: Name
fn argVals :: [JsExpr]
argVals = case Name -> Maybe SSig
specialCall Name
fn of
  Just (arity :: Int
arity, g :: [JsExpr] -> JsExpr
g) | Int
arity Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [JsExpr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [JsExpr]
argVals -> JsExpr -> State CGBodyState JsExpr
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
  _ -> do
    Maybe [Name]
argsFn <- Name -> State CGBodyState (Maybe [Name])
getArgList Name
fn
    JsExpr
fname <- Name -> State CGBodyState JsExpr
cgName Name
fn
    case Maybe [Name]
argsFn of
      Nothing -> JsExpr -> State CGBodyState JsExpr
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 agFn :: [Name]
agFn -> do
        let lenAgFn :: Int
lenAgFn = [Name] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
agFn
        let lenArgs :: Int
lenArgs = [JsExpr] -> 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
          EQ -> JsExpr -> State CGBodyState JsExpr
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
          LT -> JsExpr -> State CGBodyState JsExpr
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)
          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 (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 n :: Name
n args :: [JsExpr]
args = do
  case Name -> Maybe ([JsExpr] -> JsExpr, JsExpr -> JsExpr, SProj)
specialCased Name
n of
    Just (ctor :: [JsExpr] -> JsExpr
ctor, test :: JsExpr -> JsExpr
test, match :: SProj
match) -> JsExpr -> State CGBodyState JsExpr
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
    Nothing -> do
      (conId :: Int
conId, arity :: Int
arity) <- Name -> State CGBodyState (Int, Int)
getConsId Name
n
      let hc :: HiddenClass
hc = Name -> Int -> Int -> HiddenClass
HiddenClass Name
n Int
conId Int
arity
      HiddenClass -> StateT CGBodyState Identity ()
addHiddenClass HiddenClass
hc
      JsExpr -> State CGBodyState JsExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JsExpr -> State CGBodyState JsExpr)
-> JsExpr -> State CGBodyState JsExpr
forall a b. (a -> b) -> a -> b
$ if (Int
arity Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0)
        then JsExpr -> [JsExpr] -> JsExpr
JsNew (Text -> JsExpr
JsVar (Text -> JsExpr) -> Text -> JsExpr
forall a b. (a -> b) -> a -> b
$ HiddenClass -> Text
jsNameHiddenClass HiddenClass
hc) [JsExpr]
args
        else Text -> JsExpr
JsVar (Text -> JsExpr) -> Text -> JsExpr
forall a b. (a -> b) -> a -> b
$ HiddenClass -> Text
jsNameHiddenClass HiddenClass
hc

formConTest :: Name -> JsExpr -> State CGBodyState JsExpr
formConTest :: Name -> JsExpr -> State CGBodyState JsExpr
formConTest n :: Name
n x :: JsExpr
x = do
  case Name -> Maybe ([JsExpr] -> JsExpr, JsExpr -> JsExpr, SProj)
specialCased Name
n of
    Just (ctor :: [JsExpr] -> JsExpr
ctor, test :: JsExpr -> JsExpr
test, match :: SProj
match) -> JsExpr -> State CGBodyState JsExpr
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
    Nothing -> do
      (conId :: Int
conId, arity :: Int
arity) <- Name -> State CGBodyState (Int, Int)
getConsId Name
n
      JsExpr -> State CGBodyState JsExpr
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 "===" (JsExpr -> Text -> JsExpr
JsProp JsExpr
x (String -> Text
T.pack "type")) (Int -> JsExpr
JsInt Int
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 n :: Name
n v :: JsExpr
v i :: Int
i =
  case Name -> Maybe ([JsExpr] -> JsExpr, JsExpr -> JsExpr, SProj)
specialCased Name
n of
    Just (ctor :: [JsExpr] -> JsExpr
ctor, test :: JsExpr -> JsExpr
test, proj :: SProj
proj) -> SProj
proj JsExpr
v Int
i
    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 cond :: JsExpr
cond conseq :: JsStmt
conseq (Just alt :: JsStmt
alt) = JsExpr -> JsStmt -> Maybe JsStmt -> JsStmt
JsIf JsExpr
cond JsStmt
conseq (JsStmt -> Maybe JsStmt
forall a. a -> Maybe a
Just JsStmt
alt)
smartif cond :: JsExpr
cond conseq :: JsStmt
conseq Nothing = JsStmt
conseq

formConstTest :: JsExpr -> Const -> State CGBodyState JsExpr
formConstTest :: JsExpr -> Const -> State CGBodyState JsExpr
formConstTest scrvar :: JsExpr
scrvar t :: Const
t = case Const
t of
  BI _ -> do
    JsExpr
t' <- Const -> State CGBodyState JsExpr
cgConst Const
t
    JsPrimTy -> PrimFn -> [JsExpr] -> State CGBodyState JsExpr
cgOp' JsPrimTy
PTBool (ArithTy -> PrimFn
LEq (IntTy -> ArithTy
ATInt IntTy
ITBig)) [JsExpr
scrvar, JsExpr
t']
  _ -> do
    JsExpr
t' <- Const -> State CGBodyState JsExpr
cgConst Const
t
    JsExpr -> State CGBodyState JsExpr
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 "===" JsExpr
scrvar JsExpr
t'

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


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

cgForeignRes :: FDesc -> JsExpr -> State CGBodyState JsExpr
cgForeignRes :: FDesc -> JsExpr -> State CGBodyState JsExpr
cgForeignRes (FApp (UN "JS_IntT") _) x :: JsExpr
x = JsExpr -> State CGBodyState JsExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure JsExpr
x
cgForeignRes (FCon (UN "JS_Unit")) x :: JsExpr
x = JsExpr -> State CGBodyState JsExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure JsExpr
x
cgForeignRes (FCon (UN "JS_Str")) x :: JsExpr
x = JsExpr -> State CGBodyState JsExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure JsExpr
x
cgForeignRes (FCon (UN "JS_Ptr")) x :: JsExpr
x = JsExpr -> State CGBodyState JsExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure JsExpr
x
cgForeignRes (FCon (UN "JS_Float")) x :: JsExpr
x = JsExpr -> State CGBodyState JsExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure JsExpr
x
cgForeignRes desc :: FDesc
desc val :: JsExpr
val =
  do
    CGBodyState
st <- StateT CGBodyState Identity CGBodyState
forall (m :: * -> *) s. Monad m => StateT s m s
get
    String -> State CGBodyState JsExpr
forall a. HasCallStack => String -> a
error (String -> State CGBodyState JsExpr)
-> String -> State CGBodyState JsExpr
forall a b. (a -> b) -> a -> b
$ "Foreign return type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FDesc -> String
forall a. Show a => a -> String
show FDesc
desc String -> String -> String
forall a. [a] -> [a] -> [a]
++ " not supported. While generating function " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Text -> String
forall a. Show a => a -> String
show (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ (Text, [Text]) -> Text
forall a b. (a, b) -> a
fst ((Text, [Text]) -> Text) -> (Text, [Text]) -> Text
forall a b. (a -> b) -> a -> b
$ CGBodyState -> (Text, [Text])
currentFnNameAndArgs CGBodyState
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 (\s :: CGBodyState
s -> CGBodyState
s {usedITBig :: Bool
usedITBig = Bool
True})


cgConst :: Const -> State CGBodyState JsExpr
cgConst :: Const -> State CGBodyState JsExpr
cgConst (I i :: Int
i) = JsExpr -> State CGBodyState JsExpr
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 i :: Integer
i) =
  do
    StateT CGBodyState Identity ()
setUsedITBig
    JsExpr -> State CGBodyState JsExpr
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 "new $JSRTS.jsbn.BigInteger(%0)" [String -> JsExpr
JsStr (String -> JsExpr) -> String -> JsExpr
forall a b. (a -> b) -> a -> b
$ Integer -> String
forall a. Show a => a -> String
show Integer
i]
cgConst (Ch c :: Char
c) = JsExpr -> State CGBodyState JsExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JsExpr -> State CGBodyState JsExpr)
-> JsExpr -> State CGBodyState JsExpr
forall a b. (a -> b) -> a -> b
$ String -> JsExpr
JsStr [Char
c]
cgConst (Str s :: String
s) = JsExpr -> State CGBodyState JsExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JsExpr -> State CGBodyState JsExpr)
-> JsExpr -> State CGBodyState JsExpr
forall a b. (a -> b) -> a -> b
$ String -> JsExpr
JsStr String
s
cgConst (Fl f :: Double
f) = JsExpr -> State CGBodyState JsExpr
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 x :: Word8
x) = JsExpr -> State CGBodyState JsExpr
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 (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Word8 -> String
forall a. Show a => a -> String
show Word8
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ " & 0xFF") []
cgConst (B16 x :: Word16
x) = JsExpr -> State CGBodyState JsExpr
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 (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Word16 -> String
forall a. Show a => a -> String
show Word16
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ " & 0xFFFF") []
cgConst (B32 x :: Word32
x) = JsExpr -> State CGBodyState JsExpr
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 (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Word32 -> String
forall a. Show a => a -> String
show Word32
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ "|0" ) []
cgConst (B64 x :: Word64
x) =
  do
    StateT CGBodyState Identity ()
setUsedITBig
    JsExpr -> State CGBodyState JsExpr
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 "new $JSRTS.jsbn.BigInteger(%0).and(new $JSRTS.jsbn.BigInteger(%1))" [String -> JsExpr
JsStr (String -> JsExpr) -> String -> JsExpr
forall a b. (a -> b) -> a -> b
$ Word64 -> String
forall a. Show a => a -> String
show Word64
x, String -> JsExpr
JsStr (String -> JsExpr) -> String -> JsExpr
forall a b. (a -> b) -> a -> b
$ Integer -> String
forall a. Show a => a -> String
show 0xFFFFFFFFFFFFFFFF]
cgConst x :: Const
x | Const -> Bool
isTypeConst Const
x = JsExpr -> State CGBodyState JsExpr
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 0
cgConst x :: Const
x = String -> State CGBodyState JsExpr
forall a. HasCallStack => String -> a
error (String -> State CGBodyState JsExpr)
-> String -> State CGBodyState JsExpr
forall a b. (a -> b) -> a -> b
$ "Constant " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Const -> String
forall a. Show a => a -> String
show Const
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ " 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' pt :: JsPrimTy
pt (LExternal name :: Name
name) _ | Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "prim__null" = JsExpr -> State CGBodyState JsExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure JsExpr
JsNull
cgOp' pt :: JsPrimTy
pt (LExternal name :: Name
name) [l :: JsExpr
l,r :: JsExpr
r] | Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN "prim__eqPtr" = JsExpr -> State CGBodyState JsExpr
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 "==" JsExpr
l JsExpr
r
cgOp' pt :: JsPrimTy
pt op :: PrimFn
op exps :: [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 (useBigInt :: Bool
useBigInt, pti :: JsPrimTy
pti, combinator :: [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 (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
  Nothing -> String -> State CGBodyState JsExpr
forall a. HasCallStack => String -> a
error ("Operator " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (PrimFn, [JsExpr]) -> String
forall a. Show a => a -> String
show (PrimFn
op, [JsExpr]
exps) String -> String -> String
forall a. [a] -> [a] -> [a]
++ " not implemented")