3a86b7c · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

on master help sign in

javascript: added foldJS

3a86b7craichoo13 years ago

src/IRTS/CodegenJavaScript.hs+54−113

compare with master

unifiedsplit

@@ -262,6 +262,43 @@ jsError :: String -> JS

262jsError err = JSApp (JSFunction [] (JSError err)) []

263

264

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+

265transformJS :: (JS -> JS) -> JS -> JS

302transformJS :: (JS -> JS) -> JS -> JS

266transformJS tr js =

303transformJS tr js =

267 transformHelper js

304 transformHelper js

@@ -449,37 +486,11 @@ deadEvalApplyCases js =

449 map (removeHelper tags) js

486 map (removeHelper tags) js

450 where

487 where

451 getTags :: JS -> [Int]

488 getTags :: JS -> [Int]

489+ getTags = foldJS match (++) []

490+ where

491+ match js

452− getTags (JSNew "__IDRRT__Con" [JSNum (JSInt tag), args]) =

492+ | JSNew "__IDRRT__Con" [JSNum (JSInt tag), _] <- js = [tag]

453− tag : getTags args

493+ | otherwise = []

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 = []

483

494

484

495

485 removeHelper :: [Int] -> JS -> JS

496 removeHelper :: [Int] -> JS -> JS

@@ -509,36 +520,11 @@ initConstructors js =

509 map createConstant tags ++ replaceConstructors tags js

520 map createConstant tags ++ replaceConstructors tags js

510 where

521 where

511 getTags :: JS -> [Int]

522 getTags :: JS -> [Int]

523+ getTags = foldJS match (++) []

524+ where

525+ match js

512− getTags (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []]) = [tag]

526+ | JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []] <- js = [tag]

513−

527+ | otherwise = []

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 = []

542

528

543

529

544 replaceConstructors :: [Int] -> [JS] -> [JS]

530 replaceConstructors :: [Int] -> [JS] -> [JS]

@@ -630,58 +616,13 @@ inlineFunctions js =

630

616

631

617

632 countInvokations :: String -> JS -> Int

618 countInvokations :: String -> JS -> Int

619+ countInvokations name = foldJS match (+) 0

620+ where

621+ match :: JS -> Int

622+ match js

633− countInvokations name (JSApp (JSIdent ident) args)

623+ | JSApp (JSIdent ident) _ <- js

634− | name == ident = 1 + (sum $ map (countInvokations name) args)

624+ , name == ident = 1

635− | otherwise = sum $ map (countInvokations name) args

625+ | otherwise = 0

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

685

626

686

627

687reduceConstant :: JS -> JS

628reduceConstant :: JS -> JS