8caab55 · elk · git.iko.soy

1{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE OverloadedStrings #-}

2module Canonicalize.Expression

3module Canonicalize.Expression

3 ( canonicalize

4 ( canonicalize

4 , FreeLocals

5 , FreeLocals

9 where

10 where

10

11

12

13+import Control.Monad (foldM)

12import qualified Data.Graph as Graph

14import qualified Data.Graph as Graph

15+import qualified Data.List as List

13import qualified Data.Map.Strict as Map

16import qualified Data.Map.Strict as Map

17+import qualified Data.Text as Text

14

18

15import qualified AST.Canonical as Can

19import qualified AST.Canonical as Can

16import qualified AST.Source as Src

20import qualified AST.Source as Src

287canonicalizeLet :: R.Region -> Env.Env -> [Valid.Def] -> Valid.Expr -> Result FreeLocals [W.Warning] Can.Expr

291canonicalizeLet :: R.Region -> Env.Env -> [Valid.Def] -> Valid.Expr -> Result FreeLocals [W.Warning] Can.Expr

288canonicalizeLet letRegion env defs body =

292canonicalizeLet letRegion env defs body =

289 directUsage $

293 directUsage $

290− do let keyedDefs = zip defs [ 0 .. length defs ]

294+ do bindings <-

291− let names = foldr addBindings Dups.none keyedDefs

292− nameDict <- Dups.detect (Error.DuplicatePattern Error.DPLetBinding) names

295+ Dups.detect (Error.DuplicatePattern Error.DPLetBinding) $

296+ List.foldl' addBindings Dups.none defs

293

297

294− let bindings = Map.map A.toRegion nameDict

295− let defKeys = Map.map A.toValue nameDict

296− newEnv <- Env.addLocals bindings env

298+ newEnv <- Env.addLocals bindings env

297

299

298− ((nodes, cbody), freeLocals) <-

299 verifyBindings W.Def bindings $

300 verifyBindings W.Def bindings $

300− (,)

301+ do nodes <- foldM (addDefNodes newEnv) [] defs

301− <$> traverse (defToNode defKeys newEnv) keyedDefs

302− <*> canonicalize newEnv body

302+ cbody <- canonicalize newEnv body

303−

304− letExpr <-

305− detectCycles letRegion (Graph.stronglyConnComp nodes) cbody

303+ detectCycles letRegion (Graph.stronglyConnComp nodes) cbody

306−

307− return (letExpr, freeLocals)

308

304

309

305

310

306

311-- ADD BINDINGS

307-- ADD BINDINGS

312

308

313

309

314−type Bindings =

315− Dups.Dict (A.Located Int)

316−

317−

318−addBindings :: (Valid.Def, Int) -> Bindings -> Bindings

310+addBindings :: Dups.Dict R.Region -> Valid.Def -> Dups.Dict R.Region

319−addBindings (def, key) bindings =

311+addBindings bindings def =

320 case def of

312 case def of

321− Valid.Define defRegion (A.At region name) _ _ _ ->

313+ Valid.Define _ (A.At region name) _ _ _ ->

322− Dups.insert name region (A.At defRegion key) bindings

314+ Dups.insert name region region bindings

323

315

324− Valid.Destruct defRegion pattern _ ->

316+ Valid.Destruct _ pattern _ ->

325− addBindingsHelp (A.At defRegion key) pattern bindings

317+ addBindingsHelp bindings pattern

326

318

327

319

328−addBindingsHelp :: A.Located Int -> Src.Pattern -> Bindings -> Bindings

320+addBindingsHelp :: Dups.Dict R.Region -> Src.Pattern -> Dups.Dict R.Region

329−addBindingsHelp key (A.At region pattern) bindings =

321+addBindingsHelp bindings (A.At region pattern) =

330 case pattern of

322 case pattern of

331 Src.PAnything ->

323 Src.PAnything ->

332 bindings

324 bindings

333

325

334 Src.PVar name ->

326 Src.PVar name ->

335− Dups.insert name region key bindings

327+ Dups.insert name region region bindings

336

328

337 Src.PRecord fields ->

329 Src.PRecord fields ->

338 let

330 let

339− addField (A.At fieldRegion name) dict =

331+ addField dict (A.At fieldRegion name) =

340− Dups.insert name fieldRegion key dict

332+ Dups.insert name fieldRegion fieldRegion dict

341 in

333 in

342− foldr addField bindings fields

334+ List.foldl' addField bindings fields

343

335

344 Src.PUnit ->

336 Src.PUnit ->

345 bindings

337 bindings

346

338

347 Src.PTuple a b cs ->

339 Src.PTuple a b cs ->

348− foldr (addBindingsHelp key) bindings (a:b:cs)

340+ List.foldl' addBindingsHelp bindings (a:b:cs)

349

341

350 Src.PCtor _ _ _ patterns ->

342 Src.PCtor _ _ _ patterns ->

351− foldr (addBindingsHelp key) bindings patterns

343+ List.foldl' addBindingsHelp bindings patterns

352

344

353 Src.PList patterns ->

345 Src.PList patterns ->

354− foldr (addBindingsHelp key) bindings patterns

346+ List.foldl' addBindingsHelp bindings patterns

355

347

356− Src.PCons first rest ->

348+ Src.PCons hd tl ->

357− addBindingsHelp key rest (addBindingsHelp key first bindings)

349+ addBindingsHelp (addBindingsHelp bindings hd) tl

358

350

359− Src.PAlias ptrn (A.At reg name) ->

351+ Src.PAlias aliasPattern (A.At nameRegion name) ->

360− addBindingsHelp key ptrn (Dups.insert name reg key bindings)

352+ Dups.insert name nameRegion nameRegion $

353+ addBindingsHelp bindings aliasPattern

361

354

362 Src.PChr _ ->

355 Src.PChr _ ->

363 bindings

356 bindings

374

367

375

368

376type Node =

369type Node =

377− (Binding, Int, [Int])

370+ (Binding, N.Name, [N.Name])

378

371

379

372

380data Binding

373data Binding

381− = Define R.Region Can.Def

374+ = Define Can.Def

375+ | Edge (A.Located N.Name)

382− | Destruct R.Region Can.Pattern Can.Expr

376+ | Destruct Can.Pattern Can.Expr

383

377

384

378

385−defToNode :: Map.Map N.Name Int -> Env.Env -> (Valid.Def, Int) -> Result FreeLocals [W.Warning] Node

379+addDefNodes :: Env.Env -> [Node] -> Valid.Def -> Result FreeLocals [W.Warning] [Node]

386−defToNode defKeys env (def, key) =

380+addDefNodes env nodes def =

387 case def of

381 case def of

388− Valid.Define region aname@(A.At _ name) srcArgs body Nothing ->

382+ Valid.Define _ aname@(A.At _ name) srcArgs body maybeType ->

383+ case maybeType of

384+ Nothing ->

389− do (args, argBindings) <-

385+ do (args, argBindings) <-

390− Pattern.verify (Error.DPFuncArgs name) $

386+ Pattern.verify (Error.DPFuncArgs name) $

391− traverse (Pattern.canonicalize env) srcArgs

387+ traverse (Pattern.canonicalize env) srcArgs

392

388

393− newEnv <-

389+ newEnv <-

394− Env.addLocals argBindings env

390+ Env.addLocals argBindings env

395

391

396− (cbody, freeLocals) <-

392+ (cbody, freeLocals) <-

397− verifyBindings W.Pattern argBindings (canonicalize newEnv body)

393+ verifyBindings W.Pattern argBindings (canonicalize newEnv body)

398

394

399− logLetLocals args freeLocals

400− ( Define region (Can.Def aname args cbody)

395+ let cdef = Can.Def aname args cbody

401− , key

396+ let node = ( Define cdef, name, Map.keys freeLocals )

402− , Map.elems (Map.intersection defKeys freeLocals)

397+ logLetLocals args freeLocals (node:nodes)

403− )

404

398

399+ Just tipe ->

400+ do (Can.Forall freeVars ctipe) <- Type.toAnnotation env tipe

401+ ((args, resultType), argBindings) <-

402+ Pattern.verify (Error.DPFuncArgs name) $

403+ gatherTypedArgs env name srcArgs ctipe Index.first []

404+

405+ newEnv <-

406+ Env.addLocals argBindings env

407+

408+ (cbody, freeLocals) <-

409+ verifyBindings W.Pattern argBindings (canonicalize newEnv body)

410+

411+ let cdef = Can.TypedDef aname freeVars args cbody resultType

412+ let node = ( Define cdef, name, Map.keys freeLocals )

413+ logLetLocals args freeLocals (node:nodes)

414+

405− Valid.Destruct region pattern body ->

415+ Valid.Destruct _ pattern body ->

406 do (cpattern, _bindings) <-

416 do (cpattern, _bindings) <-

407 Pattern.verify Error.DPDestruct $

417 Pattern.verify Error.DPDestruct $

408 Pattern.canonicalize env pattern

418 Pattern.canonicalize env pattern

409

419

410− Result.Result $ \freeLocals warnings bad good ->

420+ Result.Result $ \fs ws bad good ->

411 case canonicalize env body of

421 case canonicalize env body of

412 Result.Result k ->

422 Result.Result k ->

413− k Map.empty warnings

423+ k Map.empty ws

414− (\_ ws es -> bad freeLocals ws es)

424+ (\freeLocals warnings errors ->

415− (\newFreeLocals warnings1 cbody ->

425+ bad (Map.unionWith combineUses freeLocals fs) warnings errors

426+ )

427+ (\freeLocals warnings cbody ->

428+ let

429+ names = getPatternNames [] pattern

430+ name = Text.intercalate "$" (map A.toValue names)

431+ node = ( Destruct cpattern cbody, name, Map.keys freeLocals )

432+ in

416 good

433 good

417− (Map.unionWith combineUses freeLocals newFreeLocals)

434+ (Map.unionWith combineUses fs freeLocals)

418− warnings1

435+ warnings

419− ( Destruct region cpattern cbody

436+ (List.foldl' (addEdge [name]) (node:nodes) names)

420− , key

421− , Map.elems (Map.intersection defKeys freeLocals)

422− )

423 )

437 )

424

438

425− Valid.Define region aname@(A.At _ name) srcArgs body (Just tipe) ->

426− do (Can.Forall freeVars ctipe) <- Type.toAnnotation env tipe

427− ((args, resultType), argBindings) <-

428− Pattern.verify (Error.DPFuncArgs name) $

429− gatherTypedArgs env name srcArgs ctipe Index.first []

430−

431− newEnv <-

432− Env.addLocals argBindings env

433−

434− (cbody, freeLocals) <-

435− verifyBindings W.Pattern argBindings (canonicalize newEnv body)

436−

437− logLetLocals args freeLocals

438− ( Define region (Can.TypedDef aname freeVars args cbody resultType)

439− , key

440− , Map.elems (Map.intersection defKeys freeLocals)

441− )

442−

443

439

444logLetLocals :: [arg] -> FreeLocals -> value -> Result FreeLocals w value

440logLetLocals :: [arg] -> FreeLocals -> value -> Result FreeLocals w value

445logLetLocals args letLocals value =

441logLetLocals args letLocals value =

454 value

450 value

455

451

456

452

453+addEdge :: [N.Name] -> [Node] -> A.Located N.Name -> [Node]

454+addEdge edges nodes aname@(A.At _ name) =

455+ (Edge aname, name, edges) : nodes

456+

457+

458+getPatternNames :: [A.Located N.Name] -> Src.Pattern -> [A.Located N.Name]

459+getPatternNames names (A.At region pattern) =

460+ case pattern of

461+ Src.PAnything -> names

462+ Src.PVar name -> A.At region name : names

463+ Src.PRecord fields -> fields ++ names

464+ Src.PAlias ptrn name -> getPatternNames (name : names) ptrn

465+ Src.PUnit -> names

466+ Src.PTuple a b cs -> List.foldl' getPatternNames (getPatternNames (getPatternNames names a) b) cs

467+ Src.PCtor _ _ _ args -> List.foldl' getPatternNames names args

468+ Src.PList patterns -> List.foldl' getPatternNames names patterns

469+ Src.PCons hd tl -> getPatternNames (getPatternNames names hd) tl

470+ Src.PChr _ -> names

471+ Src.PStr _ -> names

472+ Src.PInt _ -> names

473+

474+

457

475

458-- GATHER TYPED ARGS

476-- GATHER TYPED ARGS

459

477

495 Result.ok body

513 Result.ok body

496

514

497 scc : subSccs ->

515 scc : subSccs ->

498− A.At letRegion <$>

499 case scc of

516 case scc of

500 Graph.AcyclicSCC binding ->

517 Graph.AcyclicSCC binding ->

501 case binding of

518 case binding of

502− Define _ def ->

519+ Define def ->

503− Can.Let def

504− <$> detectCycles letRegion subSccs body

520+ A.At letRegion . Can.Let def <$> detectCycles letRegion subSccs body

521+

522+ Edge _ ->

523+ detectCycles letRegion subSccs body

505

524

506− Destruct _ pattern expr ->

525+ Destruct pattern expr ->

507− Can.LetDestruct pattern expr

508− <$> detectCycles letRegion subSccs body

526+ A.At letRegion . Can.LetDestruct pattern expr <$> detectCycles letRegion subSccs body

509

527

510 Graph.CyclicSCC bindings ->

528 Graph.CyclicSCC bindings ->

511− case traverse requireFunction bindings of

529+ A.At letRegion <$>

512− Just defs ->

513− Can.LetRec defs

530+ (Can.LetRec

531+ <$> checkCycle bindings []

514− <$> detectCycles letRegion subSccs body

532+ <*> detectCycles letRegion subSccs body

533+ )

515

534

516− Nothing ->

517− Result.throw (Error.RecursiveLet letRegion (map toCycleNodes bindings))

518

535

536+checkCycle :: [Binding] -> [Can.Def] -> Result i w [Can.Def]

537+checkCycle bindings defs =

538+ case bindings of

539+ [] ->

540+ Result.ok defs

519

541

520−requireFunction :: Binding -> Maybe Can.Def

542+ binding : otherBindings ->

521−requireFunction binding =

522− case binding of

543+ case binding of

523− Define _ def@(Can.Def _ (_:_) _) ->

544+ Define def@(Can.Def name args _) ->

524− Just def

545+ if null args then

546+ Result.throw (Error.RecursiveLet name (toNames otherBindings defs))

547+ else

548+ checkCycle otherBindings (def:defs)

525

549

526− Define _ def@(Can.TypedDef _ _ (_:_) _ _) ->

550+ Define def@(Can.TypedDef name _ args _ _) ->

527− Just def

551+ if null args then

552+ Result.throw (Error.RecursiveLet name (toNames otherBindings defs))

553+ else

554+ checkCycle otherBindings (def:defs)

528

555

529− _ ->

556+ Edge name ->

530− Nothing

557+ Result.throw (Error.RecursiveLet name (toNames otherBindings defs))

531

558

559+ Destruct _ _ ->

560+ -- a Destruct cannot appear in a cycle without any Edge values

561+ -- so we just keep going until we get to the edges

562+ checkCycle otherBindings defs

532

563

533−toCycleNodes :: Binding -> Error.CycleNode

534−toCycleNodes binding =

535− case binding of

536− Define _ def ->

537− case def of

538− Can.Def name args _ ->

539− if null args then Error.CycleValue name else Error.CycleFunc name

540

564

541− Can.TypedDef name _ args _ _ ->

565+toNames :: [Binding] -> [Can.Def] -> [N.Name]

542− if null args then Error.CycleValue name else Error.CycleFunc name

566+toNames bindings revDefs =

567+ case bindings of

568+ [] ->

569+ reverse (map getDefName revDefs)

570+

571+ binding : otherBindings ->

572+ case binding of

573+ Define def -> getDefName def : toNames otherBindings revDefs

574+ Edge (A.At _ name) -> name : toNames otherBindings revDefs

575+ Destruct _ _ -> toNames otherBindings revDefs

576+

577+

578+getDefName :: Can.Def -> N.Name

579+getDefName def =

580+ case def of

581+ Can.Def (A.At _ name) _ _ ->

582+ name

543

583

544− Destruct _ pattern _ ->

584+ Can.TypedDef (A.At _ name) _ _ _ _ ->

545− Error.CyclePattern pattern

585+ name

546

586

547

587

548

588