@@ -78,6 +78,15 @@ getIncludes l = do
7878 incs <- mapM getInclude l
7979 return $ T.intercalate "\n\n" incs
8080
81+includeLibs :: [String] -> String
82+includeLibs =
83+ let
84+ repl '\\' = '_'
85+ repl '/' = '_'
86+ repl c = c
87+ in
88+ concatMap (\lib -> "var " ++ (repl <$> lib) ++ " = require(\"" ++ lib ++"\");\n")
89+
8190isYes :: Maybe String -> Bool
8291isYes (Just "Y") = True
8392isYes (Just "y") = True
@@ -87,12 +96,7 @@ isYes _ = False
8796codegenJs :: CGConf -> CodeGenerator
8897codegenJs conf ci =
8998 do
90− optim <- isYes <$> lookupEnv "IDRISJS_OPTIM"
9199 debug <- isYes <$> lookupEnv "IDRISJS_DEBUG"
92− if debug then
93− if optim then putStrLn "compiling width idris-js optimizations"
94− else putStrLn "compiling widthout idris-js optimizations"
95− else pure ()
96100 let defs = Map.fromList $ liftDecls ci
97101 let used = Map.elems $ removeDeadCode defs [sMN 0 "runMain"]
98102 if debug then
@@ -112,15 +116,20 @@ codegenJs conf ci =
112116 extraRT <- TIO.readFile $ path </> (extraRunTime conf)
113117
114118 includes <- getIncludes $ includes ci
119+ let libs = T.pack $ includeLibs $ compileLibs ci
115120 TIO.writeFile (outputFile ci) $ T.concat [ header conf
116121 , "\"use strict\";\n\n"
117122 , "(function(){\n\n"
123+ -- rts
118124 , runtimeCommon, "\n"
119125 , extraRT, "\n"
120126 , jsbn, "\n"
127+ -- external libraries
128+ , includes, "\n"
129+ , libs, "\n"
130+ -- user code
121131 , doPartials (partialApplications stats), "\n"
122132 , doHiddenClasses (hiddenClasses stats), "\n"
123− , includes, "\n"
124133 , out, "\n"
125134 , jsName (sMN 0 "runMain"), "();\n"
126135 , "}.call(this))"
@@ -142,6 +151,7 @@ doHiddenClasses :: Set HiddenClass -> Text
142151doHiddenClasses x =
143152 T.intercalate "\n" (map f $ Set.toList x)
144153 where
154+ f p@(HiddenClass n id 0) = jsStmt2Text $ JsDecConst (jsNameHiddenClass p) $ JsObj [("type", JsInt id)]
145155 f p@(HiddenClass n id arity) =
146156 let vars = map dataPartName $ take arity [1..]
147157 in jsStmt2Text $
@@ -356,27 +366,9 @@ cgBody' rt (LApp tailcall (LV (Glob fn)) args) =
356366 let ((y1,y2), y3) = tailCallOptimRefreshArgs (zip argN argVals) Set.empty
357367 addUsedArgsTailCallOptim y3
358368 pure (preDecs, y1 `JsSeq` y2)
359− _ ->
360− do
361− argsFn <- getArgList fn
362− case argsFn of
363− Nothing -> do
364− fn' <- cgName fn
365− pure (preDecs, addRT rt $ jsCurryApp fn' argVals )
366− Just agFn ->
367− do
368− let lenAgFn = length agFn
369− let lenArgs = length args
370− case compare lenAgFn lenArgs of
371− EQ ->
372− pure (preDecs, addRT rt $ jsAppN fname argVals)
373− LT ->
374− pure (preDecs, addRT rt $ jsCurryApp (jsAppN fname (take lenAgFn argVals)) (drop lenAgFn argVals) )
375− GT ->
376− do
377− let part = Partial fn lenArgs lenAgFn
378− addPartial part
379− pure (preDecs, addRT rt $ jsAppN (jsNamePartial part) argVals )
369+ _ -> do
370+ app <- formApp fn argVals
371+ pure (preDecs, addRT rt app)
380372
381373cgBody' rt (LForce (LLazyApp n args)) = cgBody rt (LApp False (LV (Glob n)) args)
382374cgBody' rt (LLazyApp n args) =
@@ -454,18 +446,36 @@ altHasNoProj :: LAlt -> Bool
454446altHasNoProj (LConCase _ _ args _) = args == []
455447altHasNoProj _ = True
456448
449+formApp :: Name -> [JsExpr] -> State CGBodyState JsExpr
450+formApp fn argVals = case specialCall fn of
451+ Just (arity, g) | arity == length argVals -> pure $ g argVals
452+ _ -> do
453+ argsFn <- getArgList fn
454+ fname <- cgName fn
455+ case argsFn of
456+ Nothing -> pure $ jsCurryApp fname argVals
457+ Just agFn -> do
458+ let lenAgFn = length agFn
459+ let lenArgs = length argVals
460+ case compare lenAgFn lenArgs of
461+ EQ -> pure $ JsApp fname argVals
462+ LT -> pure $ jsCurryApp (JsApp fname (take lenAgFn argVals)) (drop lenAgFn argVals)
463+ GT -> do
464+ let part = Partial fn lenArgs lenAgFn
465+ addPartial part
466+ pure $ jsAppN (jsNamePartial part) argVals
467+
457468formCon :: Name -> [JsExpr] -> State CGBodyState JsExpr
458469formCon n args = do
459470 case specialCased n of
460471 Just (ctor, test, match) -> pure $ ctor args
461472 Nothing -> do
462473 (conId, arity) <- getConsId n
463− if (arity > 0)
464− then do
465− let hc = HiddenClass n conId arity
466− addHiddenClass hc
467− pure $ JsNew (JsVar $ jsNameHiddenClass hc) args
468− else pure $ JsInt conId
474+ let hc = HiddenClass n conId arity
475+ addHiddenClass hc
476+ pure $ if (arity > 0)
477+ then JsNew (JsVar $ jsNameHiddenClass hc) args
478+ else JsVar $ jsNameHiddenClass hc
469479
470480formConTest :: Name -> JsExpr -> State CGBodyState JsExpr
471481formConTest n x = do
@@ -473,9 +483,10 @@ formConTest n x = do
473483 Just (ctor, test, match) -> pure $ test x
474484 Nothing -> do
475485 (conId, arity) <- getConsId n
476− if (arity > 0)
477− then pure $ JsBinOp "===" (JsProp x (T.pack "type")) (JsInt conId)
478− else pure $ JsBinOp "===" x (JsInt conId)
486+ pure $ JsBinOp "===" (JsProp x (T.pack "type")) (JsInt conId)
487+ -- if (arity > 0)
488+ -- then pure $ JsBinOp "===" (JsProp x (T.pack "type")) (JsInt conId)
489+ -- else pure $ JsBinOp "===" x (JsInt conId)
479490
480491formProj :: Name -> JsExpr -> Int -> JsExpr
481492formProj n v i =