a2a2fc0 · elk · git.iko.soy

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

compare with master

unifiedsplit

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

2module AST.Expression.Canonical

3 ( Expr, Expr'

4 , Def(..)

5− , Facts(..), dummyFacts

6 , SortedDefs(..), toSortedDefs

5 , SortedDefs(..), toSortedDefs

7 )

6 )

8 where

7 where

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

27

26

28

27

29data Def

28data Def

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

29+ = Def R.Region 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")

41

30

42

31

43

32

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

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

24

25data Facts = Facts

26 { home :: Maybe ModuleName.Canonical

27− , dependencies :: [Var.TopLevel]

28 }

27 }

29

28

30

29

31dummyFacts :: Facts

30dummyFacts :: Facts

32dummyFacts =

31dummyFacts =

33− Facts Nothing []

32+ Facts Nothing

34

33

35

34

36-- EXPRESSIONS

35-- EXPRESSIONS

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

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

21

22

23data Def =

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

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

25

26

27getPattern :: Def -> Pattern.Raw

28−getPattern (Def pattern _ _) =

28+getPattern (Def _ pattern _ _) =

29 pattern

30

src/AST/Variable.hs−11

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

16

17

18

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−

30-- CANONICAL NAMES

19-- CANONICAL NAMES

31

20

32

21

src/Canonicalize.hs+4−4

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

324 annTraverse canEntry entries =

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

326

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

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

328− Canonical.Def Canonical.dummyFacts

328+ Canonical.Def region

329 <$> canonicalizePattern env pat

330 <*> canonicalizeExpr env expr

331 <*> traverse (canonicalizeRegionType env) typ

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

408 env' =

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

410

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

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

412− Canonical.Def Canonical.dummyFacts

412+ Canonical.Def defRegion

413 <$> canonicalizePattern env' p

414 <*> canonicalizeExpr env' body

415 <*> traverse (canonicalizeRegionType env') mtipe

src/Canonicalize/Body.hs+1−1

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

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

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

106 Canonical.Def

107− Canonical.dummyFacts

107+ region

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

109 expr

110 (Just (A.A region tipe))

src/Canonicalize/Setup.hs+1−1

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

327

328 -- TO PATCHES

329

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

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

331 map topLevelValue (P.boundVarList pattern)

332

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

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

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

87generateDef def =

88 do (home, name, jsBody) <-

89 case def of

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

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

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

92

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

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

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

95

96 return (Var.define home name jsBody)

src/Optimize.hs+8−13

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

32

33

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

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

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

36 let

37 (args, canBody) =

38 Expr.collectLambdas expression

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

45 return Nothing

46 in

47 do home <- maybeGetHome

48− optimizeDefHelp home deps pattern args canBody

48+ optimizeDefHelp home pattern args canBody

49

50

51optimizeDefHelp

52 :: Maybe ModuleName.Canonical

53− -> [Var.TopLevel]

54 -> P.Canonical

53 -> P.Canonical

55 -> [P.Canonical]

54 -> [P.Canonical]

56 -> Can.Expr

55 -> Can.Expr

57 -> Env.Optimizer [Opt.Def]

56 -> Env.Optimizer [Opt.Def]

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

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

59 let

58 let

60 facts =

59 facts =

61− Opt.Facts home deps

60+ Opt.Facts home

62 in

61 in

63 case (ptrn, args) of

62 case (ptrn, args) of

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

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

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

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

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

126patternToDefs home rootName pattern =

125patternToDefs home rootName pattern =

127 let

126 let

128− (deps, rootExpr) =

127+ rootExpr =

129 case home of

128 case home of

130 Nothing ->

129 Nothing ->

131− ( []

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

130+ Opt.Var (Var.local rootName)

133− )

134

131

135 Just moduleName ->

132 Just moduleName ->

136− ( [ Var.TopLevelVar moduleName rootName ]

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

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

138− )

139

134

140 toDef (name, accessExpr) =

135 toDef (name, accessExpr) =

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

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

142 in

137 in

143 map toDef (patternToSubstitutions rootExpr pattern)

138 map toDef (patternToSubstitutions rootExpr pattern)

144

139

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

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

490

491

492constrainDef :: 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) =

494 case (pattern, maybeTipe) of

495 (P.Var name, Nothing) ->

496 constrainUnannotatedDef env patternRegion name expr info

497

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

499− constrainAnnotatedDef env patternRegion name expr tipe info

499+ constrainAnnotatedDef env defRegion patternRegion name expr tipe info

500

501 _ ->

502 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 =

520 }

521

522

523−constrainAnnotatedDef :: Env.Env -> R.Region -> String -> Canonical.Expr -> ST.Canonical -> Info -> IO 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

524−constrainAnnotatedDef env region name expr tipe info =

532+constrainAnnotatedDef env defRegion region name expr tipe info =

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

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

526

534

527 let scheme =

535 let scheme =

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

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

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

533 }

541 }

534

542

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

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

536

544

537 return $ info

545 return $ info

538 { iSchemes = scheme : iSchemes info

546 { iSchemes = scheme : iSchemes info

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

542

550

543data ArgInfo =

551data ArgInfo =

544 ArgInfo

552 ArgInfo

553+ { _name :: String

554+ , _def :: R.Region

545− { _env :: Env.Env

555+ , _env :: Env.Env

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

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

547 , _vars :: [Variable]

557 , _vars :: [Variable]

548 }

558 }

549

559

550

560

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

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

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

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

553 case (expr, tipe) of

563 case (expr, tipe) of

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

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

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

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

556

566

557− constrainAnnDefHelp name result resultType $

567+ constrainAnnDefHelp result resultType $

558 ArgInfo

568 ArgInfo

569+ { _name = name

570+ , _def = defRegion

559− { _env = Env.addValues newVars env

571+ , _env = Env.addValues newVars env

560 , _args = (arg, rigidArgType) : args

572 , _args = (arg, rigidArgType) : args

561 , _vars = Map.elems newVars ++ vars

573 , _vars = Map.elems newVars ++ vars

562 }

574 }

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

574 resultVar <- mkVar Nothing

586 resultVar <- mkVar Nothing

575 let resultType = VarN resultVar

587 let resultType = VarN resultVar

576 defCon <- constrain finalEnv expr resultType

588 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

577 let resultCon =

594 let resultCon =

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

595+ CEqual hint defRegion rigidType resultType

579

596

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

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

581 CAnd [ argCons, defCon, resultCon ]

598 CAnd [ argCons, defCon, resultCon ]

src/Validate.hs+14−13

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

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

209getSimpleDefRegion decl =

210 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)) _ _) ->

212 Just (name, region)

213

214 _ ->

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

353 case def of

354 Source.Definition pat expr ->

355 addDef

356− <$> validateDef pat expr Nothing

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

357 <*> vrdHelp remainingDecls ports structure

358

359 Source.Annotation name tipe ->

360 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

362 | Pattern.isVar name pat ->

363 addDef

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

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

365 <*> vrdHelp rest ports structure

366

367 _ ->

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

391 [] ->

392 return []

393

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

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

395 (:)

396− <$> validateDef pat expr Nothing

396+ <$> validateDef defRegion pat expr Nothing

397 <*> definitionsHelp rest

398

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

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

400 case rest of

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

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

402 | Pattern.isVar name pat ->

403 (:)

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

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

405 <*> definitionsHelp rest'

406

407 _ ->

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

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

409

410

411validateDef

412+ :: R.Region

412− :: Pattern.Raw

413+ -> Pattern.Raw

413 -> Source.Expr

414 -> Source.Expr

414 -> Maybe Type.Raw

415 -> Maybe Type.Raw

415 -> Result wrn Valid.Def

416 -> Result wrn Valid.Def

416−validateDef pat expr maybeType =

417+validateDef region pat expr maybeType =

417 do validExpr <- expression expr

418 do validExpr <- expression expr

418 validateDefPattern pat validExpr

419 validateDefPattern pat validExpr

419− return $ Valid.Def pat validExpr maybeType

420+ return $ Valid.Def region pat validExpr maybeType

420

421

422

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

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