b97576d · elk · git.iko.soy

elm-compiler.cabal+2−4

compare with master

unifiedsplit

@@ -59,10 +59,8 @@ Library

59 AST.Declaration,

60 AST.Effects,

61 AST.Expression.Canonical,

62− AST.Expression.General,

63 AST.Expression.Optimized,

62 AST.Expression.Optimized,

64 AST.Expression.Source,

63 AST.Expression.Source,

65− AST.Expression.Valid,

66 AST.Helpers,

64 AST.Helpers,

67 AST.Literal,

65 AST.Literal,

68 AST.Module,

66 AST.Module,

@@ -71,6 +69,7 @@ Library

71 AST.Type,

69 AST.Type,

72 AST.Variable,

70 AST.Variable,

73 Canonicalize,

71 Canonicalize,

72+ Canonicalize.Binops,

74 Canonicalize.Body,

73 Canonicalize.Body,

75 Canonicalize.Effects,

74 Canonicalize.Effects,

76 Canonicalize.Environment,

75 Canonicalize.Environment,

@@ -109,6 +108,7 @@ Library

109 Parse.Module,

108 Parse.Module,

110 Parse.Parse,

109 Parse.Parse,

111 Parse.Pattern,

110 Parse.Pattern,

111+ Parse.Primitives,

112 Parse.Type,

113 Reporting.Annotation,

114 Reporting.Bag,

@@ -150,7 +150,6 @@ Library

150 directory >= 1.0 && < 2.0,

151 edit-distance >= 0.2 && < 0.3,

152 filepath >= 1 && < 2.0,

153− indents >= 0.3 && < 0.4,

154 language-ecmascript >= 0.15 && < 0.18,

153 language-ecmascript >= 0.15 && < 0.18,

155 language-glsl >= 0.0.2 && < 0.3,

154 language-glsl >= 0.0.2 && < 0.3,

156 mtl >= 2.2 && < 3,

155 mtl >= 2.2 && < 3,

@@ -223,7 +222,6 @@ Test-Suite compiler-tests

223 edit-distance >= 0.2 && < 0.3,

222 edit-distance >= 0.2 && < 0.3,

224 filemanip >= 0.3.5 && < 0.4,

223 filemanip >= 0.3.5 && < 0.4,

225 filepath >= 1 && < 2.0,

224 filepath >= 1 && < 2.0,

226− indents >= 0.3 && < 0.4,

227 language-ecmascript >= 0.15 && < 0.18,

225 language-ecmascript >= 0.15 && < 0.18,

228 language-glsl >= 0.0.2 && < 0.3,

226 language-glsl >= 0.0.2 && < 0.3,

229 mtl >= 2.2 && < 3,

227 mtl >= 2.2 && < 3,

src/AST/Declaration.hs+3−4

@@ -3,9 +3,8 @@ module AST.Declaration where

3

4import Data.Binary

5

6−import qualified AST.Expression.Source as Source

7−import qualified AST.Expression.Valid as Valid

8import qualified AST.Expression.Canonical as Canonical

6import qualified AST.Expression.Canonical as Canonical

7+import qualified AST.Expression.Source as Src

9import qualified AST.Type as Type

8import qualified AST.Type as Type

10import qualified Reporting.Annotation as A

9import qualified Reporting.Annotation as A

11

10

@@ -24,7 +23,7 @@ data CommentOr a

24

23

25

24

26data Raw

25data Raw

27− = Def Source.Def

26+ = Def Src.RawDef

28 | Union (Union Type.Raw)

27 | Union (Union Type.Raw)

29 | Alias (Alias Type.Raw)

28 | Alias (Alias Type.Raw)

30 | Fixity Infix

29 | Fixity Infix

@@ -45,7 +44,7 @@ data Decls def tipe =

45

44

46

45

47type Valid =

46type Valid =

48− Decls Valid.Def Type.Raw

47+ Decls Src.ValidDef Type.Raw

49

48

50

49

51type Canonical =

50type Canonical =

src/AST/Expression/Canonical.hs+111−13

@@ -1,32 +1,76 @@

1{-# OPTIONS_GHC -Wall #-}

2module AST.Expression.Canonical

3− ( Expr, Expr'

3+ ( Expr, Expr'(..)

4+ , Main(..)

4 , Def(..)

5 , Def(..)

5 , SortedDefs(..), toSortedDefs

6 , SortedDefs(..), toSortedDefs

7+ , localVar

8+ , collectApps, collectFields, collectLambdas

6 )

9 )

7 where

10 where

8

11

12+

13+import qualified Data.List as List

14+

15+import qualified AST.Effects as Effects

9−import qualified AST.Expression.General as General

16+import qualified AST.Literal as Literal

17+import qualified AST.Module.Name as ModuleName

10−import qualified AST.Pattern as Pattern

18+import qualified AST.Pattern as Ptrn

11import qualified AST.Type as Type

19import qualified AST.Type as Type

12import qualified AST.Variable as Var

20import qualified AST.Variable as Var

13import qualified Reporting.Annotation as A

21import qualified Reporting.Annotation as A

14import qualified Reporting.Region as R

22import qualified Reporting.Region as R

15

23

16

24

17−{-| Canonicalized expressions. All variables are fully resolved to the module

25+

18−they came from.

26+-- EXPRESSIONS

19−-}

27+

28+

20type Expr =

29type Expr =

30+ A.Annotated R.Region Expr'

31+

32+

33+data Expr'

34+ = Literal Literal.Literal

35+ | Var Var.Canonical

36+ | List [Expr]

37+ | Binop Var.Canonical Expr Expr

38+ | Lambda Ptrn.Canonical Expr

39+ | App Expr Expr

40+ | If [(Expr, Expr)] Expr

41+ | Let [Def] Expr

42+ | Case Expr [(Ptrn.Canonical, Expr)]

43+ | Ctor String [Expr]

44+ | Access Expr String

45+ | Update Expr [(String, Expr)]

46+ | Record [(String, Expr)]

47+ -- for type checking and code gen only

48+ | Cmd ModuleName.Canonical

49+ | Sub ModuleName.Canonical

50+ | OutgoingPort String Type.Canonical

51+ | IncomingPort String Type.Canonical

52+ | Program Main Expr

53+ | SaveEnv ModuleName.Canonical Effects.Canonical

54+ | GLShader String String Literal.GLShaderTipe

55+

56+

57+data Main

58+ = VDom

59+ | NoFlags

21− General.Expr R.Region Def Var.Canonical Type.Canonical

60+ | Flags Type.Canonical

22

61

23

62

24−type Expr' =

25− General.Expr' R.Region Def Var.Canonical Type.Canonical

26

63

64+-- DEFS

27

65

66+

28−data Def

67+data Def =

68+ Def

69+ { _region :: R.Region

70+ , _pattern :: Ptrn.Canonical

71+ , _body :: Expr

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

72+ , _type :: Maybe (A.Located Type.Canonical)

73+ }

30

74

31

75

32

76

@@ -41,7 +85,7 @@ data SortedDefs

41toSortedDefs :: Expr -> SortedDefs

85toSortedDefs :: Expr -> SortedDefs

42toSortedDefs (A.A _ expr) =

86toSortedDefs (A.A _ expr) =

43 case expr of

87 case expr of

44− General.Let defs body ->

88+ Let defs body ->

45 foldr defCons (toSortedDefs body) defs

89 foldr defCons (toSortedDefs body) defs

46

90

47 _ ->

91 _ ->

@@ -51,7 +95,7 @@ toSortedDefs (A.A _ expr) =

51defCons :: Def -> SortedDefs -> SortedDefs

95defCons :: Def -> SortedDefs -> SortedDefs

52defCons def@(Def _ (A.A _ pattern) _ _) sortedDefs =

96defCons def@(Def _ (A.A _ pattern) _ _) sortedDefs =

53 case (pattern, sortedDefs) of

97 case (pattern, sortedDefs) of

54− (Pattern.Var "main", NoMain defs) ->

98+ (Ptrn.Var "main", NoMain defs) ->

55 YesMain [] def defs

99 YesMain [] def defs

56

100

57 (_, NoMain defs) ->

101 (_, NoMain defs) ->

@@ -59,3 +103,57 @@ defCons def@(Def _ (A.A _ pattern) _ _) sortedDefs =

59

103

60 (_, YesMain defs main rest) ->

104 (_, YesMain defs main rest) ->

61 YesMain (def : defs) main rest

105 YesMain (def : defs) main rest

106+

107+

108+

109+-- HELPERS

110+

111+

112+localVar :: String -> Expr'

113+localVar x =

114+ Var (Var.Canonical Var.Local x)

115+

116+

117+-- COLLECTORS

118+

119+

120+collectApps :: Expr -> [Expr]

121+collectApps annExpr@(A.A _ expr) =

122+ case expr of

123+ App a b ->

124+ collectApps a ++ [b]

125+

126+ _ ->

127+ [annExpr]

128+

129+

130+

131+collectFields :: Expr -> Maybe String

132+collectFields expr =

133+ collectFieldsHelp expr []

134+

135+

136+collectFieldsHelp :: Expr -> [String] -> Maybe String

137+collectFieldsHelp (A.A _ expr) fields =

138+ case expr of

139+ Var var ->

140+ Just (List.intercalate "." (Var.toString var : fields))

141+

142+ Access record field ->

143+ collectFieldsHelp record (field : fields)

144+

145+ _ ->

146+ Nothing

147+

148+

149+collectLambdas :: Expr -> ([Ptrn.Canonical], Expr)

150+collectLambdas lexpr@(A.A _ expr) =

151+ case expr of

152+ Lambda pattern body ->

153+ let

154+ (ps, body') = collectLambdas body

155+ in

156+ (pattern : ps, body')

157+

158+ _ ->

159+ ([], lexpr)

src/AST/Expression/General.hsdeleted−131

@@ -1,131 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−

3−{-| The Abstract Syntax Tree (AST) for expressions comes in a couple formats.

4−The first is the fully general version and is labeled with a prime (Expr').

5−The others are specialized versions of the AST that represent specific phases

6−of the compilation process. I expect there to be more phases as we begin to

7−enrich the AST with more information.

8−-}

9−module AST.Expression.General where

10−

11−import qualified Data.List as List

12−

13−import qualified AST.Effects as Effects

14−import qualified AST.Literal as Literal

15−import qualified AST.Module.Name as ModuleName

16−import qualified AST.Pattern as Pattern

17−import qualified AST.Variable as Var

18−import qualified Reporting.Annotation as A

19−

20−

21−

22−---- GENERAL AST ----

23−

24−

25−{-| This is a fully general Abstract Syntax Tree (AST) for expressions. It has

26−"type holes" that allow us to enrich the AST with additional information as we

27−move through the compilation process. The type holes are used to represent:

28−

29− ann: Annotations for arbitrary expressions. Allows you to add information

30− to the AST like position in source code or inferred types.

31−

32− def: Definition style. The source syntax separates type annotations and

33− definitions, but after parsing we check that they are well formed and

34− collapse them.

35−

36− var: Representation of variables. Starts as strings, but is later enriched

37− with information about what module a variable came from.

38−

39−-}

40−type Expr annotation definition variable tipe =

41− A.Annotated annotation (Expr' annotation definition variable tipe)

42−

43−

44−data Expr' ann def var typ

45− = Literal Literal.Literal

46− | Var var

47− | ExplicitList [Expr ann def var typ]

48− | Binop var (Expr ann def var typ) (Expr ann def var typ)

49− | Lambda (Pattern.Pattern ann var) (Expr ann def var typ)

50− | App (Expr ann def var typ) (Expr ann def var typ)

51− | If [(Expr ann def var typ, Expr ann def var typ)] (Expr ann def var typ)

52− | Let [def] (Expr ann def var typ)

53− | Case (Expr ann def var typ) [(Pattern.Pattern ann var, Expr ann def var typ)]

54− | Data String [Expr ann def var typ]

55− | Access (Expr ann def var typ) String

56− | Update (Expr ann def var typ) [(String, Expr ann def var typ)]

57− | Record [(String, Expr ann def var typ)]

58− -- for type checking and code gen only

59− | Cmd ModuleName.Canonical

60− | Sub ModuleName.Canonical

61− | OutgoingPort String typ

62− | IncomingPort String typ

63− | Program (Main typ) (Expr ann def var typ)

64− | SaveEnv ModuleName.Canonical Effects.Canonical

65− | GLShader String String Literal.GLShaderTipe

66−

67−

68−data Main typ

69− = VDom

70− | NoFlags

71− | Flags typ

72−

73−

74−

75−---- UTILITIES ----

76−

77−

78−rawVar :: String -> Expr' ann def Var.Raw typ

79−rawVar x =

80− Var (Var.Raw x)

81−

82−

83−localVar :: String -> Expr' ann def Var.Canonical typ

84−localVar x =

85− Var (Var.Canonical Var.Local x)

86−

87−

88−tuple :: [Expr ann def var typ] -> Expr' ann def var typ

89−tuple expressions =

90− Data ("_Tuple" ++ show (length expressions)) expressions

91−

92−

93−collectFields :: (Var.ToString var) => Expr ann def var typ -> Maybe String

94−collectFields expr =

95− collectFieldsHelp expr []

96−

97−

98−collectFieldsHelp :: (Var.ToString var) => Expr ann def var typ -> [String] -> Maybe String

99−collectFieldsHelp (A.A _ expr) fields =

100− case expr of

101− Var var ->

102− Just (List.intercalate "." (Var.toString var : fields))

103−

104− Access record field ->

105− collectFieldsHelp record (field : fields)

106−

107− _ ->

108− Nothing

109−

110−

111−collectApps :: Expr ann def var typ -> [Expr ann def var typ]

112−collectApps annExpr@(A.A _ expr) =

113− case expr of

114− App a b ->

115− collectApps a ++ [b]

116−

117− _ ->

118− [annExpr]

119−

120−

121−collectLambdas :: Expr ann def var typ -> ([Pattern.Pattern ann var], Expr ann def var typ)

122−collectLambdas lexpr@(A.A _ expr) =

123− case expr of

124− Lambda pattern body ->

125− let

126− (ps, body') = collectLambdas body

127− in

128− (pattern : ps, body')

129−

130− _ ->

131− ([], lexpr)

src/AST/Expression/Optimized.hs+5−5

@@ -5,7 +5,7 @@ module AST.Expression.Optimized

5 , Decider(..), Choice(..)

6 ) where

7

8−import qualified AST.Expression.General as Expr

8+import qualified AST.Expression.Canonical as Can

9import qualified AST.Literal as Literal

10import qualified AST.Module.Name as ModuleName

11import qualified AST.Type as Type

@@ -37,7 +37,7 @@ dummyFacts =

37data Expr

38 = Literal Literal.Literal

39 | Var Var.Canonical

40− | ExplicitList [Expr]

40+ | List [Expr]

41 | Binop Var.Canonical Expr Expr

42 | Function [String] Expr

43 | Call Expr [Expr]

@@ -45,8 +45,8 @@ data Expr

45 | If [(Expr, Expr)] Expr

46 | Let [Def] Expr

47 | Case String (Decider Choice) [(Int, Expr)]

48− | Data String [Expr]

48+ | Ctor String [Expr]

49− | DataAccess Expr Int

49+ | CtorAccess Expr Int

50 | Access Expr String

51 | Update Expr [(String, Expr)]

52 | Record [(String, Expr)]

@@ -54,7 +54,7 @@ data Expr

54 | Sub ModuleName.Canonical

55 | OutgoingPort String Type.Canonical

56 | IncomingPort String Type.Canonical

57− | Program (Expr.Main Type.Canonical) Expr

57+ | Program Can.Main Expr

58 | GLShader String String Literal.GLShaderTipe

59 | Crash ModuleName.Canonical R.Region (Maybe Expr)

60

src/AST/Expression/Source.hs+83−15

@@ -1,31 +1,99 @@

1{-# OPTIONS_GHC -Wall #-}

2−module AST.Expression.Source where

2+module AST.Expression.Source

3+ ( RawExpr, RawExpr', RawDef, RawDef'(..)

4+ , ValidExpr, ValidExpr', ValidDef(..)

5+ , Expr, Expr'(..)

6+ , var, tuple, getPattern, collectLambdas

7+ )

8+ where

3

9

10+

4−import qualified AST.Expression.General as General

11+import qualified AST.Literal as Literal

5−import qualified AST.Pattern as Pattern

12+import qualified AST.Pattern as Ptrn

6import qualified AST.Type as Type

13import qualified AST.Type as Type

7import qualified AST.Variable as Var

14import qualified AST.Variable as Var

8import qualified Reporting.Annotation as A

15import qualified Reporting.Annotation as A

9import qualified Reporting.Region as R

16import qualified Reporting.Region as R

10

17

11

18

12−{-| Expressions created by the parser. These use a split representation of type

13−annotations and definitions, which is how they appear in source code and how

14−they are parsed.

15−-}

16−type Expr =

17− General.Expr R.Region Def Var.Raw Type.Raw

18

19

20+-- EXPRESSIONS

21+

22+

23+type Expr def =

24+ A.Located (Expr' def)

25+

26+

27+data Expr' def

28+ = Literal Literal.Literal

29+ | Var Var.Raw

30+ | List [Expr def]

31+ | Binop [(Expr def, A.Located String)] (Expr def)

32+ | Lambda Ptrn.Raw (Expr def)

33+ | App (Expr def) (Expr def)

34+ | If [(Expr def, Expr def)] (Expr def)

35+ | Let [def] (Expr def)

36+ | Case (Expr def) [(Ptrn.Raw, Expr def)]

37+ | Ctor String [Expr def]

38+ | Access (Expr def) String

39+ | Update (Expr def) [(String, Expr def)]

40+ | Record [(String, Expr def)]

41+ | GLShader String String Literal.GLShaderTipe

42+

43+

44+type RawExpr = Expr RawDef

19

45

20−type Expr' =

46+type RawExpr' = Expr' RawDef

21− General.Expr' R.Region Def Var.Raw Type.Raw

22

47

48+type ValidExpr = Expr ValidDef

23

49

24−type Def =

50+type ValidExpr' = Expr' ValidDef

25− A.Located Def'

26

51

27

52

53+

54+-- DEFINITIONS

55+

56+

57+type RawDef =

58+ A.Located RawDef'

59+

60+

28−data Def'

61+data RawDef'

29− = Definition Pattern.Raw Expr

62+ = Definition Ptrn.Raw RawExpr

30 | Annotation String Type.Raw

63 | Annotation String Type.Raw

31

64

65+

66+data ValidDef =

67+ Def R.Region Ptrn.Raw ValidExpr (Maybe Type.Raw)

68+

69+

70+

71+-- HELPERS

72+

73+

74+var :: String -> Expr' def

75+var x =

76+ Var (Var.Raw x)

77+

78+

79+tuple :: [Expr def] -> Expr' def

80+tuple expressions =

81+ Ctor ("_Tuple" ++ show (length expressions)) expressions

82+

83+

84+getPattern :: ValidDef -> Ptrn.Raw

85+getPattern (Def _ pattern _ _) =

86+ pattern

87+

88+

89+collectLambdas :: Expr def -> ([Ptrn.Raw], Expr def)

90+collectLambdas lexpr@(A.A _ expr) =

91+ case expr of

92+ Lambda pattern body ->

93+ let

94+ (ps, body') = collectLambdas body

95+ in

96+ (pattern : ps, body')

97+

98+ _ ->

99+ ([], lexpr)

src/AST/Expression/Valid.hsdeleted−30

@@ -1,30 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module AST.Expression.Valid where

3−

4−import qualified AST.Expression.General as General

5−import qualified AST.Pattern as Pattern

6−import qualified AST.Type as Type

7−import qualified AST.Variable as Var

8−import qualified Reporting.Region as R

9−

10−

11−{-| "Normal" expressions. When the compiler checks that type annotations and

12−ports are all paired with definitions in the appropriate order, it collapses

13−them into a Def that is easier to work with in later phases of compilation.

14−-}

15−type Expr =

16− General.Expr R.Region Def Var.Raw Type.Raw

17−

18−

19−type Expr' =

20− General.Expr' R.Region Def Var.Raw Type.Raw

21−

22−

23−data Def =

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

25−

26−

27−getPattern :: Def -> Pattern.Raw

28−getPattern (Def _ pattern _ _) =

29− pattern

30−

src/Canonicalize.hs+78−65

@@ -1,23 +1,24 @@

1{-# OPTIONS_GHC -Wall #-}

2module Canonicalize (module') where

3

4+import Prelude hiding (last)

4import qualified Data.List as List

5import qualified Data.List as List

5import qualified Data.Map as Map

6import qualified Data.Map as Map

6import qualified Data.Maybe as Maybe

7import qualified Data.Maybe as Maybe

7import qualified Data.Set as Set

8import qualified Data.Set as Set

8import qualified Data.Foldable as T

9import qualified Data.Foldable as T

9

10

10−import AST.Expression.General (Expr'(..))

11import Elm.Utils ((|>))

12

13import qualified AST.Declaration as D

14−import qualified AST.Expression.Valid as Valid

14+import qualified AST.Expression.Source as Src

15−import qualified AST.Expression.Canonical as Canonical

15+import qualified AST.Expression.Canonical as C

16import qualified AST.Module as Module

17import qualified AST.Module.Name as ModuleName

18import qualified AST.Pattern as P

19import qualified AST.Type as Type

20import qualified AST.Variable as Var

21+import qualified Canonicalize.Binops as Binops

21import qualified Canonicalize.Body as Body

22import qualified Canonicalize.Body as Body

22import qualified Canonicalize.Effects as Effects

23import qualified Canonicalize.Effects as Effects

23import qualified Canonicalize.Environment as Env

24import qualified Canonicalize.Environment as Env

@@ -250,7 +251,7 @@ declsToValues :: D.Valid -> [Var.Value]

250declsToValues (D.Decls defs unions aliases _) =

251declsToValues (D.Decls defs unions aliases _) =

251 let

252 let

252 fromDef (A.A _ def) =

253 fromDef (A.A _ def) =

253− map Var.Value (P.boundVarList (Valid.getPattern def))

254+ map Var.Value (P.boundVarList (Src.getPattern def))

254

255

255 fromUnion (A.A _ (D.Type name _ ctors)) =

256 fromUnion (A.A _ (D.Type name _ ctors)) =

256 Var.Union name (Var.Listing (map fst ctors) False)

257 Var.Union name (Var.Listing (map fst ctors) False)

@@ -319,14 +320,14 @@ splitLocatedValue (A.A region value) =

319-- DECLARATIONS

320-- DECLARATIONS

320

321

322

322−canonicalizeDecls :: Env.Environment -> D.Valid -> CResult D.Canonical

323+canonicalizeDecls :: Env.Env -> D.Valid -> CResult D.Canonical

323canonicalizeDecls env (D.Decls defs unions aliases infixes) =

324canonicalizeDecls env (D.Decls defs unions aliases infixes) =

324 let

325 let

325 annTraverse canEntry entries =

326 annTraverse canEntry entries =

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

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

327

328

328− canonicalizeDef (Valid.Def region pat expr typ) =

329+ canonicalizeDef (Src.Def region pat expr typ) =

329− Canonical.Def region

330+ C.Def region

330 <$> canonicalizePattern env pat

331 <$> canonicalizePattern env pat

331 <*> canonicalizeExpr env expr

332 <*> canonicalizeExpr env expr

332 <*> traverse (canonicalizeRegionType env) typ

333 <*> traverse (canonicalizeRegionType env) typ

@@ -347,114 +348,97 @@ canonicalizeDecls env (D.Decls defs unions aliases infixes) =

347 <*> pure infixes

348 <*> pure infixes

348

349

350

350−canonicalizeRegionType

351− :: Env.Environment

352− -> Type.Raw

353− -> CResult (A.Located Type.Canonical)

351+canonicalizeRegionType :: Env.Env -> Type.Raw -> CResult (A.Located Type.Canonical)

354canonicalizeRegionType env typ@(A.A region _) =

352canonicalizeRegionType env typ@(A.A region _) =

355 A.A region <$> Canon.tipe env typ

353 A.A region <$> Canon.tipe env typ

356

354

357

355

356+

357+-- EXPRESSIONS

358+

359+

358−canonicalizeExpr

360+canonicalizeExpr :: Env.Env -> Src.ValidExpr -> CResult C.Expr

359− :: Env.Environment

360− -> Valid.Expr

361− -> CResult Canonical.Expr

362canonicalizeExpr env (A.A region validExpr) =

361canonicalizeExpr env (A.A region validExpr) =

363 let go = canonicalizeExpr env

362 let go = canonicalizeExpr env

364 in

363 in

365 A.A region <$>

364 A.A region <$>

366 case validExpr of

365 case validExpr of

367− Literal lit ->

366+ Src.Literal lit ->

368− Result.ok (Literal lit)

367+ Result.ok (C.Literal lit)

369

368

370− Access record field ->

369+ Src.Access record field ->

371− Access <$> go record <*> Result.ok field

370+ C.Access <$> go record <*> Result.ok field

372

371

373− Update record fields ->

372+ Src.Update record fields ->

374− Update

373+ C.Update

375 <$> go record

374 <$> go record

376 <*> traverse (\(field,expr) -> (,) field <$> go expr) fields

375 <*> traverse (\(field,expr) -> (,) field <$> go expr) fields

377

376

378− Record fields ->

377+ Src.Record fields ->

379− Record

378+ C.Record

380 <$> traverse (\(field,expr) -> (,) field <$> go expr) fields

379 <$> traverse (\(field,expr) -> (,) field <$> go expr) fields

381

380

382− Binop (Var.Raw op) leftExpr rightExpr ->

381+ Src.Binop ops last ->

383− Binop

382+ canonicalizeBinop region env ops last

384− <$> Canon.variable region env op

385− <*> go leftExpr

386− <*> go rightExpr

387

383

388− Lambda arg body ->

384+ Src.Lambda arg body ->

389 let

385 let

390 env' =

386 env' =

391 Env.addPattern arg env

387 Env.addPattern arg env

392 in

388 in

389+ C.Lambda

393− Lambda <$> canonicalizePattern env' arg <*> canonicalizeExpr env' body

390+ <$> canonicalizePattern env' arg

391+ <*> canonicalizeExpr env' body

394

392

395− App func arg ->

393+ Src.App func arg ->

396− App <$> go func <*> go arg

394+ C.App <$> go func <*> go arg

397

395

398− If branches finally ->

396+ Src.If branches finally ->

399− If

397+ C.If

400 <$> traverse go' branches

398 <$> traverse go' branches

401 <*> go finally

399 <*> go finally

402 where

400 where

403 go' (condition, branch) =

401 go' (condition, branch) =

404 (,) <$> go condition <*> go branch

402 (,) <$> go condition <*> go branch

405

403

406− Let defs expr ->

404+ Src.Let defs expr ->

407− Let <$> traverse rename' defs <*> canonicalizeExpr env' expr

405+ C.Let <$> traverse rename' defs <*> canonicalizeExpr env' expr

408 where

406 where

409 env' =

407 env' =

410− foldr Env.addPattern env (map Valid.getPattern defs)

408+ foldr Env.addPattern env (map Src.getPattern defs)

411

409

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

410+ rename' (Src.Def defRegion p body mtipe) =

413− Canonical.Def defRegion

411+ C.Def defRegion

414 <$> canonicalizePattern env' p

412 <$> canonicalizePattern env' p

415 <*> canonicalizeExpr env' body

413 <*> canonicalizeExpr env' body

416 <*> traverse (canonicalizeRegionType env') mtipe

414 <*> traverse (canonicalizeRegionType env') mtipe

417

415

418− Var (Var.Raw x) ->

416+ Src.Var (Var.Raw x) ->

419− Var <$> Canon.variable region env x

417+ C.Var <$> Canon.variable region env x

420

418

421− Data name exprs ->

419+ Src.Ctor name exprs ->

422− Data name <$> traverse go exprs

420+ C.Ctor name <$> traverse go exprs

423

421

424− ExplicitList exprs ->

422+ Src.List exprs ->

425− ExplicitList <$> traverse go exprs

423+ C.List <$> traverse go exprs

426

424

427− Case expr cases ->

425+ Src.Case expr cases ->

428− Case <$> go expr <*> traverse branch cases

426+ C.Case <$> go expr <*> traverse branch cases

429 where

427 where

430 branch (ptrn, brnch) =

428 branch (ptrn, brnch) =

431 (,)

429 (,)

432 <$> canonicalizePattern env ptrn

430 <$> canonicalizePattern env ptrn

433 <*> canonicalizeExpr (Env.addPattern ptrn env) brnch

431 <*> canonicalizeExpr (Env.addPattern ptrn env) brnch

434

432

435− Cmd moduleName ->

433+ Src.GLShader uid src tipe ->

436− Result.ok (Cmd moduleName)

434+ Result.ok (C.GLShader uid src tipe)

437−

438− Sub moduleName ->

439− Result.ok (Sub moduleName)

440

435

441− OutgoingPort name tipe ->

442− OutgoingPort name <$> Canon.tipe env tipe

443

436

444− IncomingPort name tipe ->

445− IncomingPort name <$> Canon.tipe env tipe

446

437

447− Program _ _ ->

438+-- PATTERNS

448− error "DANGER - Program AST nodes should not be in canonicalization."

449

439

450− SaveEnv moduleName effects ->

451− Result.ok (SaveEnv moduleName effects)

452

440

453− GLShader uid src tipe ->

454− Result.ok (GLShader uid src tipe)

455−

456−

457−canonicalizePattern :: Env.Environment -> P.Raw -> CResult P.Canonical

441+canonicalizePattern :: Env.Env -> P.Raw -> CResult P.Canonical

458canonicalizePattern env (A.A region ptrn) =

442canonicalizePattern env (A.A region ptrn) =

459 A.A region <$>

443 A.A region <$>

460 case ptrn of

444 case ptrn of

@@ -477,3 +461,32 @@ canonicalizePattern env (A.A region ptrn) =

477 P.Data

461 P.Data

478 <$> Canon.pvar region env name (length patterns)

462 <$> Canon.pvar region env name (length patterns)

479 <*> traverse (canonicalizePattern env) patterns

463 <*> traverse (canonicalizePattern env) patterns

464+

465+

466+

467+-- BINOPS

468+

469+

470+canonicalizeBinop

471+ :: Region.Region

472+ -> Env.Env

473+ -> [(Src.ValidExpr, A.Located String)]

474+ -> Src.ValidExpr

475+ -> CResult C.Expr'

476+canonicalizeBinop region env srcOps srcLast =

477+ let

478+ opsResult =

479+ traverse (binopHelp env) srcOps

480+

481+ lastResult =

482+ canonicalizeExpr env srcLast

483+ in

484+ do (expr, ops) <- (,) <$> opsResult <*> lastResult

485+ A.drop <$> Binops.flatten region expr ops

486+

487+

488+binopHelp :: Env.Env -> (Src.ValidExpr, A.Located String) -> CResult (C.Expr, Binops.Op)

489+binopHelp env (expr, op) =

490+ (,)

491+ <$> canonicalizeExpr env expr

492+ <*> Binops.canonicalize env op

src/Canonicalize/Binops.hsnew file+112

@@ -0,0 +1,112 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Canonicalize.Binops ( Op(..), canonicalize, flatten ) where

3+

4+import Prelude hiding (last)

5+import qualified Data.Map as Map

6+

7+import AST.Declaration (Assoc(..))

8+import qualified AST.Expression.Canonical as C

9+import qualified AST.Variable as Var

10+import qualified Canonicalize.Environment as Env

11+import qualified Canonicalize.Variable as Var

12+import qualified Reporting.Annotation as A

13+import qualified Reporting.Error.Canonicalize as Error

14+import qualified Reporting.Region as Region

15+import qualified Reporting.Result as R

16+

17+

18+

19+-- CANONICALIZE

20+

21+

22+data Op =

23+ Op

24+ { _name :: Var.Canonical

25+ , _assoc :: Assoc

26+ , _prec :: Int

27+ , _region :: Region.Region

28+ }

29+

30+

31+canonicalize :: Env.Env -> A.Located String -> Var.Result Op

32+canonicalize env (A.A region op) =

33+ do name <- Var.variable region env op

34+ let (assoc, prec) = Map.findWithDefault (L, 9) name (Env._infixes env)

35+ return $ Op name assoc prec region

36+

37+

38+

39+-- FLATTEN

40+

41+

42+flatten :: (Monoid i) => Region.Region -> [(C.Expr, Op)] -> C.Expr -> R.Result i w Error.Error C.Expr

43+flatten overallRegion ops last =

44+ runStepper overallRegion (More ops last)

45+

46+

47+data Step

48+ = Done C.Expr

49+ | More [(C.Expr, Op)] C.Expr

50+ | Error Op Op

51+

52+

53+runStepper :: (Monoid i) => Region.Region -> Step -> R.Result i w Error.Error C.Expr

54+runStepper overallRegion step =

55+ case step of

56+ Done expr ->

57+ R.ok expr

58+

59+ More [] expr ->

60+ R.ok expr

61+

62+ More ( (expr, op@(Op name _ _ _)) : rest ) last ->

63+ runStepper overallRegion $

64+ flattenHelp (binop name expr) op rest last

65+

66+ Error (Op name1 assoc1 prec _) (Op name2 assoc2 _ region) ->

67+ R.throw overallRegion (Error.BadInfix region prec name1 assoc1 name2 assoc2)

68+

69+

70+flattenHelp :: (C.Expr -> C.Expr) -> Op -> [(C.Expr, Op)] -> C.Expr -> Step

71+flattenHelp makeBinop rootOp@(Op _ rootAssoc rootPrec _) middle last =

72+ case middle of

73+ [] ->

74+ Done (makeBinop last)

75+

76+ ( expr, op@(Op name assoc prec _) ) : rest ->

77+ if prec < rootPrec then

78+

79+ More ((makeBinop expr, op) : rest) last

80+

81+ else if prec > rootPrec then

82+

83+ case flattenHelp (binop name expr) op rest last of

84+ Done newLast ->

85+ Done (makeBinop newLast)

86+

87+ More newMiddle newLast ->

88+ flattenHelp makeBinop op newMiddle newLast

89+

90+ Error a b ->

91+ Error a b

92+

93+ else

94+

95+ case (rootAssoc, assoc) of

96+ (L, L) ->

97+ flattenHelp (\right -> binop name (makeBinop expr) right) op rest last

98+

99+ (R, R) ->

100+ flattenHelp (\right -> makeBinop (binop name expr right)) op rest last

101+

102+ (_, _) ->

103+ Error rootOp op

104+

105+

106+

107+-- BINOP HELPERS

108+

109+

110+binop :: Var.Canonical -> C.Expr -> C.Expr -> C.Expr

111+binop name left right =

112+ A.merge left right (C.Binop name left right)

src/Canonicalize/Body.hs+18−19

@@ -5,8 +5,7 @@ import qualified Data.Maybe as Maybe

5

6import qualified AST.Declaration as Decl

7import qualified AST.Effects as Effects

8−import qualified AST.Expression.General as E

8+import qualified AST.Expression.Canonical as C

9−import qualified AST.Expression.Canonical as Canonical

10import qualified AST.Module.Name as ModuleName

9import qualified AST.Module.Name as ModuleName

11import qualified AST.Pattern as P

10import qualified AST.Pattern as P

12import qualified AST.Type as Type

11import qualified AST.Type as Type

@@ -24,7 +23,7 @@ flatten

24 => ModuleName.Canonical

23 => ModuleName.Canonical

25 -> Decl.Canonical

24 -> Decl.Canonical

26 -> Effects.Canonical

25 -> Effects.Canonical

27− -> Result i w Error Canonical.Expr

26+ -> Result i w Error C.Expr

28flatten moduleName (Decl.Decls defs unions aliases _) effects =

27flatten moduleName (Decl.Decls defs unions aliases _) effects =

29 let

28 let

30 allDefs =

29 allDefs =

@@ -39,14 +38,14 @@ flatten moduleName (Decl.Decls defs unions aliases _) effects =

39 A.A (error "this annotation should never be needed")

38 A.A (error "this annotation should never be needed")

40 in

39 in

41 Sort.definitions $ loc $

40 Sort.definitions $ loc $

42− E.Let allDefs (loc $ E.SaveEnv moduleName effects)

41+ C.Let allDefs (loc $ C.SaveEnv moduleName effects)

43

42

44

43

45

44

46-- TYPES TO DEFS

45-- TYPES TO DEFS

47

46

48

47

49−unionToDefs :: ModuleName.Canonical -> A.Commented (Decl.Union Type.Canonical) -> [Canonical.Def]

48+unionToDefs :: ModuleName.Canonical -> A.Commented (Decl.Union Type.Canonical) -> [C.Def]

50unionToDefs moduleName (A.A (region,_) (Decl.Type name tvars constructors)) =

49unionToDefs moduleName (A.A (region,_) (Decl.Type name tvars constructors)) =

51 let

50 let

52 tagToDef (tag, tipes) =

51 tagToDef (tag, tipes) =

@@ -61,14 +60,14 @@ unionToDefs moduleName (A.A (region,_) (Decl.Type name tvars constructors)) =

61

60

62 body =

61 body =

63 A.A region $

62 A.A region $

64− E.Data tag (map (A.A region . E.localVar) vars)

63+ C.Ctor tag (map (A.A region . C.localVar) vars)

65 in

64 in

66 definition tag (buildFunction vars body) region (foldr Type.Lambda tbody tipes)

65 definition tag (buildFunction vars body) region (foldr Type.Lambda tbody tipes)

67 in

66 in

68 map tagToDef constructors

67 map tagToDef constructors

69

68

70

69

71−aliasToDefs :: ModuleName.Canonical -> A.Commented (Decl.Alias Type.Canonical) -> Maybe Canonical.Def

70+aliasToDefs :: ModuleName.Canonical -> A.Commented (Decl.Alias Type.Canonical) -> Maybe C.Def

72aliasToDefs moduleName (A.A (region,_) (Decl.Type name tvars tipe)) =

71aliasToDefs moduleName (A.A (region,_) (Decl.Type name tvars tipe)) =

73 case tipe of

72 case tipe of

74 Type.Record fields Nothing ->

73 Type.Record fields Nothing ->

@@ -87,7 +86,7 @@ aliasToDefs moduleName (A.A (region,_) (Decl.Type name tvars tipe)) =

87

86

88 record =

87 record =

89 A.A region $

88 A.A region $

90− E.Record (zip (map fst fields) (map (A.A region . E.localVar) vars))

89+ C.Record (zip (map fst fields) (map (A.A region . C.localVar) vars))

91 in

90 in

92 Just $ definition name (buildFunction vars record) region (foldr Type.Lambda resultType args)

91 Just $ definition name (buildFunction vars record) region (foldr Type.Lambda resultType args)

93

92

@@ -100,17 +99,17 @@ infiniteArgs =

100 map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]

99 map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]

101

100

102

101

103−buildFunction :: [String] -> Canonical.Expr -> Canonical.Expr

102+buildFunction :: [String] -> C.Expr -> C.Expr

104buildFunction vars body@(A.A ann _) =

103buildFunction vars body@(A.A ann _) =

105 foldr

104 foldr

106− (\pattern expr -> A.A ann (E.Lambda pattern expr))

105+ (\pattern expr -> A.A ann (C.Lambda pattern expr))

107 body

106 body

108 (map (A.A ann . P.Var) vars)

107 (map (A.A ann . P.Var) vars)

109

108

110

109

111−definition :: String -> Canonical.Expr -> Region -> Type.Canonical -> Canonical.Def

110+definition :: String -> C.Expr -> Region -> Type.Canonical -> C.Def

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

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

113− Canonical.Def

112+ C.Def

114 region

113 region

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

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

116 expr

115 expr

@@ -121,7 +120,7 @@ definition name expr@(A.A ann _) region tipe =

121-- EFFECTS

120-- EFFECTS

122

121

123

122

124−effectsToDefs :: ModuleName.Canonical -> Effects.Canonical -> [Canonical.Def]

123+effectsToDefs :: ModuleName.Canonical -> Effects.Canonical -> [C.Def]

125effectsToDefs moduleName effects =

124effectsToDefs moduleName effects =

126 case effects of

125 case effects of

127 Effects.None ->

126 Effects.None ->

@@ -135,14 +134,14 @@ effectsToDefs moduleName effects =

135 cmdToDef (A.A region name) =

134 cmdToDef (A.A region name) =

136 definition

135 definition

137 "command"

136 "command"

138− (A.A region (E.Cmd moduleName))

137+ (A.A region (C.Cmd moduleName))

139 region

138 region

140 (Type.cmd moduleName name)

139 (Type.cmd moduleName name)

141

140

142 subToDef (A.A region name) =

141 subToDef (A.A region name) =

143 definition

142 definition

144 "subscription"

143 "subscription"

145− (A.A region (E.Sub moduleName))

144+ (A.A region (C.Sub moduleName))

146 region

145 region

147 (Type.sub moduleName name)

146 (Type.sub moduleName name)

148 in

147 in

@@ -161,17 +160,17 @@ effectsToDefs moduleName effects =

161 ]

160 ]

162

161

163

162

164−portToDef :: A.Commented Effects.PortCanonical -> Canonical.Def

163+portToDef :: A.Commented Effects.PortCanonical -> C.Def

165portToDef (A.A (region, _) (Effects.PortCanonical name kind tipe)) =

164portToDef (A.A (region, _) (Effects.PortCanonical name kind tipe)) =

166 definition name (A.A region (toPortExpr name kind)) region tipe

165 definition name (A.A region (toPortExpr name kind)) region tipe

167

166

168

167

169−toPortExpr :: String -> Effects.Kind -> Canonical.Expr'

168+toPortExpr :: String -> Effects.Kind -> C.Expr'

170toPortExpr name kind =

169toPortExpr name kind =

171 case kind of

170 case kind of

172 Effects.Outgoing tipe ->

171 Effects.Outgoing tipe ->

173− E.OutgoingPort name tipe

172+ C.OutgoingPort name tipe

174

173

175 Effects.Incoming tipe ->

174 Effects.Incoming tipe ->

176− E.IncomingPort name tipe

175+ C.IncomingPort name tipe

177

176

src/Canonicalize/Effects.hs+2−2

@@ -36,7 +36,7 @@ toValues effects =

36-- CANONICALIZE

37

38

39−canonicalize :: Env.Environment -> Effects.Raw -> Result Effects.Canonical

39+canonicalize :: Env.Env -> Effects.Raw -> Result Effects.Canonical

40canonicalize env effects =

41 case effects of

42 Effects.None ->

@@ -50,7 +50,7 @@ canonicalize env effects =

50

51

52canonicalizeRawPort

53− :: Env.Environment

53+ :: Env.Env

54 -> A.Commented Effects.PortRaw

55 -> Result (A.Commented Effects.PortCanonical)

56canonicalizeRawPort env (A.A ann (Effects.PortRaw name rawType)) =

src/Canonicalize/Environment.hs+16−10

@@ -1,6 +1,6 @@

1{-# OPTIONS_GHC -Wall #-}

2module Canonicalize.Environment

3− ( Environment(..)

3+ ( Env(..)

4 , getPackage

5 , insert

6 , Patch(..), fromPatches, addPattern

@@ -14,6 +14,7 @@ import qualified Data.Map as Map

14import qualified Data.Maybe as Maybe

15import qualified Data.Set as Set

16

17+import qualified AST.Declaration as Decl

17import qualified AST.Module.Name as ModuleName

18import qualified AST.Module.Name as ModuleName

18import qualified AST.Pattern as P

19import qualified AST.Pattern as P

19import qualified AST.Type as Type

20import qualified AST.Type as Type

@@ -25,12 +26,13 @@ import qualified Elm.Package as Pkg

25-- ENVIRONMENT

26-- ENVIRONMENT

26

27

28

28−data Environment = Env

29+data Env = Env

29 { _home :: ModuleName.Canonical

30 { _home :: ModuleName.Canonical

30 , _values :: Dict Var.Canonical

31 , _values :: Dict Var.Canonical

31 , _unions :: Dict Var.Canonical

32 , _unions :: Dict Var.Canonical

32 , _aliases :: Dict (Var.Canonical, [String], Type.Canonical)

33 , _aliases :: Dict (Var.Canonical, [String], Type.Canonical)

33 , _patterns :: Dict (Var.Canonical, Int)

34 , _patterns :: Dict (Var.Canonical, Int)

35+ , _infixes :: Map.Map Var.Canonical (Decl.Assoc, Int)

34 }

36 }

35

37

36

38

@@ -38,12 +40,12 @@ type Dict a =

38 Map.Map String (Set.Set a)

40 Map.Map String (Set.Set a)

39

41

40

42

41−fromPatches :: ModuleName.Canonical -> [Patch] -> Environment

43+fromPatches :: ModuleName.Canonical -> [Patch] -> Env

42fromPatches moduleName patches =

44fromPatches moduleName patches =

43− addPatches patches (Env moduleName Map.empty Map.empty Map.empty Map.empty)

45+ addPatches patches (Env moduleName Map.empty Map.empty Map.empty Map.empty Map.empty)

44

46

45

47

46−addPattern :: P.Pattern ann var -> Environment -> Environment

48+addPattern :: P.Pattern ann var -> Env -> Env

47addPattern pattern env =

49addPattern pattern env =

48 let

50 let

49 patches =

51 patches =

@@ -52,7 +54,7 @@ addPattern pattern env =

52 addPatches patches env

54 addPatches patches env

53

55

54

56

55−getPackage :: Environment -> Pkg.Name

57+getPackage :: Env -> Pkg.Name

56getPackage env =

58getPackage env =

57 ModuleName._package (_home env)

59 ModuleName._package (_home env)

58

60

@@ -66,18 +68,19 @@ data Patch

66 | Union String Var.Canonical

68 | Union String Var.Canonical

67 | Alias String (Var.Canonical, [String], Type.Canonical)

69 | Alias String (Var.Canonical, [String], Type.Canonical)

68 | Pattern String (Var.Canonical, Int)

70 | Pattern String (Var.Canonical, Int)

71+ | Infix Var.Canonical Decl.Assoc Int

69

72

70

73

71

74

72-- ADD PATCH TO ENVIRONMENT

75-- ADD PATCH TO ENVIRONMENT

73

76

74

77

75−addPatches :: [Patch] -> Environment -> Environment

78+addPatches :: [Patch] -> Env -> Env

76addPatches patches env =

79addPatches patches env =

77 List.foldl' (flip addPatch) env patches

80 List.foldl' (flip addPatch) env patches

78

81

79

82

80−addPatch :: Patch -> Environment -> Environment

83+addPatch :: Patch -> Env -> Env

81addPatch patch env =

84addPatch patch env =

82 case patch of

85 case patch of

83 Value name var ->

86 Value name var ->

@@ -92,6 +95,9 @@ addPatch patch env =

92 Pattern name var ->

95 Pattern name var ->

93 env { _patterns = insert name var (_patterns env) }

96 env { _patterns = insert name var (_patterns env) }

94

97

98+ Infix name assoc prec ->

99+ env { _infixes = Map.insert name (assoc, prec) (_infixes env) }

100+

95

101

96insert :: (Ord a) => String -> a -> Dict a -> Dict a

102insert :: (Ord a) => String -> a -> Dict a -> Dict a

97insert key value =

103insert key value =

@@ -131,8 +137,8 @@ builtinPatches =

131-- TO TYPE DEALIASER

137-- TO TYPE DEALIASER

132

138

133

139

134−toDealiaser :: Environment -> Map.Map String String

140+toDealiaser :: Env -> Map.Map String String

135−toDealiaser (Env _ _ unions aliases _) =

141+toDealiaser (Env _ _ unions aliases _ _) =

136 let

142 let

137 dealiasUnion (localName, canonicalSet) =

143 dealiasUnion (localName, canonicalSet) =

138 case Set.toList canonicalSet of

144 case Set.toList canonicalSet of

src/Canonicalize/Setup.hs+22−13

@@ -6,11 +6,10 @@ import Control.Monad (foldM)

6import qualified Data.Graph as Graph

7import qualified Data.Map as Map

8import qualified Data.Maybe as Maybe

9−import qualified Data.Traversable as Trav

10

9

11import qualified AST.Declaration as D

10import qualified AST.Declaration as D

12import qualified AST.Effects as Effects

11import qualified AST.Effects as Effects

13−import qualified AST.Expression.Valid as Valid

12+import qualified AST.Expression.Source as Src

14import qualified AST.Module as Module

13import qualified AST.Module as Module

15import qualified AST.Module.Name as ModuleName

14import qualified AST.Module.Name as ModuleName

16import qualified AST.Pattern as P

15import qualified AST.Pattern as P

@@ -32,7 +31,7 @@ environment

32 :: Map.Map ModuleName.Raw ModuleName.Canonical

31 :: Map.Map ModuleName.Raw ModuleName.Canonical

33 -> Module.Interfaces

32 -> Module.Interfaces

34 -> Module.Valid

33 -> Module.Valid

35− -> Result Env.Environment

34+ -> Result Env.Env

36environment importDict interfaces (Module.Module name _ info) =

35environment importDict interfaces (Module.Module name _ info) =

37 let

36 let

38 (Module.Valid _ _ (defaults, imports) decls effects) =

37 (Module.Valid _ _ (defaults, imports) decls effects) =

@@ -42,7 +41,7 @@ environment importDict interfaces (Module.Module name _ info) =

42 imports ++ map (A.A (error "default import not found")) defaults

41 imports ++ map (A.A (error "default import not found")) defaults

43

42

44 getImportPatches =

43 getImportPatches =

45− Trav.traverse (importToPatches importDict interfaces) allImports

44+ traverse (importToPatches importDict interfaces) allImports

46

45

47 (typeAliasNodes, declPatches) =

46 (typeAliasNodes, declPatches) =

48 declsToPatches name decls

47 declsToPatches name decls

@@ -99,6 +98,9 @@ importToPatches importDict allInterfaces (A.A region (rawImportName, method)) =

99 qualifier =

98 qualifier =

100 maybe (ModuleName.toString rawImportName) id maybeAlias

99 maybe (ModuleName.toString rawImportName) id maybeAlias

101

100

101+ infixPatches =

102+ map (infixToPatch (Var.fromModule importName)) (Module.iFixities interface)

103+

102 qualifiedPatches =

104 qualifiedPatches =

103 interfaceToPatches importName (qualifier ++ ".") interface

105 interfaceToPatches importName (qualifier ++ ".") interface

104

106

@@ -107,9 +109,9 @@ importToPatches importDict allInterfaces (A.A region (rawImportName, method)) =

107 Result.ok (interfaceToPatches importName "" interface)

109 Result.ok (interfaceToPatches importName "" interface)

108

110

109 else

111 else

110− concat <$> Trav.traverse (valueToPatches region importName interface) exposedValues

112+ concat <$> traverse (valueToPatches region importName interface) exposedValues

111 in

113 in

112− (++) qualifiedPatches <$> unqualifiedPatches

114+ (++) (infixPatches ++ qualifiedPatches) <$> unqualifiedPatches

113

115

114

116

115interfaceToPatches :: ModuleName.Canonical -> String -> Module.Interface -> [Env.Patch]

117interfaceToPatches :: ModuleName.Canonical -> String -> Module.Interface -> [Env.Patch]

@@ -218,7 +220,7 @@ valueToPatches region moduleName interface value =

218 Result.ok realCtorList

220 Result.ok realCtorList

219

221

220 else

222 else

221− Trav.traverse ctorExists givenCtorNames

223+ traverse ctorExists givenCtorNames

222 where

224 where

223 realCtorList =

225 realCtorList =

224 map (second length) realCtors

226 map (second length) realCtors

@@ -270,16 +272,16 @@ node region name tvars alias =

270 maybe [] edges ext ++ concatMap (edges . snd) fs

272 maybe [] edges ext ++ concatMap (edges . snd) fs

271

273

272

274

273−addTypeAliases :: ModuleName.Canonical -> [Node] -> Env.Environment -> Result Env.Environment

275+addTypeAliases :: ModuleName.Canonical -> [Node] -> Env.Env -> Result Env.Env

274addTypeAliases moduleName typeAliasNodes initialEnv =

276addTypeAliases moduleName typeAliasNodes initialEnv =

275 foldM (addTypeAlias moduleName) initialEnv (Graph.stronglyConnComp typeAliasNodes)

277 foldM (addTypeAlias moduleName) initialEnv (Graph.stronglyConnComp typeAliasNodes)

276

278

277

279

278addTypeAlias

280addTypeAlias

279 :: ModuleName.Canonical

281 :: ModuleName.Canonical

280− -> Env.Environment

282+ -> Env.Env

281 -> Graph.SCC (R.Region, String, [String], Type.Raw)

283 -> Graph.SCC (R.Region, String, [String], Type.Raw)

282− -> Result Env.Environment

284+ -> Result Env.Env

283addTypeAlias moduleName env scc =

285addTypeAlias moduleName env scc =

284 case scc of

286 case scc of

285 Graph.AcyclicSCC (_, name, tvars, alias) ->

287 Graph.AcyclicSCC (_, name, tvars, alias) ->

@@ -314,7 +316,7 @@ addTypeAlias moduleName env scc =

314

316

315-}

317-}

316declsToPatches :: ModuleName.Canonical -> D.Valid -> ([Node], [Env.Patch])

318declsToPatches :: ModuleName.Canonical -> D.Valid -> ([Node], [Env.Patch])

317−declsToPatches moduleName (D.Decls defs unions aliases _) =

319+declsToPatches moduleName (D.Decls defs unions aliases infixes) =

318 let

320 let

319

321

320 -- HELPERS

322 -- HELPERS

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

327

329

328 -- TO PATCHES

330 -- TO PATCHES

329

331

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

332+ defToPatches (A.A _ (Src.Def _ pattern _ _)) =

331 map topLevelValue (P.boundVarList pattern)

333 map topLevelValue (P.boundVarList pattern)

332

334

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

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

@@ -352,13 +354,20 @@ declsToPatches moduleName (D.Decls defs unions aliases _) =

352 map aliasToNode aliases

354 map aliasToNode aliases

353 ,

355 ,

354 concat

356 concat

357+ [ map (infixToPatch (Var.topLevel moduleName)) infixes

355− [ Maybe.mapMaybe aliasToPatches aliases

358+ , Maybe.mapMaybe aliasToPatches aliases

356 , concatMap unionToPatches unions

359 , concatMap unionToPatches unions

357 , concatMap defToPatches defs

360 , concatMap defToPatches defs

358 ]

361 ]

359 )

362 )

360

363

361

364

365+infixToPatch :: (String -> Var.Canonical) -> D.Infix -> Env.Patch

366+infixToPatch toVar (D.Infix name assoc prec) =

367+ Env.Infix (toVar name) assoc prec

368+

369+

370+

362-- EFFECTS TO PATCHES

371-- EFFECTS TO PATCHES

363

372

364

373

src/Canonicalize/Sort.hs+51−52

@@ -7,8 +7,7 @@ import qualified Data.Map as Map

7import qualified Data.Maybe as Maybe

8import qualified Data.Set as Set

9

10−import AST.Expression.General (Expr'(..))

11−import qualified AST.Expression.Canonical as Canonical

10+import qualified AST.Expression.Canonical as C

12import qualified AST.Pattern as P

11import qualified AST.Pattern as P

13import qualified AST.Variable as V

12import qualified AST.Variable as V

14import qualified Reporting.Annotation as A

13import qualified Reporting.Annotation as A

@@ -20,7 +19,7 @@ import qualified Reporting.Result as R

20-- SORT DEFINITIONS

19-- SORT DEFINITIONS

21

20

22

21

23−definitions :: (Monoid i) => Canonical.Expr -> R.Result i w E.Error Canonical.Expr

22+definitions :: (Monoid i) => C.Expr -> R.Result i w E.Error C.Expr

24definitions expression =

23definitions expression =

25 let

24 let

26 (R.Result _ warnings answer) =

25 (R.Result _ warnings answer) =

@@ -89,79 +88,79 @@ delay (R.Result (LocalVars immediate delayed tags) warnings result) =

89-- REORDER EXPRESSIONS

88-- REORDER EXPRESSIONS

90

89

91

90

92−reorder :: Canonical.Expr -> R.Result LocalVars w E.Error Canonical.Expr

91+reorder :: C.Expr -> R.Result LocalVars w E.Error C.Expr

93reorder (A.A region expression) =

92reorder (A.A region expression) =

94 A.A region <$>

93 A.A region <$>

95 case expression of

94 case expression of

96− Var var ->

95+ C.Var var ->

97 addImmediate var expression

96 addImmediate var expression

98

97

99− Lambda pattern body ->

98+ C.Lambda pattern body ->

100 delay $

99 delay $

101− bindingReorder Lambda (pattern, body)

100+ bindingReorder C.Lambda (pattern, body)

102

101

103− Binop op leftExpr rightExpr ->

102+ C.Binop op leftExpr rightExpr ->

104− do binop <- Binop op <$> reorder leftExpr <*> reorder rightExpr

103+ do binop <- C.Binop op <$> reorder leftExpr <*> reorder rightExpr

105 addImmediate op binop

104 addImmediate op binop

106

105

107− Case expr cases ->

106+ C.Case expr cases ->

108− Case <$> reorder expr <*> traverse (bindingReorder (,)) cases

107+ C.Case <$> reorder expr <*> traverse (bindingReorder (,)) cases

109

108

110− Data name exprs ->

109+ C.Ctor name exprs ->

111− addTag name =<< (Data name <$> traverse reorder exprs)

110+ addTag name =<< (C.Ctor name <$> traverse reorder exprs)

112

111

113 -- Just pipe the reorder though

112 -- Just pipe the reorder though

114− Literal _ ->

113+ C.Literal _ ->

115 return expression

114 return expression

116

115

117− ExplicitList es ->

116+ C.List es ->

118− ExplicitList <$> traverse reorder es

117+ C.List <$> traverse reorder es

119

118

120− App func arg ->

119+ C.App func arg ->

121− App <$> reorder func <*> reorder arg

120+ C.App <$> reorder func <*> reorder arg

122

121

123− If branches finally ->

122+ C.If branches finally ->

124− If

123+ C.If

125 <$> traverse (\(cond,branch) -> (,) <$> reorder cond <*> reorder branch) branches

124 <$> traverse (\(cond,branch) -> (,) <$> reorder cond <*> reorder branch) branches

126 <*> reorder finally

125 <*> reorder finally

127

126

128− Access record field ->

127+ C.Access record field ->

129− Access

128+ C.Access

130 <$> reorder record

129 <$> reorder record

131 <*> return field

130 <*> return field

132

131

133− Update record fields ->

132+ C.Update record fields ->

134− Update

133+ C.Update

135 <$> reorder record

134 <$> reorder record

136 <*> traverse (traverse reorder) fields

135 <*> traverse (traverse reorder) fields

137

136

138− Record fields ->

137+ C.Record fields ->

139− Record

138+ C.Record

140 <$> traverse (traverse reorder) fields

139 <$> traverse (traverse reorder) fields

141

140

142− Cmd _ ->

141+ C.Cmd _ ->

143 return expression

142 return expression

144

143

145− Sub _ ->

144+ C.Sub _ ->

146 return expression

145 return expression

147

146

148− OutgoingPort _ _ ->

147+ C.OutgoingPort _ _ ->

149 return expression

148 return expression

150

149

151− IncomingPort _ _ ->

150+ C.IncomingPort _ _ ->

152 return expression

151 return expression

153

152

154− Program _ _ ->

153+ C.Program _ _ ->

155 error "DANGER - Program AST nodes should not be in def sorting."

154 error "DANGER - Program AST nodes should not be in def sorting."

156

155

157− SaveEnv _ _ ->

156+ C.SaveEnv _ _ ->

158 return expression

157 return expression

159

158

160− GLShader _ _ _ ->

159+ C.GLShader _ _ _ ->

161 return expression

160 return expression

162

161

163 -- Actually do some reordering

162 -- Actually do some reordering

164− Let defs body ->

163+ C.Let defs body ->

165 case reorderDefs defs of

164 case reorderDefs defs of

166 R.Result () warnings (R.Err errors) ->

165 R.Result () warnings (R.Err errors) ->

167 R.Result mempty warnings (R.Err errors)

166 R.Result mempty warnings (R.Err errors)

@@ -171,7 +170,7 @@ reorder (A.A region expression) =

171 do _ <- R.Result mempty warnings (R.Ok ())

170 do _ <- R.Result mempty warnings (R.Ok ())

172 newBody <- reorder body

171 newBody <- reorder body

173 R.accumulate defLocals $ A.drop $

172 R.accumulate defLocals $ A.drop $

174− foldr (\defGroup expr -> A.A region (Let defGroup expr)) newBody defGroups

173+ foldr (\defGroup expr -> A.A region (C.Let defGroup expr)) newBody defGroups

175

174

176

175

177

176

@@ -179,8 +178,8 @@ reorder (A.A region expression) =

179

178

180

179

181bindingReorder

180bindingReorder

182− :: (P.Canonical -> Canonical.Expr -> a)

181+ :: (P.Canonical -> C.Expr -> a)

183− -> (P.Canonical, Canonical.Expr)

182+ -> (P.Canonical, C.Expr)

184 -> R.Result LocalVars w E.Error a

183 -> R.Result LocalVars w E.Error a

185bindingReorder func (pattern, expr) =

184bindingReorder func (pattern, expr) =

186 do answer <- func pattern <$> capture pattern (reorder expr)

185 do answer <- func pattern <$> capture pattern (reorder expr)

@@ -238,8 +237,8 @@ getPatternTags (A.A _ pattern) =

238

237

239

238

240reorderDefs

239reorderDefs

241− :: [Canonical.Def]

240+ :: [C.Def]

242− -> R.Result () w E.Error (Set.Set String, [[Canonical.Def]], LocalVars)

241+ -> R.Result () w E.Error (Set.Set String, [[C.Def]], LocalVars)

243reorderDefs defs =

242reorderDefs defs =

244 do rawNodes <- sequenceA $ zipWith toRawNode [0..] defs

243 do rawNodes <- sequenceA $ zipWith toRawNode [0..] defs

245 let boundVarDict = toBoundVarDict rawNodes

244 let boundVarDict = toBoundVarDict rawNodes

@@ -247,25 +246,25 @@ reorderDefs defs =

247 return $ groupDefs boundVarDict rawNodes

246 return $ groupDefs boundVarDict rawNodes

248

247

249

248

250−toRawNode :: Int -> Canonical.Def -> R.Result () w E.Error (Canonical.Def, Int, LocalVars)

249+toRawNode :: Int -> C.Def -> R.Result () w E.Error (C.Def, Int, LocalVars)

251−toRawNode index (Canonical.Def region pattern body maybeType) =

250+toRawNode index (C.Def region pattern body maybeType) =

252 let

251 let

253 (R.Result localVars warnings answer) =

252 (R.Result localVars warnings answer) =

254 addPatternTags pattern =<< reorder body

253 addPatternTags pattern =<< reorder body

255

254

256 toRawNodeHelp newBody =

255 toRawNodeHelp newBody =

257− ( Canonical.Def region pattern newBody maybeType, index, localVars )

256+ ( C.Def region pattern newBody maybeType, index, localVars )

258 in

257 in

259 toRawNodeHelp <$> R.Result () warnings answer

258 toRawNodeHelp <$> R.Result () warnings answer

260

259

261

260

262−toBoundVarDict :: [(Canonical.Def, Int, a)] -> Map.Map String Int

261+toBoundVarDict :: [(C.Def, Int, a)] -> Map.Map String Int

263toBoundVarDict defAndDeps =

262toBoundVarDict defAndDeps =

264 Map.fromList (concatMap toBoundVarDictHelp defAndDeps)

263 Map.fromList (concatMap toBoundVarDictHelp defAndDeps)

265

264

266

265

267−toBoundVarDictHelp :: (Canonical.Def, Int, a) -> [(String, Int)]

266+toBoundVarDictHelp :: (C.Def, Int, a) -> [(String, Int)]

268−toBoundVarDictHelp (Canonical.Def _ pattern _ _, key, _) =

267+toBoundVarDictHelp (C.Def _ pattern _ _, key, _) =

269 map (\(A.A _ name) -> (name, key)) (P.boundVars pattern)

268 map (\(A.A _ name) -> (name, key)) (P.boundVars pattern)

270

269

271

270

@@ -276,8 +275,8 @@ toBoundVarDictHelp (Canonical.Def _ pattern _ _, key, _) =

276toNode

275toNode

277 :: (deps -> [String])

276 :: (deps -> [String])

278 -> Map.Map String Int

277 -> Map.Map String Int

279− -> (Canonical.Def, Int, deps)

278+ -> (C.Def, Int, deps)

280− -> (Canonical.Def, Int, [Int])

279+ -> (C.Def, Int, [Int])

281toNode toVars boundVarDict (def, index, deps) =

280toNode toVars boundVarDict (def, index, deps) =

282 let

281 let

283 localDeps =

282 localDeps =

@@ -302,7 +301,7 @@ allVars (LocalVars immediate delayed tags) =

302

301

303detectLoops

302detectLoops

304 :: Map.Map String Int

303 :: Map.Map String Int

305− -> [(Canonical.Def, Int, LocalVars)]

304+ -> [(C.Def, Int, LocalVars)]

306 -> R.Result () w E.Error ()

305 -> R.Result () w E.Error ()

307detectLoops boundVarDict rawNodes =

306detectLoops boundVarDict rawNodes =

308 F.traverse_ detectLoopsHelp $

307 F.traverse_ detectLoopsHelp $

@@ -310,7 +309,7 @@ detectLoops boundVarDict rawNodes =

310 map (toNode immediateOnly boundVarDict) rawNodes

309 map (toNode immediateOnly boundVarDict) rawNodes

311

310

312

311

313−detectLoopsHelp :: Graph.SCC Canonical.Def -> R.Result () w E.Error ()

312+detectLoopsHelp :: Graph.SCC C.Def -> R.Result () w E.Error ()

314detectLoopsHelp scc =

313detectLoopsHelp scc =

315 case scc of

314 case scc of

316 Graph.AcyclicSCC _ ->

315 Graph.AcyclicSCC _ ->

@@ -321,7 +320,7 @@ detectLoopsHelp scc =

321 [] ->

320 [] ->

322 R.ok ()

321 R.ok ()

323

322

324− def@(Canonical.Def region (A.A nameRegion _) _ _) : rest ->

323+ def@(C.Def region (A.A nameRegion _) _ _) : rest ->

325 R.throw region $ E.BadRecursion nameRegion def rest

324 R.throw region $ E.BadRecursion nameRegion def rest

326

325

327

326

@@ -331,8 +330,8 @@ detectLoopsHelp scc =

331

330

332groupDefs

331groupDefs

333 :: Map.Map String Int

332 :: Map.Map String Int

334− -> [(Canonical.Def, Int, LocalVars)]

333+ -> [(C.Def, Int, LocalVars)]

335− -> ( Set.Set String, [[Canonical.Def]], LocalVars )

334+ -> ( Set.Set String, [[C.Def]], LocalVars )

336groupDefs boundVarDict rawNodes =

335groupDefs boundVarDict rawNodes =

337 let

336 let

338 allLocalVars =

337 allLocalVars =

src/Canonicalize/Type.hs+3−3

@@ -15,7 +15,7 @@ import qualified Canonicalize.Variable as Canonicalize

15import Canonicalize.Variable (Result)

16

17

18−tipe :: Env.Environment -> T.Raw -> Result T.Canonical

18+tipe :: Env.Env -> T.Raw -> Result T.Canonical

19tipe env annType@(A.A _ typ) =

20 let

21 go =

@@ -41,7 +41,7 @@ tipe env annType@(A.A _ typ) =

41 T.Record <$> Trav.traverse goSnd fields <*> Trav.traverse go ext

42

43

44−canonicalizeApp :: Env.Environment -> T.Raw -> [T.Raw] -> Result T.Canonical

44+canonicalizeApp :: Env.Env -> T.Raw -> [T.Raw] -> Result T.Canonical

45canonicalizeApp env annFunc@(A.A region func) args =

46 case func of

47 T.RType (Var.Raw rawName) ->

@@ -69,7 +69,7 @@ canonicalizeApp env annFunc@(A.A region func) args =

69

70canonicalizeAlias

71 :: R.Region

72− -> Env.Environment

72+ -> Env.Env

73 -> (Var.Canonical, [String], T.Canonical)

74 -> [T.Raw]

75 -> Result T.Canonical

src/Canonicalize/Variable.hs+5−16

@@ -45,7 +45,7 @@ logVar var =

45-- FINDERS

46

47

48−variable :: R.Region -> Env.Environment -> String -> Result Var.Canonical

48+variable :: R.Region -> Env.Env -> String -> Result Var.Canonical

49variable region env var =

50 case toVarName var of

51 Right (name, varName) | ModuleName.isNative name ->

@@ -72,7 +72,7 @@ variable region env var =

72

73tvar

74 :: R.Region

75− -> Env.Environment

75+ -> Env.Env

76 -> String

77 -> Result

78 (Either

@@ -97,12 +97,7 @@ tvar region env var =

97 Right (v,_,_) -> v

98

99

100−pvar

101− :: R.Region

102− -> Env.Environment

103− -> String

104− -> Int

105− -> Result Var.Canonical

100+pvar :: R.Region -> Env.Env -> String -> Int -> Result Var.Canonical

106pvar region env var actualArgs =

101pvar region env var actualArgs =

107 case Set.toList <$> Map.lookup var (Env._patterns env) of

102 case Set.toList <$> Map.lookup var (Env._patterns env) of

108 Just [value] ->

103 Just [value] ->

@@ -126,20 +121,14 @@ pvar region env var actualArgs =

126-- FOUND

121-- FOUND

127

122

128

123

129−preferLocals

130− :: R.Region

131− -> Env.Environment

132− -> String

133− -> [Var.Canonical]

134− -> String

135− -> Result Var.Canonical

124+preferLocals :: R.Region -> Env.Env -> String -> [Var.Canonical] -> String -> Result Var.Canonical

136preferLocals region env =

125preferLocals region env =

137 preferLocals' region env id

126 preferLocals' region env id

138

127

139

128

140preferLocals'

129preferLocals'

141 :: R.Region

130 :: R.Region

142− -> Env.Environment

131+ -> Env.Env

143 -> (a -> Var.Canonical)

132 -> (a -> Var.Canonical)

144 -> String

133 -> String

145 -> [a]

134 -> [a]

src/Compile.hs+11−19

@@ -1,19 +1,15 @@

1+{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}

1module Compile (compile) where

2module Compile (compile) where

2

3

3−import qualified Data.Map as Map

4−

5−import qualified AST.Declaration as D

6import qualified AST.Expression.Canonical as Can

4import qualified AST.Expression.Canonical as Can

7import qualified AST.Module as Module

5import qualified AST.Module as Module

8import qualified AST.Module.Name as ModuleName

6import qualified AST.Module.Name as ModuleName

9import qualified Canonicalize

7import qualified Canonicalize

10−import Elm.Utils ((|>))

11import qualified Elm.Package as Package

8import qualified Elm.Package as Package

12import qualified Nitpick.PatternMatches as Nitpick

9import qualified Nitpick.PatternMatches as Nitpick

13import qualified Nitpick.TopLevelTypes as Nitpick

10import qualified Nitpick.TopLevelTypes as Nitpick

14import qualified Optimize

11import qualified Optimize

15−import qualified Parse.Helpers as Parse

12+import qualified Parse.Parse as Parse (program)

16−import qualified Parse.Parse as Parse

17import qualified Reporting.Error as Error

13import qualified Reporting.Error as Error

18import qualified Reporting.Render.Type as RenderType

14import qualified Reporting.Render.Type as RenderType

19import qualified Reporting.Result as Result

15import qualified Reporting.Result as Result

@@ -36,8 +32,9 @@ compile packageName canonicalImports interfaces source =

36 do

32 do

37 -- Parse the source code

33 -- Parse the source code

38 validModule <-

34 validModule <-

39− Result.format Error.Syntax $ {-# SCC elm_compiler_parse #-}

35+ Result.format Error.Syntax $

36+ {-# SCC elm_compiler_parse #-}

40− Parse.program packageName (getOpTable interfaces) source

37+ Parse.program packageName source

41

38

42 -- Canonicalize all variables, pinning down where they came from.

39 -- Canonicalize all variables, pinning down where they came from.

43 canonicalModule <-

40 canonicalModule <-

@@ -45,7 +42,8 @@ compile packageName canonicalImports interfaces source =

45

42

46 -- Run type inference on the program.

43 -- Run type inference on the program.

47 types <-

44 types <-

45+ Result.from Error.Type $

48− Result.from Error.Type $ {-# SCC elm_compiler_types #-}

46+ {-# SCC elm_compiler_types #-}

49 TI.infer interfaces canonicalModule

47 TI.infer interfaces canonicalModule

50

48

51 -- One last round of checks

49 -- One last round of checks

@@ -55,11 +53,13 @@ compile packageName canonicalImports interfaces source =

55 Can.toSortedDefs (Module.program (Module.info canonicalModule))

53 Can.toSortedDefs (Module.program (Module.info canonicalModule))

56

54

57 tagDict <-

55 tagDict <-

56+ Result.format Error.Pattern $

58− Result.format Error.Pattern $ {-# SCC elm_compiler_exhaustiveness #-}

57+ {-# SCC elm_compiler_exhaustiveness #-}

59 Nitpick.patternMatches interfaces canonicalModule

58 Nitpick.patternMatches interfaces canonicalModule

60

59

61 -- Do some basic optimizations

60 -- Do some basic optimizations

61+ let optimisedDefs =

62− let optimisedDefs = {-# SCC elm_compiler_optimization #-}

62+ {-# SCC elm_compiler_optimization #-}

63 Optimize.optimize tagDict (Module.name canonicalModule) canonicalDefs

64

65 -- Add the real list of types

@@ -70,11 +70,3 @@ compile packageName canonicalImports interfaces source =

70 }

71

72 return $ canonicalModule { Module.info = info }

73−

74−

75−getOpTable :: Module.Interfaces -> Parse.OpTable

76−getOpTable interfaces =

77− Map.elems interfaces

78− |> concatMap Module.iFixities

79− |> map (\(D.Infix op assoc lvl) -> ( op, (lvl,assoc) ))

80− |> Map.fromList

src/Docs/Check.hs+2−2

@@ -13,7 +13,7 @@ import qualified Elm.Compiler.Type as Type

13import Elm.Utils ((|>))

14import Parse.Binop (infixOp)

15import Parse.Helpers

16− ( addLocation, anyUntil, commaSep1, iParse, parens, simpleNewline

16+ ( addLocation, anyUntil, commaSep1, parens, parse, simpleNewline

17 , var, whitespace

18 )

19import qualified Reporting.Annotation as A

@@ -166,7 +166,7 @@ commentedNames (R.Region start _) comment =

166 do setPosition (newPos "docs" (R.line start) (R.column start + 3))

167 concat <$> many nameParser

168 in

169− case iParse docCommentParser comment of

169+ case parse docCommentParser comment of

170 Left _ ->

171 []

172

src/Elm/Compiler.hs+17−10

@@ -13,6 +13,7 @@ import qualified Data.Aeson as Json

13import qualified Data.Map as Map

14import qualified Data.Text.Lazy as LazyText

15import System.IO (Handle)

16+import qualified Text.Parsec.Error as Parsec

16

17

17import qualified AST.Module as Module

18import qualified AST.Module as Module

18import qualified AST.Module.Name as ModuleName

19import qualified AST.Module.Name as ModuleName

@@ -24,11 +25,13 @@ import qualified Elm.Compiler.Version

24import qualified Elm.Docs as Docs

25import qualified Elm.Docs as Docs

25import qualified Elm.Package as Package

26import qualified Elm.Package as Package

26import qualified Generate.JavaScript as JS

27import qualified Generate.JavaScript as JS

27−import qualified Parse.Module as Parse

28+import qualified Parse.Helpers as Parse (parse)

28−import qualified Parse.Parse as Parse

29+import qualified Parse.Module as Parse (header)

29import qualified Reporting.Annotation as A

30import qualified Reporting.Annotation as A

30import qualified Reporting.Bag as Bag

31import qualified Reporting.Bag as Bag

31import qualified Reporting.Error as Error

32import qualified Reporting.Error as Error

33+import qualified Reporting.Error.Syntax as SyntaxError

34+import qualified Reporting.Region as Region

32import qualified Reporting.Render.Type as RenderType

35import qualified Reporting.Render.Type as RenderType

33import qualified Reporting.Report as Report

36import qualified Reporting.Report as Report

34import qualified Reporting.Result as Result

37import qualified Reporting.Result as Result

@@ -57,13 +60,19 @@ data Tag

57parseDependencies

60parseDependencies

58 :: Package.Name

61 :: Package.Name

59 -> String

62 -> String

60− -> Either [Error] (Tag, PublicModule.Raw, [PublicModule.Raw])

63+ -> Either Error (Tag, PublicModule.Raw, [PublicModule.Raw])

61parseDependencies pkgName sourceCode =

64parseDependencies pkgName sourceCode =

62− let

63− (Result.Result _ _ answer) =

64− Parse.parse sourceCode Parse.header

65+ case Parse.parse Parse.header sourceCode of

65− in

66+ Right header ->

66− Result.answerToEither (Error . A.map Error.Syntax) (getDeps pkgName) answer

67+ Right $ getDeps pkgName header

68+

69+ Left parseError ->

70+ let

71+ pos = Region.fromSourcePos (Parsec.errorPos parseError)

72+ msgs = Parsec.errorMessages parseError

73+ err = Error.Syntax (SyntaxError.Parse msgs)

74+ in

75+ Left (Error (A.at pos pos err))

67

76

68

77

69getDeps

78getDeps

@@ -202,5 +211,3 @@ printWarning handle (Localizer localizer) location source (Warning (A.A region w

202warningToJson :: Localizer -> String -> Warning -> Json.Value

211warningToJson :: Localizer -> String -> Warning -> Json.Value

203warningToJson (Localizer localizer) location (Warning wrn) =

212warningToJson (Localizer localizer) location (Warning wrn) =

204 Warning.toJson localizer location wrn

213 Warning.toJson localizer location wrn

205−

206−

src/Elm/Compiler/Type.hs+2−2

@@ -158,8 +158,8 @@ instance Json.FromJSON Type where

158 in

159 case value of

160 Json.String text ->

161− either failure (return . fromRawType)

161+ either failure (return . fromRawType) $

162− (Parse.iParse Type.expr (replacePrimes (Text.unpack text)))

162+ Parse.parse Type.expr (replacePrimes (Text.unpack text))

163

164 Json.Object obj ->

165 fromObject obj

src/Elm/Utils.hs+2−2

@@ -99,8 +99,8 @@ missingExe command =

99-- DECL CHECKER

100

101isDeclaration :: String -> Maybe String

102−isDeclaration string =

102+isDeclaration str =

103− case Parse.iParse Parse.def string of

103+ case Parse.parse Parse.def str of

104 Right (A.A _ (Source.Definition pattern _)) ->

105 Just (List.intercalate "$" (Pattern.boundVarList pattern))

106

src/Generate/JavaScript/Expression.hs+9−10

@@ -6,11 +6,10 @@ import qualified Data.List as List

6import qualified Data.Map as Map

7import Language.ECMAScript3.Syntax

8

9−import AST.Expression.General as Expr (Main(..))

9+import qualified AST.Expression.Canonical as Can

10import AST.Expression.Optimized as Opt

11import qualified AST.Literal as L

12import qualified AST.Module.Name as ModuleName

13−import qualified AST.Type as Type

14import qualified AST.Variable as Var

13import qualified AST.Variable as Var

15import Generate.JavaScript.Helpers as Help

14import Generate.JavaScript.Helpers as Help

16import qualified Generate.JavaScript.BuiltIn as BuiltIn

15import qualified Generate.JavaScript.BuiltIn as BuiltIn

@@ -169,11 +168,11 @@ generateCode expr =

169 Case exprName decider jumps ->

168 Case exprName decider jumps ->

170 JsBlock <$> generateCase exprName decider jumps

169 JsBlock <$> generateCase exprName decider jumps

171

170

172− ExplicitList elements ->

171+ List elements ->

173 do jsElements <- mapM generateJsExpr elements

172 do jsElements <- mapM generateJsExpr elements

174 jsExpr $ BuiltIn.list jsElements

173 jsExpr $ BuiltIn.list jsElements

175

174

176− Data tag members ->

175+ Ctor tag members ->

177 let

176 let

178 ctor =

177 ctor =

179 "ctor" ==> StringLit () tag

178 "ctor" ==> StringLit () tag

@@ -184,7 +183,7 @@ generateCode expr =

184 do jsMembers <- mapM generateJsExpr members

183 do jsMembers <- mapM generateJsExpr members

185 jsExpr $ ObjectLit () (ctor : zipWith toEntry jsMembers [ 0 :: Int .. ])

184 jsExpr $ ObjectLit () (ctor : zipWith toEntry jsMembers [ 0 :: Int .. ])

186

185

187− DataAccess dataExpr index ->

186+ CtorAccess dataExpr index ->

188 do jsDataExpr <- generateJsExpr dataExpr

187 do jsDataExpr <- generateJsExpr dataExpr

189 jsExpr $ DotRef () jsDataExpr (var ("_" ++ show index))

188 jsExpr $ DotRef () jsDataExpr (var ("_" ++ show index))

190

189

@@ -216,18 +215,18 @@ generateCode expr =

216-- PROGRAMS

215-- PROGRAMS

217

216

218

217

219−generateProgram :: Expr.Main Type.Canonical -> Opt.Expr -> State Int Code

218+generateProgram :: Can.Main -> Opt.Expr -> State Int Code

220generateProgram kind body =

219generateProgram kind body =

221 case kind of

220 case kind of

222− Expr.VDom ->

221+ Can.VDom ->

223 do html <- generateJsExpr body

222 do html <- generateJsExpr body

224 jsExpr (Var.staticProgram <| html)

223 jsExpr (Var.staticProgram <| html)

225

224

226− Expr.NoFlags ->

225+ Can.NoFlags ->

227 do almostProgram <- generateJsExpr body

226 do almostProgram <- generateJsExpr body

228 jsExpr (almostProgram `call` [])

227 jsExpr (almostProgram `call` [])

229

228

230− Expr.Flags tipe ->

229+ Can.Flags tipe ->

231 do almostProgram <- generateJsExpr body

230 do almostProgram <- generateJsExpr body

232 flagDecoder <- generateJsExpr (Foreign.decode tipe)

231 flagDecoder <- generateJsExpr (Foreign.decode tipe)

233 jsExpr (almostProgram <| flagDecoder)

232 jsExpr (almostProgram <| flagDecoder)

@@ -537,7 +536,7 @@ pathToExpr root fullPath =

537 go expr path =

536 go expr path =

538 case path of

537 case path of

539 DT.Position index subpath ->

538 DT.Position index subpath ->

540− go (Opt.DataAccess expr index) subpath

539+ go (Opt.CtorAccess expr index) subpath

541

540

542 DT.Field field subpath ->

541 DT.Field field subpath ->

543 go (Opt.Access expr field) subpath

542 go (Opt.Access expr field) subpath

src/Generate/JavaScript/Foreign.hs+3−3

@@ -182,7 +182,7 @@ toMaybe tipe =

182 Opt.Var (Var.inCore ["Maybe"] tag)

183 in

184 to "oneOf" <==

185− [ Opt.ExplicitList

185+ [ Opt.List

186 [ to "null" <== [ maybe "Nothing" ]

187 , to "map" <== [ maybe "Just", decode tipe ]

188 ]

@@ -191,7 +191,7 @@ toMaybe tipe =

191

192toTuple0 :: Opt.Expr

193toTuple0 =

194− to "null" <== [ Opt.Data "_Tuple0" [] ]

194+ to "null" <== [ Opt.Ctor "_Tuple0" [] ]

195

196

197toTuple :: [T.Canonical] -> Opt.Expr

@@ -208,7 +208,7 @@ toTuple types =

208

209 makeTuple =

210 to "succeed" <==

211− [ Opt.Data

211+ [ Opt.Ctor

212 ("_Tuple" ++ show size)

213 (map (Opt.Var . Var.local . toVar . fst) pairs)

214 ]

src/Nitpick/PatternMatches.hs+23−24

@@ -6,8 +6,7 @@ import qualified Data.Map as Map

6import qualified Data.Maybe as Maybe

7import qualified Data.Set as Set

8

9−import qualified AST.Expression.General as E

9+import qualified AST.Expression.Canonical as C

10−import qualified AST.Expression.Canonical as Canonical

11import qualified AST.Helpers as Help

10import qualified AST.Helpers as Help

12import qualified AST.Module as Module

11import qualified AST.Module as Module

13import qualified AST.Module.Name as ModuleName

12import qualified AST.Module.Name as ModuleName

@@ -119,7 +118,7 @@ lookupOtherTags (Var.Canonical home name) tagDict =

119-- CHECK EXPRESSIONS

118-- CHECK EXPRESSIONS

120

119

121

120

122−checkExpression :: TagDict -> Canonical.Expr -> Result wrn ()

121+checkExpression :: TagDict -> C.Expr -> Result wrn ()

123checkExpression tagDict (A.A region expression) =

122checkExpression tagDict (A.A region expression) =

124 let

123 let

125 go =

124 go =

@@ -129,74 +128,74 @@ checkExpression tagDict (A.A region expression) =

129 go a <* go b

128 go a <* go b

130 in

129 in

131 case expression of

130 case expression of

132− E.Literal _ ->

131+ C.Literal _ ->

133 Result.ok ()

132 Result.ok ()

134

133

135− E.Var _ ->

134+ C.Var _ ->

136 Result.ok ()

135 Result.ok ()

137

136

138− E.ExplicitList listExprs ->

137+ C.List listExprs ->

139 F.traverse_ go listExprs

138 F.traverse_ go listExprs

140

139

141− E.Binop _ leftExpr rightExpr ->

140+ C.Binop _ leftExpr rightExpr ->

142 go2 leftExpr rightExpr

141 go2 leftExpr rightExpr

143

142

144− E.Lambda pattern@(A.A patRegion _) body ->

143+ C.Lambda pattern@(A.A patRegion _) body ->

145 checkPatterns tagDict patRegion Error.Arg [pattern]

144 checkPatterns tagDict patRegion Error.Arg [pattern]

146 <* go body

145 <* go body

147

146

148− E.App func arg ->

147+ C.App func arg ->

149 go2 func arg

148 go2 func arg

150

149

151− E.If branches finally ->

150+ C.If branches finally ->

152 F.traverse_ (uncurry go2) branches

151 F.traverse_ (uncurry go2) branches

153 <* go finally

152 <* go finally

154

153

155− E.Let defs body ->

154+ C.Let defs body ->

156 go body

155 go body

157 <* F.traverse_ goDef defs

156 <* F.traverse_ goDef defs

158 where

157 where

159− goDef (Canonical.Def _ pattern@(A.A patRegion _) expr _) =

158+ goDef (C.Def _ pattern@(A.A patRegion _) expr _) =

160 checkPatterns tagDict patRegion Error.LetBound [pattern]

159 checkPatterns tagDict patRegion Error.LetBound [pattern]

161 <* go expr

160 <* go expr

162

161

163− E.Case expr branches ->

162+ C.Case expr branches ->

164 go expr

163 go expr

165 <* checkPatterns tagDict region Error.Case (map fst branches)

164 <* checkPatterns tagDict region Error.Case (map fst branches)

166 <* F.traverse_ (go . snd) branches

165 <* F.traverse_ (go . snd) branches

167

166

168− E.Data _ctor exprs ->

167+ C.Ctor _ctor exprs ->

169 F.traverse_ go exprs

168 F.traverse_ go exprs

170

169

171− E.Access record _field ->

170+ C.Access record _field ->

172 go record

171 go record

173

172

174− E.Update record fields ->

173+ C.Update record fields ->

175 go record

174 go record

176 <* F.traverse_ (go . snd) fields

175 <* F.traverse_ (go . snd) fields

177

176

178− E.Record fields ->

177+ C.Record fields ->

179 F.traverse_ (go . snd) fields

178 F.traverse_ (go . snd) fields

180

179

181− E.Cmd _ ->

180+ C.Cmd _ ->

182 Result.ok ()

181 Result.ok ()

183

182

184− E.Sub _ ->

183+ C.Sub _ ->

185 Result.ok ()

184 Result.ok ()

186

185

187− E.OutgoingPort _ _ ->

186+ C.OutgoingPort _ _ ->

188 Result.ok ()

187 Result.ok ()

189

188

190− E.IncomingPort _ _ ->

189+ C.IncomingPort _ _ ->

191 Result.ok ()

190 Result.ok ()

192

191

193− E.Program _ _ ->

192+ C.Program _ _ ->

194 error "DANGER - Program AST nodes should not be in Nitpick.PatternMatches."

193 error "DANGER - Program AST nodes should not be in Nitpick.PatternMatches."

195

194

196− E.SaveEnv _ _ ->

195+ C.SaveEnv _ _ ->

197 Result.ok ()

196 Result.ok ()

198

197

199− E.GLShader _ _ _ ->

198+ C.GLShader _ _ _ ->

200 Result.ok ()

199 Result.ok ()

201

200

202

201

src/Nitpick/TopLevelTypes.hs+4−5

@@ -6,7 +6,6 @@ import Data.Map ((!))

6import qualified Data.Map as Map

7

8import qualified AST.Expression.Canonical as Can

9−import qualified AST.Expression.General as Expr

10import qualified AST.Module.Name as ModuleName

9import qualified AST.Module.Name as ModuleName

11import qualified AST.Pattern as P

10import qualified AST.Pattern as P

12import qualified AST.Type as Type

11import qualified AST.Type as Type

@@ -88,21 +87,21 @@ checkMain typeEnv (Can.Def facts pattern@(A.A region _) body maybeType) =

88 case Type.deepDealias mainType of

87 case Type.deepDealias mainType of

89 Type.App name [_]

88 Type.App name [_]

90 | name == vdomNode ->

89 | name == vdomNode ->

91− return Expr.VDom

90+ return Can.VDom

92

91

93 Type.App name [flags, _, _]

92 Type.App name [flags, _, _]

94 | name == program && flags == never ->

93 | name == program && flags == never ->

95− return Expr.NoFlags

94+ return Can.NoFlags

96

95

97 | name == program ->

96 | name == program ->

98− return (Expr.Flags flags)

97+ return (Can.Flags flags)

99 <* Effects.checkPortType makeError flags

98 <* Effects.checkPortType makeError flags

100

99

101 _ ->

100 _ ->

102 Result.throw region (Error.BadMain mainType)

101 Result.throw region (Error.BadMain mainType)

103 in

102 in

104 do kind <- getMainKind

103 do kind <- getMainKind

105− let newBody = A.A undefined (Expr.Program kind body)

104+ let newBody = A.A undefined (Can.Program kind body)

106 return (Can.Def facts pattern newBody maybeType)

105 return (Can.Def facts pattern newBody maybeType)

107

106

108

107

src/Optimize.hs+37−38

@@ -4,7 +4,6 @@ import qualified Control.Monad as M

4import qualified Data.Map as Map

5import qualified Data.Traversable as T

6

7−import qualified AST.Expression.General as Expr

8import qualified AST.Expression.Canonical as Can

7import qualified AST.Expression.Canonical as Can

9import qualified AST.Expression.Optimized as Opt

8import qualified AST.Expression.Optimized as Opt

10import qualified AST.Module.Name as ModuleName

9import qualified AST.Module.Name as ModuleName

@@ -35,7 +34,7 @@ optimizeDef :: Bool -> Can.Def -> Env.Optimizer [Opt.Def]

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

34optimizeDef isRoot (Can.Def _ pattern expression _) =

36 let

35 let

37 (args, canBody) =

36 (args, canBody) =

38− Expr.collectLambdas expression

37+ Can.collectLambdas expression

39

38

40 maybeGetHome =

39 maybeGetHome =

41 if isRoot then

40 if isRoot then

@@ -161,7 +160,7 @@ patternToSubstitutions expr (A.A _ pattern) =

161 (alias, expr) : patternToSubstitutions expr realPattern

160 (alias, expr) : patternToSubstitutions expr realPattern

162

161

163 P.Data _ patterns ->

162 P.Data _ patterns ->

164− concat (zipWith (patternToSubstitutions . Opt.DataAccess expr) [0..] patterns)

163+ concat (zipWith (patternToSubstitutions . Opt.CtorAccess expr) [0..] patterns)

165

164

166

165

167

166

@@ -190,10 +189,10 @@ optimizeExpr context annExpr@(A.A region expression) =

190 -- expressions that cannot be turned into tail calls

189 -- expressions that cannot be turned into tail calls

191 in

190 in

192 case expression of

191 case expression of

193− Expr.Literal lit ->

192+ Can.Literal lit ->

194 pure (Opt.Literal lit)

193 pure (Opt.Literal lit)

195

194

196− Expr.Var name ->

195+ Can.Var name ->

197 if name == Var.inCore ["Debug"] "crash" then

196 if name == Var.inCore ["Debug"] "crash" then

198 do home <- Env.getHome

197 do home <- Env.getHome

199 pure (Opt.Crash home region Nothing)

198 pure (Opt.Crash home region Nothing)

@@ -201,24 +200,24 @@ optimizeExpr context annExpr@(A.A region expression) =

201 else

200 else

202 pure (Opt.Var name)

201 pure (Opt.Var name)

203

202

204− Expr.ExplicitList elements ->

203+ Can.List elements ->

205− Opt.ExplicitList

204+ Opt.List

206 <$> T.traverse justConvert elements

205 <$> T.traverse justConvert elements

207

206

208− Expr.Binop op leftExpr rightExpr ->

207+ Can.Binop op leftExpr rightExpr ->

209 optimizeBinop context region op leftExpr rightExpr

208 optimizeBinop context region op leftExpr rightExpr

210

209

211− Expr.Lambda _ _ ->

210+ Can.Lambda _ _ ->

212 let

211 let

213 (patterns, body) =

212 (patterns, body) =

214− Expr.collectLambdas annExpr

213+ Can.collectLambdas annExpr

215 in

214 in

216 uncurry Opt.Function <$> optimizeFunction Nothing patterns body

215 uncurry Opt.Function <$> optimizeFunction Nothing patterns body

217

216

218− Expr.App _ _ ->

217+ Can.App _ _ ->

219 let

218 let

220 (func:args) =

219 (func:args) =

221− Expr.collectApps annExpr

220+ Can.collectApps annExpr

222 in

221 in

223 case isTailCall context func (length args) of

222 case isTailCall context func (length args) of

224 Just (name, argNames) ->

223 Just (name, argNames) ->

@@ -233,7 +232,7 @@ optimizeExpr context annExpr@(A.A region expression) =

233 Env.setTailCall hasTailCall

232 Env.setTailCall hasTailCall

234 return (Opt.Call optFunc optArgs)

233 return (Opt.Call optFunc optArgs)

235

234

236− Expr.If branches finally ->

235+ Can.If branches finally ->

237 let

236 let

238 crawlBranch (cond,branch) =

237 crawlBranch (cond,branch) =

239 (,) <$> justConvert cond <*> keepLooking branch

238 (,) <$> justConvert cond <*> keepLooking branch

@@ -242,11 +241,11 @@ optimizeExpr context annExpr@(A.A region expression) =

242 <$> T.traverse crawlBranch branches

241 <$> T.traverse crawlBranch branches

243 <*> keepLooking finally

242 <*> keepLooking finally

244

243

245− Expr.Let defs body ->

244+ Can.Let defs body ->

246 do optDefs <- concat <$> T.traverse (optimizeDef False) defs

245 do optDefs <- concat <$> T.traverse (optimizeDef False) defs

247 Opt.Let optDefs <$> keepLooking body

246 Opt.Let optDefs <$> keepLooking body

248

247

249− Expr.Case expr branches ->

248+ Can.Case expr branches ->

250 do optExpr <- optimizeExpr Nothing expr

249 do optExpr <- optimizeExpr Nothing expr

251 variantDict <- Env.getVariantDict

250 variantDict <- Env.getVariantDict

252

251

@@ -255,42 +254,42 @@ optimizeExpr context annExpr@(A.A region expression) =

255 let optCase = Case.optimize variantDict name optBranches

254 let optCase = Case.optimize variantDict name optBranches

256 return $ Opt.Let [ Opt.Def Opt.dummyFacts name optExpr ] optCase

255 return $ Opt.Let [ Opt.Def Opt.dummyFacts name optExpr ] optCase

257

256

258− Expr.Data name exprs ->

257+ Can.Ctor name exprs ->

259− Opt.Data name <$> T.traverse justConvert exprs

258+ Opt.Ctor name <$> T.traverse justConvert exprs

260

259

261− Expr.Access record field ->

260+ Can.Access record field ->

262 Opt.Access

261 Opt.Access

263 <$> justConvert record

262 <$> justConvert record

264 <*> pure field

263 <*> pure field

265

264

266− Expr.Update record fields ->

265+ Can.Update record fields ->

267 Opt.Update

266 Opt.Update

268 <$> justConvert record

267 <$> justConvert record

269 <*> T.traverse (mapSnd justConvert) fields

268 <*> T.traverse (mapSnd justConvert) fields

270

269

271− Expr.Record fields ->

270+ Can.Record fields ->

272 Opt.Record

271 Opt.Record

273 <$> T.traverse (mapSnd justConvert) fields

272 <$> T.traverse (mapSnd justConvert) fields

274

273

275− Expr.Cmd moduleName ->

274+ Can.Cmd moduleName ->

276 pure (Opt.Cmd moduleName)

275 pure (Opt.Cmd moduleName)

277

276

278− Expr.Sub moduleName ->

277+ Can.Sub moduleName ->

279 pure (Opt.Sub moduleName)

278 pure (Opt.Sub moduleName)

280

279

281− Expr.OutgoingPort name tipe ->

280+ Can.OutgoingPort name tipe ->

282 pure (Opt.OutgoingPort name tipe)

281 pure (Opt.OutgoingPort name tipe)

283

282

284− Expr.IncomingPort name tipe ->

283+ Can.IncomingPort name tipe ->

285 pure (Opt.IncomingPort name tipe)

284 pure (Opt.IncomingPort name tipe)

286

285

287− Expr.Program kind expr ->

286+ Can.Program kind expr ->

288 Opt.Program kind <$> justConvert expr

287 Opt.Program kind <$> justConvert expr

289

288

290− Expr.SaveEnv _ _ ->

289+ Can.SaveEnv _ _ ->

291 error "save_the_environment should never make it to optimization phase"

290 error "save_the_environment should never make it to optimization phase"

292

291

293− Expr.GLShader uid src gltipe ->

292+ Can.GLShader uid src gltipe ->

294 pure (Opt.GLShader uid src gltipe)

293 pure (Opt.GLShader uid src gltipe)

295

294

296

295

@@ -348,7 +347,7 @@ tagCrashBranch region pattern@(A.A pr _) expr =

348isTailCall :: Context -> Can.Expr -> Int -> Maybe (String, [String])

347isTailCall :: Context -> Can.Expr -> Int -> Maybe (String, [String])

349isTailCall context (A.A _ function) arity =

348isTailCall context (A.A _ function) arity =

350 case (context, function) of

349 case (context, function) of

351− ( Just (ctxName, ctxArity, argNames), Expr.Var (Var.Canonical home name) ) ->

350+ ( Just (ctxName, ctxArity, argNames), Can.Var (Var.Canonical home name) ) ->

352

351

353 if name == ctxName && arity == ctxArity && Var.isLocalHome home then

352 if name == ctxName && arity == ctxArity && Var.isLocalHome home then

354 Just (name, argNames)

353 Just (name, argNames)

@@ -374,10 +373,10 @@ depattern canPattern@(A.A _ pattern) expr =

374 A.A (error "the annotation added in 'depattern' should not be observed!")

373 A.A (error "the annotation added in 'depattern' should not be observed!")

375

374

376 caseExpr e branches =

375 caseExpr e branches =

377− ann (Expr.Case e branches)

376+ ann (Can.Case e branches)

378

377

379 var name =

378 var name =

380− ann (Expr.Var (Var.local name))

379+ ann (Can.Var (Var.local name))

381

380

382 caseify =

381 caseify =

383 do name <- Env.freshName

382 do name <- Env.freshName

@@ -421,7 +420,7 @@ optimizeBinop

421optimizeBinop context region op leftExpr rightExpr =

420optimizeBinop context region op leftExpr rightExpr =

422 let

421 let

423 ann = A.A region

422 ann = A.A region

424− binop = ann (Expr.Binop op leftExpr rightExpr)

423+ binop = ann (Can.Binop op leftExpr rightExpr)

425 in

424 in

426 if op == forwardApply then

425 if op == forwardApply then

427

426

@@ -434,20 +433,20 @@ optimizeBinop context region op leftExpr rightExpr =

434 else if op == forwardCompose then

433 else if op == forwardCompose then

435

434

436 do var <- Env.freshName

435 do var <- Env.freshName

437− let makeRoot func = ann (Expr.App func (ann (Expr.Var (Var.local var))))

436+ let makeRoot func = ann (Can.App func (ann (Can.Var (Var.local var))))

438 let body = collect makeRoot left forwardCompose binop

437 let body = collect makeRoot left forwardCompose binop

439− optimizeExpr context (ann (Expr.Lambda (ann (P.Var var)) body))

438+ optimizeExpr context (ann (Can.Lambda (ann (P.Var var)) body))

440

439

441 else if op == backwardCompose then

440 else if op == backwardCompose then

442

441

443 do var <- Env.freshName

442 do var <- Env.freshName

444− let makeRoot func = ann (Expr.App func (ann (Expr.Var (Var.local var))))

443+ let makeRoot func = ann (Can.App func (ann (Can.Var (Var.local var))))

445 let body = collect makeRoot right backwardCompose binop

444 let body = collect makeRoot right backwardCompose binop

446− optimizeExpr context (ann (Expr.Lambda (ann (P.Var var)) body))

445+ optimizeExpr context (ann (Can.Lambda (ann (P.Var var)) body))

447

446

448 else if op == Var.Canonical Var.BuiltIn "::" then

447 else if op == Var.Canonical Var.BuiltIn "::" then

449

448

450− optimizeExpr context (ann (Expr.Data "::" [ leftExpr, rightExpr ]))

449+ optimizeExpr context (ann (Can.Ctor "::" [ leftExpr, rightExpr ]))

451

450

452 else

451 else

453

452

@@ -497,11 +496,11 @@ right =

497collect :: (Can.Expr -> Can.Expr) -> Assoc -> Var.Canonical -> Can.Expr -> Can.Expr

496collect :: (Can.Expr -> Can.Expr) -> Assoc -> Var.Canonical -> Can.Expr -> Can.Expr

498collect makeRoot assoc desiredOp annExpr@(A.A ann expr) =

497collect makeRoot assoc desiredOp annExpr@(A.A ann expr) =

499 case expr of

498 case expr of

500− Expr.Binop op leftExpr rightExpr | op == desiredOp ->

499+ Can.Binop op leftExpr rightExpr | op == desiredOp ->

501 let

500 let

502 (func, arg) = assoc leftExpr rightExpr

501 (func, arg) = assoc leftExpr rightExpr

503 in

502 in

504− A.A ann (Expr.App func (collect makeRoot assoc desiredOp arg))

503+ A.A ann (Can.App func (collect makeRoot assoc desiredOp arg))

505

504

506 _ ->

505 _ ->

507 makeRoot annExpr

506 makeRoot annExpr

src/Optimize/Inline.hs+9−9

@@ -100,7 +100,7 @@ count expression =

100 Var.TopLevel _ ->

101 Map.empty

102

103− ExplicitList exprs ->

103+ List exprs ->

104 countMany exprs

105

106 Binop _op left right ->

@@ -151,10 +151,10 @@ count expression =

151 in

152 Map.unionsWith (+) (countDecider decider : map (count . snd) jumps)

153

154− Data _tag values ->

154+ Ctor _tag values ->

155 countMany values

156

157− DataAccess root _index ->

157+ CtorAccess root _index ->

158 count root

159

160 Access record _field ->

@@ -207,8 +207,8 @@ replace substitutions expression =

207 Var _ ->

208 expression

209

210− ExplicitList exprs ->

210+ List exprs ->

211− ExplicitList (map go exprs)

211+ List (map go exprs)

212

213 Binop op left right ->

214 Binop op (go left) (go right)

@@ -262,11 +262,11 @@ replace substitutions expression =

262 in

263 Case exprName (goDecider decider) (map (second go) jumps)

264

265− Data tag values ->

265+ Ctor tag values ->

266− Data tag (map go values)

266+ Ctor tag (map go values)

267

268− DataAccess root index ->

268+ CtorAccess root index ->

269− DataAccess (go root) index

269+ CtorAccess (go root) index

270

271 Access record field ->

272 Access (go record) field

src/Parse/Binop.hs+47−137

@@ -1,22 +1,54 @@

1−module Parse.Binop (infixOp, binops, OpTable) where

1+module Parse.Binop (binops, infixOp) where

2

3−import qualified Data.List as List

4−import qualified Data.Map as Map

5import Text.Parsec

3import Text.Parsec

6− ( (<|>), choice, getState, lookAhead, lower, many1

4+ ( (<|>), choice, lookAhead, lower, many1

7 , notFollowedBy, satisfy, string, try

5 , notFollowedBy, satisfy, string, try

8 )

6 )

9

7

10−import AST.Declaration (Assoc(L, N, R))

11−import AST.Expression.General (Expr'(Binop))

12−import qualified AST.Expression.Source as Source

8+import qualified AST.Expression.Source as Src

13import qualified AST.Helpers as Help

9import qualified AST.Helpers as Help

14−import qualified AST.Variable as Var

15−import Parse.Helpers (IParser, OpTable, commitIf, expecting, failure, whitespace)

10+import Parse.Helpers (IParser, addLocation, commitIf, expecting, failure, whitespace)

16import qualified Reporting.Annotation as A

11import qualified Reporting.Annotation as A

17

12

18

13

19

14

15+-- BINARY EXPRESSIONS

16+

17+

18+binops :: IParser Src.RawExpr -> IParser Src.RawExpr -> IParser Src.RawExpr

19+binops parseTerm parseLastTerm =

20+ addLocation $

21+ do expr <- parseTerm

22+ (ops, last) <- binopsHelp parseTerm parseLastTerm expr

23+ case ops of

24+ [] ->

25+ return (A.drop last)

26+

27+ _ ->

28+ return (Src.Binop ops last)

29+

30+

31+binopsHelp

32+ :: IParser Src.RawExpr

33+ -> IParser Src.RawExpr

34+ -> Src.RawExpr

35+ -> IParser ([(Src.RawExpr, A.Located String)], Src.RawExpr)

36+binopsHelp parseTerm parseLastTerm expr =

37+ choice

38+ [ commitIf (whitespace >> infixOpWith (fail "")) $

39+ do whitespace

40+ op <- addLocation infixOp

41+ whitespace

42+ choice

43+ [ do (ops, last) <- binopsHelp parseTerm parseLastTerm =<< try parseTerm

44+ return ( (expr, op) : ops, last )

45+ , (,) [(expr, op)] <$> parseLastTerm

46+ ]

47+ , return ( [], expr )

48+ ]

49+

50+

51+

20-- INFIX OPERATORS

52-- INFIX OPERATORS

21

53

22

54

@@ -34,14 +66,6 @@ infixOpWith checker =

34 _ -> return op

66 _ -> return op

35

67

36

68

37−failOn :: String -> String -> IParser a

38−failOn op msg =

39− do try $ lookAhead $ do

40− string op

41− notFollowedBy (satisfy Help.isSymbol)

42− failure msg

43−

44−

45notReserved :: IParser a

69notReserved :: IParser a

46notReserved =

70notReserved =

47 choice

71 choice

@@ -52,123 +76,9 @@ notReserved =

52 ]

76 ]

53

77

54

78

55−

79+failOn :: String -> String -> IParser a

56−-- BINARY EXPRESSIONS

80+failOn op msg =

57−

81+ do try $ lookAhead $ do

58−

82+ string op

59−opLevel :: OpTable -> String -> Int

83+ notFollowedBy (satisfy Help.isSymbol)

60−opLevel table op =

84+ failure msg

61− fst $ Map.findWithDefault (9,L) op table

62−

63−

64−opAssoc :: OpTable -> String -> Assoc

65−opAssoc table op =

66− snd $ Map.findWithDefault (9,L) op table

67−

68−

69−hasLevel :: OpTable -> Int -> (String, Source.Expr) -> Bool

70−hasLevel table n (op,_) =

71− opLevel table op == n

72−

73−

74−binops

75− :: IParser Source.Expr

76− -> IParser Source.Expr

77− -> IParser Source.Expr

78−binops term last =

79− do e <- term

80− table <- getState

81− split table 0 e =<< nextOps

82− where

83− nextOps =

84− choice

85− [ commitIf (whitespace >> infixOpWith (fail "")) $

86− do whitespace

87− op <- infixOp

88− whitespace

89− expr <- Left <$> try term <|> Right <$> last

90− case expr of

91− Left t -> (:) (op,t) <$> nextOps

92− Right e -> return [(op,e)]

93− , return []

94− ]

95−

96−

97−split

98− :: OpTable

99− -> Int

100− -> Source.Expr

101− -> [(String, Source.Expr)]

102− -> IParser Source.Expr

103−split _ _ e [] = return e

104−split table n e eops =

105− do assoc <- getAssoc table n eops

106− es <- sequence (splitLevel table n e eops)

107− let ops = map fst (filter (hasLevel table n) eops)

108− case assoc of

109− R -> joinR es ops

110− _ -> joinL es ops

111−

112−

113−splitLevel

114− :: OpTable

115− -> Int

116− -> Source.Expr

117− -> [(String, Source.Expr)]

118− -> [IParser Source.Expr]

119−splitLevel table n e eops =

120− case break (hasLevel table n) eops of

121− (lops, (_op,e'):rops) ->

122− split table (n+1) e lops : splitLevel table n e' rops

123−

124− (lops, []) ->

125− [ split table (n+1) e lops ]

126−

127−

128−joinL :: [Source.Expr] -> [String] -> IParser Source.Expr

129−joinL exprs ops =

130− case (exprs, ops) of

131− ([expr], []) ->

132− return expr

133−

134− (a:b:remainingExprs, op:remainingOps) ->

135− let binop = A.merge a b (Binop (Var.Raw op) a b)

136− in

137− joinL (binop : remainingExprs) remainingOps

138−

139− (_, _) ->

140− failure "Ill-formed binary expression. Report a compiler bug."

141−

142−

143−joinR :: [Source.Expr] -> [String] -> IParser Source.Expr

144−joinR exprs ops =

145− case (exprs, ops) of

146− ([expr], []) ->

147− return expr

148−

149− (a:b:remainingExprs, op:remainingOps) ->

150− do e <- joinR (b:remainingExprs) remainingOps

151− return (A.merge a e (Binop (Var.Raw op) a e))

152−

153− (_, _) ->

154− failure "Ill-formed binary expression. Report a compiler bug."

155−

156−

157−getAssoc :: OpTable -> Int -> [(String,Source.Expr)] -> IParser Assoc

158−getAssoc table n eops

159− | all (==L) assocs = return L

160− | all (==R) assocs = return R

161− | all (==N) assocs =

162− case assocs of

163− [_] -> return N

164− _ -> failure (msg "precedence")

165− | otherwise = failure (msg "associativity")

166− where

167− levelOps = filter (hasLevel table n) eops

168− assocs = map (opAssoc table . fst) levelOps

169− msg problem =

170− concat

171− [ "Conflicting " ++ problem ++ " for binary operators ("

172− , List.intercalate ", " (map fst eops), "). "

173− , "Consider adding parentheses to disambiguate."

174− ]

src/Parse/Expression.hs+58−65

@@ -2,7 +2,6 @@ module Parse.Expression (term, expr, def) where

2

3import qualified Data.List as List

4import Text.Parsec hiding (newline, spaces)

5−import qualified Text.Parsec.Indent as Indent

6

5

7import qualified Parse.Binop as Binop

6import qualified Parse.Binop as Binop

8import Parse.Helpers

7import Parse.Helpers

@@ -11,11 +10,9 @@ import qualified Parse.Literal as Literal

11import qualified Parse.Pattern as Pattern

10import qualified Parse.Pattern as Pattern

12import qualified Parse.Type as Type

11import qualified Parse.Type as Type

13

12

14−import qualified AST.Expression.General as E

13+import qualified AST.Expression.Source as Src

15−import qualified AST.Expression.Source as Source

16import qualified AST.Literal as L

14import qualified AST.Literal as L

17import qualified AST.Pattern as P

15import qualified AST.Pattern as P

18−import qualified AST.Variable as Var

19import qualified Reporting.Annotation as A

16import qualified Reporting.Annotation as A

20

17

21

18

@@ -23,25 +20,25 @@ import qualified Reporting.Annotation as A

23-------- Basic Terms --------

20-------- Basic Terms --------

24

21

25

22

26−varTerm :: IParser Source.Expr'

23+varTerm :: IParser Src.RawExpr'

27varTerm =

24varTerm =

28 toVar <$> Help.var

25 toVar <$> Help.var

29

26

30

27

31−toVar :: String -> Source.Expr'

28+toVar :: String -> Src.RawExpr'

32toVar v =

29toVar v =

33 case v of

30 case v of

34 "True" ->

31 "True" ->

35− E.Literal (L.Boolean True)

32+ Src.Literal (L.Boolean True)

36

33

37 "False" ->

34 "False" ->

38− E.Literal (L.Boolean False)

35+ Src.Literal (L.Boolean False)

39

36

40 _ ->

37 _ ->

41− E.rawVar v

38+ Src.var v

42

39

43

40

44−accessor :: IParser Source.Expr'

41+accessor :: IParser Src.RawExpr'

45accessor =

42accessor =

46 do (start, lbl, end) <- located (try (string "." >> rLabel))

43 do (start, lbl, end) <- located (try (string "." >> rLabel))

47

44

@@ -49,60 +46,56 @@ accessor =

49 A.at start end value

46 A.at start end value

50

47

51 return $

48 return $

52− E.Lambda

49+ Src.Lambda

53 (ann (P.Var "_"))

50 (ann (P.Var "_"))

54− (ann (E.Access (ann (E.rawVar "_")) lbl))

51+ (ann (Src.Access (ann (Src.var "_")) lbl))

55

52

56

53

57−negative :: IParser Source.Expr'

54+negative :: IParser Src.RawExpr'

58negative =

55negative =

59− do (start, nTerm, end) <-

60− located $ try $

56+ try $

61− do char '-'

57+ do (A.A region _) <- addLocation (char '-')

62− notFollowedBy (char '.' <|> char '-')

58+ notFollowedBy (char '.' <|> char '-')

63− term

59+ negativeTerm <- term

64

60

65− let ann e =

61+ let zero = A.A region (Src.Literal (L.IntNum 0))

66− A.at start end e

62+ let minus = A.A region "-"

63+

64+ return $ Src.Binop [(zero, minus)] negativeTerm

67

65

68− return $

69− E.Binop

70− (Var.Raw "-")

71− (ann (E.Literal (L.IntNum 0)))

72− nTerm

73

66

74

67

75

68

76-------- Complex Terms --------

69-------- Complex Terms --------

77

70

78

71

79−listTerm :: IParser Source.Expr'

72+listTerm :: IParser Src.RawExpr'

80listTerm =

73listTerm =

81 choice

74 choice

82 [ do pos <- getPosition

75 [ do pos <- getPosition

83 let uid = show (sourceLine pos) ++ ":" ++ show (sourceColumn pos)

76 let uid = show (sourceLine pos) ++ ":" ++ show (sourceColumn pos)

84 (rawSrc, tipe) <- Literal.shader

77 (rawSrc, tipe) <- Literal.shader

85− return $ E.GLShader uid (filter (/='\r') rawSrc) tipe

78+ return $ Src.GLShader uid (filter (/='\r') rawSrc) tipe

86− , braces (E.ExplicitList <$> commaSep expr)

79+ , braces (Src.List <$> commaSep expr)

87 ]

80 ]

88

81

89

82

90−parensTerm :: IParser Source.Expr

83+parensTerm :: IParser Src.RawExpr

91parensTerm =

84parensTerm =

92 let

85 let

93 mkFunc args realBody start end =

86 mkFunc args realBody start end =

94 foldr

87 foldr

95− (\arg body -> A.at start end (E.Lambda (A.at start end (P.Var arg)) body))

88+ (\arg body -> A.at start end (Src.Lambda (A.at start end (P.Var arg)) body))

96− (A.at start end (realBody (A.at start end . E.rawVar)))

89+ (A.at start end (realBody (A.at start end . Src.var)))

97 args

90 args

98

91

99 mkBinop op =

92 mkBinop op =

100− mkFunc ["x","y"] (\var -> E.Binop (Var.Raw op) (var "x") (var "y"))

93+ mkFunc ["x","y"] $ \var -> Src.Binop [(var "x", op)] (var "y")

101

94

102 tupleFn =

95 tupleFn =

103 do commas <- many1 comma

96 do commas <- many1 comma

104 let args = map (('v':) . show) [ 0 .. length commas ]

97 let args = map (('v':) . show) [ 0 .. length commas ]

105− return $ mkFunc args (\var -> E.tuple (map var args))

98+ return $ mkFunc args (\var -> Src.tuple (map var args))

106

99

107 parenedExpr =

100 parenedExpr =

108 do expressions <- padded (commaSep expr)

101 do expressions <- padded (commaSep expr)

@@ -111,17 +104,17 @@ parensTerm =

111 [expression] ->

104 [expression] ->

112 expression

105 expression

113 _ ->

106 _ ->

114− A.at start end (E.tuple expressions)

107+ A.at start end (Src.tuple expressions)

115 in

108 in

116 do (start, mkExpr, end) <-

109 do (start, mkExpr, end) <-

117 located $ choice $

110 located $ choice $

118− [ mkBinop <$> try (parens Binop.infixOp)

111+ [ mkBinop <$> try (parens (addLocation Binop.infixOp))

119 , parens (tupleFn <|> parenedExpr)

112 , parens (tupleFn <|> parenedExpr)

120 ]

113 ]

121 return (mkExpr start end)

114 return (mkExpr start end)

122

115

123

116

124−recordTerm :: IParser Source.Expr

117+recordTerm :: IParser Src.RawExpr

125recordTerm =

118recordTerm =

126 addLocation $ brackets $ choice $

119 addLocation $ brackets $ choice $

127 [ do starter <- try (addLocation rLabel)

120 [ do starter <- try (addLocation rLabel)

@@ -130,14 +123,14 @@ recordTerm =

130 [ update starter

123 [ update starter

131 , literal starter

124 , literal starter

132 ]

125 ]

133− , return (E.Record [])

126+ , return (Src.Record [])

134 ]

127 ]

135 where

128 where

136 update (A.A ann starter) =

129 update (A.A ann starter) =

137 do try (string "|")

130 do try (string "|")

138 whitespace

131 whitespace

139 fields <- commaSep1 field

132 fields <- commaSep1 field

140− return (E.Update (A.A ann (E.rawVar starter)) fields)

133+ return (Src.Update (A.A ann (Src.var starter)) fields)

141

134

142 literal (A.A _ starter) =

135 literal (A.A _ starter) =

143 do try equals

136 do try equals

@@ -148,8 +141,8 @@ recordTerm =

148 [ do try comma

141 [ do try comma

149 whitespace

142 whitespace

150 fields <- commaSep field

143 fields <- commaSep field

151− return (E.Record ((starter, value) : fields))

144+ return (Src.Record ((starter, value) : fields))

152− , return (E.Record [(starter, value)])

145+ , return (Src.Record [(starter, value)])

153 ]

146 ]

154

147

155 field =

148 field =

@@ -159,11 +152,11 @@ recordTerm =

159 return (key, value)

152 return (key, value)

160

153

161

154

162−term :: IParser Source.Expr

155+term :: IParser Src.RawExpr

163term =

156term =

164 choice

157 choice

165 [ addLocation $ choice $

158 [ addLocation $ choice $

166− [ E.Literal <$> Literal.literal

159+ [ Src.Literal <$> Literal.literal

167 , listTerm

160 , listTerm

168 , accessor

161 , accessor

169 , negative

162 , negative

@@ -181,7 +174,7 @@ term =

181-------- Applications --------

174-------- Applications --------

182

175

183

176

184−appExpr :: IParser Source.Expr

177+appExpr :: IParser Src.RawExpr

185appExpr =

178appExpr =

186 expecting "an expression" $

179 expecting "an expression" $

187 do t <- term

180 do t <- term

@@ -190,14 +183,14 @@ appExpr =

190 return $

183 return $

191 case ts of

184 case ts of

192 [] -> t

185 [] -> t

193− _ -> List.foldl' (\f x -> A.merge f x $ E.App f x) t ts

186+ _ -> List.foldl' (\f x -> A.merge f x $ Src.App f x) t ts

194

187

195

188

196

189

197-------- Normal Expressions --------

190-------- Normal Expressions --------

198

191

199

192

200−expr :: IParser Source.Expr

193+expr :: IParser Src.RawExpr

201expr =

194expr =

202 addLocation (choice [ letExpr, caseExpr, ifExpr ])

195 addLocation (choice [ letExpr, caseExpr, ifExpr ])

203 <|> lambdaExpr

196 <|> lambdaExpr

@@ -205,7 +198,7 @@ expr =

205 <?> "an expression"

198 <?> "an expression"

206

199

207

200

208−binaryExpr :: IParser Source.Expr

201+binaryExpr :: IParser Src.RawExpr

209binaryExpr =

202binaryExpr =

210 Binop.binops appExpr lastExpr

203 Binop.binops appExpr lastExpr

211 where

204 where

@@ -215,12 +208,12 @@ binaryExpr =

215 <?> "an expression"

208 <?> "an expression"

216

209

217

210

218−ifExpr :: IParser Source.Expr'

211+ifExpr :: IParser Src.RawExpr'

219ifExpr =

212ifExpr =

220 ifHelp []

213 ifHelp []

221

214

222

215

223−ifHelp :: [(Source.Expr, Source.Expr)] -> IParser Source.Expr'

216+ifHelp :: [(Src.RawExpr, Src.RawExpr)] -> IParser Src.RawExpr'

224ifHelp branches =

217ifHelp branches =

225 do try (reserved "if")

218 do try (reserved "if")

226 whitespace

219 whitespace

@@ -233,11 +226,11 @@ ifHelp branches =

233 let newBranches = (condition, thenBranch) : branches

226 let newBranches = (condition, thenBranch) : branches

234 choice

227 choice

235 [ ifHelp newBranches

228 [ ifHelp newBranches

236− , E.If (reverse newBranches) <$> expr

229+ , Src.If (reverse newBranches) <$> expr

237 ]

230 ]

238

231

239

232

240−lambdaExpr :: IParser Source.Expr

233+lambdaExpr :: IParser Src.RawExpr

241lambdaExpr =

234lambdaExpr =

242 do start <- getMyPosition

235 do start <- getMyPosition

243 char '\\' <|> char '\x03BB' <?> "an anonymous function"

236 char '\\' <|> char '\x03BB' <?> "an anonymous function"

@@ -246,22 +239,22 @@ lambdaExpr =

246 padded rightArrow

239 padded rightArrow

247 body <- expr

240 body <- expr

248 end <- getMyPosition

241 end <- getMyPosition

249− return (foldr (\a b -> A.at start end $ E.Lambda a b) body args)

242+ return (foldr (\a b -> A.at start end $ Src.Lambda a b) body args)

250

243

251

244

252−caseExpr :: IParser Source.Expr'

245+caseExpr :: IParser Src.RawExpr'

253caseExpr =

246caseExpr =

254 do try (reserved "case")

247 do try (reserved "case")

255 exp <- padded expr

248 exp <- padded expr

256 reserved "of"

249 reserved "of"

257 whitespace

250 whitespace

258− Indent.withPos $

251+ Help.withPos $

259 do firstBranch <- branch

252 do firstBranch <- branch

260 branches <-

253 branches <-

261 many $ do

254 many $ do

262− try (whitespace >> Indent.checkIndent)

255+ try (whitespace >> Help.checkIndent)

263 branch

256 branch

264− return $ E.Case exp (firstBranch : branches)

257+ return $ Src.Case exp (firstBranch : branches)

265 where

258 where

266 branch =

259 branch =

267 do p <- Pattern.expr

260 do p <- Pattern.expr

@@ -273,20 +266,20 @@ caseExpr =

273-- LET

266-- LET

274

267

275

268

276−letExpr :: IParser Source.Expr'

269+letExpr :: IParser Src.RawExpr'

277letExpr =

270letExpr =

278 do try (reserved "let")

271 do try (reserved "let")

279 whitespace

272 whitespace

280− defs <- Indent.block (def <* whitespace)

273+ defs <- Help.block (def <* whitespace)

281 whitespace

274 whitespace

282 reserved "in"

275 reserved "in"

283 whitespace

276 whitespace

284− E.Let defs <$> expr

277+ Src.Let defs <$> expr

285

278

286

279

287−def :: IParser Source.Def

280+def :: IParser Src.RawDef

288def =

281def =

289− addLocation $ Indent.withPos $

282+ addLocation $ Help.withPos $

290 do start <- defStart

283 do start <- defStart

291 whitespace

284 whitespace

292 case start of

285 case start of

@@ -295,7 +288,7 @@ def =

295 [ do hasType

288 [ do hasType

296 whitespace

289 whitespace

297 tipe <- Type.expr

290 tipe <- Type.expr

298− return $ Source.Annotation name tipe

291+ return $ Src.Annotation name tipe

299 , defEnd start []

292 , defEnd start []

300 ]

293 ]

301

294

@@ -311,7 +304,7 @@ defStart =

311 ]

304 ]

312

305

313

306

314−defEnd :: P.Raw -> [P.Raw] -> IParser Source.Def'

307+defEnd :: P.Raw -> [P.Raw] -> IParser Src.RawDef'

315defEnd start revArgs =

308defEnd start revArgs =

316 choice

309 choice

317 [ do arg <- Pattern.term

310 [ do arg <- Pattern.term

@@ -320,10 +313,10 @@ defEnd start revArgs =

320 , do equals

313 , do equals

321 whitespace

314 whitespace

322 body <- expr

315 body <- expr

323− return $ Source.Definition start (makeFunction revArgs body)

316+ return $ Src.Definition start (makeFunction revArgs body)

324 ]

317 ]

325

318

326

319

327−makeFunction :: [P.Raw] -> Source.Expr -> Source.Expr

320+makeFunction :: [P.Raw] -> Src.RawExpr -> Src.RawExpr

328makeFunction revArgs body@(A.A ann _) =

321makeFunction revArgs body@(A.A ann _) =

329− List.foldl' (\expr arg -> A.A ann $ E.Lambda arg expr) body revArgs

322+ List.foldl' (\expr arg -> A.A ann $ Src.Lambda arg expr) body revArgs

src/Parse/Helpers.hs+32−71

@@ -1,12 +1,10 @@

1{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}

2module Parse.Helpers

3− ( expecting, failure, anyUntil

3+ ( module Parse.Primitives

4− , OpTable

5− , IParser, SourceM, iParse

6 , var, lowVar, capVar, rLabel, reserved, reserveds

4 , var, lowVar, capVar, rLabel, reserved, reserveds

7 , equals, rightArrow, hasType

5 , equals, rightArrow, hasType

8− , commitIf

6+ , commitIf, followedBy, anyUntil

9− , followedBy, comma, commaSep1, commaSep

7+ , comma, commaSep1, commaSep

10 , pipeSep1, consSep1, dotSep1, spaceSep1, spacePrefix, constrainedSpacePrefix

8 , pipeSep1, consSep1, dotSep1, spaceSep1, spacePrefix, constrainedSpacePrefix

11 , braces, parens, brackets

9 , braces, parens, brackets

12 , accessible

10 , accessible

@@ -16,74 +14,24 @@ module Parse.Helpers

16 )

14 )

17 where

15 where

18

16

19−import Control.Monad.State (State)

20import Data.Char (isUpper)

17import Data.Char (isUpper)

21−import qualified Data.Map as Map

22−import Text.Parsec hiding (State, newline, space, spaces)

18+import Text.Parsec hiding (newline, space, spaces)

23−import Text.Parsec.Indent (indented, runIndent)

24

19

25−import qualified AST.Declaration as Decl

20+import qualified AST.Expression.Source as Src

26−import qualified AST.Expression.General as E

27−import qualified AST.Expression.Source as Source

28import qualified AST.Variable as Variable

21import qualified AST.Variable as Variable

22+import Parse.Primitives

29import qualified Reporting.Annotation as A

23import qualified Reporting.Annotation as A

30import qualified Reporting.Error.Syntax as Syntax

24import qualified Reporting.Error.Syntax as Syntax

31import qualified Reporting.Region as R

25import qualified Reporting.Region as R

32

26

33

27

34

28

35−-- ERROR HELP

36−

37−

38−expecting :: String -> IParser a -> IParser a

39−expecting =

40− flip (<?>)

41−

42−

43−failure :: String -> IParser a

44−failure msg = do

45− inp <- getInput

46− setInput ('x':inp)

47− anyToken

48− fail msg

49−

50−

51−anyUntil :: IParser String -> IParser String

52−anyUntil end =

53− go

54− where

55− go =

56− end <|> (:) <$> anyChar <*> go

57−

58−

59−

60−-- SETUP

61−

62−

63−type IParser a = ParsecT String OpTable SourceM a

64−

65−type OpTable = Map.Map String (Int, Decl.Assoc)

66−

67−type SourceM = State SourcePos

68−

69−

70−iParse :: IParser a -> String -> Either ParseError a

71−iParse parser source =

72− iParseWithTable "" Map.empty parser source

73−

74−

75−iParseWithTable :: SourceName -> OpTable -> IParser a -> String -> Either ParseError a

76−iParseWithTable sourceName table aParser input =

77− runIndent sourceName $ runParserT aParser table sourceName input

78−

79−

80−

81-- VARIABLES

29-- VARIABLES

82

30

83

31

84var :: IParser String

32var :: IParser String

85var =

33var =

86− makeVar (letter <|> char '_') <?> "a name"

34+ makeVar letter <?> "a name"

87

35

88

36

89lowVar :: IParser String

37lowVar :: IParser String

@@ -164,7 +112,7 @@ hasType =

164

112

165

113

166

114

167−-- SEPARATORS

115+-- WEIRD COMBINATORS

168

116

169

117

170commitIf :: IParser a -> IParser b -> IParser b

118commitIf :: IParser a -> IParser b -> IParser b

@@ -175,6 +123,26 @@ commitIf check p =

175 try (lookAhead check) >> p

123 try (lookAhead check) >> p

176

124

177

125

126+anyUntil :: IParser String -> IParser String

127+anyUntil end =

128+ go

129+ where

130+ go =

131+ end <|> (:) <$> anyChar <*> go

132+

133+

134+

135+followedBy :: IParser a -> IParser b -> IParser a

136+followedBy a b =

137+ do x <- a

138+ b

139+ return x

140+

141+

142+

143+-- SEPARATORS

144+

145+

178spaceySepBy1 :: IParser b -> IParser a -> IParser [a]

146spaceySepBy1 :: IParser b -> IParser a -> IParser [a]

179spaceySepBy1 sep parser =

147spaceySepBy1 sep parser =

180 do value <- parser

148 do value <- parser

@@ -243,13 +211,6 @@ constrainedSpacePrefix parser constraint =

243-- SURROUNDED BY

211-- SURROUNDED BY

244

212

245

213

246−followedBy :: IParser a -> IParser b -> IParser a

247−followedBy a b =

248− do x <- a

249− b

250− return x

251−

252−

253surround :: Char -> Char -> String -> IParser a -> IParser a

214surround :: Char -> Char -> String -> IParser a -> IParser a

254surround a z name p = do

215surround a z name p = do

255 char a

216 char a

@@ -296,7 +257,7 @@ located parser =

296 return (start, value, end)

257 return (start, value, end)

297

258

298

259

299−accessible :: IParser Source.Expr -> IParser Source.Expr

260+accessible :: IParser Src.RawExpr -> IParser Src.RawExpr

300accessible exprParser =

261accessible exprParser =

301 do start <- getMyPosition

262 do start <- getMyPosition

302

263

@@ -314,11 +275,11 @@ accessible exprParser =

314 end <- getMyPosition

275 end <- getMyPosition

315 return . A.at start end $

276 return . A.at start end $

316 case rootExpr of

277 case rootExpr of

317− E.Var (Variable.Raw name@(c:_))

278+ Src.Var (Variable.Raw name@(c:_))

318 | isUpper c ->

279 | isUpper c ->

319− E.rawVar (name ++ '.' : v)

280+ Src.var (name ++ '.' : v)

320 _ ->

281 _ ->

321− E.Access annotatedRootExpr v

282+ Src.Access annotatedRootExpr v

322

283

323

284

324dot :: IParser ()

285dot :: IParser ()

src/Parse/Literal.hs+10−61

@@ -6,14 +6,13 @@ import Control.Monad (join)

6import qualified Data.Map as Map

7import qualified Language.GLSL.Parser as GLP

8import qualified Language.GLSL.Syntax as GLS

9−import qualified Text.Parsec.Token as T

10import Text.Parsec

9import Text.Parsec

11 ( ParseError, (<|>), (<?>), anyChar, char, choice, digit, hexDigit

10 ( ParseError, (<|>), (<?>), anyChar, char, choice, digit, hexDigit

12 , lookAhead, many1, manyTill, notFollowedBy, option, parserFail

11 , lookAhead, many1, manyTill, notFollowedBy, option, parserFail

13− , satisfy, string, try

12+ , string, try

14 )

13 )

15

14

16−import Parse.Helpers (IParser, SourceM, expecting, failure, iParse, reserveds)

15+import Parse.Helpers (IParser, expecting)

17import qualified AST.Literal as L

16import qualified AST.Literal as L

18

17

19

18

@@ -25,7 +24,7 @@ literal :: IParser L.Literal

25literal =

24literal =

26 choice

25 choice

27 [ toLiteral <$> rawNumber

26 [ toLiteral <$> rawNumber

28− , {-# SCC elm_compiler_parse_str #-} L.Str <$> str

27+ , L.Str <$> str

29 , L.Chr <$> chr

28 , L.Chr <$> chr

30 ]

29 ]

31

30

@@ -96,9 +95,7 @@ exponent =

96str :: IParser String

95str :: IParser String

97str =

96str =

98 expecting "a string like \"hello\"" $

97 expecting "a string like \"hello\"" $

99− do charSeq <- choice [ multiStr, singleStr ]

98+ choice [ multiStr, singleStr ]

100− either (fail . show) return $

101− processAs T.stringLiteral ('"' : charSeq ++ "\"")

102

99

103

100

104delimitedSequence :: IParser a -> IParser String -> IParser String

101delimitedSequence :: IParser a -> IParser String -> IParser String

@@ -114,7 +111,7 @@ multiStr =

114

111

115singleStr :: IParser String

112singleStr :: IParser String

116singleStr =

113singleStr =

117− delimitedSequence (char '"') (charWithin '"')

114+ delimitedSequence (char '"') ((:[]) <$> anyChar)

118

115

119

116

120

117

@@ -125,37 +122,26 @@ chr :: IParser Char

125chr =

122chr =

126 expecting "a character like 'x'" $

123 expecting "a character like 'x'" $

127 do char '\''

124 do char '\''

128− charSeq <- concat <$> many1 (charWithin '\'') <?> "a character"

125+ myChar <- anyChar <?> "a character"

129− case processAs T.charLiteral ("'" ++ charSeq ++ "'") of

130− Right character ->

131− do char '\''

126+ char '\''

132− return character

127+ return myChar

133

128

134− Left _ ->

129+{-

135 failure $

130 failure $

136 "Elm uses double quotes for strings. Switch\

131 "Elm uses double quotes for strings. Switch\

137 \ the ' to \" on both ends of the string and\

132 \ the ' to \" on both ends of the string and\

138 \ you should be all set!"

133 \ you should be all set!"

139−

134+-}

140

135

141

136

142-- CHARACTER HELPERS

137-- CHARACTER HELPERS

143

138

144

139

145−charWithin :: Char -> IParser String

146−charWithin delim =

147− choice

148− [ escaped delim

149− , (:[]) <$> satisfy (/= delim)

150− ]

151−

152−

153multilineStringChar :: IParser String

140multilineStringChar :: IParser String

154multilineStringChar =

141multilineStringChar =

155 do notFollowedBy (string "\"\"\"")

142 do notFollowedBy (string "\"\"\"")

156 choice

143 choice

157 [ newlineChar

144 [ newlineChar

158− , escaped '\"'

159 , escapeQuotes <$> anyChar

145 , escapeQuotes <$> anyChar

160 ]

146 ]

161

147

@@ -173,43 +159,6 @@ newlineChar =

173 ]

159 ]

174

160

175

161

176−escaped :: Char -> IParser String

177−escaped delim =

178− try $ do

179− char '\\'

180− c <- char '\\' <|> char delim

181− return ['\\', c]

182−

183−

184−processAs

185− :: (T.GenTokenParser String u SourceM -> IParser a)

186− -> String

187− -> Either ParseError a

188−processAs processor rawString =

189− iParse (processor lexer) rawString

190− where

191− lexer :: T.GenTokenParser String u SourceM

192− lexer =

193− T.makeTokenParser elmDef

194−

195− -- I don't know how many of these are necessary for charLiteral/stringLiteral

196− elmDef :: T.GenLanguageDef String u SourceM

197− elmDef =

198− T.LanguageDef

199− { T.commentStart = "{-"

200− , T.commentEnd = "-}"

201− , T.commentLine = "--"

202− , T.nestedComments = True

203− , T.identStart = undefined

204− , T.identLetter = undefined

205− , T.opStart = undefined

206− , T.opLetter = undefined

207− , T.reservedNames = reserveds

208− , T.reservedOpNames = [":", "->", "|"]

209− , T.caseSensitive = True

210− }

211−

212−

213

162

214-- SHADERS

163-- SHADERS

215

164

src/Parse/Module.hs+6−2

@@ -1,10 +1,14 @@

1{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}

2module Parse.Module (moduleDecl, header, getModuleName) where

3

4−import Text.Parsec hiding (newline, spaces)

4+import Text.Parsec hiding (newline, parse, spaces)

5

6import Parse.Binop (infixOp)

7import Parse.Helpers

8+ ( IParser, addLocation, brackets, capVar, commaSep, commaSep1

9+ , docComment, dotSep1, equals, expecting, followedBy, freshLine

10+ , getMyPosition, lowVar, padded, parens, parse, reserved, whitespace

11+ )

8import qualified AST.Module as Module

12import qualified AST.Module as Module

9import qualified AST.Module.Name as ModuleName

13import qualified AST.Module.Name as ModuleName

10import qualified AST.Variable as Var

14import qualified AST.Variable as Var

@@ -20,7 +24,7 @@ getModuleName source =

20 (ModuleDecl _ names _ _) <- moduleDecl

24 (ModuleDecl _ names _ _) <- moduleDecl

21 return (ModuleName.toString names)

25 return (ModuleName.toString names)

22 in

26 in

23− case iParse minimalParser source of

27+ case parse minimalParser source of

24 Right name ->

28 Right name ->

25 Just name

29 Just name

26

30

src/Parse/Parse.hs+14−83

@@ -1,18 +1,16 @@

1{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}

2−module Parse.Parse (program, parse) where

2+module Parse.Parse (program) where

3

4−import qualified Data.Map as Map

5−import qualified Data.Traversable as T

6−import Text.Parsec (char, eof, letter, many, putState, (<|>))

4+import Text.Parsec (char, eof, letter, many, (<|>))

7import qualified Text.Parsec.Error as Parsec

5import qualified Text.Parsec.Error as Parsec

8

6

9import qualified AST.Declaration as Decl

7import qualified AST.Declaration as Decl

10import qualified AST.Module as Module

8import qualified AST.Module as Module

11import qualified AST.Module.Name as ModuleName

9import qualified AST.Module.Name as ModuleName

12import qualified Elm.Package as Package

10import qualified Elm.Package as Package

13−import Parse.Helpers

11+import Parse.Helpers (IParser, commitIf, freshLine, newline, parse, spaces)

14import qualified Parse.Module as Parse (header)

12import qualified Parse.Module as Parse (header)

15−import qualified Parse.Declaration as Parse (declaration, infixDecl)

13+import qualified Parse.Declaration as Parse (declaration)

16import qualified Reporting.Region as R

14import qualified Reporting.Region as R

17import qualified Reporting.Error.Syntax as Error

15import qualified Reporting.Error.Syntax as Error

18import qualified Reporting.Result as Result

16import qualified Reporting.Result as Result

@@ -20,28 +18,20 @@ import qualified Validate

20

18

21

19

22

20

23−program :: Package.Name -> OpTable -> String -> Validate.Result wrn Module.Valid

21+program :: Package.Name -> String -> Validate.Result wrn Module.Valid

24−program pkgName table src =

22+program pkgName src =

25− do modul <-

26− parseWithTable table src (programParser pkgName)

23+ do modul <- toResult (parse (programParser pkgName) src)

27−

28 Validate.module' modul

24 Validate.module' modul

29

25

30

26

31−

32-- HEADERS AND DECLARATIONS

27-- HEADERS AND DECLARATIONS

33

28

34

29

35programParser :: Package.Name -> IParser Module.Source

30programParser :: Package.Name -> IParser Module.Source

36programParser pkgName =

31programParser pkgName =

37− do (Module.Header tag name exports settings docs imports) <-

32+ do (Module.Header tag name exports settings docs imports) <- Parse.header

38− Parse.header

39−

40− decls <-

41− declarations

33+ decls <- declarations

42−

43 many (spaces <|> newline)

34 many (spaces <|> newline)

44−

45 eof

35 eof

46

36

47 return $

37 return $

@@ -65,12 +55,12 @@ freshDef =

65

55

66

56

67

57

68−-- RUN PARSERS

58+-- PARSER OUTPUT TO RESULT

69

59

70

60

71−parse :: String -> IParser a -> Validate.Result wrn a

61+toResult :: Either Parsec.ParseError a -> Validate.Result wrn a

72−parse source parser =

62+toResult parserOutput =

73− case iParse parser source of

63+ case parserOutput of

74 Right result ->

64 Right result ->

75 return result

65 return result

76

66

@@ -78,63 +68,4 @@ parse source parser =

78 let pos = R.fromSourcePos (Parsec.errorPos err)

68 let pos = R.fromSourcePos (Parsec.errorPos err)

79 msgs = Parsec.errorMessages err

69 msgs = Parsec.errorMessages err

80 in

70 in

81− Result.throw (R.Region pos pos) (Error.Parse msgs)

71+ Result.throw (R.Region pos pos) (Error.Parse msgs)

82−

83−

84−parseWithTable :: OpTable -> String -> IParser a -> Validate.Result wrn a

85−parseWithTable table source parser =

86− do infixInfoList <- parse source parseFixities

87−

88− infixTable <- makeInfixTable table infixInfoList

89−

90− parse source $

91− do putState infixTable

92− parser

93−

94−

95−

96−-- INFIX INFO

97−

98−

99−makeInfixTable

100− :: Map.Map String (Int, Decl.Assoc)

101− -> [(String, InfixInfo)]

102− -> Validate.Result wrn (Map.Map String (Int, Decl.Assoc))

103−makeInfixTable table newInfo =

104− let add (op, info) dict =

105− Map.insertWith (++) op [info] dict

106−

107− infoTable =

108− foldr add Map.empty newInfo

109−

110− check op infoList =

111− case infoList of

112− [] ->

113− error "problem parsing infix declarations, this should never happen"

114−

115− [InfixInfo region info] ->

116− if Map.member op table

117− then Result.throw region (Error.InfixDuplicate op)

118− else return info

119−

120− InfixInfo region _ : _ ->

121− Result.throw region (Error.InfixDuplicate op)

122− in

123− Map.union table <$> T.sequenceA (Map.mapWithKey check infoTable)

124−

125−

126−parseFixities :: IParser [(String, InfixInfo)]

127−parseFixities =

128− onFreshLines (:) [] infics

129− where

130− infics =

131− do start <- getMyPosition

132− (Decl.Fixity (Decl.Infix op assoc level)) <- Parse.infixDecl

133− end <- getMyPosition

134− return (op, InfixInfo (R.Region start end) (level, assoc))

135−

136−

137−data InfixInfo = InfixInfo

138− { _region :: R.Region

139− , _info :: (Int, Decl.Assoc)

140− }

src/Parse/Primitives.hsnew file+84

@@ -0,0 +1,84 @@

1+{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}

2+module Parse.Primitives

3+ ( IParser, parse

4+ , expecting, failure

5+ , withPos, block, checkIndent, indented

6+ )

7+ where

8+

9+import Control.Monad.Identity (Identity, runIdentity)

10+import qualified Text.Parsec.Pos as Pos

11+import Text.Parsec

12+ ( ParsecT, runParserT, getState, putState

13+ , SourcePos, sourceColumn, sourceLine, setSourceLine, getPosition

14+ , getInput, setInput

15+ , ParseError, (<?>), parserFail, anyToken, many1

16+ )

17+

18+

19+

20+-- PARSER

21+

22+

23+type IParser a =

24+ ParsecT String SourcePos Identity a

25+

26+

27+parse :: IParser a -> String -> Either ParseError a

28+parse parser source =

29+ runIdentity (runParserT parser (Pos.initialPos "") "" source)

30+

31+

32+

33+-- ERROR HANDLING

34+

35+

36+expecting :: String -> IParser a -> IParser a

37+expecting =

38+ flip (<?>)

39+

40+

41+failure :: String -> IParser a

42+failure msg =

43+ do input <- getInput

44+ setInput ('x' : input)

45+ anyToken

46+ fail msg

47+

48+

49+

50+-- INDENTATION

51+

52+

53+withPos :: IParser a -> IParser a

54+withPos parser =

55+ do old <- getState

56+ new <- getPosition

57+ putState new

58+ result <- parser

59+ putState old

60+ return result

61+

62+

63+block :: IParser a -> IParser [a]

64+block parser =

65+ withPos $

66+ many1 (checkIndent >> parser)

67+

68+

69+checkIndent :: IParser ()

70+checkIndent =

71+ do old <- getState

72+ new <- getPosition

73+ if sourceColumn old == sourceColumn new

74+ then return ()

75+ else parserFail "indentation doesn't match"

76+

77+

78+indented :: IParser ()

79+indented =

80+ do old <- getState

81+ new <- getPosition

82+ if sourceColumn new <= sourceColumn old

83+ then parserFail "not indented"

84+ else putState $ setSourceLine old (sourceLine new)

src/Reporting/Error/Canonicalize.hs+16

@@ -5,6 +5,7 @@ import Control.Arrow (second)

5import qualified Data.Char as Char

6import Text.PrettyPrint.ANSI.Leijen (Doc, dullyellow, fillSep, indent, text)

7

8+import qualified AST.Declaration as Decl

8import qualified AST.Expression.Canonical as Canonical

9import qualified AST.Expression.Canonical as Canonical

9import qualified AST.Module.Name as ModuleName

10import qualified AST.Module.Name as ModuleName

10import qualified AST.Pattern as P

11import qualified AST.Pattern as P

@@ -20,6 +21,7 @@ import qualified Reporting.Report as Report

20data Error

21data Error

21 = Var VarError

22 = Var VarError

22 | BadRecursion Region.Region Canonical.Def [Canonical.Def]

23 | BadRecursion Region.Region Canonical.Def [Canonical.Def]

24+ | BadInfix Region.Region Int Var.Canonical Decl.Assoc Var.Canonical Decl.Assoc

23 | Pattern PatternError

25 | Pattern PatternError

24 | Alias AliasError

26 | Alias AliasError

25 | Import ModuleName.Raw ImportError

27 | Import ModuleName.Raw ImportError

@@ -165,6 +167,17 @@ toReport localizer err =

165 _ ->

167 _ ->

166 badMutualRecursion region (defToString def) (map (defToString) defs)

168 badMutualRecursion region (defToString def) (map (defToString) defs)

167

169

170+ BadInfix region _prec (Var.Canonical _ name1) _assoc1 (Var.Canonical _ name2) _assoc2 ->

171+ Report.report

172+ "INFIX PROBLEM"

173+ (Just region)

174+ ("You cannot mix (" ++ name1 ++ ") and (" ++ name2 ++ ") without parentheses.")

175+ (

176+ Help.stack

177+ [ Help.reflowParagraph $

178+ "I do not know how to group these expressions. Add parentheses for me!"

179+ ]

180+ )

168

181

169 Pattern patternError ->

182 Pattern patternError ->

170 case patternError of

183 case patternError of

@@ -296,6 +309,9 @@ extractSuggestions err =

296 BadRecursion _ _ _ ->

309 BadRecursion _ _ _ ->

297 Nothing

310 Nothing

298

311

312+ BadInfix _ _ _ _ _ _ ->

313+ Nothing

314+

299 Pattern _ ->

315 Pattern _ ->

300 Nothing

316 Nothing

301

317

src/Reporting/Error/Syntax.hs−12

@@ -26,7 +26,6 @@ data Error

26 | MissingManagerOnEffectModule String

27 | UnexpectedPort String

28

29− | InfixDuplicate String

30 | TypeWithoutDefinition String

29 | TypeWithoutDefinition String

31

30

32 | DuplicateArgument String String

31 | DuplicateArgument String String

@@ -163,17 +162,6 @@ toReport _localizer err =

163 \ stay relatively organized."

162 \ stay relatively organized."

164 )

163 )

165

164

166− InfixDuplicate opName ->

167− Report.report

168− "INFIX OVERLAP"

169− Nothing

170− ("The infix declarations for " ++ Help.functionName opName ++ " must be removed.")

171− ( Help.reflowParagraph $

172− "The precedence and associativity of a particular operator can only be set in\

173− \ one place in a code base, and " ++ Help.functionName opName

174− ++ " has already been set somewhere else."

175− )

176−

177 TypeWithoutDefinition valueName ->

165 TypeWithoutDefinition valueName ->

178 Report.report

166 Report.report

179 "MISSING DEFINITION"

167 "MISSING DEFINITION"

src/Type/Constrain/Expression.hs+48−49

@@ -5,8 +5,7 @@ import Control.Arrow (second)

5import qualified Control.Monad as Monad

6import qualified Data.Map as Map

7

8−import qualified AST.Expression.General as E

8+import qualified AST.Expression.Canonical as C

9−import qualified AST.Expression.Canonical as Canonical

10import qualified AST.Literal as Lit

9import qualified AST.Literal as Lit

11import qualified AST.Pattern as P

10import qualified AST.Pattern as P

12import qualified AST.Type as ST

11import qualified AST.Type as ST

@@ -22,31 +21,31 @@ import Type.Type hiding (Descriptor(..))

22

21

23

22

24

23

25−constrain :: Env.Env -> Canonical.Expr -> Type -> IO TypeConstraint

24+constrain :: Env.Env -> C.Expr -> Type -> IO TypeConstraint

26constrain env annotatedExpr@(A.A region expression) tipe =

25constrain env annotatedExpr@(A.A region expression) tipe =

27 case expression of

26 case expression of

28− E.Literal lit ->

27+ C.Literal lit ->

29 Literal.constrain env region lit tipe

28 Literal.constrain env region lit tipe

30

29

31− E.Cmd _ ->

30+ C.Cmd _ ->

32 return CTrue

31 return CTrue

33

32

34− E.Sub _ ->

33+ C.Sub _ ->

35 return CTrue

34 return CTrue

36

35

37− E.OutgoingPort _ _ ->

36+ C.OutgoingPort _ _ ->

38 return CTrue

37 return CTrue

39

38

40− E.IncomingPort _ _ ->

39+ C.IncomingPort _ _ ->

41 return CTrue

40 return CTrue

42

41

43− E.Program _ _ ->

42+ C.Program _ _ ->

44 error "DANGER - Program AST nodes should not be in type inference."

43 error "DANGER - Program AST nodes should not be in type inference."

45

44

46− E.SaveEnv moduleName effects ->

45+ C.SaveEnv moduleName effects ->

47 Effects.constrain env moduleName effects

46 Effects.constrain env moduleName effects

48

47

49− E.GLShader _uid _src gltipe ->

48+ C.GLShader _uid _src gltipe ->

50 exists $ \attr ->

49 exists $ \attr ->

51 exists $ \unif ->

50 exists $ \unif ->

52 let

51 let

@@ -70,16 +69,16 @@ constrain env annotatedExpr@(A.A region expression) tipe =

70 in

69 in

71 return (CEqual Error.Shader region (shaderTipe attribute uniform varying) tipe)

70 return (CEqual Error.Shader region (shaderTipe attribute uniform varying) tipe)

72

71

73− E.Var var ->

72+ C.Var var ->

74 return (CInstance region (V.toString var) tipe)

73 return (CInstance region (V.toString var) tipe)

75

74

76− E.ExplicitList exprs ->

75+ C.List exprs ->

77 constrainList env region exprs tipe

76 constrainList env region exprs tipe

78

77

79− E.Binop op leftExpr rightExpr ->

78+ C.Binop op leftExpr rightExpr ->

80 constrainBinop env region op leftExpr rightExpr tipe

79 constrainBinop env region op leftExpr rightExpr tipe

81

80

82− E.Lambda pattern body ->

81+ C.Lambda pattern body ->

83 exists $ \argType ->

82 exists $ \argType ->

84 exists $ \resType ->

83 exists $ \resType ->

85 do (Pattern.Info headers vars cons) <- Pattern.constrain env pattern argType

84 do (Pattern.Info headers vars cons) <- Pattern.constrain env pattern argType

@@ -88,19 +87,19 @@ constrain env annotatedExpr@(A.A region expression) tipe =

88 ex vars (CLet [monoscheme headers] (cons /\ bodyCon))

87 ex vars (CLet [monoscheme headers] (cons /\ bodyCon))

89 /\ CEqual Error.Lambda region (argType ==> resType) tipe

88 /\ CEqual Error.Lambda region (argType ==> resType) tipe

90

89

91− E.App _ _ ->

90+ C.App _ _ ->

92 let

91 let

93− (f:args) = E.collectApps annotatedExpr

92+ (f:args) = C.collectApps annotatedExpr

94 in

93 in

95 constrainApp env region f args tipe

94 constrainApp env region f args tipe

96

95

97− E.If branches finally ->

96+ C.If branches finally ->

98 constrainIf env region branches finally tipe

97 constrainIf env region branches finally tipe

99

98

100− E.Case expr branches ->

99+ C.Case expr branches ->

101 constrainCase env region expr branches tipe

100 constrainCase env region expr branches tipe

102

101

103− E.Data name exprs ->

102+ C.Ctor name exprs ->

104 do vars <- Monad.forM exprs $ \_ -> mkVar Nothing

103 do vars <- Monad.forM exprs $ \_ -> mkVar Nothing

105 let pairs = zip exprs (map VarN vars)

104 let pairs = zip exprs (map VarN vars)

106 (ctipe, cs) <- Monad.foldM step (tipe, CTrue) (reverse pairs)

105 (ctipe, cs) <- Monad.foldM step (tipe, CTrue) (reverse pairs)

@@ -110,16 +109,16 @@ constrain env annotatedExpr@(A.A region expression) tipe =

110 do c' <- constrain env e x

109 do c' <- constrain env e x

111 return (x ==> t, c /\ c')

110 return (x ==> t, c /\ c')

112

111

113− E.Access expr field ->

112+ C.Access expr field ->

114 exists $ \recordType ->

113 exists $ \recordType ->

115 exists $ \ext ->

114 exists $ \ext ->

116 do recordCon <- constrain env expr recordType

115 do recordCon <- constrain env expr recordType

117− let maybeBody = E.collectFields expr

116+ let maybeBody = C.collectFields expr

118 let desiredType = record (Map.singleton field tipe) ext

117 let desiredType = record (Map.singleton field tipe) ext

119 let fieldCon = CEqual (Error.Access maybeBody field) region recordType desiredType

118 let fieldCon = CEqual (Error.Access maybeBody field) region recordType desiredType

120 return $ recordCon /\ fieldCon

119 return $ recordCon /\ fieldCon

121

120

122− E.Update expr fields ->

121+ C.Update expr fields ->

123 exists $ \t ->

122 exists $ \t ->

124 do oldVars <- mapM (\_ -> mkVar Nothing) fields

123 do oldVars <- mapM (\_ -> mkVar Nothing) fields

125 let oldFields = Map.fromList (zip (map fst fields) (map VarN oldVars))

124 let oldFields = Map.fromList (zip (map fst fields) (map VarN oldVars))

@@ -133,7 +132,7 @@ constrain env annotatedExpr@(A.A region expression) tipe =

133

132

134 return $ cOld /\ ex newVars (CAnd (cNew : cs))

133 return $ cOld /\ ex newVars (CAnd (cNew : cs))

135

134

136− E.Record fields ->

135+ C.Record fields ->

137 do vars <- Monad.forM fields (\_ -> mkVar Nothing)

136 do vars <- Monad.forM fields (\_ -> mkVar Nothing)

138 fieldCons <-

137 fieldCons <-

139 Monad.zipWithM

138 Monad.zipWithM

@@ -144,7 +143,7 @@ constrain env annotatedExpr@(A.A region expression) tipe =

144 let recordType = record fields' (TermN EmptyRecord1)

143 let recordType = record fields' (TermN EmptyRecord1)

145 return (ex vars (CAnd (fieldCons ++ [CEqual Error.Record region recordType tipe])))

144 return (ex vars (CAnd (fieldCons ++ [CEqual Error.Record region recordType tipe])))

146

145

147− E.Let defs body ->

146+ C.Let defs body ->

148 do bodyCon <- constrain env body tipe

147 do bodyCon <- constrain env body tipe

149

148

150 (Info schemes rqs fqs headers c2 c1) <-

149 (Info schemes rqs fqs headers c2 c1) <-

@@ -166,8 +165,8 @@ constrain env annotatedExpr@(A.A region expression) tipe =

166constrainApp

165constrainApp

167 :: Env.Env

166 :: Env.Env

168 -> R.Region

167 -> R.Region

169− -> Canonical.Expr

168+ -> C.Expr

170− -> [Canonical.Expr]

169+ -> [C.Expr]

171 -> Type

170 -> Type

172 -> IO TypeConstraint

171 -> IO TypeConstraint

173constrainApp env region f args tipe =

172constrainApp env region f args tipe =

@@ -185,7 +184,7 @@ constrainApp env region f args tipe =

185 where

184 where

186 maybeName =

185 maybeName =

187 case f of

186 case f of

188− A.A _ (E.Var canonicalName) ->

187+ A.A _ (C.Var canonicalName) ->

189 Just canonicalName

188 Just canonicalName

190

189

191 _ ->

190 _ ->

@@ -199,7 +198,7 @@ argConstraints

199 -> Int

198 -> Int

200 -> Variable

199 -> Variable

201 -> Int

200 -> Int

202− -> [Canonical.Expr]

201+ -> [C.Expr]

203 -> IO ([Variable], [TypeConstraint], [TypeConstraint], [TypeConstraint], Maybe R.Region, Variable)

202 -> IO ([Variable], [TypeConstraint], [TypeConstraint], [TypeConstraint], Maybe R.Region, Variable)

204argConstraints env name region totalArgs overallVar index args =

203argConstraints env name region totalArgs overallVar index args =

205 case args of

204 case args of

@@ -250,8 +249,8 @@ constrainBinop

250 :: Env.Env

249 :: Env.Env

251 -> R.Region

250 -> R.Region

252 -> V.Canonical

251 -> V.Canonical

253− -> Canonical.Expr

252+ -> C.Expr

254− -> Canonical.Expr

253+ -> C.Expr

255 -> Type

254 -> Type

256 -> IO TypeConstraint

255 -> IO TypeConstraint

257constrainBinop env region op leftExpr@(A.A leftRegion _) rightExpr@(A.A rightRegion _) tipe =

256constrainBinop env region op leftExpr@(A.A leftRegion _) rightExpr@(A.A rightRegion _) tipe =

@@ -282,7 +281,7 @@ constrainBinop env region op leftExpr@(A.A leftRegion _) rightExpr@(A.A rightReg

282-- CONSTRAIN LISTS

281-- CONSTRAIN LISTS

283

282

284

283

285−constrainList :: Env.Env -> R.Region -> [Canonical.Expr] -> Type -> IO TypeConstraint

284+constrainList :: Env.Env -> R.Region -> [C.Expr] -> Type -> IO TypeConstraint

286constrainList env region exprs tipe =

285constrainList env region exprs tipe =

287 do (exprInfo, exprCons) <-

286 do (exprInfo, exprCons) <-

288 unzip <$> mapM elementConstraint exprs

287 unzip <$> mapM elementConstraint exprs

@@ -307,8 +306,8 @@ constrainList env region exprs tipe =

307constrainIf

306constrainIf

308 :: Env.Env

307 :: Env.Env

309 -> R.Region

308 -> R.Region

310− -> [(Canonical.Expr, Canonical.Expr)]

309+ -> [(C.Expr, C.Expr)]

311− -> Canonical.Expr

310+ -> C.Expr

312 -> Type

311 -> Type

313 -> IO TypeConstraint

312 -> IO TypeConstraint

314constrainIf env region branches finally tipe =

313constrainIf env region branches finally tipe =

@@ -366,8 +365,8 @@ constrainIf env region branches finally tipe =

366constrainCase

365constrainCase

367 :: Env.Env

366 :: Env.Env

368 -> R.Region

367 -> R.Region

369− -> Canonical.Expr

368+ -> C.Expr

370− -> [(P.Canonical, Canonical.Expr)]

369+ -> [(P.Canonical, C.Expr)]

371 -> Type

370 -> Type

372 -> IO TypeConstraint

371 -> IO TypeConstraint

373constrainCase env region expr branches tipe =

372constrainCase env region expr branches tipe =

@@ -444,8 +443,8 @@ collectPairs index items =

444-- EXPAND PATTERNS

443-- EXPAND PATTERNS

445

444

446

445

447−expandPattern :: Canonical.Def -> [Canonical.Def]

446+expandPattern :: C.Def -> [C.Def]

448−expandPattern def@(Canonical.Def facts lpattern expr maybeType) =

447+expandPattern def@(C.Def facts lpattern expr maybeType) =

449 let

448 let

450 (A.A patternRegion pattern) =

449 (A.A patternRegion pattern) =

451 lpattern

450 lpattern

@@ -467,17 +466,17 @@ expandPattern def@(Canonical.Def facts lpattern expr maybeType) =

467 A.A patternRegion (P.Var name)

466 A.A patternRegion (P.Var name)

468

467

469 localVar name =

468 localVar name =

470− A.A patternRegion (E.localVar name)

469+ A.A patternRegion (C.localVar name)

471

470

472 mainDef =

471 mainDef =

473− Canonical.Def facts (pvar combinedName) expr maybeType

472+ C.Def facts (pvar combinedName) expr maybeType

474

473

475 toDef name =

474 toDef name =

476 let

475 let

477 extract =

476 extract =

478− E.Case (localVar combinedName) [(lpattern, localVar name)]

477+ C.Case (localVar combinedName) [(lpattern, localVar name)]

479 in

478 in

480− Canonical.Def facts (pvar name) (A.A patternRegion extract) Nothing

479+ C.Def facts (pvar name) (A.A patternRegion extract) Nothing

481

480

482

481

483

482

@@ -494,8 +493,8 @@ data Info = Info

494 }

493 }

495

494

496

495

497−constrainDef :: Env.Env -> Info -> Canonical.Def -> IO Info

496+constrainDef :: Env.Env -> Info -> C.Def -> IO Info

498−constrainDef env info (Canonical.Def defRegion (A.A patternRegion pattern) expr maybeTipe) =

497+constrainDef env info (C.Def defRegion (A.A patternRegion pattern) expr maybeTipe) =

499 case (pattern, maybeTipe) of

498 case (pattern, maybeTipe) of

500 (P.Var name, Nothing) ->

499 (P.Var name, Nothing) ->

501 constrainUnannotatedDef env patternRegion name expr info

500 constrainUnannotatedDef env patternRegion name expr info

@@ -511,7 +510,7 @@ constrainUnannotatedDef

511 :: Env.Env

510 :: Env.Env

512 -> R.Region

511 -> R.Region

513 -> String

512 -> String

514− -> Canonical.Expr

513+ -> C.Expr

515 -> Info

514 -> Info

516 -> IO Info

515 -> IO Info

517constrainUnannotatedDef env patternRegion name expr info =

516constrainUnannotatedDef env patternRegion name expr info =

@@ -530,7 +529,7 @@ constrainAnnotatedDef

530 -> R.Region

529 -> R.Region

531 -> R.Region

530 -> R.Region

532 -> String

531 -> String

533− -> Canonical.Expr

532+ -> C.Expr

534 -> ST.Canonical

533 -> ST.Canonical

535 -> Info

534 -> Info

536 -> IO Info

535 -> IO Info

@@ -563,10 +562,10 @@ data ArgInfo =

563 }

562 }

564

563

565

564

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

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

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

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

568 case (expr, tipe) of

567 case (expr, tipe) of

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

568+ (A.A _ (C.Lambda arg result), ST.Lambda argType resultType) ->

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

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

571

570

572 constrainAnnDefHelp result resultType $

571 constrainAnnDefHelp result resultType $

@@ -594,7 +593,7 @@ constrainAnnDefHelp expr tipe (ArgInfo name defRegion env args vars) =

594

593

595 let sharedArity = length args

594 let sharedArity = length args

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

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

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

596+ let argsArity = sharedArity + length (fst (C.collectLambdas expr))

598 let hint = Error.ReturnType name typeArity argsArity region

597 let hint = Error.ReturnType name typeArity argsArity region

599 let resultCon =

598 let resultCon =

600 CEqual hint defRegion rigidType resultType

599 CEqual hint defRegion rigidType resultType

src/Validate.hs+60−81

@@ -6,12 +6,9 @@ import qualified Data.Map as Map

6import qualified Data.Maybe as Maybe

7import qualified Data.Set as Set

8import qualified Data.Foldable as F

9−import qualified Data.Traversable as T

10

9

11−import AST.Expression.General as Expr

12import qualified AST.Effects as Effects

10import qualified AST.Effects as Effects

13−import qualified AST.Expression.Source as Source

11+import qualified AST.Expression.Source as Src

14−import qualified AST.Expression.Valid as Valid

15import qualified AST.Declaration as D

12import qualified AST.Declaration as D

16import qualified AST.Module as Module

13import qualified AST.Module as Module

17import qualified AST.Module.Name as ModuleName

14import qualified AST.Module.Name as ModuleName

@@ -77,7 +74,7 @@ validateEffects

77 :: Module.SourceTag

74 :: Module.SourceTag

78 -> Module.SourceSettings

75 -> Module.SourceSettings

79 -> [A.Commented Effects.PortRaw]

76 -> [A.Commented Effects.PortRaw]

80− -> [A.Commented Valid.Def]

77+ -> [A.Commented Src.ValidDef]

81 -> Result wrn Effects.Raw

78 -> Result wrn Effects.Raw

82validateEffects tag settings@(A.A _ pairs) ports validDefs =

79validateEffects tag settings@(A.A _ pairs) ports validDefs =

83 case tag of

80 case tag of

@@ -191,7 +188,7 @@ extractOne name settingsDict =

191checkManager

188checkManager

192 :: R.Region

189 :: R.Region

193 -> Effects.ManagerType

190 -> Effects.ManagerType

194− -> [A.Commented Valid.Def]

191+ -> [A.Commented Src.ValidDef]

195 -> Result wrn (R.Region, R.Region, R.Region)

192 -> Result wrn (R.Region, R.Region, R.Region)

196checkManager tagRegion managerType validDefs =

193checkManager tagRegion managerType validDefs =

197 let

194 let

@@ -205,10 +202,10 @@ checkManager tagRegion managerType validDefs =

205 <*> requireRegion tagRegion regionDict "onSelfMsg"

202 <*> requireRegion tagRegion regionDict "onSelfMsg"

206

203

207

204

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

205+getSimpleDefRegion :: A.Commented Src.ValidDef -> Maybe (String, R.Region)

209getSimpleDefRegion decl =

206getSimpleDefRegion decl =

210 case decl of

207 case decl of

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

208+ A.A _ (Src.Def region (A.A _ (Pattern.Var name)) _ _) ->

212 Just (name, region)

209 Just (name, region)

213

210

214 _ ->

211 _ ->

@@ -341,7 +338,7 @@ vrdHelp commentedDecls ports structure =

341

338

342vrdDefHelp

339vrdDefHelp

343 :: [A.Commented D.Raw]

340 :: [A.Commented D.Raw]

344− -> A.Commented Source.Def'

341+ -> A.Commented Src.RawDef'

345 -> [A.Commented Effects.PortRaw]

342 -> [A.Commented Effects.PortRaw]

346 -> D.Valid

343 -> D.Valid

347 -> Result wrn ValidStuff

344 -> Result wrn ValidStuff

@@ -351,14 +348,14 @@ vrdDefHelp remainingDecls (A.A ann def) ports structure =

351 ValidStuff finalPorts (D.addDef (A.A ann validDef) struct)

348 ValidStuff finalPorts (D.addDef (A.A ann validDef) struct)

352 in

349 in

353 case def of

350 case def of

354− Source.Definition pat expr ->

351+ Src.Definition pat expr ->

355 addDef

352 addDef

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

353 <$> validateDef (fst ann) pat expr Nothing

357 <*> vrdHelp remainingDecls ports structure

354 <*> vrdHelp remainingDecls ports structure

358

355

359− Source.Annotation name tipe ->

356+ Src.Annotation name tipe ->

360 case remainingDecls of

357 case remainingDecls of

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

358+ A.A _ (D.Def (A.A defRegion (Src.Definition pat expr))) : rest

362 | Pattern.isVar name pat ->

359 | Pattern.isVar name pat ->

363 addDef

360 addDef

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

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

@@ -373,32 +370,32 @@ vrdDefHelp remainingDecls (A.A ann def) ports structure =

373-- VALIDATE DEFINITIONS

370-- VALIDATE DEFINITIONS

374

371

375

372

376−definitions :: [Source.Def] -> Result wrn [Valid.Def]

373+definitions :: [Src.RawDef] -> Result wrn [Src.ValidDef]

377definitions sourceDefs =

374definitions sourceDefs =

378 do validDefs <- definitionsHelp sourceDefs

375 do validDefs <- definitionsHelp sourceDefs

379

376

380 validDefs

377 validDefs

381− |> map Valid.getPattern

378+ |> map Src.getPattern

382 |> concatMap Pattern.boundVars

379 |> concatMap Pattern.boundVars

383 |> detectDuplicates Error.DuplicateDefinition

380 |> detectDuplicates Error.DuplicateDefinition

384

381

385 return validDefs

382 return validDefs

386

383

387

384

388−definitionsHelp :: [Source.Def] -> Result wrn [Valid.Def]

385+definitionsHelp :: [Src.RawDef] -> Result wrn [Src.ValidDef]

389definitionsHelp sourceDefs =

386definitionsHelp sourceDefs =

390 case sourceDefs of

387 case sourceDefs of

391 [] ->

388 [] ->

392 return []

389 return []

393

390

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

391+ A.A defRegion (Src.Definition pat expr) : rest ->

395 (:)

392 (:)

396 <$> validateDef defRegion pat expr Nothing

393 <$> validateDef defRegion pat expr Nothing

397 <*> definitionsHelp rest

394 <*> definitionsHelp rest

398

395

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

396+ A.A annRegion (Src.Annotation name tipe) : rest ->

400 case rest of

397 case rest of

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

398+ A.A defRegion (Src.Definition pat expr) : rest'

402 | Pattern.isVar name pat ->

399 | Pattern.isVar name pat ->

403 (:)

400 (:)

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

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

@@ -411,18 +408,18 @@ definitionsHelp sourceDefs =

411validateDef

408validateDef

412 :: R.Region

409 :: R.Region

413 -> Pattern.Raw

410 -> Pattern.Raw

414− -> Source.Expr

411+ -> Src.RawExpr

415 -> Maybe Type.Raw

412 -> Maybe Type.Raw

416− -> Result wrn Valid.Def

413+ -> Result wrn Src.ValidDef

417validateDef region pat expr maybeType =

414validateDef region pat expr maybeType =

418 do validExpr <- expression expr

415 do validExpr <- expression expr

419 validateDefPattern pat validExpr

416 validateDefPattern pat validExpr

420− return $ Valid.Def region pat validExpr maybeType

417+ return $ Src.Def region pat validExpr maybeType

421

418

422

419

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

420+validateDefPattern :: Pattern.Raw -> Src.ValidExpr -> Result wrn ()

424validateDefPattern pattern body =

421validateDefPattern pattern body =

425− case fst (Expr.collectLambdas body) of

422+ case fst (Src.collectLambdas body) of

426 [] ->

423 [] ->

427 return ()

424 return ()

428

425

@@ -459,59 +456,59 @@ checkArguments funcName args =

459-- VALIDATE EXPRESSIONS

456-- VALIDATE EXPRESSIONS

460

457

461

458

462−expression :: Source.Expr -> Result wrn Valid.Expr

459+expression :: Src.RawExpr -> Result wrn Src.ValidExpr

463expression (A.A ann sourceExpression) =

460expression (A.A ann sourceExpression) =

464 A.A ann <$>

461 A.A ann <$>

465 case sourceExpression of

462 case sourceExpression of

466− Var x ->

463+ Src.Var x ->

467− return (Var x)

464+ return (Src.Var x)

468

465

469− Lambda pattern body ->

466+ Src.Lambda pattern body ->

470− Lambda

467+ Src.Lambda

471− <$> validatePattern pattern

468+ <$> validatePattern pattern

472− <*> expression body

469+ <*> expression body

473

470

474− Binop op leftExpr rightExpr ->

471+ Src.Binop ops lastExpr ->

475− Binop op

472+ Src.Binop

476− <$> expression leftExpr

473+ <$> traverse (\(expr,op) -> (,) <$> expression expr <*> pure op) ops

477− <*> expression rightExpr

474+ <*> expression lastExpr

478

475

479− Case e branches ->

476+ Src.Case e branches ->

480− Case

477+ Src.Case

481 <$> expression e

478 <$> expression e

482− <*> T.traverse (\(p,b) -> (,) <$> validatePattern p <*> expression b) branches

479+ <*> traverse (\(p,b) -> (,) <$> validatePattern p <*> expression b) branches

483

480

484− Data name args ->

481+ Src.Ctor name args ->

485− Data name <$> T.traverse expression args

482+ Src.Ctor name <$> traverse expression args

486

483

487− Literal lit ->

484+ Src.Literal lit ->

488− return (Literal lit)

485+ return (Src.Literal lit)

489

486

490− ExplicitList expressions ->

487+ Src.List expressions ->

491− ExplicitList

488+ Src.List

492− <$> T.traverse expression expressions

489+ <$> traverse expression expressions

493

490

494− App funcExpr argExpr ->

491+ Src.App funcExpr argExpr ->

495− App

492+ Src.App

496 <$> expression funcExpr

493 <$> expression funcExpr

497 <*> expression argExpr

494 <*> expression argExpr

498

495

499− If branches finally ->

496+ Src.If branches finally ->

500− If

497+ Src.If

501− <$> T.traverse both branches

498+ <$> traverse both branches

502 <*> expression finally

499 <*> expression finally

503

500

504− Access record field ->

501+ Src.Access record field ->

505− Access

502+ Src.Access

506 <$> expression record

503 <$> expression record

507 <*> return field

504 <*> return field

508

505

509− Update record fields ->

506+ Src.Update record fields ->

510− Update

507+ Src.Update

511 <$> expression record

508 <$> expression record

512− <*> T.traverse second fields

509+ <*> traverse second fields

513

510

514− Record fields ->

511+ Src.Record fields ->

515 let

512 let

516 checkDups seenFields (field,_) =

513 checkDups seenFields (field,_) =

517 if Set.member field seenFields then

514 if Set.member field seenFields then

@@ -521,41 +518,23 @@ expression (A.A ann sourceExpression) =

521 return (Set.insert field seenFields)

518 return (Set.insert field seenFields)

522 in

519 in

523 do foldM_ checkDups Set.empty fields

520 do foldM_ checkDups Set.empty fields

524− Record <$> T.traverse second fields

521+ Src.Record <$> traverse second fields

525

522

526− Let defs body ->

523+ Src.Let defs body ->

527− Let

524+ Src.Let

528 <$> definitions defs

525 <$> definitions defs

529 <*> expression body

526 <*> expression body

530

527

531− Cmd moduleName ->

532− return (Cmd moduleName)

533−

534− Sub moduleName ->

535− return (Sub moduleName)

536−

537− OutgoingPort name tipe ->

538− return (OutgoingPort name tipe)

539−

540− IncomingPort name tipe ->

541− return (IncomingPort name tipe)

542−

543− Program _ _ ->

544− error "DANGER - Program AST nodes should not be in validation phase."

545−

546− SaveEnv moduleName effects ->

547− return (SaveEnv moduleName effects)

548−

549− GLShader uid src gltipe ->

528+ Src.GLShader uid src gltipe ->

550− return (GLShader uid src gltipe)

529+ return (Src.GLShader uid src gltipe)

551

530

552

531

553−second :: (a, Source.Expr) -> Result wrn (a, Valid.Expr)

532+second :: (a, Src.RawExpr) -> Result wrn (a, Src.ValidExpr)

554second (value, expr) =

533second (value, expr) =

555 (,) value <$> expression expr

534 (,) value <$> expression expr

556

535

557

536

558−both :: (Source.Expr, Source.Expr) -> Result wrn (Valid.Expr, Valid.Expr)

537+both :: (Src.RawExpr, Src.RawExpr) -> Result wrn (Src.ValidExpr, Src.ValidExpr)

559both (expr1, expr2) =

538both (expr1, expr2) =

560 (,) <$> expression expr1 <*> expression expr2

539 (,) <$> expression expr1 <*> expression expr2

561

540

@@ -580,7 +559,7 @@ checkDuplicates (ValidStuff ports (D.Decls defs unions aliases _)) =

580 -- SIMPLE NAMES

559 -- SIMPLE NAMES

581

560

582 defValues =

561 defValues =

583− concatMap (Pattern.boundVars . Valid.getPattern . A.drop) defs

562+ concatMap (Pattern.boundVars . Src.getPattern . A.drop) defs

584

563

585 portValues =

564 portValues =

586 map fromPort ports

565 map fromPort ports