git.iko.soy/Idris-dev
on master help sign in
created names for partial applications
2be53f8Rui Barreiro
src/IRTS/JavaScript/Codegen.hs+37−8
compare with master
unifiedsplit
@@ -41,11 +41,14 @@ import Data.Data
41import Data.Generics.Uniplate.Data
41import Data.Generics.Uniplate.Data
42import Data.List
42import Data.List
43
43
44+data Partial = Partial Name Int Int deriving (Eq, Ord)
45+
44data CGStats = CGStats { usedWriteStr :: Bool
46data CGStats = CGStats { usedWriteStr :: Bool
47+ , partialApplications :: Set Partial
45 }
48 }
46
49
47emptyStats :: CGStats
50emptyStats :: CGStats
48−emptyStats = CGStats {usedWriteStr = False}
51+emptyStats = CGStats {usedWriteStr = False, partialApplications = Set.empty}
49
52
50data CGConf = CGConf { header :: Text
53data CGConf = CGConf { header :: Text
51 , footer :: Text
54 , footer :: Text
@@ -92,6 +95,7 @@ codegenJs conf ci =
92 , "\"use strict\";\n\n"
95 , "\"use strict\";\n\n"
93 , "(function(){\n\n"
96 , "(function(){\n\n"
94 , initialization conf stats
97 , initialization conf stats
98+ , doPartials (partialApplications stats)
95 , includes, "\n"
99 , includes, "\n"
96 , js_aux_defs, "\n"
100 , js_aux_defs, "\n"
97 , out, "\n"
101 , out, "\n"
@@ -106,10 +110,24 @@ jsName n = T.pack $ "idris_" ++ concatMap jschar (showCG n)
106 where jschar x | isAlpha x || isDigit x = [x]
110 where jschar x | isAlpha x || isDigit x = [x]
107 | otherwise = "_" ++ show (fromEnum x) ++ "_"
111 | otherwise = "_" ++ show (fromEnum x) ++ "_"
108
112
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+
109doCodegen :: CGConf -> LDefs -> [LDecl] -> (Text, CGStats)
126doCodegen :: CGConf -> LDefs -> [LDecl] -> (Text, CGStats)
110doCodegen conf defs decls =
127doCodegen conf defs decls =
111 let xs = map (doCodegenDecl conf defs) decls
128 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 }
113 in (T.intercalate "\n" $ map fst xs, foldl' groupCGStats emptyStats (map snd xs) )
131 in (T.intercalate "\n" $ map fst xs, foldl' groupCGStats emptyStats (map snd xs) )
114
132
115doCodegenDecl :: CGConf -> LDefs -> LDecl -> (Text, CGStats)
133doCodegenDecl :: CGConf -> LDefs -> LDecl -> (Text, CGStats)
@@ -123,12 +141,14 @@ seqJs :: [JsAST] -> JsAST
123seqJs [] = JsEmpty
141seqJs [] = JsEmpty
124seqJs (x:xs) = JsSeq x (seqJs xs)
142seqJs (x:xs) = JsSeq x (seqJs xs)
125
143
144+
126data CGBodyState = CGBodyState { defs :: LDefs
145data CGBodyState = CGBodyState { defs :: LDefs
127 , lastIntName :: Int
146 , lastIntName :: Int
128 , currentFnNameAndArgs :: (Text, [Text])
147 , currentFnNameAndArgs :: (Text, [Text])
129 , isTailRec :: Bool
148 , isTailRec :: Bool
130 , conf :: CGConf
149 , conf :: CGConf
131 , usedWrite :: Bool
150 , usedWrite :: Bool
151+ , partialApps :: Set Partial
132 }
152 }
133
153
134getNewCGName :: State CGBodyState Text
154getNewCGName :: State CGBodyState Text
@@ -139,6 +159,11 @@ getNewCGName =
139 put $ st {lastIntName = v}
159 put $ st {lastIntName = v}
140 return $ T.pack $ "cgIdris_" ++ show v
160 return $ T.pack $ "cgIdris_" ++ show v
141
161
162+addPartial :: Partial -> State CGBodyState ()
163+addPartial p =
164+ modify (\s -> s {partialApps = Set.insert p (partialApps s) })
165+
166+
142getNewCGNames :: Int -> State CGBodyState [Text]
167getNewCGNames :: Int -> State CGBodyState [Text]
143getNewCGNames n =
168getNewCGNames n =
144 mapM (\_ -> getNewCGName) [1..n]
169 mapM (\_ -> getNewCGName) [1..n]
@@ -189,17 +214,17 @@ cgFun cnf dfs n args def =
189 , isTailRec = False
214 , isTailRec = False
190 , conf = cnf
215 , conf = cnf
191 , usedWrite = False
216 , usedWrite = False
217+ , partialApps = Set.empty
192 }
218 }
193 )
219 )
194 body = if isTailRec st then
220 body = if isTailRec st then
195 JsFor (JsLetList [("cgArgs", JsApp "Array.prototype.slice.call" [JsVar "arguments"]), ("cgArgs2", JsNull) ] , JsTrue, JsSetVar "cgArgs" (JsVar "cgArgs2") ) $
221 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 $
197 replaceVarsByProj
222 replaceVarsByProj
198 (JsVar "cgArgs")
223 (JsVar "cgArgs")
199 (Map.fromList $ zip argNames [0..])
224 (Map.fromList $ zip argNames [0..])
200 ((seqJs decs) `JsSeq` res)
225 ((seqJs decs) `JsSeq` res)
201 else JsSeq (seqJs decs) res
226 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})
203
228
204getSwitchJs :: JsAST -> [LAlt] -> JsAST
229getSwitchJs :: JsAST -> [LAlt] -> JsAST
205getSwitchJs x alts =
230getSwitchJs x alts =
@@ -224,8 +249,10 @@ cgBody rt (LV (Glob n)) =
224 pure $ ([], addRT rt $ JsApp (jsName n) [])
249 pure $ ([], addRT rt $ JsApp (jsName n) [])
225 Just a ->
250 Just a ->
226 do
251 do
227− newNames <- getNewCGNames $ length a
252+ --newNames <- getNewCGNames $ length a
253+ let part = Partial n 0 (length a)
254+ addPartial part
228− pure ([], addRT rt $ JsCurryLambda newNames (JsApp (jsName n) (map JsVar newNames)))
255+ pure ([], addRT rt $ JsApp (jsPartialName part) []) --JsCurryLambda newNames (JsApp (jsName n) (map JsVar newNames)))
229 Nothing ->
256 Nothing ->
230 pure $ ([], addRT rt $ JsVar $ jsName n)
257 pure $ ([], addRT rt $ JsVar $ jsName n)
231cgBody rt (LApp tailcall (LV (Glob fn)) args) =
258cgBody rt (LApp tailcall (LV (Glob fn)) args) =
@@ -262,8 +289,10 @@ cgBody rt (LApp tailcall (LV (Glob fn)) args) =
262 pure (preDecs, addRT rt $ JsCurryApp (JsApp fname (take lenAgFn argVals )) (drop lenAgFn argVals) )
289 pure (preDecs, addRT rt $ JsCurryApp (JsApp fname (take lenAgFn argVals )) (drop lenAgFn argVals) )
263 GT ->
290 GT ->
264 do
291 do
292+ let part = Partial fn lenArgs lenAgFn
293+ addPartial part
265− newNames <- getNewCGNames $ lenAgFn - lenArgs
294+ --newNames <- getNewCGNames $ lenAgFn - lenArgs
266− pure (preDecs, addRT rt $ JsCurryLambda newNames (JsApp fname (argVals ++ (map JsVar newNames) ) ) )
295+ pure (preDecs, addRT rt $ JsApp (jsPartialName part) argVals ) -- JsCurryLambda newNames (JsApp fname (argVals ++ (map JsVar newNames) ) ) )
267
296
268cgBody rt (LForce (LLazyApp n args)) = cgBody rt (LApp False (LV (Glob n)) args)
297cgBody rt (LForce (LLazyApp n args)) = cgBody rt (LApp False (LV (Glob n)) args)
269cgBody rt (LLazyApp n args) =
298cgBody rt (LLazyApp n args) =