a2a2fc0 · elk · git.iko.soy

git.iko.soy/elk

Track region information in canonical defs

This way we can show the whole def and underline the bad return value in type errors where the annotation clashes with the body

commita2a2fc0c4cd4e77920449439aa760ea4f4419435 authorEvan Czaplicki <evancz@users.noreply.github.com> dateTue 20 Sep 2016, 12:55 (10 years ago) parentdcce951

11 files changed+62−72

compare with master

unifiedsplit

src/AST/Expression/Canonical.hs+1−12 src/AST/Expression/Optimized.hs+1−2 src/AST/Expression/Valid.hs+2−2 src/AST/Variable.hs−11 src/Canonicalize.hs+4−4 src/Canonicalize/Body.hs+1−1 src/Canonicalize/Setup.hs+1−1 src/Generate/JavaScript/Expression.hs+2−2 src/Optimize.hs+8−13 src/Type/Constrain/Expression.hs+28−11 src/Validate.hs+14−13

src/AST/Expression/Canonical.hs+1−12

@@ -2,7 +2,6 @@

22module AST.Expression.Canonical

33 ( Expr, Expr'

44 , Def(..)

5− , Facts(..), dummyFacts

65 , SortedDefs(..), toSortedDefs

76 )

87 where

@@ -27,17 +26,7 @@ type Expr' =

2726

2827

2928data Def

30− = Def Facts Pattern.Canonical Expr (Maybe (A.Located Type.Canonical))

31−

32−

33−data Facts = Facts

34− { dependencies :: [Var.TopLevel]

35− }

36−

37−

38−dummyFacts :: Facts

39−dummyFacts =

40− Facts (error "This should be set by Canonicalize.Sort")

29+ = Def R.Region Pattern.Canonical Expr (Maybe (A.Located Type.Canonical))

4130

4231

4332

src/AST/Expression/Optimized.hs+1−2

@@ -24,13 +24,12 @@ data Def

2424

2525data Facts = Facts

2626 { home :: Maybe ModuleName.Canonical

27− , dependencies :: [Var.TopLevel]

2827 }

2928

3029

3130dummyFacts :: Facts

3231dummyFacts =

33− Facts Nothing []

32+ Facts Nothing

3433

3534

3635-- EXPRESSIONS

src/AST/Expression/Valid.hs+2−2

@@ -21,10 +21,10 @@ type Expr' =

2121

2222

2323data Def =

24− Def Pattern.Raw Expr (Maybe Type.Raw)

24+ Def R.Region Pattern.Raw Expr (Maybe Type.Raw)

2525

2626

2727getPattern :: Def -> Pattern.Raw

28−getPattern (Def pattern _ _) =

28+getPattern (Def _ pattern _ _) =

2929 pattern

3030

src/AST/Variable.hs−11

@@ -16,17 +16,6 @@ newtype Raw = Raw String

1616

1717

1818

19−-- TOP LEVEL NAMES

20−

21−

22−data TopLevel = TopLevelVar

23− { topHome :: ModuleName.Canonical

24− , topName :: String

25− }

26− deriving (Eq, Ord)

27−

28−

29−

3019-- CANONICAL NAMES

3120

3221

src/Canonicalize.hs+4−4

@@ -324,8 +324,8 @@ canonicalizeDecls env (D.Decls defs unions aliases infixes) =

324324 annTraverse canEntry entries =

325325 traverse (\(A.A ann entry) -> A.A ann <$> canEntry entry) entries

326326

327− canonicalizeDef (Valid.Def pat expr typ) =

328− Canonical.Def Canonical.dummyFacts

327+ canonicalizeDef (Valid.Def region pat expr typ) =

328+ Canonical.Def region

329329 <$> canonicalizePattern env pat

330330 <*> canonicalizeExpr env expr

331331 <*> traverse (canonicalizeRegionType env) typ

@@ -408,8 +408,8 @@ canonicalizeExpr env (A.A region validExpr) =

408408 env' =

409409 foldr Env.addPattern env (map Valid.getPattern defs)

410410

411− rename' (Valid.Def p body mtipe) =

412− Canonical.Def Canonical.dummyFacts

411+ rename' (Valid.Def defRegion p body mtipe) =

412+ Canonical.Def defRegion

413413 <$> canonicalizePattern env' p

414414 <*> canonicalizeExpr env' body

415415 <*> traverse (canonicalizeRegionType env') mtipe

src/Canonicalize/Body.hs+1−1

@@ -104,7 +104,7 @@ buildFunction vars body@(A.A ann _) =

104104definition :: String -> Canonical.Expr -> R.Region -> Type.Canonical -> Canonical.Def

105105definition name expr@(A.A ann _) region tipe =

106106 Canonical.Def

107− Canonical.dummyFacts

107+ region

108108 (A.A ann (P.Var name))

109109 expr

110110 (Just (A.A region tipe))

src/Canonicalize/Setup.hs+1−1

@@ -327,7 +327,7 @@ declsToPatches moduleName (D.Decls defs unions aliases _) =

327327

328328 -- TO PATCHES

329329

330− defToPatches (A.A _ (Valid.Def pattern _ _)) =

330+ defToPatches (A.A _ (Valid.Def _ pattern _ _)) =

331331 map topLevelValue (P.boundVarList pattern)

332332

333333 unionToPatches (A.A _ (D.Type name _ ctors)) =

src/Generate/JavaScript/Expression.hs+2−2

@@ -87,10 +87,10 @@ generateDef :: Opt.Def -> State Int [Statement ()]

8787generateDef def =

8888 do (home, name, jsBody) <-

8989 case def of

90− Opt.TailDef (Opt.Facts home _) name argNames body ->

90+ Opt.TailDef (Opt.Facts home) name argNames body ->

9191 (,,) home name <$> generateTailFunction name argNames body

9292

93− Opt.Def (Opt.Facts home _) name body ->

93+ Opt.Def (Opt.Facts home) name body ->

9494 (,,) home name <$> generateJsExpr body

9595

9696 return (Var.define home name jsBody)

src/Optimize.hs+8−13

@@ -32,7 +32,7 @@ optimize variantDict home defs =

3232

3333

3434optimizeDef :: Bool -> Can.Def -> Env.Optimizer [Opt.Def]

35−optimizeDef isRoot (Can.Def (Can.Facts deps) pattern expression _) =

35+optimizeDef isRoot (Can.Def _ pattern expression _) =

3636 let

3737 (args, canBody) =

3838 Expr.collectLambdas expression

@@ -45,20 +45,19 @@ optimizeDef isRoot (Can.Def (Can.Facts deps) pattern expression _) =

4545 return Nothing

4646 in

4747 do home <- maybeGetHome

48− optimizeDefHelp home deps pattern args canBody

48+ optimizeDefHelp home pattern args canBody

4949

5050

5151optimizeDefHelp

5252 :: Maybe ModuleName.Canonical

53− -> [Var.TopLevel]

5453 -> P.Canonical

5554 -> [P.Canonical]

5655 -> Can.Expr

5756 -> Env.Optimizer [Opt.Def]

58−optimizeDefHelp home deps pattern@(A.A _ ptrn) args rawBody =

57+optimizeDefHelp home pattern@(A.A _ ptrn) args rawBody =

5958 let

6059 facts =

61− Opt.Facts home deps

60+ Opt.Facts home

6261 in

6362 case (ptrn, args) of

6463 (P.Var name, _ : _) ->

@@ -125,20 +124,16 @@ depatternArgs (names, rawExpr) ptrn =

125124patternToDefs :: Maybe ModuleName.Canonical -> String -> P.Canonical -> [Opt.Def]

126125patternToDefs home rootName pattern =

127126 let

128− (deps, rootExpr) =

127+ rootExpr =

129128 case home of

130129 Nothing ->

131− ( []

132− , Opt.Var (Var.local rootName)

133− )

130+ Opt.Var (Var.local rootName)

134131

135132 Just moduleName ->

136− ( [ Var.TopLevelVar moduleName rootName ]

137− , Opt.Var (Var.topLevel moduleName rootName)

138− )

133+ Opt.Var (Var.topLevel moduleName rootName)

139134

140135 toDef (name, accessExpr) =

141− Opt.Def (Opt.Facts home deps) name accessExpr

136+ Opt.Def (Opt.Facts home) name accessExpr

142137 in

143138 map toDef (patternToSubstitutions rootExpr pattern)

144139

src/Type/Constrain/Expression.hs+28−11

@@ -490,13 +490,13 @@ data Info = Info

490490

491491

492492constrainDef :: Env.Env -> Info -> Canonical.Def -> IO Info

493−constrainDef env info (Canonical.Def _ (A.A patternRegion pattern) expr maybeTipe) =

493+constrainDef env info (Canonical.Def defRegion (A.A patternRegion pattern) expr maybeTipe) =

494494 case (pattern, maybeTipe) of

495495 (P.Var name, Nothing) ->

496496 constrainUnannotatedDef env patternRegion name expr info

497497

498498 (P.Var name, Just (A.A _ tipe)) ->

499− constrainAnnotatedDef env patternRegion name expr tipe info

499+ constrainAnnotatedDef env defRegion patternRegion name expr tipe info

500500

501501 _ ->

502502 error "canonical definitions must not have complex patterns as names in the contstraint generation phase"

@@ -520,8 +520,16 @@ constrainUnannotatedDef env patternRegion name expr info =

520520 }

521521

522522

523−constrainAnnotatedDef :: Env.Env -> R.Region -> String -> Canonical.Expr -> ST.Canonical -> Info -> IO Info

524−constrainAnnotatedDef env region name expr tipe info =

523+constrainAnnotatedDef

524+ :: Env.Env

525+ -> R.Region

526+ -> R.Region

527+ -> String

528+ -> Canonical.Expr

529+ -> ST.Canonical

530+ -> Info

531+ -> IO Info

532+constrainAnnotatedDef env defRegion region name expr tipe info =

525533 do (flexType, flexVars) <- Env.instantiateType Flex env tipe

526534

527535 let scheme =

@@ -532,7 +540,7 @@ constrainAnnotatedDef env region name expr tipe info =

532540 , _header = Map.singleton name (A.A region flexType)

533541 }

534542

535− defCon <- constrainAnnDefHelp name expr tipe (ArgInfo env [] [])

543+ defCon <- constrainAnnDefHelp expr tipe (ArgInfo name defRegion env [] [])

536544

537545 return $ info

538546 { iSchemes = scheme : iSchemes info

@@ -542,21 +550,25 @@ constrainAnnotatedDef env region name expr tipe info =

542550

543551data ArgInfo =

544552 ArgInfo

545− { _env :: Env.Env

553+ { _name :: String

554+ , _def :: R.Region

555+ , _env :: Env.Env

546556 , _args :: [(P.Canonical, Type)]

547557 , _vars :: [Variable]

548558 }

549559

550560

551−constrainAnnDefHelp :: String -> Canonical.Expr -> ST.Canonical -> ArgInfo -> IO TypeConstraint

552−constrainAnnDefHelp name expr tipe (ArgInfo env args vars) =

561+constrainAnnDefHelp :: Canonical.Expr -> ST.Canonical -> ArgInfo -> IO TypeConstraint

562+constrainAnnDefHelp expr tipe (ArgInfo name defRegion env args vars) =

553563 case (expr, tipe) of

554564 (A.A _ (E.Lambda arg result), ST.Lambda argType resultType) ->

555565 do (rigidArgType, newVars) <- Env.instantiateType Rigid env argType

556566

557− constrainAnnDefHelp name result resultType $

567+ constrainAnnDefHelp result resultType $

558568 ArgInfo

559− { _env = Env.addValues newVars env

569+ { _name = name

570+ , _def = defRegion

571+ , _env = Env.addValues newVars env

560572 , _args = (arg, rigidArgType) : args

561573 , _vars = Map.elems newVars ++ vars

562574 }

@@ -574,8 +586,13 @@ constrainAnnDefHelp name expr tipe (ArgInfo env args vars) =

574586 resultVar <- mkVar Nothing

575587 let resultType = VarN resultVar

576588 defCon <- constrain finalEnv expr resultType

589+

590+ let sharedArity = length args

591+ let typeArity = sharedArity + length (ST.collectLambdas tipe) - 1

592+ let argsArity = sharedArity + length (fst (E.collectLambdas expr))

593+ let hint = Error.ReturnType name typeArity argsArity region

577594 let resultCon =

578− CEqual (Error.ReturnType name (length args)) region resultType rigidType

595+ CEqual hint defRegion rigidType resultType

579596

580597 return $ forall rigidVars $ ex (resultVar : argVars) $ CLet [monoscheme headers] $

581598 CAnd [ argCons, defCon, resultCon ]

src/Validate.hs+14−13

@@ -208,7 +208,7 @@ checkManager tagRegion managerType validDefs =

208208getSimpleDefRegion :: A.Commented Valid.Def -> Maybe (String, R.Region)

209209getSimpleDefRegion decl =

210210 case decl of

211− A.A (region, _) (Valid.Def (A.A _ (Pattern.Var name)) _ _) ->

211+ A.A _ (Valid.Def region (A.A _ (Pattern.Var name)) _ _) ->

212212 Just (name, region)

213213

214214 _ ->

@@ -353,15 +353,15 @@ vrdDefHelp remainingDecls (A.A ann def) ports structure =

353353 case def of

354354 Source.Definition pat expr ->

355355 addDef

356− <$> validateDef pat expr Nothing

356+ <$> validateDef (fst ann) pat expr Nothing

357357 <*> vrdHelp remainingDecls ports structure

358358

359359 Source.Annotation name tipe ->

360360 case remainingDecls of

361− A.A _ (D.Def (A.A _ (Source.Definition pat expr))) : rest

361+ A.A _ (D.Def (A.A defRegion (Source.Definition pat expr))) : rest

362362 | Pattern.isVar name pat ->

363363 addDef

364− <$> validateDef pat expr (Just tipe)

364+ <$> validateDef (R.merge (fst ann) defRegion) pat expr (Just tipe)

365365 <*> vrdHelp rest ports structure

366366

367367 _ ->

@@ -391,32 +391,33 @@ definitionsHelp sourceDefs =

391391 [] ->

392392 return []

393393

394− A.A _ (Source.Definition pat expr) : rest ->

394+ A.A defRegion (Source.Definition pat expr) : rest ->

395395 (:)

396− <$> validateDef pat expr Nothing

396+ <$> validateDef defRegion pat expr Nothing

397397 <*> definitionsHelp rest

398398

399− A.A region (Source.Annotation name tipe) : rest ->

399+ A.A annRegion (Source.Annotation name tipe) : rest ->

400400 case rest of

401− A.A _ (Source.Definition pat expr) : rest'

401+ A.A defRegion (Source.Definition pat expr) : rest'

402402 | Pattern.isVar name pat ->

403403 (:)

404− <$> validateDef pat expr (Just tipe)

404+ <$> validateDef (R.merge annRegion defRegion) pat expr (Just tipe)

405405 <*> definitionsHelp rest'

406406

407407 _ ->

408− Result.throw region (Error.TypeWithoutDefinition name)

408+ Result.throw annRegion (Error.TypeWithoutDefinition name)

409409

410410

411411validateDef

412− :: Pattern.Raw

412+ :: R.Region

413+ -> Pattern.Raw

413414 -> Source.Expr

414415 -> Maybe Type.Raw

415416 -> Result wrn Valid.Def

416−validateDef pat expr maybeType =

417+validateDef region pat expr maybeType =

417418 do validExpr <- expression expr

418419 validateDefPattern pat validExpr

419− return $ Valid.Def pat validExpr maybeType

420+ return $ Valid.Def region pat validExpr maybeType

420421

421422

422423validateDefPattern :: Pattern.Raw -> Valid.Expr -> Result wrn ()