@@ -71,6 +71,15 @@ getIncludes l = do
7171 incs <- mapM getInclude l
7272 return $ T.intercalate "\n\n" incs
7373
74+includeLibs :: [String] -> String
75+includeLibs =
76+ let
77+ repl '\\' = '_'
78+ repl '/' = '_'
79+ repl c = c
80+ in
81+ concatMap (\lib -> "var " ++ (repl <$> lib) ++ " = require(\"" ++ lib ++"\");\n")
82+
7483isYes :: Maybe String -> Bool
7584isYes (Just "Y") = True
7685isYes (Just "y") = True
@@ -80,12 +89,7 @@ isYes _ = False
8089codegenJs :: CGConf -> CodeGenerator
8190codegenJs conf ci =
8291 do
83− optim <- isYes <$> lookupEnv "IDRISJS_OPTIM"
8492 debug <- isYes <$> lookupEnv "IDRISJS_DEBUG"
85− if debug then
86− if optim then putStrLn "compiling width idris-js optimizations"
87− else putStrLn "compiling widthout idris-js optimizations"
88− else pure ()
8993 let defs = Map.fromList $ liftDecls ci
9094 let used = Map.elems $ removeDeadCode defs [sMN 0 "runMain"]
9195 if debug then
@@ -105,15 +109,20 @@ codegenJs conf ci =
105109 extraRT <- TIO.readFile $ path </> (extraRunTime conf)
106110
107111 includes <- getIncludes $ includes ci
112+ let libs = T.pack $ includeLibs $ compileLibs ci
108113 TIO.writeFile (outputFile ci) $ T.concat [ header conf
109114 , "\"use strict\";\n\n"
110115 , "(function(){\n\n"
116+ -- rts
111117 , runtimeCommon, "\n"
112118 , extraRT, "\n"
113119 , jsbn, "\n"
120+ -- external libraries
121+ , includes, "\n"
122+ , libs, "\n"
123+ -- user code
114124 , doPartials (partialApplications stats), "\n"
115125 , doHiddenClasses (hiddenClasses stats), "\n"
116− , includes, "\n"
117126 , out, "\n"
118127 , jsName (sMN 0 "runMain"), "();\n"
119128 , "}.call(this))"
@@ -135,6 +144,7 @@ doHiddenClasses :: Set HiddenClass -> Text
135144doHiddenClasses x =
136145 T.intercalate "\n" (map f $ Set.toList x)
137146 where
147+ f p@(HiddenClass n id 0) = jsStmt2Text $ JsDecConst (jsNameHiddenClass p) $ JsObj [("type", JsInt id)]
138148 f p@(HiddenClass n id arity) =
139149 let vars = map dataPartName $ take arity [1..]
140150 in jsStmt2Text $
@@ -349,27 +359,9 @@ cgBody' rt (LApp tailcall (LV (Glob fn)) args) =
349359 let ((y1,y2), y3) = tailCallOptimRefreshArgs (zip argN argVals) Set.empty
350360 addUsedArgsTailCallOptim y3
351361 pure (preDecs, y1 `JsSeq` y2)
352− _ ->
353− do
354− argsFn <- getArgList fn
355− case argsFn of
356− Nothing -> do
357− fn' <- cgName fn
358− pure (preDecs, addRT rt $ jsCurryApp fn' argVals )
359− Just agFn ->
360− do
361− let lenAgFn = length agFn
362− let lenArgs = length args
363− case compare lenAgFn lenArgs of
364− EQ ->
365− pure (preDecs, addRT rt $ jsAppN fname argVals)
366− LT ->
367− pure (preDecs, addRT rt $ jsCurryApp (jsAppN fname (take lenAgFn argVals)) (drop lenAgFn argVals) )
368− GT ->
369− do
370− let part = Partial fn lenArgs lenAgFn
371− addPartial part
372− pure (preDecs, addRT rt $ jsAppN (jsNamePartial part) argVals )
362+ _ -> do
363+ app <- formApp fn argVals
364+ pure (preDecs, addRT rt app)
373365
374366cgBody' rt (LForce (LLazyApp n args)) = cgBody rt (LApp False (LV (Glob n)) args)
375367cgBody' rt (LLazyApp n args) =
@@ -447,18 +439,36 @@ altHasNoProj :: LAlt -> Bool
447439altHasNoProj (LConCase _ _ args _) = args == []
448440altHasNoProj _ = True
449441
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+
450461formCon :: Name -> [JsExpr] -> State CGBodyState JsExpr
451462formCon n args = do
452463 case specialCased n of
453464 Just (ctor, test, match) -> pure $ ctor args
454465 Nothing -> do
455466 (conId, arity) <- getConsId n
456− if (arity > 0)
457− then do
458− let hc = HiddenClass n conId arity
459− addHiddenClass hc
460− pure $ JsNew (JsVar $ jsNameHiddenClass hc) args
461− 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
462472
463473formConTest :: Name -> JsExpr -> State CGBodyState JsExpr
464474formConTest n x = do
@@ -466,9 +476,10 @@ formConTest n x = do
466476 Just (ctor, test, match) -> pure $ test x
467477 Nothing -> do
468478 (conId, arity) <- getConsId n
469− if (arity > 0)
470− then pure $ JsBinOp "===" (JsProp x (T.pack "type")) (JsInt conId)
471− 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)
472483
473484formProj :: Name -> JsExpr -> Int -> JsExpr
474485formProj n v i =