{-# 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
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
(<>) = forall a. Monoid a => a -> a -> a
mappend
#endif
instance Monoid CGStats where
mempty :: CGStats
mempty = CGStats { partialApplications :: Set Partial
partialApplications = forall a. Set a
Set.empty
, hiddenClasses :: Set HiddenClass
hiddenClasses = 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 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 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 { :: Text
, :: Text
, CGConf -> [Char]
jsbnPath :: String
, :: String
}
getInclude :: FilePath -> IO Text
getInclude :: [Char] -> IO Text
getInclude [Char]
p =
do
[Char]
libs <- IO [Char]
getIdrisLibDir
let libPath :: [Char]
libPath = [Char]
libs [Char] -> [Char] -> [Char]
</> [Char]
p
Bool
exitsInLib <- [Char] -> IO Bool
doesFileExist [Char]
libPath
if Bool
exitsInLib then
[Char] -> IO Text
TIO.readFile [Char]
libPath
else [Char] -> IO Text
TIO.readFile [Char]
p
getIncludes :: [FilePath] -> IO Text
getIncludes :: [[Char]] -> IO Text
getIncludes [[Char]]
l = do
[Text]
incs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM [Char] -> IO Text
getInclude [[Char]]
l
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
"\n\n" [Text]
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
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\[Char]
lib -> [Char]
"var " forall a. [a] -> [a] -> [a]
++ (Char -> Char
repl forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char]
lib) forall a. [a] -> [a] -> [a]
++ [Char]
" = require(\"" forall a. [a] -> [a] -> [a]
++ [Char]
lib 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) =
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 forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
argTy forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
args then
case (FDesc
retTy, 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 forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
args,Text
"))"
, [Text] -> Text
T.concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\Int
x -> [Text] -> Text
T.concat [Text
"(arguments[", [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show Int
x , Text
"])"]) [forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
args .. (forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
argTy 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 forall a b. (a -> b) -> a -> b
$ [Char]
exportname
, 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
Bool
debug <- Maybe [Char] -> Bool
isYes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"IDRISJS_DEBUG"
let defs' :: Map Name LDecl
defs' = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList 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
forall k a. Map k a -> [a]
Map.elems forall a b. (a -> b) -> a -> b
$ Map Name LDecl -> [Name] -> Map Name LDecl
removeDeadCode Map Name LDecl
defs ([ExportIFace] -> [Name]
getExpNames forall a b. (a -> b) -> a -> b
$ CodegenInfo -> [ExportIFace]
exportDecls CodegenInfo
ci)
else forall k a. Map k a -> [a]
Map.elems 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"]
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug forall a b. (a -> b) -> a -> b
$ do
[Char] -> [Char] -> IO ()
writeFile (CodegenInfo -> [Char]
outputFile CodegenInfo
ci forall a. [a] -> [a] -> [a]
++ [Char]
".LDeclsDebug") forall a b. (a -> b) -> a -> b
$ ([[Char]] -> [Char]
unlines forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse [Char]
"" forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> [Char]
show [LDecl]
used) forall a. [a] -> [a] -> [a]
++ [Char]
"\n\n\n"
[Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"Finished calculating used"
let (Text
out, CGStats
stats) = Map Name LDecl -> [LDecl] -> (Text, CGStats)
doCodegen Map Name LDecl
defs [LDecl]
used
[Char]
path <- IO [Char]
getIdrisJSRTSDir
Text
jsbn <- if CGStats -> Bool
usedBigInt CGStats
stats
then [Char] -> IO Text
TIO.readFile forall a b. (a -> b) -> a -> b
$ [Char]
path [Char] -> [Char] -> [Char]
</> CGConf -> [Char]
jsbnPath CGConf
conf
else forall (m :: * -> *) a. Monad m => a -> m a
return Text
""
Text
runtimeCommon <- [Char] -> IO Text
TIO.readFile forall a b. (a -> b) -> a -> b
$ [Char]
path [Char] -> [Char] -> [Char]
</> [Char]
"Runtime-common.js"
Text
extraRT <- [Char] -> IO Text
TIO.readFile forall a b. (a -> b) -> a -> b
$ [Char]
path [Char] -> [Char] -> [Char]
</> (CGConf -> [Char]
extraRunTime CGConf
conf)
Text
includes <- [[Char]] -> IO Text
getIncludes forall a b. (a -> b) -> a -> b
$ CodegenInfo -> [[Char]]
includes CodegenInfo
ci
let libs :: Text
libs = [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
includeLibs forall a b. (a -> b) -> a -> b
$ CodegenInfo -> [[Char]]
compileLibs CodegenInfo
ci
[Char] -> Text -> IO ()
TIO.writeFile (CodegenInfo -> [Char]
outputFile CodegenInfo
ci) forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [ CGConf -> Text
header CGConf
conf
, Text
"\"use strict\";\n\n"
, Text
"(function(){\n\n"
, Text
runtimeCommon, Text
"\n"
, Text
extraRT, Text
"\n"
, Text
jsbn, Text
"\n"
, Text
includes, Text
"\n"
, Text
libs, Text
"\n"
, Set Partial -> Text
doPartials (CGStats -> Set Partial
partialApplications CGStats
stats), Text
"\n"
, Set HiddenClass -> Text
doHiddenClasses (CGStats -> Set HiddenClass
hiddenClasses CGStats
stats), Text
"\n"
, Text
out, Text
"\n"
, if Bool
iface then [Text] -> Text
T.concat [Text
"module.exports = {\n", Text -> [Text] -> Text
T.intercalate Text
",\n" forall a b. (a -> b) -> a -> b
$ 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), Text
"\n};\n"]
else Name -> Text
jsName (Int -> [Char] -> Name
sMN Int
0 [Char]
"runMain") Text -> Text -> Text
`T.append` Text
"();\n"
, Text
"}.call(this))"
, CGConf -> Text
footer CGConf
conf
]
doPartials :: Set Partial -> Text
doPartials :: Set Partial -> Text
doPartials Set Partial
x =
Text -> [Text] -> Text
T.intercalate Text
"\n" (forall a b. (a -> b) -> [a] -> [b]
map Partial -> Text
f forall a b. (a -> b) -> a -> b
$ 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 = forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"x"forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show) [Int
1..Int
i]
vars2 :: [Text]
vars2 = forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"x"forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show) [(Int
iforall a. Num a => a -> a -> a
+Int
1)..Int
j]
in JsStmt -> Text
jsStmt2Text forall a b. (a -> b) -> a -> b
$
Text -> [Text] -> JsStmt -> JsStmt
JsFun (Partial -> Text
jsNamePartial Partial
p) [Text]
vars1 forall a b. (a -> b) -> a -> b
$ JsExpr -> JsStmt
JsReturn forall a b. (a -> b) -> a -> b
$
[Text] -> JsExpr -> JsExpr
jsCurryLam [Text]
vars2 (Text -> [JsExpr] -> JsExpr
jsAppN (Name -> Text
jsName Name
n) (forall a b. (a -> b) -> [a] -> [b]
map Text -> JsExpr
JsVar ([Text]
vars1 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" (forall a b. (a -> b) -> [a] -> [b]
map HiddenClass -> Text
f forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ Text -> JsExpr -> JsStmt
JsDecConst (HiddenClass -> Text
jsNameHiddenClass HiddenClass
p) 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 = forall a b. (a -> b) -> [a] -> [b]
map Int -> Text
dataPartName forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take Int
arity [Int
1..]
in JsStmt -> Text
jsStmt2Text forall a b. (a -> b) -> a -> b
$
Text -> [Text] -> JsStmt -> JsStmt
JsFun (HiddenClass -> Text
jsNameHiddenClass HiddenClass
p) [Text]
vars 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)) forall a b. (a -> b) -> a -> b
$ [JsStmt] -> JsStmt
seqJs
forall a b. (a -> b) -> a -> b
$ 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
doCodegen :: Map Name LDecl -> [LDecl] -> (Text, CGStats)
doCodegen :: Map Name LDecl -> [LDecl] -> (Text, CGStats)
doCodegen Map Name LDecl
defs = 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 forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ 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
"", 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
CGBodyState
st <- forall (m :: * -> *) s. Monad m => StateT s m s
get
let v :: Int
v = CGBodyState -> Int
lastIntName CGBodyState
st forall a. Num a => a -> a -> a
+ Int
1
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put forall a b. (a -> b) -> a -> b
$ CGBodyState
st {lastIntName :: Int
lastIntName = Int
v}
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int -> Text
jsNameGenerated Int
v
addPartial :: Partial -> State CGBodyState ()
addPartial :: Partial -> StateT CGBodyState Identity ()
addPartial Partial
p =
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (\CGBodyState
s -> CGBodyState
s {partialApps :: Set Partial
partialApps = 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 HiddenClass
p =
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (\CGBodyState
s -> CGBodyState
s {hiddenCls :: Set HiddenClass
hiddenCls = 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 Set (Text, Text)
p =
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (\CGBodyState
s -> CGBodyState
s {usedArgsTailCallOptim :: Set (Text, Text)
usedArgsTailCallOptim = 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 Name
n =
do
CGBodyState
st <- forall (m :: * -> *) s. Monad m => StateT s m s
get
case 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 Name
_ Int
conId Int
arity) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
conId, Int
arity)
Maybe LDecl
_ -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Internal JS Backend error " forall a. [a] -> [a] -> [a]
++ Name -> [Char]
showCG Name
n 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 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
_) -> forall a. a -> Maybe a
Just [Name]
a
Maybe LDecl
_ -> forall a. Maybe a
Nothing
getArgList :: Name -> State CGBodyState (Maybe [Name])
getArgList :: Name -> State CGBodyState (Maybe [Name])
getArgList Name
n =
do
CGBodyState
st <- forall (m :: * -> *) s. Monad m => StateT s m s
get
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 Map Name LDecl
dfs Name
n [Name]
args LExp
def = do
let fnName :: Text
fnName = Name -> Text
jsName Name
n
let argNames :: [Text]
argNames = forall a b. (a -> b) -> [a] -> [b]
map Name -> Text
jsName [Name]
args
let (([JsStmt]
decs, JsStmt
res),CGBodyState
st) = 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 = forall k a. Map k a
Map.empty
, currentFnNameAndArgs :: (Text, [Text])
currentFnNameAndArgs = (Text
fnName, [Text]
argNames)
, usedArgsTailCallOptim :: Set (Text, Text)
usedArgsTailCallOptim = forall a. Set a
Set.empty
, isTailRec :: Bool
isTailRec = Bool
False
, usedITBig :: Bool
usedITBig = Bool
False
, partialApps :: Set Partial
partialApps = forall a. Set a
Set.empty
, hiddenCls :: Set HiddenClass
hiddenCls = 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 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 forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(Text
x,Text
y) -> Text -> JsExpr -> JsStmt
JsDecLet Text
x (Text -> JsExpr
JsVar Text
y) ) (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), 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 (forall a. Ord a => a -> Set a -> Set a
Set.insert Text
n Set Text
s)
in if forall a. Set a -> Bool
Set.null forall a b. (a -> b) -> a -> b
$ (forall a. Ord a => [a] -> Set a
Set.fromList [ Text
z | Text
z <- forall from to. Biplate from to => from -> [to]
universeBi JsExpr
x ]) 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), 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
CGBodyState
st <- forall (m :: * -> *) s. Monad m => StateT s m s
get
case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
b (CGBodyState -> Map Name JsExpr
reWrittenNames CGBodyState
st) of
Just JsExpr
e -> forall (f :: * -> *) a. Applicative f => a -> f a
pure JsExpr
e
Maybe JsExpr
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> JsExpr
JsVar 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 forall a. Eq a => a -> a -> Bool
== [Char] -> [Char] -> Name
qualifyN [Char]
"Prelude.Bool" [Char]
"False" Bool -> Bool -> Bool
&&
Name
tt forall a. Eq a => a -> a -> Bool
== [Char] -> [Char] -> Name
qualifyN [Char]
"Prelude.Bool" [Char]
"True") ->
case (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 forall a. Eq a => a -> a -> Bool
== JsPrimTy
PTBool -> do
[([JsStmt], JsStmt)]
z <- 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]
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 forall a b. (a -> b) -> a -> b
$ [JsExpr] -> JsExpr
c forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (JsStmt -> JsExpr
jsStmt2Expr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [([JsStmt], JsStmt)]
z
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [([JsStmt], JsStmt)]
z, BodyResTarget -> JsExpr -> JsStmt
addRT BodyResTarget
rt JsExpr
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 forall a. Eq a => a -> a -> Bool
== [Char] -> [Char] -> Name
qualifyN [Char]
"Prelude.Bool" [Char]
"False" Bool -> Bool -> Bool
&&
Name
tt forall a. Eq a => a -> a -> Bool
== [Char] -> [Char] -> Name
qualifyN [Char]
"Prelude.Bool" [Char]
"True") -> do
([JsStmt]
d, 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)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ([JsStmt]
d, BodyResTarget -> JsExpr -> JsStmt
addRT BodyResTarget
rt forall a b. (a -> b) -> a -> b
$ Text -> JsExpr -> JsExpr
JsUniOp ([Char] -> Text
T.pack [Char]
"!") forall a b. (a -> b) -> a -> b
$ Text -> JsExpr -> JsExpr
JsUniOp ([Char] -> Text
T.pack [Char]
"!") JsExpr
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 forall a. Eq a => a -> a -> Bool
== [Char] -> [Char] -> Name
qualifyN [Char]
"Prelude.Bool" [Char]
"False" Bool -> Bool -> Bool
&&
Name
tt forall a. Eq a => a -> a -> Bool
== [Char] -> [Char] -> Name
qualifyN [Char]
"Prelude.Bool" [Char]
"True") -> do
([JsStmt]
d, 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)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ([JsStmt]
d, BodyResTarget -> JsExpr -> JsStmt
addRT BodyResTarget
rt forall a b. (a -> b) -> a -> b
$ Text -> JsExpr -> JsExpr
JsUniOp ([Char] -> Text
T.pack [Char]
"!") forall a b. (a -> b) -> a -> b
$ Text -> JsExpr -> JsExpr
JsUniOp ([Char] -> Text
T.pack [Char]
"!") JsExpr
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 forall a. Eq a => a -> a -> Bool
== [Char] -> [Char] -> Name
qualifyN [Char]
"Prelude.Bool" [Char]
"False" Bool -> Bool -> Bool
&&
Name
tt forall a. Eq a => a -> a -> Bool
== [Char] -> [Char] -> Name
qualifyN [Char]
"Prelude.Bool" [Char]
"True") -> do
([JsStmt]
d, 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)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ([JsStmt]
d, BodyResTarget -> JsExpr -> JsStmt
addRT BodyResTarget
rt forall a b. (a -> b) -> a -> b
$ Text -> JsExpr -> JsExpr
JsUniOp ([Char] -> Text
T.pack [Char]
"!") JsExpr
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 forall a. Eq a => a -> a -> Bool
== [Char] -> [Char] -> Name
qualifyN [Char]
"Prelude.Bool" [Char]
"False" Bool -> Bool -> Bool
&&
Name
tt forall a. Eq a => a -> a -> Bool
== [Char] -> [Char] -> Name
qualifyN [Char]
"Prelude.Bool" [Char]
"True") -> do
([JsStmt]
d, 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)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ([JsStmt]
d, BodyResTarget -> JsExpr -> JsStmt
addRT BodyResTarget
rt forall a b. (a -> b) -> a -> b
$ Text -> JsExpr -> JsExpr
JsUniOp ([Char] -> Text
T.pack [Char]
"!") JsExpr
test)
(LCase CaseType
f LExp
e [LConCase Int
nf Name
ff [] LExp
alt, LConCase Int
nt Name
tt [] LExp
conseq])
| (Name
ff forall a. Eq a => a -> a -> Bool
== [Char] -> [Char] -> Name
qualifyN [Char]
"Prelude.Bool" [Char]
"False" Bool -> Bool -> Bool
&&
Name
tt 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 forall a b. (a -> b) -> a -> b
$ CaseType -> LExp -> [LAlt] -> LExp
LCase CaseType
f LExp
e [forall e. Int -> Name -> [Name] -> e -> LAlt' e
LConCase Int
nt Name
tt [] LExp
conseq, 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
Maybe [Name]
argsFn <- Name -> State CGBodyState (Maybe [Name])
getArgList Name
n
case Maybe [Name]
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
JsExpr
n' <- Name -> State CGBodyState JsExpr
cgName Name
n
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ([], BodyResTarget -> JsExpr -> JsStmt
addRT BodyResTarget
rt JsExpr
n')
cgBody' BodyResTarget
rt (LApp Bool
tailcall (LV Name
fn) [LExp]
args) =
do
let fname :: Text
fname = Name -> Text
jsName Name
fn
CGBodyState
st <- forall (m :: * -> *) s. Monad m => StateT s m s
get
let (Text
currFn, [Text]
argN) = CGBodyState -> (Text, [Text])
currentFnNameAndArgs CGBodyState
st
[([JsStmt], JsStmt)]
z <- 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 = forall a b. (a -> b) -> [a] -> [b]
map (JsStmt -> JsExpr
jsStmt2Expr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [([JsStmt], JsStmt)]
z
let preDecs :: [JsStmt]
preDecs = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [([JsStmt], JsStmt)]
z
case (Text
fname forall a. Eq a => a -> a -> Bool
== Text
currFn Bool -> Bool -> Bool
&& (forall (t :: * -> *) a. Foldable t => t a -> Int
length [LExp]
args) forall a. Eq a => a -> a -> Bool
== (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
argN), BodyResTarget
rt) of
(Bool
True, BodyResTarget
ReturnBT) ->
do
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (\CGBodyState
x-> CGBodyState
x {isTailRec :: Bool
isTailRec = Bool
True})
let ((JsStmt
y1,JsStmt
y2), Set (Text, Text)
y3) = [(Text, JsExpr)]
-> Set Text -> ((JsStmt, JsStmt), Set (Text, Text))
tailCallOptimRefreshArgs (forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
argN [JsExpr]
argVals) forall a. Set a
Set.empty
Set (Text, Text) -> StateT CGBodyState Identity ()
addUsedArgsTailCallOptim Set (Text, Text)
y3
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([JsStmt]
preDecs, JsStmt
y1 JsStmt -> JsStmt -> JsStmt
`JsSeq` JsStmt
y2)
(Bool, BodyResTarget)
_ -> do
JsExpr
app <- Name -> [JsExpr] -> State CGBodyState JsExpr
formApp Name
fn [JsExpr]
argVals
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([JsStmt]
preDecs, BodyResTarget -> JsExpr -> JsStmt
addRT BodyResTarget
rt JsExpr
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
([JsStmt]
d,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)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], BodyResTarget -> JsExpr -> JsStmt
addRT BodyResTarget
rt forall a b. (a -> b) -> a -> b
$ JsExpr -> JsExpr
jsLazy forall a b. (a -> b) -> a -> b
$ JsStmt -> JsExpr
jsStmt2Expr forall a b. (a -> b) -> a -> b
$ JsStmt -> JsStmt -> JsStmt
JsSeq ([JsStmt] -> JsStmt
seqJs [JsStmt]
d) JsStmt
v)
cgBody' BodyResTarget
rt (LForce LExp
e) =
do
([JsStmt]
d,JsStmt
v) <- BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
cgBody BodyResTarget
GetExpBT LExp
e
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([JsStmt]
d, BodyResTarget -> JsExpr -> JsStmt
addRT BodyResTarget
rt forall a b. (a -> b) -> a -> b
$ JsExpr -> JsExpr
JsForce forall a b. (a -> b) -> a -> b
$ JsStmt -> JsExpr
jsStmt2Expr JsStmt
v)
cgBody' BodyResTarget
rt (LLet Name
n LExp
v LExp
sc) =
do
([JsStmt]
d1, JsStmt
v1) <- BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
cgBody (Text -> BodyResTarget
DecConstBT forall a b. (a -> b) -> a -> b
$ Name -> Text
jsName Name
n) LExp
v
([JsStmt]
d2, JsStmt
v2) <- BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
cgBody BodyResTarget
rt LExp
sc
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (([JsStmt]
d1 forall a. [a] -> [a] -> [a]
++ JsStmt
v1 forall a. a -> [a] -> [a]
: [JsStmt]
d2), JsStmt
v2)
cgBody' BodyResTarget
rt (LProj LExp
e Int
i) =
do
([JsStmt]
d, JsStmt
v) <- BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
cgBody BodyResTarget
GetExpBT LExp
e
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ([JsStmt]
d, BodyResTarget -> JsExpr -> JsStmt
addRT BodyResTarget
rt forall a b. (a -> b) -> a -> b
$ JsExpr -> JsExpr -> JsExpr
JsArrayProj (Int -> JsExpr
JsInt forall a b. (a -> b) -> a -> b
$ Int
iforall a. Num a => a -> a -> a
+Int
1) forall a b. (a -> b) -> a -> b
$ JsStmt -> JsExpr
jsStmt2Expr JsStmt
v)
cgBody' BodyResTarget
rt (LCon Maybe Name
_ Int
conId Name
n [LExp]
args) =
do
[([JsStmt], JsStmt)]
z <- 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 (forall a b. (a -> b) -> [a] -> [b]
map (JsStmt -> JsExpr
jsStmt2Expr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [([JsStmt], JsStmt)]
z)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [([JsStmt], JsStmt)]
z, BodyResTarget -> JsExpr -> JsStmt
addRT BodyResTarget
rt JsExpr
con)
cgBody' BodyResTarget
rt (LCase CaseType
_ LExp
e [LAlt]
alts) = do
([JsStmt]
d, JsStmt
v) <- BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
cgBody BodyResTarget
GetExpBT LExp
e
Text
resName <- State CGBodyState Text
getNewCGName
(JsStmt
decSw, JsExpr
entry) <-
case (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all LAlt -> Bool
altHasNoProj [LAlt]
alts Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Int
length [LAlt]
alts forall a. Ord a => a -> a -> Bool
<= Int
2, JsStmt
v) of
(Bool
True, JsStmt
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (JsStmt
JsEmpty, JsStmt -> JsExpr
jsStmt2Expr JsStmt
v)
(Bool
False, JsExprStmt (JsVar Text
n)) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (JsStmt
JsEmpty, JsStmt -> JsExpr
jsStmt2Expr JsStmt
v)
(Bool, JsStmt)
_ -> do
Text
swName <- State CGBodyState Text
getNewCGName
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> JsExpr -> JsStmt
JsDecConst Text
swName 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 JsStmt
x) -> JsStmt
x
Maybe JsStmt
Nothing -> JsExpr -> JsStmt
JsExprStmt JsExpr
JsNull
case BodyResTarget
rt of
BodyResTarget
ReturnBT -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([JsStmt]
d forall a. [a] -> [a] -> [a]
++ [JsStmt
decSw], JsStmt
sw)
(DecBT Text
nvar) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([JsStmt]
d forall a. [a] -> [a] -> [a]
++ [JsStmt
decSw, Text -> JsExpr -> JsStmt
JsDecLet Text
nvar JsExpr
JsNull], JsStmt
sw)
(DecConstBT Text
nvar) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([JsStmt]
d forall a. [a] -> [a] -> [a]
++ [JsStmt
decSw, Text -> JsExpr -> JsStmt
JsDecLet Text
nvar JsExpr
JsNull], JsStmt
sw)
(SetBT Text
nvar) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([JsStmt]
d forall a. [a] -> [a] -> [a]
++ [JsStmt
decSw], JsStmt
sw)
BodyResTarget
GetExpBT ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure
([JsStmt]
d forall a. [a] -> [a] -> [a]
++ [JsStmt
decSw, Text -> JsExpr -> JsStmt
JsDecLet Text
resName JsExpr
JsNull, JsStmt
sw], JsExpr -> JsStmt
JsExprStmt forall a b. (a -> b) -> a -> b
$ Text -> JsExpr
JsVar Text
resName)
cgBody' BodyResTarget
rt (LConst Const
c) =
do
JsExpr
cst <- Const -> State CGBodyState JsExpr
cgConst Const
c
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], (BodyResTarget -> JsExpr -> JsStmt
addRT BodyResTarget
rt) forall a b. (a -> b) -> a -> b
$ JsExpr
cst)
cgBody' BodyResTarget
rt (LOp PrimFn
op [LExp]
args) =
do
[([JsStmt], JsStmt)]
z <- 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 (forall a b. (a -> b) -> [a] -> [b]
map (JsStmt -> JsExpr
jsStmt2Expr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [([JsStmt], JsStmt)]
z)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [([JsStmt], JsStmt)]
z, BodyResTarget -> JsExpr -> JsStmt
addRT BodyResTarget
rt forall a b. (a -> b) -> a -> b
$ JsExpr
res)
cgBody' BodyResTarget
rt LExp
LNothing = forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], BodyResTarget -> JsExpr -> JsStmt
addRT BodyResTarget
rt JsExpr
JsNull)
cgBody' BodyResTarget
rt (LError [Char]
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], JsExpr -> JsStmt
JsError 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
[([JsStmt], JsStmt)]
z <- 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) (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(FDesc, LExp)]
args)
[JsExpr]
jsArgs <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (FDesc, JsExpr) -> State CGBodyState JsExpr
cgForeignArg (forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(FDesc, LExp)]
args) (forall a b. (a -> b) -> [a] -> [b]
map (JsStmt -> JsExpr
jsStmt2Expr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [([JsStmt], JsStmt)]
z))
JsExpr
jsDres <- FDesc -> JsExpr -> State CGBodyState JsExpr
cgForeignRes FDesc
dres forall a b. (a -> b) -> a -> b
$ Text -> [JsExpr] -> JsExpr
JsForeign ([Char] -> Text
T.pack [Char]
code) [JsExpr]
jsArgs
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [([JsStmt], JsStmt)]
z, BodyResTarget -> JsExpr -> JsStmt
addRT BodyResTarget
rt forall a b. (a -> b) -> a -> b
$ JsExpr
jsDres)
cgBody' BodyResTarget
_ LExp
x = forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Instruction " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show LExp
x 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 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 forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length [JsExpr]
argVals -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [JsExpr] -> JsExpr
g [JsExpr]
argVals
Maybe SSig
_ -> 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
Maybe [Name]
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ JsExpr -> [JsExpr] -> JsExpr
jsCurryApp JsExpr
fname [JsExpr]
argVals
Just [Name]
agFn -> do
let lenAgFn :: Int
lenAgFn = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
agFn
let lenArgs :: Int
lenArgs = forall (t :: * -> *) a. Foldable t => t a -> Int
length [JsExpr]
argVals
case forall a. Ord a => a -> a -> Ordering
compare Int
lenAgFn Int
lenArgs of
Ordering
EQ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ JsExpr -> [JsExpr] -> JsExpr
JsApp JsExpr
fname [JsExpr]
argVals
Ordering
LT -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ JsExpr -> [JsExpr] -> JsExpr
jsCurryApp (JsExpr -> [JsExpr] -> JsExpr
JsApp JsExpr
fname (forall a. Int -> [a] -> [a]
take Int
lenAgFn [JsExpr]
argVals)) (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
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [JsExpr] -> JsExpr
ctor [JsExpr]
args
Maybe ([JsExpr] -> JsExpr, JsExpr -> JsExpr, SProj)
Nothing -> do
(Int
conId, 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
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ if (Int
arity forall a. Ord a => a -> a -> Bool
> Int
0)
then JsExpr -> [JsExpr] -> JsExpr
JsNew (Text -> JsExpr
JsVar forall a b. (a -> b) -> a -> b
$ HiddenClass -> Text
jsNameHiddenClass HiddenClass
hc) [JsExpr]
args
else Text -> JsExpr
JsVar 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 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) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ JsExpr -> JsExpr
test JsExpr
x
Maybe ([JsExpr] -> JsExpr, JsExpr -> JsExpr, SProj)
Nothing -> do
(Int
conId, Int
arity) <- Name -> State CGBodyState (Int, Int)
getConsId Name
n
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> JsExpr -> JsExpr -> JsExpr
JsBinOp Text
"===" (JsExpr -> Text -> JsExpr
JsProp JsExpr
x ([Char] -> Text
T.pack [Char]
"type")) (Int -> JsExpr
JsInt Int
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 (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
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']
Const
_ -> do
JsExpr
t' <- Const -> State CGBodyState JsExpr
cgConst Const
t
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> JsExpr -> JsExpr -> JsExpr
JsBinOp Text
"===" JsExpr
scrvar JsExpr
t'
cgIfTree :: BodyResTarget
-> Text
-> JsExpr
-> [LAlt]
-> State CGBodyState (Maybe JsStmt)
cgIfTree :: BodyResTarget
-> Text -> JsExpr -> [LAlt] -> State CGBodyState (Maybe JsStmt)
cgIfTree BodyResTarget
_ Text
_ JsExpr
_ [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
cgIfTree BodyResTarget
rt Text
resName JsExpr
scrvar ((LConstCase Const
t LExp
exp):[LAlt]
r) = do
([JsStmt]
d, 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
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just 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 BodyResTarget
rt Text
resName JsExpr
scrvar ((LDefaultCase LExp
exp):[LAlt]
r) = do
([JsStmt]
d, JsStmt
v) <- BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
cgBody (Text -> BodyResTarget -> BodyResTarget
altsRT Text
resName BodyResTarget
rt) LExp
exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ JsStmt -> JsStmt -> JsStmt
JsSeq ([JsStmt] -> JsStmt
seqJs [JsStmt]
d) JsStmt
v
cgIfTree BodyResTarget
rt Text
resName JsExpr
scrvar ((LConCase Int
_ Name
n [Name]
args LExp
exp):[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 <- forall (m :: * -> *) s. Monad m => StateT s m s
get
let rwn :: Map Name JsExpr
rwn = CGBodyState -> Map Name JsExpr
reWrittenNames CGBodyState
st
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put forall a b. (a -> b) -> a -> b
$
CGBodyState
st
{ reWrittenNames :: Map Name JsExpr
reWrittenNames =
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
(\Map Name JsExpr
m (Name
n, Int
j) -> 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
(forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
args [Int
1 ..])
}
([JsStmt]
d, JsStmt
v) <- BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
cgBody (Text -> BodyResTarget -> BodyResTarget
altsRT Text
resName BodyResTarget
rt) LExp
exp
CGBodyState
st1 <- forall (m :: * -> *) s. Monad m => StateT s m s
get
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put 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
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just 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 Text
"JS_IntT") [FDesc]
_, JsExpr
v) = forall (f :: * -> *) a. Applicative f => a -> f a
pure JsExpr
v
cgForeignArg (FCon (UN Text
"JS_Str"), JsExpr
v) = forall (f :: * -> *) a. Applicative f => a -> f a
pure JsExpr
v
cgForeignArg (FCon (UN Text
"JS_Ptr"), JsExpr
v) = forall (f :: * -> *) a. Applicative f => a -> f a
pure JsExpr
v
cgForeignArg (FCon (UN Text
"JS_Unit"), JsExpr
v) = forall (f :: * -> *) a. Applicative f => a -> f a
pure JsExpr
v
cgForeignArg (FCon (UN Text
"JS_Float"), JsExpr
v) = 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) =
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
JsExpr
jsx <- (FDesc, JsExpr) -> State CGBodyState JsExpr
cgForeignArg (FDesc
a, Text -> JsExpr
JsVar Text
"x")
JsExpr
jsres <- FDesc -> JsExpr -> State CGBodyState JsExpr
cgForeignRes FDesc
b forall a b. (a -> b) -> a -> b
$ JsExpr -> [JsExpr] -> JsExpr
jsCurryApp (JsExpr -> [JsExpr] -> JsExpr
jsCurryApp JsExpr
f [JsExpr
jsx]) [JsExpr
JsNull]
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Text] -> JsStmt -> JsExpr
JsLambda [Text
"x"] forall a b. (a -> b) -> a -> b
$ JsExpr -> JsStmt
JsReturn JsExpr
jsres
cgForeignArg (FDesc
desc, JsExpr
_) =
do
CGBodyState
st <- forall (m :: * -> *) s. Monad m => StateT s m s
get
forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Foreign arg type " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show FDesc
desc forall a. [a] -> [a] -> [a]
++ [Char]
" not supported. While generating function " forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst 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 Text
"JS_IntT") [FDesc]
_) JsExpr
x = forall (f :: * -> *) a. Applicative f => a -> f a
pure JsExpr
x
cgForeignRes (FCon (UN Text
"JS_Unit")) JsExpr
x = forall (f :: * -> *) a. Applicative f => a -> f a
pure JsExpr
x
cgForeignRes (FCon (UN Text
"JS_Str")) JsExpr
x = forall (f :: * -> *) a. Applicative f => a -> f a
pure JsExpr
x
cgForeignRes (FCon (UN Text
"JS_Ptr")) JsExpr
x = forall (f :: * -> *) a. Applicative f => a -> f a
pure JsExpr
x
cgForeignRes (FCon (UN Text
"JS_Float")) JsExpr
x = forall (f :: * -> *) a. Applicative f => a -> f a
pure JsExpr
x
cgForeignRes FDesc
desc JsExpr
val =
do
CGBodyState
st <- forall (m :: * -> *) s. Monad m => StateT s m s
get
forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Foreign return type " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show FDesc
desc forall a. [a] -> [a] -> [a]
++ [Char]
" not supported. While generating function " forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ CGBodyState -> (Text, [Text])
currentFnNameAndArgs CGBodyState
st)
setUsedITBig :: State CGBodyState ()
setUsedITBig :: StateT CGBodyState Identity ()
setUsedITBig = forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (\CGBodyState
s -> CGBodyState
s {usedITBig :: Bool
usedITBig = Bool
True})
cgConst :: Const -> State CGBodyState JsExpr
cgConst :: Const -> State CGBodyState JsExpr
cgConst (I Int
i) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Int -> JsExpr
JsInt Int
i
cgConst (BI Integer
i) =
do
StateT CGBodyState Identity ()
setUsedITBig
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> [JsExpr] -> JsExpr
JsForeign Text
"new $JSRTS.jsbn.BigInteger(%0)" [[Char] -> JsExpr
JsStr forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show Integer
i]
cgConst (Ch Char
c) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Char] -> JsExpr
JsStr [Char
c]
cgConst (Str [Char]
s) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Char] -> JsExpr
JsStr [Char]
s
cgConst (Fl Double
f) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Double -> JsExpr
JsDouble Double
f
cgConst (B8 Word8
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> [JsExpr] -> JsExpr
JsForeign ([Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show Word8
x forall a. [a] -> [a] -> [a]
++ [Char]
" & 0xFF") []
cgConst (B16 Word16
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> [JsExpr] -> JsExpr
JsForeign ([Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show Word16
x forall a. [a] -> [a] -> [a]
++ [Char]
" & 0xFFFF") []
cgConst (B32 Word32
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> [JsExpr] -> JsExpr
JsForeign ([Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show Word32
x forall a. [a] -> [a] -> [a]
++ [Char]
"|0" ) []
cgConst (B64 Word64
x) =
do
StateT CGBodyState Identity ()
setUsedITBig
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show Word64
x, [Char] -> JsExpr
JsStr forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show Integer
0xFFFFFFFFFFFFFFFF]
cgConst Const
x | Const -> Bool
isTypeConst Const
x = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Int -> JsExpr
JsInt Int
0
cgConst Const
x = forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Constant " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Const
x 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 forall a. Eq a => a -> a -> Bool
== [Char] -> Name
sUN [Char]
"prim__null" = forall (f :: * -> *) a. Applicative f => a -> f a
pure JsExpr
JsNull
cgOp' JsPrimTy
pt (LExternal Name
name) [JsExpr
l,JsExpr
r] | Name
name forall a. Eq a => a -> a -> Bool
== [Char] -> Name
sUN [Char]
"prim__eqPtr" = forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 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
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
useBigInt StateT CGBodyState Identity ()
setUsedITBig
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ JsPrimTy -> JsPrimTy -> JsExpr -> JsExpr
jsPrimCoerce JsPrimTy
pti JsPrimTy
pt forall a b. (a -> b) -> a -> b
$ [JsExpr] -> JsExpr
combinator [JsExpr]
exps
Maybe PrimDec
Nothing -> forall a. HasCallStack => [Char] -> a
error ([Char]
"Operator " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (PrimFn
op, [JsExpr]
exps) forall a. [a] -> [a] -> [a]
++ [Char]
" not implemented")