@@ -262,6 +262,43 @@ jsError :: String -> JS
262262jsError err = JSApp (JSFunction [] (JSError err)) []
263263
264264
265+foldJS :: (JS -> a) -> (a -> a -> a) -> a -> JS -> a
266+foldJS tr add acc js =
267+ fold js
268+ where
269+ fold js
270+ | JSFunction args body <- js =
271+ add (tr js) (fold body)
272+ | JSSeq seq <- js =
273+ add (tr js) $ foldl' add acc (map fold seq)
274+ | JSReturn ret <- js =
275+ add (tr js) (fold ret)
276+ | JSApp lhs rhs <- js =
277+ add (tr js) $ add (fold lhs) (foldl' add acc $ map fold rhs)
278+ | JSNew _ args <- js =
279+ add (tr js) $ foldl' add acc $ map fold args
280+ | JSOp _ lhs rhs <- js =
281+ add (tr js) $ add (fold lhs) (fold rhs)
282+ | JSProj obj _ <- js =
283+ add (tr js) (fold obj)
284+ | JSArray vals <- js =
285+ add (tr js) $ foldl' add acc $ map fold vals
286+ | JSAssign lhs rhs <- js =
287+ add (tr js) $ add (fold lhs) (fold rhs)
288+ | JSIndex lhs rhs <- js =
289+ add (tr js) $ add (fold lhs) (fold rhs)
290+ | JSAlloc _ val <- js =
291+ add (tr js) $ fromMaybe acc $ fmap fold val
292+ | JSTernary c t f <- js =
293+ add (tr js) $ add (fold c) (add (fold t) (fold f))
294+ | JSParens val <- js =
295+ add (tr js) $ fold val
296+ | JSCond conds <- js =
297+ add (tr js) $ foldl' add acc $ map (uncurry add . (fold *** fold)) conds
298+ | otherwise =
299+ tr js
300+
301+
265302transformJS :: (JS -> JS) -> JS -> JS
266303transformJS tr js =
267304 transformHelper js
@@ -449,37 +486,11 @@ deadEvalApplyCases js =
449486 map (removeHelper tags) js
450487 where
451488 getTags :: JS -> [Int]
452− getTags (JSNew "__IDRRT__Con" [JSNum (JSInt tag), args]) =
453− tag : getTags args
454−
455− getTags (JSNew _ args) = concatMap getTags args
456−
457− getTags (JSFunction _ body) = getTags body
458−
459− getTags (JSReturn ret) = getTags ret
460−
461− getTags (JSApp lhs rhs) = getTags lhs ++ concatMap getTags rhs
462−
463− getTags (JSSeq seq) = concatMap getTags seq
464−
465− getTags (JSOp _ lhs rhs) = getTags lhs ++ getTags rhs
466−
467− getTags (JSProj obj _) = getTags obj
468−
469− getTags (JSArray vals) = concatMap getTags vals
470−
471− getTags (JSAssign lhs rhs) = getTags lhs ++ getTags rhs
472−
473− getTags (JSAlloc _ (Just val)) = getTags val
474−
475− getTags (JSCond conds) =
476− concatMap (uncurry (++)) $ map (getTags *** getTags) conds
477−
478− getTags (JSTernary c t f) = getTags c ++ getTags t ++ getTags f
479−
480− getTags (JSParens js) = getTags js
481−
482− getTags js = []
489+ getTags = foldJS match (++) []
490+ where
491+ match js
492+ | JSNew "__IDRRT__Con" [JSNum (JSInt tag), _] <- js = [tag]
493+ | otherwise = []
483494
484495
485496 removeHelper :: [Int] -> JS -> JS
@@ -509,36 +520,11 @@ initConstructors js =
509520 map createConstant tags ++ replaceConstructors tags js
510521 where
511522 getTags :: JS -> [Int]
512− getTags (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []]) = [tag]
513−
514− getTags (JSNew _ args) = concatMap getTags args
515−
516− getTags (JSFunction _ body) = getTags body
517−
518− getTags (JSReturn ret) = getTags ret
519−
520− getTags (JSApp lhs rhs) = getTags lhs ++ concatMap getTags rhs
521−
522− getTags (JSSeq seq) = concatMap getTags seq
523−
524− getTags (JSOp _ lhs rhs) = getTags lhs ++ getTags rhs
525−
526− getTags (JSProj obj _) = getTags obj
527−
528− getTags (JSArray vals) = concatMap getTags vals
529−
530− getTags (JSAssign lhs rhs) = getTags lhs ++ getTags rhs
531−
532− getTags (JSAlloc _ (Just val)) = getTags val
533−
534− getTags (JSCond conds) =
535− concatMap (uncurry (++)) $ map (getTags *** getTags) conds
536−
537− getTags (JSTernary c t f) = getTags c ++ getTags t ++ getTags f
538−
539− getTags (JSParens js) = getTags js
540−
541− getTags js = []
523+ getTags = foldJS match (++) []
524+ where
525+ match js
526+ | JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []] <- js = [tag]
527+ | otherwise = []
542528
543529
544530 replaceConstructors :: [Int] -> [JS] -> [JS]
@@ -630,58 +616,13 @@ inlineFunctions js =
630616
631617
632618 countInvokations :: String -> JS -> Int
633− countInvokations name (JSApp (JSIdent ident) args)
634− | name == ident = 1 + (sum $ map (countInvokations name) args)
635− | otherwise = sum $ map (countInvokations name) args
636−
637− countInvokations name (JSApp lhs rhs) =
638− countInvokations name lhs + (sum $ map (countInvokations name) rhs)
639−
640− countInvokations name (JSFunction _ body) =
641− countInvokations name body
642−
643− countInvokations name (JSSeq seq) =
644− sum $ map (countInvokations name) seq
645−
646− countInvokations name (JSReturn ret) =
647− countInvokations name ret
648−
649− countInvokations name (JSNew _ args) =
650− sum $ map (countInvokations name) args
651−
652− countInvokations name (JSOp _ lhs rhs) =
653− countInvokations name lhs + countInvokations name rhs
654−
655− countInvokations name (JSProj obj _) =
656− countInvokations name obj
657−
658− countInvokations name (JSArray vals) =
659− sum $ map (countInvokations name) vals
660−
661− countInvokations name (JSAssign _ rhs) =
662− countInvokations name rhs
663−
664− countInvokations name (JSAlloc _ (Just js)) =
665− countInvokations name js
666−
667− countInvokations name (JSIndex lhs rhs) =
668− countInvokations name lhs + countInvokations name rhs
669−
670− countInvokations name (JSCond conds) =
671− sum $ map (uncurry (+)) (
672− map (countInvokations name *** countInvokations name) conds
673− )
674−
675− countInvokations name (JSTernary c t f) =
676− sum $ [ countInvokations name c
677− , countInvokations name t
678− , countInvokations name f
679− ]
680−
681− countInvokations name (JSParens js) =
682− countInvokations name js
683−
684− countInvokations _ _ = 0
619+ countInvokations name = foldJS match (+) 0
620+ where
621+ match :: JS -> Int
622+ match js
623+ | JSApp (JSIdent ident) _ <- js
624+ , name == ident = 1
625+ | otherwise = 0
685626
686627
687628reduceConstant :: JS -> JS