@@ -89,12 +89,7 @@ isYes _ = False
8989codegenJs :: CGConf -> CodeGenerator
9090codegenJs conf ci =
9191 do
92− optim <- isYes <$> lookupEnv "IDRISJS_OPTIM"
9392 debug <- isYes <$> lookupEnv "IDRISJS_DEBUG"
94− if debug then
95− if optim then putStrLn "compiling width idris-js optimizations"
96− else putStrLn "compiling widthout idris-js optimizations"
97− else pure ()
9893 let defs = Map.fromList $ liftDecls ci
9994 let used = Map.elems $ removeDeadCode defs [sMN 0 "runMain"]
10095 if debug then
@@ -118,13 +113,16 @@ codegenJs conf ci =
118113 TIO.writeFile (outputFile ci) $ T.concat [ header conf
119114 , "\"use strict\";\n\n"
120115 , "(function(){\n\n"
116+ -- rts
121117 , runtimeCommon, "\n"
122118 , extraRT, "\n"
123119 , jsbn, "\n"
124− , doPartials (partialApplications stats), "\n"
125− , doHiddenClasses (hiddenClasses stats), "\n"
120+ -- external libraries
126121 , includes, "\n"
127122 , libs, "\n"
123+ -- user code
124+ , doPartials (partialApplications stats), "\n"
125+ , doHiddenClasses (hiddenClasses stats), "\n"
128126 , out, "\n"
129127 , jsName (sMN 0 "runMain"), "();\n"
130128 , "}.call(this))"
@@ -146,6 +144,7 @@ doHiddenClasses :: Set HiddenClass -> Text
146144doHiddenClasses x =
147145 T.intercalate "\n" (map f $ Set.toList x)
148146 where
147+ f p@(HiddenClass n id 0) = jsStmt2Text $ JsDecConst (jsNameHiddenClass p) $ JsObj [("type", JsInt id)]
149148 f p@(HiddenClass n id arity) =
150149 let vars = map dataPartName $ take arity [1..]
151150 in jsStmt2Text $
@@ -360,27 +359,9 @@ cgBody' rt (LApp tailcall (LV (Glob fn)) args) =
360359 let ((y1,y2), y3) = tailCallOptimRefreshArgs (zip argN argVals) Set.empty
361360 addUsedArgsTailCallOptim y3
362361 pure (preDecs, y1 `JsSeq` y2)
363− _ ->
364− do
365− argsFn <- getArgList fn
366− case argsFn of
367− Nothing -> do
368− fn' <- cgName fn
369− pure (preDecs, addRT rt $ jsCurryApp fn' argVals )
370− Just agFn ->
371− do
372− let lenAgFn = length agFn
373− let lenArgs = length args
374− case compare lenAgFn lenArgs of
375− EQ ->
376− pure (preDecs, addRT rt $ jsAppN fname argVals)
377− LT ->
378− pure (preDecs, addRT rt $ jsCurryApp (jsAppN fname (take lenAgFn argVals)) (drop lenAgFn argVals) )
379− GT ->
380− do
381− let part = Partial fn lenArgs lenAgFn
382− addPartial part
383− pure (preDecs, addRT rt $ jsAppN (jsNamePartial part) argVals )
362+ _ -> do
363+ app <- formApp fn argVals
364+ pure (preDecs, addRT rt app)
384365
385366cgBody' rt (LForce (LLazyApp n args)) = cgBody rt (LApp False (LV (Glob n)) args)
386367cgBody' rt (LLazyApp n args) =
@@ -458,18 +439,36 @@ altHasNoProj :: LAlt -> Bool
458439altHasNoProj (LConCase _ _ args _) = args == []
459440altHasNoProj _ = True
460441
442+formApp :: Name -> [JsExpr] -> State CGBodyState JsExpr
443+formApp fn argVals = case specialCall fn of
444+ Just (arity, g) | arity == length argVals -> pure $ g argVals
445+ _ -> do
446+ argsFn <- getArgList fn
447+ fname <- cgName fn
448+ case argsFn of
449+ Nothing -> pure $ jsCurryApp fname argVals
450+ Just agFn -> do
451+ let lenAgFn = length agFn
452+ let lenArgs = length argVals
453+ case compare lenAgFn lenArgs of
454+ EQ -> pure $ JsApp fname argVals
455+ LT -> pure $ jsCurryApp (JsApp fname (take lenAgFn argVals)) (drop lenAgFn argVals)
456+ GT -> do
457+ let part = Partial fn lenArgs lenAgFn
458+ addPartial part
459+ pure $ jsAppN (jsNamePartial part) argVals
460+
461461formCon :: Name -> [JsExpr] -> State CGBodyState JsExpr
462462formCon n args = do
463463 case specialCased n of
464464 Just (ctor, test, match) -> pure $ ctor args
465465 Nothing -> do
466466 (conId, arity) <- getConsId n
467− if (arity > 0)
468− then do
469− let hc = HiddenClass n conId arity
470− addHiddenClass hc
471− pure $ JsNew (JsVar $ jsNameHiddenClass hc) args
472− else pure $ JsInt conId
467+ let hc = HiddenClass n conId arity
468+ addHiddenClass hc
469+ pure $ if (arity > 0)
470+ then JsNew (JsVar $ jsNameHiddenClass hc) args
471+ else JsVar $ jsNameHiddenClass hc
473472
474473formConTest :: Name -> JsExpr -> State CGBodyState JsExpr
475474formConTest n x = do
@@ -477,9 +476,10 @@ formConTest n x = do
477476 Just (ctor, test, match) -> pure $ test x
478477 Nothing -> do
479478 (conId, arity) <- getConsId n
480− if (arity > 0)
481− then pure $ JsBinOp "===" (JsProp x (T.pack "type")) (JsInt conId)
482− else pure $ JsBinOp "===" x (JsInt conId)
479+ pure $ JsBinOp "===" (JsProp x (T.pack "type")) (JsInt conId)
480+ -- if (arity > 0)
481+ -- then pure $ JsBinOp "===" (JsProp x (T.pack "type")) (JsInt conId)
482+ -- else pure $ JsBinOp "===" x (JsInt conId)
483483
484484formProj :: Name -> JsExpr -> Int -> JsExpr
485485formProj n v i =