@@ -41,11 +41,14 @@ import Data.Data
4141import Data.Generics.Uniplate.Data
4242import Data.List
4343
44+data Partial = Partial Name Int Int deriving (Eq, Ord)
45+
4446data CGStats = CGStats { usedWriteStr :: Bool
47+ , partialApplications :: Set Partial
4548 }
4649
4750emptyStats :: CGStats
48−emptyStats = CGStats {usedWriteStr = False}
51+emptyStats = CGStats {usedWriteStr = False, partialApplications = Set.empty}
4952
5053data CGConf = CGConf { header :: Text
5154 , footer :: Text
@@ -92,6 +95,7 @@ codegenJs conf ci =
9295 , "\"use strict\";\n\n"
9396 , "(function(){\n\n"
9497 , initialization conf stats
98+ , doPartials (partialApplications stats)
9599 , includes, "\n"
96100 , js_aux_defs, "\n"
97101 , out, "\n"
@@ -106,10 +110,24 @@ jsName n = T.pack $ "idris_" ++ concatMap jschar (showCG n)
106110 where jschar x | isAlpha x || isDigit x = [x]
107111 | otherwise = "_" ++ show (fromEnum x) ++ "_"
108112
113+jsPartialName :: Partial -> Text
114+jsPartialName (Partial n i j) = T.concat ["partial_", T.pack $ show i, "_", T.pack $ show j, "_" , jsName n]
115+
116+doPartials :: Set Partial -> Text
117+doPartials x =
118+ T.intercalate "\n" (map f $ Set.toList x)
119+ where
120+ f p@(Partial n i j) =
121+ let vars1 = map (T.pack . ("x"++) . show) [1..i]
122+ vars2 = map (T.pack . ("x"++) . show) [(i+1)..j]
123+ in jsAst2Text $
124+ JsFun (jsPartialName p) vars1 $ JsReturn $ JsCurryLambda vars2 (JsApp (jsName n) (map JsVar (vars1 ++ vars2)) )
125+
109126doCodegen :: CGConf -> LDefs -> [LDecl] -> (Text, CGStats)
110127doCodegen conf defs decls =
111128 let xs = map (doCodegenDecl conf defs) decls
112− groupCGStats x y = CGStats {usedWriteStr = usedWriteStr x || usedWriteStr y}
129+ groupCGStats x y = CGStats {usedWriteStr = usedWriteStr x || usedWriteStr y
130+ , partialApplications = partialApplications x `Set.union` partialApplications y }
113131 in (T.intercalate "\n" $ map fst xs, foldl' groupCGStats emptyStats (map snd xs) )
114132
115133doCodegenDecl :: CGConf -> LDefs -> LDecl -> (Text, CGStats)
@@ -123,12 +141,14 @@ seqJs :: [JsAST] -> JsAST
123141seqJs [] = JsEmpty
124142seqJs (x:xs) = JsSeq x (seqJs xs)
125143
144+
126145data CGBodyState = CGBodyState { defs :: LDefs
127146 , lastIntName :: Int
128147 , currentFnNameAndArgs :: (Text, [Text])
129148 , isTailRec :: Bool
130149 , conf :: CGConf
131150 , usedWrite :: Bool
151+ , partialApps :: Set Partial
132152 }
133153
134154getNewCGName :: State CGBodyState Text
@@ -139,6 +159,11 @@ getNewCGName =
139159 put $ st {lastIntName = v}
140160 return $ T.pack $ "cgIdris_" ++ show v
141161
162+addPartial :: Partial -> State CGBodyState ()
163+addPartial p =
164+ modify (\s -> s {partialApps = Set.insert p (partialApps s) })
165+
166+
142167getNewCGNames :: Int -> State CGBodyState [Text]
143168getNewCGNames n =
144169 mapM (\_ -> getNewCGName) [1..n]
@@ -189,17 +214,17 @@ cgFun cnf dfs n args def =
189214 , isTailRec = False
190215 , conf = cnf
191216 , usedWrite = False
217+ , partialApps = Set.empty
192218 }
193219 )
194220 body = if isTailRec st then
195221 JsFor (JsLetList [("cgArgs", JsApp "Array.prototype.slice.call" [JsVar "arguments"]), ("cgArgs2", JsNull) ] , JsTrue, JsSetVar "cgArgs" (JsVar "cgArgs2") ) $
196− --JsSeq (JsDecVar "cgArgs" $ JsApp "Array.prototype.slice.call" [JsVar "arguments"]) $ JsWhileTrue $
197222 replaceVarsByProj
198223 (JsVar "cgArgs")
199224 (Map.fromList $ zip argNames [0..])
200225 ((seqJs decs) `JsSeq` res)
201226 else JsSeq (seqJs decs) res
202− in (JsFun fnName argNames $ body, CGStats {usedWriteStr = usedWrite st})
227+ in (JsFun fnName argNames $ body, CGStats {usedWriteStr = usedWrite st, partialApplications = partialApps st})
203228
204229getSwitchJs :: JsAST -> [LAlt] -> JsAST
205230getSwitchJs x alts =
@@ -224,8 +249,10 @@ cgBody rt (LV (Glob n)) =
224249 pure $ ([], addRT rt $ JsApp (jsName n) [])
225250 Just a ->
226251 do
227− newNames <- getNewCGNames $ length a
228− pure ([], addRT rt $ JsCurryLambda newNames (JsApp (jsName n) (map JsVar newNames)))
252+ --newNames <- getNewCGNames $ length a
253+ let part = Partial n 0 (length a)
254+ addPartial part
255+ pure ([], addRT rt $ JsApp (jsPartialName part) []) --JsCurryLambda newNames (JsApp (jsName n) (map JsVar newNames)))
229256 Nothing ->
230257 pure $ ([], addRT rt $ JsVar $ jsName n)
231258cgBody rt (LApp tailcall (LV (Glob fn)) args) =
@@ -262,8 +289,10 @@ cgBody rt (LApp tailcall (LV (Glob fn)) args) =
262289 pure (preDecs, addRT rt $ JsCurryApp (JsApp fname (take lenAgFn argVals )) (drop lenAgFn argVals) )
263290 GT ->
264291 do
265− newNames <- getNewCGNames $ lenAgFn - lenArgs
266− pure (preDecs, addRT rt $ JsCurryLambda newNames (JsApp fname (argVals ++ (map JsVar newNames) ) ) )
292+ let part = Partial fn lenArgs lenAgFn
293+ addPartial part
294+ --newNames <- getNewCGNames $ lenAgFn - lenArgs
295+ pure (preDecs, addRT rt $ JsApp (jsPartialName part) argVals ) -- JsCurryLambda newNames (JsApp fname (argVals ++ (map JsVar newNames) ) ) )
267296
268297cgBody rt (LForce (LLazyApp n args)) = cgBody rt (LApp False (LV (Glob n)) args)
269298cgBody rt (LLazyApp n args) =