git.iko.soy/elk
on master help sign in
Attempt to speed up the parsing phase

- Remove dependency on indents package. Track state in ParsecT directly. - Create separate ASTs for Source and Canonical - Figure out infix associativity after canonicalization, fix #1096 - Seems to reduce parsing time by 50% by the numbers, but not feeling it. - String and Char parsing are messed up. Needs additional work.

commitb97576dbd206b56b82e2e282343d07101f8b3246 authorEvan Czaplicki <evancz@users.noreply.github.com> dateTue 22 Nov 2016, 18:09 (10 years ago) parent0d7f304
38 files changed+1005−1067
compare with master
unifiedsplit
elm-compiler.cabal+2−4 src/AST/Declaration.hs+3−4 src/AST/Expression/Canonical.hs+111−13 src/AST/Expression/General.hs−131 src/AST/Expression/Optimized.hs+5−5 src/AST/Expression/Source.hs+83−15 src/AST/Expression/Valid.hs−30 src/Canonicalize.hs+78−65 src/Canonicalize/Binops.hs+112 src/Canonicalize/Body.hs+18−19 src/Canonicalize/Effects.hs+2−2 src/Canonicalize/Environment.hs+16−10 src/Canonicalize/Setup.hs+22−13 src/Canonicalize/Sort.hs+51−52 src/Canonicalize/Type.hs+3−3 src/Canonicalize/Variable.hs+5−16 src/Compile.hs+11−19 src/Docs/Check.hs+2−2 src/Elm/Compiler.hs+17−10 src/Elm/Compiler/Type.hs+2−2 src/Elm/Utils.hs+2−2 src/Generate/JavaScript/Expression.hs+9−10 src/Generate/JavaScript/Foreign.hs+3−3 src/Nitpick/PatternMatches.hs+23−24 src/Nitpick/TopLevelTypes.hs+4−5 src/Optimize.hs+37−38 src/Optimize/Inline.hs+9−9 src/Parse/Binop.hs+47−137 src/Parse/Expression.hs+58−65 src/Parse/Helpers.hs+32−71 src/Parse/Literal.hs+10−61 src/Parse/Module.hs+6−2 src/Parse/Parse.hs+14−83 src/Parse/Primitives.hs+84 src/Reporting/Error/Canonicalize.hs+16 src/Reporting/Error/Syntax.hs−12 src/Type/Constrain/Expression.hs+48−49 src/Validate.hs+60−81
elm-compiler.cabal+2−4
@@ -59,10 +59,8 @@ Library
5959 AST.Declaration,
6060 AST.Effects,
6161 AST.Expression.Canonical,
62− AST.Expression.General,
6362 AST.Expression.Optimized,
6463 AST.Expression.Source,
65− AST.Expression.Valid,
6664 AST.Helpers,
6765 AST.Literal,
6866 AST.Module,
@@ -71,6 +69,7 @@ Library
7169 AST.Type,
7270 AST.Variable,
7371 Canonicalize,
72+ Canonicalize.Binops,
7473 Canonicalize.Body,
7574 Canonicalize.Effects,
7675 Canonicalize.Environment,
@@ -109,6 +108,7 @@ Library
109108 Parse.Module,
110109 Parse.Parse,
111110 Parse.Pattern,
111+ Parse.Primitives,
112112 Parse.Type,
113113 Reporting.Annotation,
114114 Reporting.Bag,
@@ -150,7 +150,6 @@ Library
150150 directory >= 1.0 && < 2.0,
151151 edit-distance >= 0.2 && < 0.3,
152152 filepath >= 1 && < 2.0,
153− indents >= 0.3 && < 0.4,
154153 language-ecmascript >= 0.15 && < 0.18,
155154 language-glsl >= 0.0.2 && < 0.3,
156155 mtl >= 2.2 && < 3,
@@ -223,7 +222,6 @@ Test-Suite compiler-tests
223222 edit-distance >= 0.2 && < 0.3,
224223 filemanip >= 0.3.5 && < 0.4,
225224 filepath >= 1 && < 2.0,
226− indents >= 0.3 && < 0.4,
227225 language-ecmascript >= 0.15 && < 0.18,
228226 language-glsl >= 0.0.2 && < 0.3,
229227 mtl >= 2.2 && < 3,
src/AST/Declaration.hs+3−4
@@ -3,9 +3,8 @@ module AST.Declaration where
33
44import Data.Binary
55
6−import qualified AST.Expression.Source as Source
7−import qualified AST.Expression.Valid as Valid
86import qualified AST.Expression.Canonical as Canonical
7+import qualified AST.Expression.Source as Src
98import qualified AST.Type as Type
109import qualified Reporting.Annotation as A
1110
@@ -24,7 +23,7 @@ data CommentOr a
2423
2524
2625data Raw
27− = Def Source.Def
26+ = Def Src.RawDef
2827 | Union (Union Type.Raw)
2928 | Alias (Alias Type.Raw)
3029 | Fixity Infix
@@ -45,7 +44,7 @@ data Decls def tipe =
4544
4645
4746type Valid =
48− Decls Valid.Def Type.Raw
47+ Decls Src.ValidDef Type.Raw
4948
5049
5150type Canonical =
src/AST/Expression/Canonical.hs+111−13
@@ -1,32 +1,76 @@
11{-# OPTIONS_GHC -Wall #-}
22module AST.Expression.Canonical
3− ( Expr, Expr'
3+ ( Expr, Expr'(..)
4+ , Main(..)
45 , Def(..)
56 , SortedDefs(..), toSortedDefs
7+ , localVar
8+ , collectApps, collectFields, collectLambdas
69 )
710 where
811
9−import qualified AST.Expression.General as General
10−import qualified AST.Pattern as Pattern
12+
13+import qualified Data.List as List
14+
15+import qualified AST.Effects as Effects
16+import qualified AST.Literal as Literal
17+import qualified AST.Module.Name as ModuleName
18+import qualified AST.Pattern as Ptrn
1119import qualified AST.Type as Type
1220import qualified AST.Variable as Var
1321import qualified Reporting.Annotation as A
1422import qualified Reporting.Region as R
1523
1624
17−{-| Canonicalized expressions. All variables are fully resolved to the module
18−they came from.
19−-}
25+
26+-- EXPRESSIONS
27+
28+
2029type Expr =
21− General.Expr R.Region Def Var.Canonical Type.Canonical
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
60+ | Flags Type.Canonical
2261
2362
24−type Expr' =
25− General.Expr' R.Region Def Var.Canonical Type.Canonical
2663
64+-- DEFS
2765
28−data Def
29− = Def R.Region Pattern.Canonical Expr (Maybe (A.Located Type.Canonical))
66+
67+data Def =
68+ Def
69+ { _region :: R.Region
70+ , _pattern :: Ptrn.Canonical
71+ , _body :: Expr
72+ , _type :: Maybe (A.Located Type.Canonical)
73+ }
3074
3175
3276
@@ -41,7 +85,7 @@ data SortedDefs
4185toSortedDefs :: Expr -> SortedDefs
4286toSortedDefs (A.A _ expr) =
4387 case expr of
44− General.Let defs body ->
88+ Let defs body ->
4589 foldr defCons (toSortedDefs body) defs
4690
4791 _ ->
@@ -51,7 +95,7 @@ toSortedDefs (A.A _ expr) =
5195defCons :: Def -> SortedDefs -> SortedDefs
5296defCons def@(Def _ (A.A _ pattern) _ _) sortedDefs =
5397 case (pattern, sortedDefs) of
54− (Pattern.Var "main", NoMain defs) ->
98+ (Ptrn.Var "main", NoMain defs) ->
5599 YesMain [] def defs
56100
57101 (_, NoMain defs) ->
@@ -59,3 +103,57 @@ defCons def@(Def _ (A.A _ pattern) _ _) sortedDefs =
59103
60104 (_, YesMain defs main rest) ->
61105 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
55 , Decider(..), Choice(..)
66 ) where
77
8−import qualified AST.Expression.General as Expr
8+import qualified AST.Expression.Canonical as Can
99import qualified AST.Literal as Literal
1010import qualified AST.Module.Name as ModuleName
1111import qualified AST.Type as Type
@@ -37,7 +37,7 @@ dummyFacts =
3737data Expr
3838 = Literal Literal.Literal
3939 | Var Var.Canonical
40− | ExplicitList [Expr]
40+ | List [Expr]
4141 | Binop Var.Canonical Expr Expr
4242 | Function [String] Expr
4343 | Call Expr [Expr]
@@ -45,8 +45,8 @@ data Expr
4545 | If [(Expr, Expr)] Expr
4646 | Let [Def] Expr
4747 | Case String (Decider Choice) [(Int, Expr)]
48− | Data String [Expr]
49− | DataAccess Expr Int
48+ | Ctor String [Expr]
49+ | CtorAccess Expr Int
5050 | Access Expr String
5151 | Update Expr [(String, Expr)]
5252 | Record [(String, Expr)]
@@ -54,7 +54,7 @@ data Expr
5454 | Sub ModuleName.Canonical
5555 | OutgoingPort String Type.Canonical
5656 | IncomingPort String Type.Canonical
57− | Program (Expr.Main Type.Canonical) Expr
57+ | Program Can.Main Expr
5858 | GLShader String String Literal.GLShaderTipe
5959 | Crash ModuleName.Canonical R.Region (Maybe Expr)
6060
src/AST/Expression/Source.hs+83−15
@@ -1,31 +1,99 @@
11{-# 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
39
4−import qualified AST.Expression.General as General
5−import qualified AST.Pattern as Pattern
10+
11+import qualified AST.Literal as Literal
12+import qualified AST.Pattern as Ptrn
613import qualified AST.Type as Type
714import qualified AST.Variable as Var
815import qualified Reporting.Annotation as A
916import qualified Reporting.Region as R
1017
1118
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
1819
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
1945
20−type Expr' =
21− General.Expr' R.Region Def Var.Raw Type.Raw
46+type RawExpr' = Expr' RawDef
2247
48+type ValidExpr = Expr ValidDef
2349
24−type Def =
25− A.Located Def'
50+type ValidExpr' = Expr' ValidDef
2651
2752
28−data Def'
29− = Definition Pattern.Raw Expr
53+
54+-- DEFINITIONS
55+
56+
57+type RawDef =
58+ A.Located RawDef'
59+
60+
61+data RawDef'
62+ = Definition Ptrn.Raw RawExpr
3063 | Annotation String Type.Raw
3164
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 @@
11{-# OPTIONS_GHC -Wall #-}
22module Canonicalize (module') where
33
4+import Prelude hiding (last)
45import qualified Data.List as List
56import qualified Data.Map as Map
67import qualified Data.Maybe as Maybe
78import qualified Data.Set as Set
89import qualified Data.Foldable as T
910
10−import AST.Expression.General (Expr'(..))
1111import Elm.Utils ((|>))
1212
1313import qualified AST.Declaration as D
14−import qualified AST.Expression.Valid as Valid
15−import qualified AST.Expression.Canonical as Canonical
14+import qualified AST.Expression.Source as Src
15+import qualified AST.Expression.Canonical as C
1616import qualified AST.Module as Module
1717import qualified AST.Module.Name as ModuleName
1818import qualified AST.Pattern as P
1919import qualified AST.Type as Type
2020import qualified AST.Variable as Var
21+import qualified Canonicalize.Binops as Binops
2122import qualified Canonicalize.Body as Body
2223import qualified Canonicalize.Effects as Effects
2324import qualified Canonicalize.Environment as Env
@@ -250,7 +251,7 @@ declsToValues :: D.Valid -> [Var.Value]
250251declsToValues (D.Decls defs unions aliases _) =
251252 let
252253 fromDef (A.A _ def) =
253− map Var.Value (P.boundVarList (Valid.getPattern def))
254+ map Var.Value (P.boundVarList (Src.getPattern def))
254255
255256 fromUnion (A.A _ (D.Type name _ ctors)) =
256257 Var.Union name (Var.Listing (map fst ctors) False)
@@ -319,14 +320,14 @@ splitLocatedValue (A.A region value) =
319320-- DECLARATIONS
320321
321322
322−canonicalizeDecls :: Env.Environment -> D.Valid -> CResult D.Canonical
323+canonicalizeDecls :: Env.Env -> D.Valid -> CResult D.Canonical
323324canonicalizeDecls env (D.Decls defs unions aliases infixes) =
324325 let
325326 annTraverse canEntry entries =
326327 traverse (\(A.A ann entry) -> A.A ann <$> canEntry entry) entries
327328
328− canonicalizeDef (Valid.Def region pat expr typ) =
329− Canonical.Def region
329+ canonicalizeDef (Src.Def region pat expr typ) =
330+ C.Def region
330331 <$> canonicalizePattern env pat
331332 <*> canonicalizeExpr env expr
332333 <*> traverse (canonicalizeRegionType env) typ
@@ -347,114 +348,97 @@ canonicalizeDecls env (D.Decls defs unions aliases infixes) =
347348 <*> pure infixes
348349
349350
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)
354352canonicalizeRegionType env typ@(A.A region _) =
355353 A.A region <$> Canon.tipe env typ
356354
357355
358−canonicalizeExpr
359− :: Env.Environment
360− -> Valid.Expr
361− -> CResult Canonical.Expr
356+
357+-- EXPRESSIONS
358+
359+
360+canonicalizeExpr :: Env.Env -> Src.ValidExpr -> CResult C.Expr
362361canonicalizeExpr env (A.A region validExpr) =
363362 let go = canonicalizeExpr env
364363 in
365364 A.A region <$>
366365 case validExpr of
367− Literal lit ->
368− Result.ok (Literal lit)
366+ Src.Literal lit ->
367+ Result.ok (C.Literal lit)
369368
370− Access record field ->
371− Access <$> go record <*> Result.ok field
369+ Src.Access record field ->
370+ C.Access <$> go record <*> Result.ok field
372371
373− Update record fields ->
374− Update
372+ Src.Update record fields ->
373+ C.Update
375374 <$> go record
376375 <*> traverse (\(field,expr) -> (,) field <$> go expr) fields
377376
378− Record fields ->
379− Record
377+ Src.Record fields ->
378+ C.Record
380379 <$> traverse (\(field,expr) -> (,) field <$> go expr) fields
381380
382− Binop (Var.Raw op) leftExpr rightExpr ->
383− Binop
384− <$> Canon.variable region env op
385− <*> go leftExpr
386− <*> go rightExpr
381+ Src.Binop ops last ->
382+ canonicalizeBinop region env ops last
387383
388− Lambda arg body ->
384+ Src.Lambda arg body ->
389385 let
390386 env' =
391387 Env.addPattern arg env
392388 in
393− Lambda <$> canonicalizePattern env' arg <*> canonicalizeExpr env' body
389+ C.Lambda
390+ <$> canonicalizePattern env' arg
391+ <*> canonicalizeExpr env' body
394392
395− App func arg ->
396− App <$> go func <*> go arg
393+ Src.App func arg ->
394+ C.App <$> go func <*> go arg
397395
398− If branches finally ->
399− If
396+ Src.If branches finally ->
397+ C.If
400398 <$> traverse go' branches
401399 <*> go finally
402400 where
403401 go' (condition, branch) =
404402 (,) <$> go condition <*> go branch
405403
406− Let defs expr ->
407− Let <$> traverse rename' defs <*> canonicalizeExpr env' expr
404+ Src.Let defs expr ->
405+ C.Let <$> traverse rename' defs <*> canonicalizeExpr env' expr
408406 where
409407 env' =
410− foldr Env.addPattern env (map Valid.getPattern defs)
408+ foldr Env.addPattern env (map Src.getPattern defs)
411409
412− rename' (Valid.Def defRegion p body mtipe) =
413− Canonical.Def defRegion
410+ rename' (Src.Def defRegion p body mtipe) =
411+ C.Def defRegion
414412 <$> canonicalizePattern env' p
415413 <*> canonicalizeExpr env' body
416414 <*> traverse (canonicalizeRegionType env') mtipe
417415
418− Var (Var.Raw x) ->
419− Var <$> Canon.variable region env x
416+ Src.Var (Var.Raw x) ->
417+ C.Var <$> Canon.variable region env x
420418
421− Data name exprs ->
422− Data name <$> traverse go exprs
419+ Src.Ctor name exprs ->
420+ C.Ctor name <$> traverse go exprs
423421
424− ExplicitList exprs ->
425− ExplicitList <$> traverse go exprs
422+ Src.List exprs ->
423+ C.List <$> traverse go exprs
426424
427− Case expr cases ->
428− Case <$> go expr <*> traverse branch cases
425+ Src.Case expr cases ->
426+ C.Case <$> go expr <*> traverse branch cases
429427 where
430428 branch (ptrn, brnch) =
431429 (,)
432430 <$> canonicalizePattern env ptrn
433431 <*> canonicalizeExpr (Env.addPattern ptrn env) brnch
434432
435− Cmd moduleName ->
436− Result.ok (Cmd moduleName)
437−
438− Sub moduleName ->
439− Result.ok (Sub moduleName)
433+ Src.GLShader uid src tipe ->
434+ Result.ok (C.GLShader uid src tipe)
440435
441− OutgoingPort name tipe ->
442− OutgoingPort name <$> Canon.tipe env tipe
443436
444− IncomingPort name tipe ->
445− IncomingPort name <$> Canon.tipe env tipe
446437
447− Program _ _ ->
448− error "DANGER - Program AST nodes should not be in canonicalization."
438+-- PATTERNS
449439
450− SaveEnv moduleName effects ->
451− Result.ok (SaveEnv moduleName effects)
452440
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
458442canonicalizePattern env (A.A region ptrn) =
459443 A.A region <$>
460444 case ptrn of
@@ -477,3 +461,32 @@ canonicalizePattern env (A.A region ptrn) =
477461 P.Data
478462 <$> Canon.pvar region env name (length patterns)
479463 <*> 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
55
66import qualified AST.Declaration as Decl
77import qualified AST.Effects as Effects
8−import qualified AST.Expression.General as E
9−import qualified AST.Expression.Canonical as Canonical
8+import qualified AST.Expression.Canonical as C
109import qualified AST.Module.Name as ModuleName
1110import qualified AST.Pattern as P
1211import qualified AST.Type as Type
@@ -24,7 +23,7 @@ flatten
2423 => ModuleName.Canonical
2524 -> Decl.Canonical
2625 -> Effects.Canonical
27− -> Result i w Error Canonical.Expr
26+ -> Result i w Error C.Expr
2827flatten moduleName (Decl.Decls defs unions aliases _) effects =
2928 let
3029 allDefs =
@@ -39,14 +38,14 @@ flatten moduleName (Decl.Decls defs unions aliases _) effects =
3938 A.A (error "this annotation should never be needed")
4039 in
4140 Sort.definitions $ loc $
42− E.Let allDefs (loc $ E.SaveEnv moduleName effects)
41+ C.Let allDefs (loc $ C.SaveEnv moduleName effects)
4342
4443
4544
4645-- TYPES TO DEFS
4746
4847
49−unionToDefs :: ModuleName.Canonical -> A.Commented (Decl.Union Type.Canonical) -> [Canonical.Def]
48+unionToDefs :: ModuleName.Canonical -> A.Commented (Decl.Union Type.Canonical) -> [C.Def]
5049unionToDefs moduleName (A.A (region,_) (Decl.Type name tvars constructors)) =
5150 let
5251 tagToDef (tag, tipes) =
@@ -61,14 +60,14 @@ unionToDefs moduleName (A.A (region,_) (Decl.Type name tvars constructors)) =
6160
6261 body =
6362 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)
6564 in
6665 definition tag (buildFunction vars body) region (foldr Type.Lambda tbody tipes)
6766 in
6867 map tagToDef constructors
6968
7069
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
7271aliasToDefs moduleName (A.A (region,_) (Decl.Type name tvars tipe)) =
7372 case tipe of
7473 Type.Record fields Nothing ->
@@ -87,7 +86,7 @@ aliasToDefs moduleName (A.A (region,_) (Decl.Type name tvars tipe)) =
8786
8887 record =
8988 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))
9190 in
9291 Just $ definition name (buildFunction vars record) region (foldr Type.Lambda resultType args)
9392
@@ -100,17 +99,17 @@ infiniteArgs =
10099 map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]
101100
102101
103−buildFunction :: [String] -> Canonical.Expr -> Canonical.Expr
102+buildFunction :: [String] -> C.Expr -> C.Expr
104103buildFunction vars body@(A.A ann _) =
105104 foldr
106− (\pattern expr -> A.A ann (E.Lambda pattern expr))
105+ (\pattern expr -> A.A ann (C.Lambda pattern expr))
107106 body
108107 (map (A.A ann . P.Var) vars)
109108
110109
111−definition :: String -> Canonical.Expr -> Region -> Type.Canonical -> Canonical.Def
110+definition :: String -> C.Expr -> Region -> Type.Canonical -> C.Def
112111definition name expr@(A.A ann _) region tipe =
113− Canonical.Def
112+ C.Def
114113 region
115114 (A.A ann (P.Var name))
116115 expr
@@ -121,7 +120,7 @@ definition name expr@(A.A ann _) region tipe =
121120-- EFFECTS
122121
123122
124−effectsToDefs :: ModuleName.Canonical -> Effects.Canonical -> [Canonical.Def]
123+effectsToDefs :: ModuleName.Canonical -> Effects.Canonical -> [C.Def]
125124effectsToDefs moduleName effects =
126125 case effects of
127126 Effects.None ->
@@ -135,14 +134,14 @@ effectsToDefs moduleName effects =
135134 cmdToDef (A.A region name) =
136135 definition
137136 "command"
138− (A.A region (E.Cmd moduleName))
137+ (A.A region (C.Cmd moduleName))
139138 region
140139 (Type.cmd moduleName name)
141140
142141 subToDef (A.A region name) =
143142 definition
144143 "subscription"
145− (A.A region (E.Sub moduleName))
144+ (A.A region (C.Sub moduleName))
146145 region
147146 (Type.sub moduleName name)
148147 in
@@ -161,17 +160,17 @@ effectsToDefs moduleName effects =
161160 ]
162161
163162
164−portToDef :: A.Commented Effects.PortCanonical -> Canonical.Def
163+portToDef :: A.Commented Effects.PortCanonical -> C.Def
165164portToDef (A.A (region, _) (Effects.PortCanonical name kind tipe)) =
166165 definition name (A.A region (toPortExpr name kind)) region tipe
167166
168167
169−toPortExpr :: String -> Effects.Kind -> Canonical.Expr'
168+toPortExpr :: String -> Effects.Kind -> C.Expr'
170169toPortExpr name kind =
171170 case kind of
172171 Effects.Outgoing tipe ->
173− E.OutgoingPort name tipe
172+ C.OutgoingPort name tipe
174173
175174 Effects.Incoming tipe ->
176− E.IncomingPort name tipe
175+ C.IncomingPort name tipe
177176
src/Canonicalize/Effects.hs+2−2
@@ -36,7 +36,7 @@ toValues effects =
3636-- CANONICALIZE
3737
3838
39−canonicalize :: Env.Environment -> Effects.Raw -> Result Effects.Canonical
39+canonicalize :: Env.Env -> Effects.Raw -> Result Effects.Canonical
4040canonicalize env effects =
4141 case effects of
4242 Effects.None ->
@@ -50,7 +50,7 @@ canonicalize env effects =
5050
5151
5252canonicalizeRawPort
53− :: Env.Environment
53+ :: Env.Env
5454 -> A.Commented Effects.PortRaw
5555 -> Result (A.Commented Effects.PortCanonical)
5656canonicalizeRawPort env (A.A ann (Effects.PortRaw name rawType)) =
src/Canonicalize/Environment.hs+16−10
@@ -1,6 +1,6 @@
11{-# OPTIONS_GHC -Wall #-}
22module Canonicalize.Environment
3− ( Environment(..)
3+ ( Env(..)
44 , getPackage
55 , insert
66 , Patch(..), fromPatches, addPattern
@@ -14,6 +14,7 @@ import qualified Data.Map as Map
1414import qualified Data.Maybe as Maybe
1515import qualified Data.Set as Set
1616
17+import qualified AST.Declaration as Decl
1718import qualified AST.Module.Name as ModuleName
1819import qualified AST.Pattern as P
1920import qualified AST.Type as Type
@@ -25,12 +26,13 @@ import qualified Elm.Package as Pkg
2526-- ENVIRONMENT
2627
2728
28−data Environment = Env
29+data Env = Env
2930 { _home :: ModuleName.Canonical
3031 , _values :: Dict Var.Canonical
3132 , _unions :: Dict Var.Canonical
3233 , _aliases :: Dict (Var.Canonical, [String], Type.Canonical)
3334 , _patterns :: Dict (Var.Canonical, Int)
35+ , _infixes :: Map.Map Var.Canonical (Decl.Assoc, Int)
3436 }
3537
3638
@@ -38,12 +40,12 @@ type Dict a =
3840 Map.Map String (Set.Set a)
3941
4042
41−fromPatches :: ModuleName.Canonical -> [Patch] -> Environment
43+fromPatches :: ModuleName.Canonical -> [Patch] -> Env
4244fromPatches 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)
4446
4547
46−addPattern :: P.Pattern ann var -> Environment -> Environment
48+addPattern :: P.Pattern ann var -> Env -> Env
4749addPattern pattern env =
4850 let
4951 patches =
@@ -52,7 +54,7 @@ addPattern pattern env =
5254 addPatches patches env
5355
5456
55−getPackage :: Environment -> Pkg.Name
57+getPackage :: Env -> Pkg.Name
5658getPackage env =
5759 ModuleName._package (_home env)
5860
@@ -66,18 +68,19 @@ data Patch
6668 | Union String Var.Canonical
6769 | Alias String (Var.Canonical, [String], Type.Canonical)
6870 | Pattern String (Var.Canonical, Int)
71+ | Infix Var.Canonical Decl.Assoc Int
6972
7073
7174
7275-- ADD PATCH TO ENVIRONMENT
7376
7477
75−addPatches :: [Patch] -> Environment -> Environment
78+addPatches :: [Patch] -> Env -> Env
7679addPatches patches env =
7780 List.foldl' (flip addPatch) env patches
7881
7982
80−addPatch :: Patch -> Environment -> Environment
83+addPatch :: Patch -> Env -> Env
8184addPatch patch env =
8285 case patch of
8386 Value name var ->
@@ -92,6 +95,9 @@ addPatch patch env =
9295 Pattern name var ->
9396 env { _patterns = insert name var (_patterns env) }
9497
98+ Infix name assoc prec ->
99+ env { _infixes = Map.insert name (assoc, prec) (_infixes env) }
100+
95101
96102insert :: (Ord a) => String -> a -> Dict a -> Dict a
97103insert key value =
@@ -131,8 +137,8 @@ builtinPatches =
131137-- TO TYPE DEALIASER
132138
133139
134−toDealiaser :: Environment -> Map.Map String String
135−toDealiaser (Env _ _ unions aliases _) =
140+toDealiaser :: Env -> Map.Map String String
141+toDealiaser (Env _ _ unions aliases _ _) =
136142 let
137143 dealiasUnion (localName, canonicalSet) =
138144 case Set.toList canonicalSet of
src/Canonicalize/Setup.hs+22−13
@@ -6,11 +6,10 @@ import Control.Monad (foldM)
66import qualified Data.Graph as Graph
77import qualified Data.Map as Map
88import qualified Data.Maybe as Maybe
9−import qualified Data.Traversable as Trav
109
1110import qualified AST.Declaration as D
1211import qualified AST.Effects as Effects
13−import qualified AST.Expression.Valid as Valid
12+import qualified AST.Expression.Source as Src
1413import qualified AST.Module as Module
1514import qualified AST.Module.Name as ModuleName
1615import qualified AST.Pattern as P
@@ -32,7 +31,7 @@ environment
3231 :: Map.Map ModuleName.Raw ModuleName.Canonical
3332 -> Module.Interfaces
3433 -> Module.Valid
35− -> Result Env.Environment
34+ -> Result Env.Env
3635environment importDict interfaces (Module.Module name _ info) =
3736 let
3837 (Module.Valid _ _ (defaults, imports) decls effects) =
@@ -42,7 +41,7 @@ environment importDict interfaces (Module.Module name _ info) =
4241 imports ++ map (A.A (error "default import not found")) defaults
4342
4443 getImportPatches =
45− Trav.traverse (importToPatches importDict interfaces) allImports
44+ traverse (importToPatches importDict interfaces) allImports
4645
4746 (typeAliasNodes, declPatches) =
4847 declsToPatches name decls
@@ -99,6 +98,9 @@ importToPatches importDict allInterfaces (A.A region (rawImportName, method)) =
9998 qualifier =
10099 maybe (ModuleName.toString rawImportName) id maybeAlias
101100
101+ infixPatches =
102+ map (infixToPatch (Var.fromModule importName)) (Module.iFixities interface)
103+
102104 qualifiedPatches =
103105 interfaceToPatches importName (qualifier ++ ".") interface
104106
@@ -107,9 +109,9 @@ importToPatches importDict allInterfaces (A.A region (rawImportName, method)) =
107109 Result.ok (interfaceToPatches importName "" interface)
108110
109111 else
110− concat <$> Trav.traverse (valueToPatches region importName interface) exposedValues
112+ concat <$> traverse (valueToPatches region importName interface) exposedValues
111113 in
112− (++) qualifiedPatches <$> unqualifiedPatches
114+ (++) (infixPatches ++ qualifiedPatches) <$> unqualifiedPatches
113115
114116
115117interfaceToPatches :: ModuleName.Canonical -> String -> Module.Interface -> [Env.Patch]
@@ -218,7 +220,7 @@ valueToPatches region moduleName interface value =
218220 Result.ok realCtorList
219221
220222 else
221− Trav.traverse ctorExists givenCtorNames
223+ traverse ctorExists givenCtorNames
222224 where
223225 realCtorList =
224226 map (second length) realCtors
@@ -270,16 +272,16 @@ node region name tvars alias =
270272 maybe [] edges ext ++ concatMap (edges . snd) fs
271273
272274
273−addTypeAliases :: ModuleName.Canonical -> [Node] -> Env.Environment -> Result Env.Environment
275+addTypeAliases :: ModuleName.Canonical -> [Node] -> Env.Env -> Result Env.Env
274276addTypeAliases moduleName typeAliasNodes initialEnv =
275277 foldM (addTypeAlias moduleName) initialEnv (Graph.stronglyConnComp typeAliasNodes)
276278
277279
278280addTypeAlias
279281 :: ModuleName.Canonical
280− -> Env.Environment
282+ -> Env.Env
281283 -> Graph.SCC (R.Region, String, [String], Type.Raw)
282− -> Result Env.Environment
284+ -> Result Env.Env
283285addTypeAlias moduleName env scc =
284286 case scc of
285287 Graph.AcyclicSCC (_, name, tvars, alias) ->
@@ -314,7 +316,7 @@ addTypeAlias moduleName env scc =
314316
315317-}
316318declsToPatches :: ModuleName.Canonical -> D.Valid -> ([Node], [Env.Patch])
317−declsToPatches moduleName (D.Decls defs unions aliases _) =
319+declsToPatches moduleName (D.Decls defs unions aliases infixes) =
318320 let
319321
320322 -- HELPERS
@@ -327,7 +329,7 @@ declsToPatches moduleName (D.Decls defs unions aliases _) =
327329
328330 -- TO PATCHES
329331
330− defToPatches (A.A _ (Valid.Def _ pattern _ _)) =
332+ defToPatches (A.A _ (Src.Def _ pattern _ _)) =
331333 map topLevelValue (P.boundVarList pattern)
332334
333335 unionToPatches (A.A _ (D.Type name _ ctors)) =
@@ -352,13 +354,20 @@ declsToPatches moduleName (D.Decls defs unions aliases _) =
352354 map aliasToNode aliases
353355 ,
354356 concat
355− [ Maybe.mapMaybe aliasToPatches aliases
357+ [ map (infixToPatch (Var.topLevel moduleName)) infixes
358+ , Maybe.mapMaybe aliasToPatches aliases
356359 , concatMap unionToPatches unions
357360 , concatMap defToPatches defs
358361 ]
359362 )
360363
361364
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+
362371-- EFFECTS TO PATCHES
363372
364373
src/Canonicalize/Sort.hs+51−52
@@ -7,8 +7,7 @@ import qualified Data.Map as Map
77import qualified Data.Maybe as Maybe
88import qualified Data.Set as Set
99
10−import AST.Expression.General (Expr'(..))
11−import qualified AST.Expression.Canonical as Canonical
10+import qualified AST.Expression.Canonical as C
1211import qualified AST.Pattern as P
1312import qualified AST.Variable as V
1413import qualified Reporting.Annotation as A
@@ -20,7 +19,7 @@ import qualified Reporting.Result as R
2019-- SORT DEFINITIONS
2120
2221
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
2423definitions expression =
2524 let
2625 (R.Result _ warnings answer) =
@@ -89,79 +88,79 @@ delay (R.Result (LocalVars immediate delayed tags) warnings result) =
8988-- REORDER EXPRESSIONS
9089
9190
92−reorder :: Canonical.Expr -> R.Result LocalVars w E.Error Canonical.Expr
91+reorder :: C.Expr -> R.Result LocalVars w E.Error C.Expr
9392reorder (A.A region expression) =
9493 A.A region <$>
9594 case expression of
96− Var var ->
95+ C.Var var ->
9796 addImmediate var expression
9897
99− Lambda pattern body ->
98+ C.Lambda pattern body ->
10099 delay $
101− bindingReorder Lambda (pattern, body)
100+ bindingReorder C.Lambda (pattern, body)
102101
103− Binop op leftExpr rightExpr ->
104− do binop <- Binop op <$> reorder leftExpr <*> reorder rightExpr
102+ C.Binop op leftExpr rightExpr ->
103+ do binop <- C.Binop op <$> reorder leftExpr <*> reorder rightExpr
105104 addImmediate op binop
106105
107− Case expr cases ->
108− Case <$> reorder expr <*> traverse (bindingReorder (,)) cases
106+ C.Case expr cases ->
107+ C.Case <$> reorder expr <*> traverse (bindingReorder (,)) cases
109108
110− Data name exprs ->
111− addTag name =<< (Data name <$> traverse reorder exprs)
109+ C.Ctor name exprs ->
110+ addTag name =<< (C.Ctor name <$> traverse reorder exprs)
112111
113112 -- Just pipe the reorder though
114− Literal _ ->
113+ C.Literal _ ->
115114 return expression
116115
117− ExplicitList es ->
118− ExplicitList <$> traverse reorder es
116+ C.List es ->
117+ C.List <$> traverse reorder es
119118
120− App func arg ->
121− App <$> reorder func <*> reorder arg
119+ C.App func arg ->
120+ C.App <$> reorder func <*> reorder arg
122121
123− If branches finally ->
124− If
122+ C.If branches finally ->
123+ C.If
125124 <$> traverse (\(cond,branch) -> (,) <$> reorder cond <*> reorder branch) branches
126125 <*> reorder finally
127126
128− Access record field ->
129− Access
127+ C.Access record field ->
128+ C.Access
130129 <$> reorder record
131130 <*> return field
132131
133− Update record fields ->
134− Update
132+ C.Update record fields ->
133+ C.Update
135134 <$> reorder record
136135 <*> traverse (traverse reorder) fields
137136
138− Record fields ->
139− Record
137+ C.Record fields ->
138+ C.Record
140139 <$> traverse (traverse reorder) fields
141140
142− Cmd _ ->
141+ C.Cmd _ ->
143142 return expression
144143
145− Sub _ ->
144+ C.Sub _ ->
146145 return expression
147146
148− OutgoingPort _ _ ->
147+ C.OutgoingPort _ _ ->
149148 return expression
150149
151− IncomingPort _ _ ->
150+ C.IncomingPort _ _ ->
152151 return expression
153152
154− Program _ _ ->
153+ C.Program _ _ ->
155154 error "DANGER - Program AST nodes should not be in def sorting."
156155
157− SaveEnv _ _ ->
156+ C.SaveEnv _ _ ->
158157 return expression
159158
160− GLShader _ _ _ ->
159+ C.GLShader _ _ _ ->
161160 return expression
162161
163162 -- Actually do some reordering
164− Let defs body ->
163+ C.Let defs body ->
165164 case reorderDefs defs of
166165 R.Result () warnings (R.Err errors) ->
167166 R.Result mempty warnings (R.Err errors)
@@ -171,7 +170,7 @@ reorder (A.A region expression) =
171170 do _ <- R.Result mempty warnings (R.Ok ())
172171 newBody <- reorder body
173172 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
175174
176175
177176
@@ -179,8 +178,8 @@ reorder (A.A region expression) =
179178
180179
181180bindingReorder
182− :: (P.Canonical -> Canonical.Expr -> a)
183− -> (P.Canonical, Canonical.Expr)
181+ :: (P.Canonical -> C.Expr -> a)
182+ -> (P.Canonical, C.Expr)
184183 -> R.Result LocalVars w E.Error a
185184bindingReorder func (pattern, expr) =
186185 do answer <- func pattern <$> capture pattern (reorder expr)
@@ -238,8 +237,8 @@ getPatternTags (A.A _ pattern) =
238237
239238
240239reorderDefs
241− :: [Canonical.Def]
242− -> R.Result () w E.Error (Set.Set String, [[Canonical.Def]], LocalVars)
240+ :: [C.Def]
241+ -> R.Result () w E.Error (Set.Set String, [[C.Def]], LocalVars)
243242reorderDefs defs =
244243 do rawNodes <- sequenceA $ zipWith toRawNode [0..] defs
245244 let boundVarDict = toBoundVarDict rawNodes
@@ -247,25 +246,25 @@ reorderDefs defs =
247246 return $ groupDefs boundVarDict rawNodes
248247
249248
250−toRawNode :: Int -> Canonical.Def -> R.Result () w E.Error (Canonical.Def, Int, LocalVars)
251−toRawNode index (Canonical.Def region pattern body maybeType) =
249+toRawNode :: Int -> C.Def -> R.Result () w E.Error (C.Def, Int, LocalVars)
250+toRawNode index (C.Def region pattern body maybeType) =
252251 let
253252 (R.Result localVars warnings answer) =
254253 addPatternTags pattern =<< reorder body
255254
256255 toRawNodeHelp newBody =
257− ( Canonical.Def region pattern newBody maybeType, index, localVars )
256+ ( C.Def region pattern newBody maybeType, index, localVars )
258257 in
259258 toRawNodeHelp <$> R.Result () warnings answer
260259
261260
262−toBoundVarDict :: [(Canonical.Def, Int, a)] -> Map.Map String Int
261+toBoundVarDict :: [(C.Def, Int, a)] -> Map.Map String Int
263262toBoundVarDict defAndDeps =
264263 Map.fromList (concatMap toBoundVarDictHelp defAndDeps)
265264
266265
267−toBoundVarDictHelp :: (Canonical.Def, Int, a) -> [(String, Int)]
268−toBoundVarDictHelp (Canonical.Def _ pattern _ _, key, _) =
266+toBoundVarDictHelp :: (C.Def, Int, a) -> [(String, Int)]
267+toBoundVarDictHelp (C.Def _ pattern _ _, key, _) =
269268 map (\(A.A _ name) -> (name, key)) (P.boundVars pattern)
270269
271270
@@ -276,8 +275,8 @@ toBoundVarDictHelp (Canonical.Def _ pattern _ _, key, _) =
276275toNode
277276 :: (deps -> [String])
278277 -> Map.Map String Int
279− -> (Canonical.Def, Int, deps)
280− -> (Canonical.Def, Int, [Int])
278+ -> (C.Def, Int, deps)
279+ -> (C.Def, Int, [Int])
281280toNode toVars boundVarDict (def, index, deps) =
282281 let
283282 localDeps =
@@ -302,7 +301,7 @@ allVars (LocalVars immediate delayed tags) =
302301
303302detectLoops
304303 :: Map.Map String Int
305− -> [(Canonical.Def, Int, LocalVars)]
304+ -> [(C.Def, Int, LocalVars)]
306305 -> R.Result () w E.Error ()
307306detectLoops boundVarDict rawNodes =
308307 F.traverse_ detectLoopsHelp $
@@ -310,7 +309,7 @@ detectLoops boundVarDict rawNodes =
310309 map (toNode immediateOnly boundVarDict) rawNodes
311310
312311
313−detectLoopsHelp :: Graph.SCC Canonical.Def -> R.Result () w E.Error ()
312+detectLoopsHelp :: Graph.SCC C.Def -> R.Result () w E.Error ()
314313detectLoopsHelp scc =
315314 case scc of
316315 Graph.AcyclicSCC _ ->
@@ -321,7 +320,7 @@ detectLoopsHelp scc =
321320 [] ->
322321 R.ok ()
323322
324− def@(Canonical.Def region (A.A nameRegion _) _ _) : rest ->
323+ def@(C.Def region (A.A nameRegion _) _ _) : rest ->
325324 R.throw region $ E.BadRecursion nameRegion def rest
326325
327326
@@ -331,8 +330,8 @@ detectLoopsHelp scc =
331330
332331groupDefs
333332 :: Map.Map String Int
334− -> [(Canonical.Def, Int, LocalVars)]
335− -> ( Set.Set String, [[Canonical.Def]], LocalVars )
333+ -> [(C.Def, Int, LocalVars)]
334+ -> ( Set.Set String, [[C.Def]], LocalVars )
336335groupDefs boundVarDict rawNodes =
337336 let
338337 allLocalVars =
src/Canonicalize/Type.hs+3−3
@@ -15,7 +15,7 @@ import qualified Canonicalize.Variable as Canonicalize
1515import Canonicalize.Variable (Result)
1616
1717
18−tipe :: Env.Environment -> T.Raw -> Result T.Canonical
18+tipe :: Env.Env -> T.Raw -> Result T.Canonical
1919tipe env annType@(A.A _ typ) =
2020 let
2121 go =
@@ -41,7 +41,7 @@ tipe env annType@(A.A _ typ) =
4141 T.Record <$> Trav.traverse goSnd fields <*> Trav.traverse go ext
4242
4343
44−canonicalizeApp :: Env.Environment -> T.Raw -> [T.Raw] -> Result T.Canonical
44+canonicalizeApp :: Env.Env -> T.Raw -> [T.Raw] -> Result T.Canonical
4545canonicalizeApp env annFunc@(A.A region func) args =
4646 case func of
4747 T.RType (Var.Raw rawName) ->
@@ -69,7 +69,7 @@ canonicalizeApp env annFunc@(A.A region func) args =
6969
7070canonicalizeAlias
7171 :: R.Region
72− -> Env.Environment
72+ -> Env.Env
7373 -> (Var.Canonical, [String], T.Canonical)
7474 -> [T.Raw]
7575 -> Result T.Canonical
src/Canonicalize/Variable.hs+5−16
@@ -45,7 +45,7 @@ logVar var =
4545-- FINDERS
4646
4747
48−variable :: R.Region -> Env.Environment -> String -> Result Var.Canonical
48+variable :: R.Region -> Env.Env -> String -> Result Var.Canonical
4949variable region env var =
5050 case toVarName var of
5151 Right (name, varName) | ModuleName.isNative name ->
@@ -72,7 +72,7 @@ variable region env var =
7272
7373tvar
7474 :: R.Region
75− -> Env.Environment
75+ -> Env.Env
7676 -> String
7777 -> Result
7878 (Either
@@ -97,12 +97,7 @@ tvar region env var =
9797 Right (v,_,_) -> v
9898
9999
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
106101pvar region env var actualArgs =
107102 case Set.toList <$> Map.lookup var (Env._patterns env) of
108103 Just [value] ->
@@ -126,20 +121,14 @@ pvar region env var actualArgs =
126121-- FOUND
127122
128123
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
136125preferLocals region env =
137126 preferLocals' region env id
138127
139128
140129preferLocals'
141130 :: R.Region
142− -> Env.Environment
131+ -> Env.Env
143132 -> (a -> Var.Canonical)
144133 -> String
145134 -> [a]
src/Compile.hs+11−19
@@ -1,19 +1,15 @@
1+{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
12module Compile (compile) where
23
3−import qualified Data.Map as Map
4−
5−import qualified AST.Declaration as D
64import qualified AST.Expression.Canonical as Can
75import qualified AST.Module as Module
86import qualified AST.Module.Name as ModuleName
97import qualified Canonicalize
10−import Elm.Utils ((|>))
118import qualified Elm.Package as Package
129import qualified Nitpick.PatternMatches as Nitpick
1310import qualified Nitpick.TopLevelTypes as Nitpick
1411import qualified Optimize
15−import qualified Parse.Helpers as Parse
16−import qualified Parse.Parse as Parse
12+import qualified Parse.Parse as Parse (program)
1713import qualified Reporting.Error as Error
1814import qualified Reporting.Render.Type as RenderType
1915import qualified Reporting.Result as Result
@@ -36,8 +32,9 @@ compile packageName canonicalImports interfaces source =
3632 do
3733 -- Parse the source code
3834 validModule <-
39− Result.format Error.Syntax $ {-# SCC elm_compiler_parse #-}
40− Parse.program packageName (getOpTable interfaces) source
35+ Result.format Error.Syntax $
36+ {-# SCC elm_compiler_parse #-}
37+ Parse.program packageName source
4138
4239 -- Canonicalize all variables, pinning down where they came from.
4340 canonicalModule <-
@@ -45,7 +42,8 @@ compile packageName canonicalImports interfaces source =
4542
4643 -- Run type inference on the program.
4744 types <-
48− Result.from Error.Type $ {-# SCC elm_compiler_types #-}
45+ Result.from Error.Type $
46+ {-# SCC elm_compiler_types #-}
4947 TI.infer interfaces canonicalModule
5048
5149 -- One last round of checks
@@ -55,11 +53,13 @@ compile packageName canonicalImports interfaces source =
5553 Can.toSortedDefs (Module.program (Module.info canonicalModule))
5654
5755 tagDict <-
58− Result.format Error.Pattern $ {-# SCC elm_compiler_exhaustiveness #-}
56+ Result.format Error.Pattern $
57+ {-# SCC elm_compiler_exhaustiveness #-}
5958 Nitpick.patternMatches interfaces canonicalModule
6059
6160 -- Do some basic optimizations
62− let optimisedDefs = {-# SCC elm_compiler_optimization #-}
61+ let optimisedDefs =
62+ {-# SCC elm_compiler_optimization #-}
6363 Optimize.optimize tagDict (Module.name canonicalModule) canonicalDefs
6464
6565 -- Add the real list of types
@@ -70,11 +70,3 @@ compile packageName canonicalImports interfaces source =
7070 }
7171
7272 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
1313import Elm.Utils ((|>))
1414import Parse.Binop (infixOp)
1515import Parse.Helpers
16− ( addLocation, anyUntil, commaSep1, iParse, parens, simpleNewline
16+ ( addLocation, anyUntil, commaSep1, parens, parse, simpleNewline
1717 , var, whitespace
1818 )
1919import qualified Reporting.Annotation as A
@@ -166,7 +166,7 @@ commentedNames (R.Region start _) comment =
166166 do setPosition (newPos "docs" (R.line start) (R.column start + 3))
167167 concat <$> many nameParser
168168 in
169− case iParse docCommentParser comment of
169+ case parse docCommentParser comment of
170170 Left _ ->
171171 []
172172
src/Elm/Compiler.hs+17−10
@@ -13,6 +13,7 @@ import qualified Data.Aeson as Json
1313import qualified Data.Map as Map
1414import qualified Data.Text.Lazy as LazyText
1515import System.IO (Handle)
16+import qualified Text.Parsec.Error as Parsec
1617
1718import qualified AST.Module as Module
1819import qualified AST.Module.Name as ModuleName
@@ -24,11 +25,13 @@ import qualified Elm.Compiler.Version
2425import qualified Elm.Docs as Docs
2526import qualified Elm.Package as Package
2627import qualified Generate.JavaScript as JS
27−import qualified Parse.Module as Parse
28−import qualified Parse.Parse as Parse
28+import qualified Parse.Helpers as Parse (parse)
29+import qualified Parse.Module as Parse (header)
2930import qualified Reporting.Annotation as A
3031import qualified Reporting.Bag as Bag
3132import qualified Reporting.Error as Error
33+import qualified Reporting.Error.Syntax as SyntaxError
34+import qualified Reporting.Region as Region
3235import qualified Reporting.Render.Type as RenderType
3336import qualified Reporting.Report as Report
3437import qualified Reporting.Result as Result
@@ -57,13 +60,19 @@ data Tag
5760parseDependencies
5861 :: Package.Name
5962 -> String
60− -> Either [Error] (Tag, PublicModule.Raw, [PublicModule.Raw])
63+ -> Either Error (Tag, PublicModule.Raw, [PublicModule.Raw])
6164parseDependencies pkgName sourceCode =
62− let
63− (Result.Result _ _ answer) =
64− Parse.parse sourceCode Parse.header
65− in
66− Result.answerToEither (Error . A.map Error.Syntax) (getDeps pkgName) answer
65+ case Parse.parse Parse.header sourceCode of
66+ Right header ->
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))
6776
6877
6978getDeps
@@ -202,5 +211,3 @@ printWarning handle (Localizer localizer) location source (Warning (A.A region w
202211warningToJson :: Localizer -> String -> Warning -> Json.Value
203212warningToJson (Localizer localizer) location (Warning wrn) =
204213 Warning.toJson localizer location wrn
205−
206−
src/Elm/Compiler/Type.hs+2−2
@@ -158,8 +158,8 @@ instance Json.FromJSON Type where
158158 in
159159 case value of
160160 Json.String text ->
161− either failure (return . fromRawType)
162− (Parse.iParse Type.expr (replacePrimes (Text.unpack text)))
161+ either failure (return . fromRawType) $
162+ Parse.parse Type.expr (replacePrimes (Text.unpack text))
163163
164164 Json.Object obj ->
165165 fromObject obj
src/Elm/Utils.hs+2−2
@@ -99,8 +99,8 @@ missingExe command =
9999-- DECL CHECKER
100100
101101isDeclaration :: String -> Maybe String
102−isDeclaration string =
103− case Parse.iParse Parse.def string of
102+isDeclaration str =
103+ case Parse.parse Parse.def str of
104104 Right (A.A _ (Source.Definition pattern _)) ->
105105 Just (List.intercalate "$" (Pattern.boundVarList pattern))
106106
src/Generate/JavaScript/Expression.hs+9−10
@@ -6,11 +6,10 @@ import qualified Data.List as List
66import qualified Data.Map as Map
77import Language.ECMAScript3.Syntax
88
9−import AST.Expression.General as Expr (Main(..))
9+import qualified AST.Expression.Canonical as Can
1010import AST.Expression.Optimized as Opt
1111import qualified AST.Literal as L
1212import qualified AST.Module.Name as ModuleName
13−import qualified AST.Type as Type
1413import qualified AST.Variable as Var
1514import Generate.JavaScript.Helpers as Help
1615import qualified Generate.JavaScript.BuiltIn as BuiltIn
@@ -169,11 +168,11 @@ generateCode expr =
169168 Case exprName decider jumps ->
170169 JsBlock <$> generateCase exprName decider jumps
171170
172− ExplicitList elements ->
171+ List elements ->
173172 do jsElements <- mapM generateJsExpr elements
174173 jsExpr $ BuiltIn.list jsElements
175174
176− Data tag members ->
175+ Ctor tag members ->
177176 let
178177 ctor =
179178 "ctor" ==> StringLit () tag
@@ -184,7 +183,7 @@ generateCode expr =
184183 do jsMembers <- mapM generateJsExpr members
185184 jsExpr $ ObjectLit () (ctor : zipWith toEntry jsMembers [ 0 :: Int .. ])
186185
187− DataAccess dataExpr index ->
186+ CtorAccess dataExpr index ->
188187 do jsDataExpr <- generateJsExpr dataExpr
189188 jsExpr $ DotRef () jsDataExpr (var ("_" ++ show index))
190189
@@ -216,18 +215,18 @@ generateCode expr =
216215-- PROGRAMS
217216
218217
219−generateProgram :: Expr.Main Type.Canonical -> Opt.Expr -> State Int Code
218+generateProgram :: Can.Main -> Opt.Expr -> State Int Code
220219generateProgram kind body =
221220 case kind of
222− Expr.VDom ->
221+ Can.VDom ->
223222 do html <- generateJsExpr body
224223 jsExpr (Var.staticProgram <| html)
225224
226− Expr.NoFlags ->
225+ Can.NoFlags ->
227226 do almostProgram <- generateJsExpr body
228227 jsExpr (almostProgram `call` [])
229228
230− Expr.Flags tipe ->
229+ Can.Flags tipe ->
231230 do almostProgram <- generateJsExpr body
232231 flagDecoder <- generateJsExpr (Foreign.decode tipe)
233232 jsExpr (almostProgram <| flagDecoder)
@@ -537,7 +536,7 @@ pathToExpr root fullPath =
537536 go expr path =
538537 case path of
539538 DT.Position index subpath ->
540− go (Opt.DataAccess expr index) subpath
539+ go (Opt.CtorAccess expr index) subpath
541540
542541 DT.Field field subpath ->
543542 go (Opt.Access expr field) subpath
src/Generate/JavaScript/Foreign.hs+3−3
@@ -182,7 +182,7 @@ toMaybe tipe =
182182 Opt.Var (Var.inCore ["Maybe"] tag)
183183 in
184184 to "oneOf" <==
185− [ Opt.ExplicitList
185+ [ Opt.List
186186 [ to "null" <== [ maybe "Nothing" ]
187187 , to "map" <== [ maybe "Just", decode tipe ]
188188 ]
@@ -191,7 +191,7 @@ toMaybe tipe =
191191
192192toTuple0 :: Opt.Expr
193193toTuple0 =
194− to "null" <== [ Opt.Data "_Tuple0" [] ]
194+ to "null" <== [ Opt.Ctor "_Tuple0" [] ]
195195
196196
197197toTuple :: [T.Canonical] -> Opt.Expr
@@ -208,7 +208,7 @@ toTuple types =
208208
209209 makeTuple =
210210 to "succeed" <==
211− [ Opt.Data
211+ [ Opt.Ctor
212212 ("_Tuple" ++ show size)
213213 (map (Opt.Var . Var.local . toVar . fst) pairs)
214214 ]
src/Nitpick/PatternMatches.hs+23−24
@@ -6,8 +6,7 @@ import qualified Data.Map as Map
66import qualified Data.Maybe as Maybe
77import qualified Data.Set as Set
88
9−import qualified AST.Expression.General as E
10−import qualified AST.Expression.Canonical as Canonical
9+import qualified AST.Expression.Canonical as C
1110import qualified AST.Helpers as Help
1211import qualified AST.Module as Module
1312import qualified AST.Module.Name as ModuleName
@@ -119,7 +118,7 @@ lookupOtherTags (Var.Canonical home name) tagDict =
119118-- CHECK EXPRESSIONS
120119
121120
122−checkExpression :: TagDict -> Canonical.Expr -> Result wrn ()
121+checkExpression :: TagDict -> C.Expr -> Result wrn ()
123122checkExpression tagDict (A.A region expression) =
124123 let
125124 go =
@@ -129,74 +128,74 @@ checkExpression tagDict (A.A region expression) =
129128 go a <* go b
130129 in
131130 case expression of
132− E.Literal _ ->
131+ C.Literal _ ->
133132 Result.ok ()
134133
135− E.Var _ ->
134+ C.Var _ ->
136135 Result.ok ()
137136
138− E.ExplicitList listExprs ->
137+ C.List listExprs ->
139138 F.traverse_ go listExprs
140139
141− E.Binop _ leftExpr rightExpr ->
140+ C.Binop _ leftExpr rightExpr ->
142141 go2 leftExpr rightExpr
143142
144− E.Lambda pattern@(A.A patRegion _) body ->
143+ C.Lambda pattern@(A.A patRegion _) body ->
145144 checkPatterns tagDict patRegion Error.Arg [pattern]
146145 <* go body
147146
148− E.App func arg ->
147+ C.App func arg ->
149148 go2 func arg
150149
151− E.If branches finally ->
150+ C.If branches finally ->
152151 F.traverse_ (uncurry go2) branches
153152 <* go finally
154153
155− E.Let defs body ->
154+ C.Let defs body ->
156155 go body
157156 <* F.traverse_ goDef defs
158157 where
159− goDef (Canonical.Def _ pattern@(A.A patRegion _) expr _) =
158+ goDef (C.Def _ pattern@(A.A patRegion _) expr _) =
160159 checkPatterns tagDict patRegion Error.LetBound [pattern]
161160 <* go expr
162161
163− E.Case expr branches ->
162+ C.Case expr branches ->
164163 go expr
165164 <* checkPatterns tagDict region Error.Case (map fst branches)
166165 <* F.traverse_ (go . snd) branches
167166
168− E.Data _ctor exprs ->
167+ C.Ctor _ctor exprs ->
169168 F.traverse_ go exprs
170169
171− E.Access record _field ->
170+ C.Access record _field ->
172171 go record
173172
174− E.Update record fields ->
173+ C.Update record fields ->
175174 go record
176175 <* F.traverse_ (go . snd) fields
177176
178− E.Record fields ->
177+ C.Record fields ->
179178 F.traverse_ (go . snd) fields
180179
181− E.Cmd _ ->
180+ C.Cmd _ ->
182181 Result.ok ()
183182
184− E.Sub _ ->
183+ C.Sub _ ->
185184 Result.ok ()
186185
187− E.OutgoingPort _ _ ->
186+ C.OutgoingPort _ _ ->
188187 Result.ok ()
189188
190− E.IncomingPort _ _ ->
189+ C.IncomingPort _ _ ->
191190 Result.ok ()
192191
193− E.Program _ _ ->
192+ C.Program _ _ ->
194193 error "DANGER - Program AST nodes should not be in Nitpick.PatternMatches."
195194
196− E.SaveEnv _ _ ->
195+ C.SaveEnv _ _ ->
197196 Result.ok ()
198197
199− E.GLShader _ _ _ ->
198+ C.GLShader _ _ _ ->
200199 Result.ok ()
201200
202201
src/Nitpick/TopLevelTypes.hs+4−5
@@ -6,7 +6,6 @@ import Data.Map ((!))
66import qualified Data.Map as Map
77
88import qualified AST.Expression.Canonical as Can
9−import qualified AST.Expression.General as Expr
109import qualified AST.Module.Name as ModuleName
1110import qualified AST.Pattern as P
1211import qualified AST.Type as Type
@@ -88,21 +87,21 @@ checkMain typeEnv (Can.Def facts pattern@(A.A region _) body maybeType) =
8887 case Type.deepDealias mainType of
8988 Type.App name [_]
9089 | name == vdomNode ->
91− return Expr.VDom
90+ return Can.VDom
9291
9392 Type.App name [flags, _, _]
9493 | name == program && flags == never ->
95− return Expr.NoFlags
94+ return Can.NoFlags
9695
9796 | name == program ->
98− return (Expr.Flags flags)
97+ return (Can.Flags flags)
9998 <* Effects.checkPortType makeError flags
10099
101100 _ ->
102101 Result.throw region (Error.BadMain mainType)
103102 in
104103 do kind <- getMainKind
105− let newBody = A.A undefined (Expr.Program kind body)
104+ let newBody = A.A undefined (Can.Program kind body)
106105 return (Can.Def facts pattern newBody maybeType)
107106
108107
src/Optimize.hs+37−38
@@ -4,7 +4,6 @@ import qualified Control.Monad as M
44import qualified Data.Map as Map
55import qualified Data.Traversable as T
66
7−import qualified AST.Expression.General as Expr
87import qualified AST.Expression.Canonical as Can
98import qualified AST.Expression.Optimized as Opt
109import qualified AST.Module.Name as ModuleName
@@ -35,7 +34,7 @@ optimizeDef :: Bool -> Can.Def -> Env.Optimizer [Opt.Def]
3534optimizeDef isRoot (Can.Def _ pattern expression _) =
3635 let
3736 (args, canBody) =
38− Expr.collectLambdas expression
37+ Can.collectLambdas expression
3938
4039 maybeGetHome =
4140 if isRoot then
@@ -161,7 +160,7 @@ patternToSubstitutions expr (A.A _ pattern) =
161160 (alias, expr) : patternToSubstitutions expr realPattern
162161
163162 P.Data _ patterns ->
164− concat (zipWith (patternToSubstitutions . Opt.DataAccess expr) [0..] patterns)
163+ concat (zipWith (patternToSubstitutions . Opt.CtorAccess expr) [0..] patterns)
165164
166165
167166
@@ -190,10 +189,10 @@ optimizeExpr context annExpr@(A.A region expression) =
190189 -- expressions that cannot be turned into tail calls
191190 in
192191 case expression of
193− Expr.Literal lit ->
192+ Can.Literal lit ->
194193 pure (Opt.Literal lit)
195194
196− Expr.Var name ->
195+ Can.Var name ->
197196 if name == Var.inCore ["Debug"] "crash" then
198197 do home <- Env.getHome
199198 pure (Opt.Crash home region Nothing)
@@ -201,24 +200,24 @@ optimizeExpr context annExpr@(A.A region expression) =
201200 else
202201 pure (Opt.Var name)
203202
204− Expr.ExplicitList elements ->
205− Opt.ExplicitList
203+ Can.List elements ->
204+ Opt.List
206205 <$> T.traverse justConvert elements
207206
208− Expr.Binop op leftExpr rightExpr ->
207+ Can.Binop op leftExpr rightExpr ->
209208 optimizeBinop context region op leftExpr rightExpr
210209
211− Expr.Lambda _ _ ->
210+ Can.Lambda _ _ ->
212211 let
213212 (patterns, body) =
214− Expr.collectLambdas annExpr
213+ Can.collectLambdas annExpr
215214 in
216215 uncurry Opt.Function <$> optimizeFunction Nothing patterns body
217216
218− Expr.App _ _ ->
217+ Can.App _ _ ->
219218 let
220219 (func:args) =
221− Expr.collectApps annExpr
220+ Can.collectApps annExpr
222221 in
223222 case isTailCall context func (length args) of
224223 Just (name, argNames) ->
@@ -233,7 +232,7 @@ optimizeExpr context annExpr@(A.A region expression) =
233232 Env.setTailCall hasTailCall
234233 return (Opt.Call optFunc optArgs)
235234
236− Expr.If branches finally ->
235+ Can.If branches finally ->
237236 let
238237 crawlBranch (cond,branch) =
239238 (,) <$> justConvert cond <*> keepLooking branch
@@ -242,11 +241,11 @@ optimizeExpr context annExpr@(A.A region expression) =
242241 <$> T.traverse crawlBranch branches
243242 <*> keepLooking finally
244243
245− Expr.Let defs body ->
244+ Can.Let defs body ->
246245 do optDefs <- concat <$> T.traverse (optimizeDef False) defs
247246 Opt.Let optDefs <$> keepLooking body
248247
249− Expr.Case expr branches ->
248+ Can.Case expr branches ->
250249 do optExpr <- optimizeExpr Nothing expr
251250 variantDict <- Env.getVariantDict
252251
@@ -255,42 +254,42 @@ optimizeExpr context annExpr@(A.A region expression) =
255254 let optCase = Case.optimize variantDict name optBranches
256255 return $ Opt.Let [ Opt.Def Opt.dummyFacts name optExpr ] optCase
257256
258− Expr.Data name exprs ->
259− Opt.Data name <$> T.traverse justConvert exprs
257+ Can.Ctor name exprs ->
258+ Opt.Ctor name <$> T.traverse justConvert exprs
260259
261− Expr.Access record field ->
260+ Can.Access record field ->
262261 Opt.Access
263262 <$> justConvert record
264263 <*> pure field
265264
266− Expr.Update record fields ->
265+ Can.Update record fields ->
267266 Opt.Update
268267 <$> justConvert record
269268 <*> T.traverse (mapSnd justConvert) fields
270269
271− Expr.Record fields ->
270+ Can.Record fields ->
272271 Opt.Record
273272 <$> T.traverse (mapSnd justConvert) fields
274273
275− Expr.Cmd moduleName ->
274+ Can.Cmd moduleName ->
276275 pure (Opt.Cmd moduleName)
277276
278− Expr.Sub moduleName ->
277+ Can.Sub moduleName ->
279278 pure (Opt.Sub moduleName)
280279
281− Expr.OutgoingPort name tipe ->
280+ Can.OutgoingPort name tipe ->
282281 pure (Opt.OutgoingPort name tipe)
283282
284− Expr.IncomingPort name tipe ->
283+ Can.IncomingPort name tipe ->
285284 pure (Opt.IncomingPort name tipe)
286285
287− Expr.Program kind expr ->
286+ Can.Program kind expr ->
288287 Opt.Program kind <$> justConvert expr
289288
290− Expr.SaveEnv _ _ ->
289+ Can.SaveEnv _ _ ->
291290 error "save_the_environment should never make it to optimization phase"
292291
293− Expr.GLShader uid src gltipe ->
292+ Can.GLShader uid src gltipe ->
294293 pure (Opt.GLShader uid src gltipe)
295294
296295
@@ -348,7 +347,7 @@ tagCrashBranch region pattern@(A.A pr _) expr =
348347isTailCall :: Context -> Can.Expr -> Int -> Maybe (String, [String])
349348isTailCall context (A.A _ function) arity =
350349 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) ) ->
352351
353352 if name == ctxName && arity == ctxArity && Var.isLocalHome home then
354353 Just (name, argNames)
@@ -374,10 +373,10 @@ depattern canPattern@(A.A _ pattern) expr =
374373 A.A (error "the annotation added in 'depattern' should not be observed!")
375374
376375 caseExpr e branches =
377− ann (Expr.Case e branches)
376+ ann (Can.Case e branches)
378377
379378 var name =
380− ann (Expr.Var (Var.local name))
379+ ann (Can.Var (Var.local name))
381380
382381 caseify =
383382 do name <- Env.freshName
@@ -421,7 +420,7 @@ optimizeBinop
421420optimizeBinop context region op leftExpr rightExpr =
422421 let
423422 ann = A.A region
424− binop = ann (Expr.Binop op leftExpr rightExpr)
423+ binop = ann (Can.Binop op leftExpr rightExpr)
425424 in
426425 if op == forwardApply then
427426
@@ -434,20 +433,20 @@ optimizeBinop context region op leftExpr rightExpr =
434433 else if op == forwardCompose then
435434
436435 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))))
438437 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))
440439
441440 else if op == backwardCompose then
442441
443442 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))))
445444 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))
447446
448447 else if op == Var.Canonical Var.BuiltIn "::" then
449448
450− optimizeExpr context (ann (Expr.Data "::" [ leftExpr, rightExpr ]))
449+ optimizeExpr context (ann (Can.Ctor "::" [ leftExpr, rightExpr ]))
451450
452451 else
453452
@@ -497,11 +496,11 @@ right =
497496collect :: (Can.Expr -> Can.Expr) -> Assoc -> Var.Canonical -> Can.Expr -> Can.Expr
498497collect makeRoot assoc desiredOp annExpr@(A.A ann expr) =
499498 case expr of
500− Expr.Binop op leftExpr rightExpr | op == desiredOp ->
499+ Can.Binop op leftExpr rightExpr | op == desiredOp ->
501500 let
502501 (func, arg) = assoc leftExpr rightExpr
503502 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))
505504
506505 _ ->
507506 makeRoot annExpr
src/Optimize/Inline.hs+9−9
@@ -100,7 +100,7 @@ count expression =
100100 Var.TopLevel _ ->
101101 Map.empty
102102
103− ExplicitList exprs ->
103+ List exprs ->
104104 countMany exprs
105105
106106 Binop _op left right ->
@@ -151,10 +151,10 @@ count expression =
151151 in
152152 Map.unionsWith (+) (countDecider decider : map (count . snd) jumps)
153153
154− Data _tag values ->
154+ Ctor _tag values ->
155155 countMany values
156156
157− DataAccess root _index ->
157+ CtorAccess root _index ->
158158 count root
159159
160160 Access record _field ->
@@ -207,8 +207,8 @@ replace substitutions expression =
207207 Var _ ->
208208 expression
209209
210− ExplicitList exprs ->
211− ExplicitList (map go exprs)
210+ List exprs ->
211+ List (map go exprs)
212212
213213 Binop op left right ->
214214 Binop op (go left) (go right)
@@ -262,11 +262,11 @@ replace substitutions expression =
262262 in
263263 Case exprName (goDecider decider) (map (second go) jumps)
264264
265− Data tag values ->
266− Data tag (map go values)
265+ Ctor tag values ->
266+ Ctor tag (map go values)
267267
268− DataAccess root index ->
269− DataAccess (go root) index
268+ CtorAccess root index ->
269+ CtorAccess (go root) index
270270
271271 Access record field ->
272272 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
22
3−import qualified Data.List as List
4−import qualified Data.Map as Map
53import Text.Parsec
6− ( (<|>), choice, getState, lookAhead, lower, many1
4+ ( (<|>), choice, lookAhead, lower, many1
75 , notFollowedBy, satisfy, string, try
86 )
97
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
139import 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)
1611import qualified Reporting.Annotation as A
1712
1813
1914
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+
2052-- INFIX OPERATORS
2153
2254
@@ -34,14 +66,6 @@ infixOpWith checker =
3466 _ -> return op
3567
3668
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−
4569notReserved :: IParser a
4670notReserved =
4771 choice
@@ -52,123 +76,9 @@ notReserved =
5276 ]
5377
5478
55−
56−-- BINARY EXPRESSIONS
57−
58−
59−opLevel :: OpTable -> String -> Int
60−opLevel table op =
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− ]
79+failOn :: String -> String -> IParser a
80+failOn op msg =
81+ do try $ lookAhead $ do
82+ string op
83+ notFollowedBy (satisfy Help.isSymbol)
84+ failure msg
src/Parse/Expression.hs+58−65
@@ -2,7 +2,6 @@ module Parse.Expression (term, expr, def) where
22
33import qualified Data.List as List
44import Text.Parsec hiding (newline, spaces)
5−import qualified Text.Parsec.Indent as Indent
65
76import qualified Parse.Binop as Binop
87import Parse.Helpers
@@ -11,11 +10,9 @@ import qualified Parse.Literal as Literal
1110import qualified Parse.Pattern as Pattern
1211import qualified Parse.Type as Type
1312
14−import qualified AST.Expression.General as E
15−import qualified AST.Expression.Source as Source
13+import qualified AST.Expression.Source as Src
1614import qualified AST.Literal as L
1715import qualified AST.Pattern as P
18−import qualified AST.Variable as Var
1916import qualified Reporting.Annotation as A
2017
2118
@@ -23,25 +20,25 @@ import qualified Reporting.Annotation as A
2320-------- Basic Terms --------
2421
2522
26−varTerm :: IParser Source.Expr'
23+varTerm :: IParser Src.RawExpr'
2724varTerm =
2825 toVar <$> Help.var
2926
3027
31−toVar :: String -> Source.Expr'
28+toVar :: String -> Src.RawExpr'
3229toVar v =
3330 case v of
3431 "True" ->
35− E.Literal (L.Boolean True)
32+ Src.Literal (L.Boolean True)
3633
3734 "False" ->
38− E.Literal (L.Boolean False)
35+ Src.Literal (L.Boolean False)
3936
4037 _ ->
41− E.rawVar v
38+ Src.var v
4239
4340
44−accessor :: IParser Source.Expr'
41+accessor :: IParser Src.RawExpr'
4542accessor =
4643 do (start, lbl, end) <- located (try (string "." >> rLabel))
4744
@@ -49,60 +46,56 @@ accessor =
4946 A.at start end value
5047
5148 return $
52− E.Lambda
49+ Src.Lambda
5350 (ann (P.Var "_"))
54− (ann (E.Access (ann (E.rawVar "_")) lbl))
51+ (ann (Src.Access (ann (Src.var "_")) lbl))
5552
5653
57−negative :: IParser Source.Expr'
54+negative :: IParser Src.RawExpr'
5855negative =
59− do (start, nTerm, end) <-
60− located $ try $
61− do char '-'
62− notFollowedBy (char '.' <|> char '-')
63− term
56+ try $
57+ do (A.A region _) <- addLocation (char '-')
58+ notFollowedBy (char '.' <|> char '-')
59+ negativeTerm <- term
6460
65− let ann e =
66− A.at start end e
61+ let zero = A.A region (Src.Literal (L.IntNum 0))
62+ let minus = A.A region "-"
63+
64+ return $ Src.Binop [(zero, minus)] negativeTerm
6765
68− return $
69− E.Binop
70− (Var.Raw "-")
71− (ann (E.Literal (L.IntNum 0)))
72− nTerm
7366
7467
7568
7669-------- Complex Terms --------
7770
7871
79−listTerm :: IParser Source.Expr'
72+listTerm :: IParser Src.RawExpr'
8073listTerm =
8174 choice
8275 [ do pos <- getPosition
8376 let uid = show (sourceLine pos) ++ ":" ++ show (sourceColumn pos)
8477 (rawSrc, tipe) <- Literal.shader
85− return $ E.GLShader uid (filter (/='\r') rawSrc) tipe
86− , braces (E.ExplicitList <$> commaSep expr)
78+ return $ Src.GLShader uid (filter (/='\r') rawSrc) tipe
79+ , braces (Src.List <$> commaSep expr)
8780 ]
8881
8982
90−parensTerm :: IParser Source.Expr
83+parensTerm :: IParser Src.RawExpr
9184parensTerm =
9285 let
9386 mkFunc args realBody start end =
9487 foldr
95− (\arg body -> A.at start end (E.Lambda (A.at start end (P.Var arg)) body))
96− (A.at start end (realBody (A.at start end . E.rawVar)))
88+ (\arg body -> A.at start end (Src.Lambda (A.at start end (P.Var arg)) body))
89+ (A.at start end (realBody (A.at start end . Src.var)))
9790 args
9891
9992 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")
10194
10295 tupleFn =
10396 do commas <- many1 comma
10497 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))
10699
107100 parenedExpr =
108101 do expressions <- padded (commaSep expr)
@@ -111,17 +104,17 @@ parensTerm =
111104 [expression] ->
112105 expression
113106 _ ->
114− A.at start end (E.tuple expressions)
107+ A.at start end (Src.tuple expressions)
115108 in
116109 do (start, mkExpr, end) <-
117110 located $ choice $
118− [ mkBinop <$> try (parens Binop.infixOp)
111+ [ mkBinop <$> try (parens (addLocation Binop.infixOp))
119112 , parens (tupleFn <|> parenedExpr)
120113 ]
121114 return (mkExpr start end)
122115
123116
124−recordTerm :: IParser Source.Expr
117+recordTerm :: IParser Src.RawExpr
125118recordTerm =
126119 addLocation $ brackets $ choice $
127120 [ do starter <- try (addLocation rLabel)
@@ -130,14 +123,14 @@ recordTerm =
130123 [ update starter
131124 , literal starter
132125 ]
133− , return (E.Record [])
126+ , return (Src.Record [])
134127 ]
135128 where
136129 update (A.A ann starter) =
137130 do try (string "|")
138131 whitespace
139132 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)
141134
142135 literal (A.A _ starter) =
143136 do try equals
@@ -148,8 +141,8 @@ recordTerm =
148141 [ do try comma
149142 whitespace
150143 fields <- commaSep field
151− return (E.Record ((starter, value) : fields))
152− , return (E.Record [(starter, value)])
144+ return (Src.Record ((starter, value) : fields))
145+ , return (Src.Record [(starter, value)])
153146 ]
154147
155148 field =
@@ -159,11 +152,11 @@ recordTerm =
159152 return (key, value)
160153
161154
162−term :: IParser Source.Expr
155+term :: IParser Src.RawExpr
163156term =
164157 choice
165158 [ addLocation $ choice $
166− [ E.Literal <$> Literal.literal
159+ [ Src.Literal <$> Literal.literal
167160 , listTerm
168161 , accessor
169162 , negative
@@ -181,7 +174,7 @@ term =
181174-------- Applications --------
182175
183176
184−appExpr :: IParser Source.Expr
177+appExpr :: IParser Src.RawExpr
185178appExpr =
186179 expecting "an expression" $
187180 do t <- term
@@ -190,14 +183,14 @@ appExpr =
190183 return $
191184 case ts of
192185 [] -> 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
194187
195188
196189
197190-------- Normal Expressions --------
198191
199192
200−expr :: IParser Source.Expr
193+expr :: IParser Src.RawExpr
201194expr =
202195 addLocation (choice [ letExpr, caseExpr, ifExpr ])
203196 <|> lambdaExpr
@@ -205,7 +198,7 @@ expr =
205198 <?> "an expression"
206199
207200
208−binaryExpr :: IParser Source.Expr
201+binaryExpr :: IParser Src.RawExpr
209202binaryExpr =
210203 Binop.binops appExpr lastExpr
211204 where
@@ -215,12 +208,12 @@ binaryExpr =
215208 <?> "an expression"
216209
217210
218−ifExpr :: IParser Source.Expr'
211+ifExpr :: IParser Src.RawExpr'
219212ifExpr =
220213 ifHelp []
221214
222215
223−ifHelp :: [(Source.Expr, Source.Expr)] -> IParser Source.Expr'
216+ifHelp :: [(Src.RawExpr, Src.RawExpr)] -> IParser Src.RawExpr'
224217ifHelp branches =
225218 do try (reserved "if")
226219 whitespace
@@ -233,11 +226,11 @@ ifHelp branches =
233226 let newBranches = (condition, thenBranch) : branches
234227 choice
235228 [ ifHelp newBranches
236− , E.If (reverse newBranches) <$> expr
229+ , Src.If (reverse newBranches) <$> expr
237230 ]
238231
239232
240−lambdaExpr :: IParser Source.Expr
233+lambdaExpr :: IParser Src.RawExpr
241234lambdaExpr =
242235 do start <- getMyPosition
243236 char '\\' <|> char '\x03BB' <?> "an anonymous function"
@@ -246,22 +239,22 @@ lambdaExpr =
246239 padded rightArrow
247240 body <- expr
248241 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)
250243
251244
252−caseExpr :: IParser Source.Expr'
245+caseExpr :: IParser Src.RawExpr'
253246caseExpr =
254247 do try (reserved "case")
255248 exp <- padded expr
256249 reserved "of"
257250 whitespace
258− Indent.withPos $
251+ Help.withPos $
259252 do firstBranch <- branch
260253 branches <-
261254 many $ do
262− try (whitespace >> Indent.checkIndent)
255+ try (whitespace >> Help.checkIndent)
263256 branch
264− return $ E.Case exp (firstBranch : branches)
257+ return $ Src.Case exp (firstBranch : branches)
265258 where
266259 branch =
267260 do p <- Pattern.expr
@@ -273,20 +266,20 @@ caseExpr =
273266-- LET
274267
275268
276−letExpr :: IParser Source.Expr'
269+letExpr :: IParser Src.RawExpr'
277270letExpr =
278271 do try (reserved "let")
279272 whitespace
280− defs <- Indent.block (def <* whitespace)
273+ defs <- Help.block (def <* whitespace)
281274 whitespace
282275 reserved "in"
283276 whitespace
284− E.Let defs <$> expr
277+ Src.Let defs <$> expr
285278
286279
287−def :: IParser Source.Def
280+def :: IParser Src.RawDef
288281def =
289− addLocation $ Indent.withPos $
282+ addLocation $ Help.withPos $
290283 do start <- defStart
291284 whitespace
292285 case start of
@@ -295,7 +288,7 @@ def =
295288 [ do hasType
296289 whitespace
297290 tipe <- Type.expr
298− return $ Source.Annotation name tipe
291+ return $ Src.Annotation name tipe
299292 , defEnd start []
300293 ]
301294
@@ -311,7 +304,7 @@ defStart =
311304 ]
312305
313306
314−defEnd :: P.Raw -> [P.Raw] -> IParser Source.Def'
307+defEnd :: P.Raw -> [P.Raw] -> IParser Src.RawDef'
315308defEnd start revArgs =
316309 choice
317310 [ do arg <- Pattern.term
@@ -320,10 +313,10 @@ defEnd start revArgs =
320313 , do equals
321314 whitespace
322315 body <- expr
323− return $ Source.Definition start (makeFunction revArgs body)
316+ return $ Src.Definition start (makeFunction revArgs body)
324317 ]
325318
326319
327−makeFunction :: [P.Raw] -> Source.Expr -> Source.Expr
320+makeFunction :: [P.Raw] -> Src.RawExpr -> Src.RawExpr
328321makeFunction 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 @@
11{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
22module Parse.Helpers
3− ( expecting, failure, anyUntil
4− , OpTable
5− , IParser, SourceM, iParse
3+ ( module Parse.Primitives
64 , var, lowVar, capVar, rLabel, reserved, reserveds
75 , equals, rightArrow, hasType
8− , commitIf
9− , followedBy, comma, commaSep1, commaSep
6+ , commitIf, followedBy, anyUntil
7+ , comma, commaSep1, commaSep
108 , pipeSep1, consSep1, dotSep1, spaceSep1, spacePrefix, constrainedSpacePrefix
119 , braces, parens, brackets
1210 , accessible
@@ -16,74 +14,24 @@ module Parse.Helpers
1614 )
1715 where
1816
19−import Control.Monad.State (State)
2017import Data.Char (isUpper)
21−import qualified Data.Map as Map
22−import Text.Parsec hiding (State, newline, space, spaces)
23−import Text.Parsec.Indent (indented, runIndent)
18+import Text.Parsec hiding (newline, space, spaces)
2419
25−import qualified AST.Declaration as Decl
26−import qualified AST.Expression.General as E
27−import qualified AST.Expression.Source as Source
20+import qualified AST.Expression.Source as Src
2821import qualified AST.Variable as Variable
22+import Parse.Primitives
2923import qualified Reporting.Annotation as A
3024import qualified Reporting.Error.Syntax as Syntax
3125import qualified Reporting.Region as R
3226
3327
3428
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−
8129-- VARIABLES
8230
8331
8432var :: IParser String
8533var =
86− makeVar (letter <|> char '_') <?> "a name"
34+ makeVar letter <?> "a name"
8735
8836
8937lowVar :: IParser String
@@ -164,7 +112,7 @@ hasType =
164112
165113
166114
167−-- SEPARATORS
115+-- WEIRD COMBINATORS
168116
169117
170118commitIf :: IParser a -> IParser b -> IParser b
@@ -175,6 +123,26 @@ commitIf check p =
175123 try (lookAhead check) >> p
176124
177125
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+
178146spaceySepBy1 :: IParser b -> IParser a -> IParser [a]
179147spaceySepBy1 sep parser =
180148 do value <- parser
@@ -243,13 +211,6 @@ constrainedSpacePrefix parser constraint =
243211-- SURROUNDED BY
244212
245213
246−followedBy :: IParser a -> IParser b -> IParser a
247−followedBy a b =
248− do x <- a
249− b
250− return x
251−
252−
253214surround :: Char -> Char -> String -> IParser a -> IParser a
254215surround a z name p = do
255216 char a
@@ -296,7 +257,7 @@ located parser =
296257 return (start, value, end)
297258
298259
299−accessible :: IParser Source.Expr -> IParser Source.Expr
260+accessible :: IParser Src.RawExpr -> IParser Src.RawExpr
300261accessible exprParser =
301262 do start <- getMyPosition
302263
@@ -314,11 +275,11 @@ accessible exprParser =
314275 end <- getMyPosition
315276 return . A.at start end $
316277 case rootExpr of
317− E.Var (Variable.Raw name@(c:_))
278+ Src.Var (Variable.Raw name@(c:_))
318279 | isUpper c ->
319− E.rawVar (name ++ '.' : v)
280+ Src.var (name ++ '.' : v)
320281 _ ->
321− E.Access annotatedRootExpr v
282+ Src.Access annotatedRootExpr v
322283
323284
324285dot :: IParser ()
src/Parse/Literal.hs+10−61
@@ -6,14 +6,13 @@ import Control.Monad (join)
66import qualified Data.Map as Map
77import qualified Language.GLSL.Parser as GLP
88import qualified Language.GLSL.Syntax as GLS
9−import qualified Text.Parsec.Token as T
109import Text.Parsec
1110 ( ParseError, (<|>), (<?>), anyChar, char, choice, digit, hexDigit
1211 , lookAhead, many1, manyTill, notFollowedBy, option, parserFail
13− , satisfy, string, try
12+ , string, try
1413 )
1514
16−import Parse.Helpers (IParser, SourceM, expecting, failure, iParse, reserveds)
15+import Parse.Helpers (IParser, expecting)
1716import qualified AST.Literal as L
1817
1918
@@ -25,7 +24,7 @@ literal :: IParser L.Literal
2524literal =
2625 choice
2726 [ toLiteral <$> rawNumber
28− , {-# SCC elm_compiler_parse_str #-} L.Str <$> str
27+ , L.Str <$> str
2928 , L.Chr <$> chr
3029 ]
3130
@@ -96,9 +95,7 @@ exponent =
9695str :: IParser String
9796str =
9897 expecting "a string like \"hello\"" $
99− do charSeq <- choice [ multiStr, singleStr ]
100− either (fail . show) return $
101− processAs T.stringLiteral ('"' : charSeq ++ "\"")
98+ choice [ multiStr, singleStr ]
10299
103100
104101delimitedSequence :: IParser a -> IParser String -> IParser String
@@ -114,7 +111,7 @@ multiStr =
114111
115112singleStr :: IParser String
116113singleStr =
117− delimitedSequence (char '"') (charWithin '"')
114+ delimitedSequence (char '"') ((:[]) <$> anyChar)
118115
119116
120117
@@ -125,37 +122,26 @@ chr :: IParser Char
125122chr =
126123 expecting "a character like 'x'" $
127124 do char '\''
128− charSeq <- concat <$> many1 (charWithin '\'') <?> "a character"
129− case processAs T.charLiteral ("'" ++ charSeq ++ "'") of
130− Right character ->
131− do char '\''
132− return character
125+ myChar <- anyChar <?> "a character"
126+ char '\''
127+ return myChar
133128
134− Left _ ->
129+{-
135130 failure $
136131 "Elm uses double quotes for strings. Switch\
137132 \ the ' to \" on both ends of the string and\
138133 \ you should be all set!"
139−
134+-}
140135
141136
142137-- CHARACTER HELPERS
143138
144139
145−charWithin :: Char -> IParser String
146−charWithin delim =
147− choice
148− [ escaped delim
149− , (:[]) <$> satisfy (/= delim)
150− ]
151−
152−
153140multilineStringChar :: IParser String
154141multilineStringChar =
155142 do notFollowedBy (string "\"\"\"")
156143 choice
157144 [ newlineChar
158− , escaped '\"'
159145 , escapeQuotes <$> anyChar
160146 ]
161147
@@ -173,43 +159,6 @@ newlineChar =
173159 ]
174160
175161
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−
213162
214163-- SHADERS
215164
src/Parse/Module.hs+6−2
@@ -1,10 +1,14 @@
11{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
22module Parse.Module (moduleDecl, header, getModuleName) where
33
4−import Text.Parsec hiding (newline, spaces)
4+import Text.Parsec hiding (newline, parse, spaces)
55
66import Parse.Binop (infixOp)
77import 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+ )
812import qualified AST.Module as Module
913import qualified AST.Module.Name as ModuleName
1014import qualified AST.Variable as Var
@@ -20,7 +24,7 @@ getModuleName source =
2024 (ModuleDecl _ names _ _) <- moduleDecl
2125 return (ModuleName.toString names)
2226 in
23− case iParse minimalParser source of
27+ case parse minimalParser source of
2428 Right name ->
2529 Just name
2630
src/Parse/Parse.hs+14−83
@@ -1,18 +1,16 @@
11{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2−module Parse.Parse (program, parse) where
2+module Parse.Parse (program) where
33
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, (<|>))
75import qualified Text.Parsec.Error as Parsec
86
97import qualified AST.Declaration as Decl
108import qualified AST.Module as Module
119import qualified AST.Module.Name as ModuleName
1210import qualified Elm.Package as Package
13−import Parse.Helpers
11+import Parse.Helpers (IParser, commitIf, freshLine, newline, parse, spaces)
1412import qualified Parse.Module as Parse (header)
15−import qualified Parse.Declaration as Parse (declaration, infixDecl)
13+import qualified Parse.Declaration as Parse (declaration)
1614import qualified Reporting.Region as R
1715import qualified Reporting.Error.Syntax as Error
1816import qualified Reporting.Result as Result
@@ -20,28 +18,20 @@ import qualified Validate
2018
2119
2220
23−program :: Package.Name -> OpTable -> String -> Validate.Result wrn Module.Valid
24−program pkgName table src =
25− do modul <-
26− parseWithTable table src (programParser pkgName)
27−
21+program :: Package.Name -> String -> Validate.Result wrn Module.Valid
22+program pkgName src =
23+ do modul <- toResult (parse (programParser pkgName) src)
2824 Validate.module' modul
2925
3026
31−
3227-- HEADERS AND DECLARATIONS
3328
3429
3530programParser :: Package.Name -> IParser Module.Source
3631programParser pkgName =
37− do (Module.Header tag name exports settings docs imports) <-
38− Parse.header
39−
40− decls <-
41− declarations
42−
32+ do (Module.Header tag name exports settings docs imports) <- Parse.header
33+ decls <- declarations
4334 many (spaces <|> newline)
44−
4535 eof
4636
4737 return $
@@ -65,12 +55,12 @@ freshDef =
6555
6656
6757
68−-- RUN PARSERS
58+-- PARSER OUTPUT TO RESULT
6959
7060
71−parse :: String -> IParser a -> Validate.Result wrn a
72−parse source parser =
73− case iParse parser source of
61+toResult :: Either Parsec.ParseError a -> Validate.Result wrn a
62+toResult parserOutput =
63+ case parserOutput of
7464 Right result ->
7565 return result
7666
@@ -78,63 +68,4 @@ parse source parser =
7868 let pos = R.fromSourcePos (Parsec.errorPos err)
7969 msgs = Parsec.errorMessages err
8070 in
81− 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− }
71+ Result.throw (R.Region pos pos) (Error.Parse msgs)
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)
55import qualified Data.Char as Char
66import Text.PrettyPrint.ANSI.Leijen (Doc, dullyellow, fillSep, indent, text)
77
8+import qualified AST.Declaration as Decl
89import qualified AST.Expression.Canonical as Canonical
910import qualified AST.Module.Name as ModuleName
1011import qualified AST.Pattern as P
@@ -20,6 +21,7 @@ import qualified Reporting.Report as Report
2021data Error
2122 = Var VarError
2223 | BadRecursion Region.Region Canonical.Def [Canonical.Def]
24+ | BadInfix Region.Region Int Var.Canonical Decl.Assoc Var.Canonical Decl.Assoc
2325 | Pattern PatternError
2426 | Alias AliasError
2527 | Import ModuleName.Raw ImportError
@@ -165,6 +167,17 @@ toReport localizer err =
165167 _ ->
166168 badMutualRecursion region (defToString def) (map (defToString) defs)
167169
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+ )
168181
169182 Pattern patternError ->
170183 case patternError of
@@ -296,6 +309,9 @@ extractSuggestions err =
296309 BadRecursion _ _ _ ->
297310 Nothing
298311
312+ BadInfix _ _ _ _ _ _ ->
313+ Nothing
314+
299315 Pattern _ ->
300316 Nothing
301317
src/Reporting/Error/Syntax.hs−12
@@ -26,7 +26,6 @@ data Error
2626 | MissingManagerOnEffectModule String
2727 | UnexpectedPort String
2828
29− | InfixDuplicate String
3029 | TypeWithoutDefinition String
3130
3231 | DuplicateArgument String String
@@ -163,17 +162,6 @@ toReport _localizer err =
163162 \ stay relatively organized."
164163 )
165164
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−
177165 TypeWithoutDefinition valueName ->
178166 Report.report
179167 "MISSING DEFINITION"
src/Type/Constrain/Expression.hs+48−49
@@ -5,8 +5,7 @@ import Control.Arrow (second)
55import qualified Control.Monad as Monad
66import qualified Data.Map as Map
77
8−import qualified AST.Expression.General as E
9−import qualified AST.Expression.Canonical as Canonical
8+import qualified AST.Expression.Canonical as C
109import qualified AST.Literal as Lit
1110import qualified AST.Pattern as P
1211import qualified AST.Type as ST
@@ -22,31 +21,31 @@ import Type.Type hiding (Descriptor(..))
2221
2322
2423
25−constrain :: Env.Env -> Canonical.Expr -> Type -> IO TypeConstraint
24+constrain :: Env.Env -> C.Expr -> Type -> IO TypeConstraint
2625constrain env annotatedExpr@(A.A region expression) tipe =
2726 case expression of
28− E.Literal lit ->
27+ C.Literal lit ->
2928 Literal.constrain env region lit tipe
3029
31− E.Cmd _ ->
30+ C.Cmd _ ->
3231 return CTrue
3332
34− E.Sub _ ->
33+ C.Sub _ ->
3534 return CTrue
3635
37− E.OutgoingPort _ _ ->
36+ C.OutgoingPort _ _ ->
3837 return CTrue
3938
40− E.IncomingPort _ _ ->
39+ C.IncomingPort _ _ ->
4140 return CTrue
4241
43− E.Program _ _ ->
42+ C.Program _ _ ->
4443 error "DANGER - Program AST nodes should not be in type inference."
4544
46− E.SaveEnv moduleName effects ->
45+ C.SaveEnv moduleName effects ->
4746 Effects.constrain env moduleName effects
4847
49− E.GLShader _uid _src gltipe ->
48+ C.GLShader _uid _src gltipe ->
5049 exists $ \attr ->
5150 exists $ \unif ->
5251 let
@@ -70,16 +69,16 @@ constrain env annotatedExpr@(A.A region expression) tipe =
7069 in
7170 return (CEqual Error.Shader region (shaderTipe attribute uniform varying) tipe)
7271
73− E.Var var ->
72+ C.Var var ->
7473 return (CInstance region (V.toString var) tipe)
7574
76− E.ExplicitList exprs ->
75+ C.List exprs ->
7776 constrainList env region exprs tipe
7877
79− E.Binop op leftExpr rightExpr ->
78+ C.Binop op leftExpr rightExpr ->
8079 constrainBinop env region op leftExpr rightExpr tipe
8180
82− E.Lambda pattern body ->
81+ C.Lambda pattern body ->
8382 exists $ \argType ->
8483 exists $ \resType ->
8584 do (Pattern.Info headers vars cons) <- Pattern.constrain env pattern argType
@@ -88,19 +87,19 @@ constrain env annotatedExpr@(A.A region expression) tipe =
8887 ex vars (CLet [monoscheme headers] (cons /\ bodyCon))
8988 /\ CEqual Error.Lambda region (argType ==> resType) tipe
9089
91− E.App _ _ ->
90+ C.App _ _ ->
9291 let
93− (f:args) = E.collectApps annotatedExpr
92+ (f:args) = C.collectApps annotatedExpr
9493 in
9594 constrainApp env region f args tipe
9695
97− E.If branches finally ->
96+ C.If branches finally ->
9897 constrainIf env region branches finally tipe
9998
100− E.Case expr branches ->
99+ C.Case expr branches ->
101100 constrainCase env region expr branches tipe
102101
103− E.Data name exprs ->
102+ C.Ctor name exprs ->
104103 do vars <- Monad.forM exprs $ \_ -> mkVar Nothing
105104 let pairs = zip exprs (map VarN vars)
106105 (ctipe, cs) <- Monad.foldM step (tipe, CTrue) (reverse pairs)
@@ -110,16 +109,16 @@ constrain env annotatedExpr@(A.A region expression) tipe =
110109 do c' <- constrain env e x
111110 return (x ==> t, c /\ c')
112111
113− E.Access expr field ->
112+ C.Access expr field ->
114113 exists $ \recordType ->
115114 exists $ \ext ->
116115 do recordCon <- constrain env expr recordType
117− let maybeBody = E.collectFields expr
116+ let maybeBody = C.collectFields expr
118117 let desiredType = record (Map.singleton field tipe) ext
119118 let fieldCon = CEqual (Error.Access maybeBody field) region recordType desiredType
120119 return $ recordCon /\ fieldCon
121120
122− E.Update expr fields ->
121+ C.Update expr fields ->
123122 exists $ \t ->
124123 do oldVars <- mapM (\_ -> mkVar Nothing) fields
125124 let oldFields = Map.fromList (zip (map fst fields) (map VarN oldVars))
@@ -133,7 +132,7 @@ constrain env annotatedExpr@(A.A region expression) tipe =
133132
134133 return $ cOld /\ ex newVars (CAnd (cNew : cs))
135134
136− E.Record fields ->
135+ C.Record fields ->
137136 do vars <- Monad.forM fields (\_ -> mkVar Nothing)
138137 fieldCons <-
139138 Monad.zipWithM
@@ -144,7 +143,7 @@ constrain env annotatedExpr@(A.A region expression) tipe =
144143 let recordType = record fields' (TermN EmptyRecord1)
145144 return (ex vars (CAnd (fieldCons ++ [CEqual Error.Record region recordType tipe])))
146145
147− E.Let defs body ->
146+ C.Let defs body ->
148147 do bodyCon <- constrain env body tipe
149148
150149 (Info schemes rqs fqs headers c2 c1) <-
@@ -166,8 +165,8 @@ constrain env annotatedExpr@(A.A region expression) tipe =
166165constrainApp
167166 :: Env.Env
168167 -> R.Region
169− -> Canonical.Expr
170− -> [Canonical.Expr]
168+ -> C.Expr
169+ -> [C.Expr]
171170 -> Type
172171 -> IO TypeConstraint
173172constrainApp env region f args tipe =
@@ -185,7 +184,7 @@ constrainApp env region f args tipe =
185184 where
186185 maybeName =
187186 case f of
188− A.A _ (E.Var canonicalName) ->
187+ A.A _ (C.Var canonicalName) ->
189188 Just canonicalName
190189
191190 _ ->
@@ -199,7 +198,7 @@ argConstraints
199198 -> Int
200199 -> Variable
201200 -> Int
202− -> [Canonical.Expr]
201+ -> [C.Expr]
203202 -> IO ([Variable], [TypeConstraint], [TypeConstraint], [TypeConstraint], Maybe R.Region, Variable)
204203argConstraints env name region totalArgs overallVar index args =
205204 case args of
@@ -250,8 +249,8 @@ constrainBinop
250249 :: Env.Env
251250 -> R.Region
252251 -> V.Canonical
253− -> Canonical.Expr
254− -> Canonical.Expr
252+ -> C.Expr
253+ -> C.Expr
255254 -> Type
256255 -> IO TypeConstraint
257256constrainBinop 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
282281-- CONSTRAIN LISTS
283282
284283
285−constrainList :: Env.Env -> R.Region -> [Canonical.Expr] -> Type -> IO TypeConstraint
284+constrainList :: Env.Env -> R.Region -> [C.Expr] -> Type -> IO TypeConstraint
286285constrainList env region exprs tipe =
287286 do (exprInfo, exprCons) <-
288287 unzip <$> mapM elementConstraint exprs
@@ -307,8 +306,8 @@ constrainList env region exprs tipe =
307306constrainIf
308307 :: Env.Env
309308 -> R.Region
310− -> [(Canonical.Expr, Canonical.Expr)]
311− -> Canonical.Expr
309+ -> [(C.Expr, C.Expr)]
310+ -> C.Expr
312311 -> Type
313312 -> IO TypeConstraint
314313constrainIf env region branches finally tipe =
@@ -366,8 +365,8 @@ constrainIf env region branches finally tipe =
366365constrainCase
367366 :: Env.Env
368367 -> R.Region
369− -> Canonical.Expr
370− -> [(P.Canonical, Canonical.Expr)]
368+ -> C.Expr
369+ -> [(P.Canonical, C.Expr)]
371370 -> Type
372371 -> IO TypeConstraint
373372constrainCase env region expr branches tipe =
@@ -444,8 +443,8 @@ collectPairs index items =
444443-- EXPAND PATTERNS
445444
446445
447−expandPattern :: Canonical.Def -> [Canonical.Def]
448−expandPattern def@(Canonical.Def facts lpattern expr maybeType) =
446+expandPattern :: C.Def -> [C.Def]
447+expandPattern def@(C.Def facts lpattern expr maybeType) =
449448 let
450449 (A.A patternRegion pattern) =
451450 lpattern
@@ -467,17 +466,17 @@ expandPattern def@(Canonical.Def facts lpattern expr maybeType) =
467466 A.A patternRegion (P.Var name)
468467
469468 localVar name =
470− A.A patternRegion (E.localVar name)
469+ A.A patternRegion (C.localVar name)
471470
472471 mainDef =
473− Canonical.Def facts (pvar combinedName) expr maybeType
472+ C.Def facts (pvar combinedName) expr maybeType
474473
475474 toDef name =
476475 let
477476 extract =
478− E.Case (localVar combinedName) [(lpattern, localVar name)]
477+ C.Case (localVar combinedName) [(lpattern, localVar name)]
479478 in
480− Canonical.Def facts (pvar name) (A.A patternRegion extract) Nothing
479+ C.Def facts (pvar name) (A.A patternRegion extract) Nothing
481480
482481
483482
@@ -494,8 +493,8 @@ data Info = Info
494493 }
495494
496495
497−constrainDef :: Env.Env -> Info -> Canonical.Def -> IO Info
498−constrainDef env info (Canonical.Def defRegion (A.A patternRegion pattern) expr maybeTipe) =
496+constrainDef :: Env.Env -> Info -> C.Def -> IO Info
497+constrainDef env info (C.Def defRegion (A.A patternRegion pattern) expr maybeTipe) =
499498 case (pattern, maybeTipe) of
500499 (P.Var name, Nothing) ->
501500 constrainUnannotatedDef env patternRegion name expr info
@@ -511,7 +510,7 @@ constrainUnannotatedDef
511510 :: Env.Env
512511 -> R.Region
513512 -> String
514− -> Canonical.Expr
513+ -> C.Expr
515514 -> Info
516515 -> IO Info
517516constrainUnannotatedDef env patternRegion name expr info =
@@ -530,7 +529,7 @@ constrainAnnotatedDef
530529 -> R.Region
531530 -> R.Region
532531 -> String
533− -> Canonical.Expr
532+ -> C.Expr
534533 -> ST.Canonical
535534 -> Info
536535 -> IO Info
@@ -563,10 +562,10 @@ data ArgInfo =
563562 }
564563
565564
566−constrainAnnDefHelp :: Canonical.Expr -> ST.Canonical -> ArgInfo -> IO TypeConstraint
565+constrainAnnDefHelp :: C.Expr -> ST.Canonical -> ArgInfo -> IO TypeConstraint
567566constrainAnnDefHelp expr tipe (ArgInfo name defRegion env args vars) =
568567 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) ->
570569 do (rigidArgType, newVars) <- Env.instantiateType Rigid env argType
571570
572571 constrainAnnDefHelp result resultType $
@@ -594,7 +593,7 @@ constrainAnnDefHelp expr tipe (ArgInfo name defRegion env args vars) =
594593
595594 let sharedArity = length args
596595 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))
598597 let hint = Error.ReturnType name typeArity argsArity region
599598 let resultCon =
600599 CEqual hint defRegion rigidType resultType
src/Validate.hs+60−81
@@ -6,12 +6,9 @@ import qualified Data.Map as Map
66import qualified Data.Maybe as Maybe
77import qualified Data.Set as Set
88import qualified Data.Foldable as F
9−import qualified Data.Traversable as T
109
11−import AST.Expression.General as Expr
1210import qualified AST.Effects as Effects
13−import qualified AST.Expression.Source as Source
14−import qualified AST.Expression.Valid as Valid
11+import qualified AST.Expression.Source as Src
1512import qualified AST.Declaration as D
1613import qualified AST.Module as Module
1714import qualified AST.Module.Name as ModuleName
@@ -77,7 +74,7 @@ validateEffects
7774 :: Module.SourceTag
7875 -> Module.SourceSettings
7976 -> [A.Commented Effects.PortRaw]
80− -> [A.Commented Valid.Def]
77+ -> [A.Commented Src.ValidDef]
8178 -> Result wrn Effects.Raw
8279validateEffects tag settings@(A.A _ pairs) ports validDefs =
8380 case tag of
@@ -191,7 +188,7 @@ extractOne name settingsDict =
191188checkManager
192189 :: R.Region
193190 -> Effects.ManagerType
194− -> [A.Commented Valid.Def]
191+ -> [A.Commented Src.ValidDef]
195192 -> Result wrn (R.Region, R.Region, R.Region)
196193checkManager tagRegion managerType validDefs =
197194 let
@@ -205,10 +202,10 @@ checkManager tagRegion managerType validDefs =
205202 <*> requireRegion tagRegion regionDict "onSelfMsg"
206203
207204
208−getSimpleDefRegion :: A.Commented Valid.Def -> Maybe (String, R.Region)
205+getSimpleDefRegion :: A.Commented Src.ValidDef -> Maybe (String, R.Region)
209206getSimpleDefRegion decl =
210207 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)) _ _) ->
212209 Just (name, region)
213210
214211 _ ->
@@ -341,7 +338,7 @@ vrdHelp commentedDecls ports structure =
341338
342339vrdDefHelp
343340 :: [A.Commented D.Raw]
344− -> A.Commented Source.Def'
341+ -> A.Commented Src.RawDef'
345342 -> [A.Commented Effects.PortRaw]
346343 -> D.Valid
347344 -> Result wrn ValidStuff
@@ -351,14 +348,14 @@ vrdDefHelp remainingDecls (A.A ann def) ports structure =
351348 ValidStuff finalPorts (D.addDef (A.A ann validDef) struct)
352349 in
353350 case def of
354− Source.Definition pat expr ->
351+ Src.Definition pat expr ->
355352 addDef
356353 <$> validateDef (fst ann) pat expr Nothing
357354 <*> vrdHelp remainingDecls ports structure
358355
359− Source.Annotation name tipe ->
356+ Src.Annotation name tipe ->
360357 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
362359 | Pattern.isVar name pat ->
363360 addDef
364361 <$> validateDef (R.merge (fst ann) defRegion) pat expr (Just tipe)
@@ -373,32 +370,32 @@ vrdDefHelp remainingDecls (A.A ann def) ports structure =
373370-- VALIDATE DEFINITIONS
374371
375372
376−definitions :: [Source.Def] -> Result wrn [Valid.Def]
373+definitions :: [Src.RawDef] -> Result wrn [Src.ValidDef]
377374definitions sourceDefs =
378375 do validDefs <- definitionsHelp sourceDefs
379376
380377 validDefs
381− |> map Valid.getPattern
378+ |> map Src.getPattern
382379 |> concatMap Pattern.boundVars
383380 |> detectDuplicates Error.DuplicateDefinition
384381
385382 return validDefs
386383
387384
388−definitionsHelp :: [Source.Def] -> Result wrn [Valid.Def]
385+definitionsHelp :: [Src.RawDef] -> Result wrn [Src.ValidDef]
389386definitionsHelp sourceDefs =
390387 case sourceDefs of
391388 [] ->
392389 return []
393390
394− A.A defRegion (Source.Definition pat expr) : rest ->
391+ A.A defRegion (Src.Definition pat expr) : rest ->
395392 (:)
396393 <$> validateDef defRegion pat expr Nothing
397394 <*> definitionsHelp rest
398395
399− A.A annRegion (Source.Annotation name tipe) : rest ->
396+ A.A annRegion (Src.Annotation name tipe) : rest ->
400397 case rest of
401− A.A defRegion (Source.Definition pat expr) : rest'
398+ A.A defRegion (Src.Definition pat expr) : rest'
402399 | Pattern.isVar name pat ->
403400 (:)
404401 <$> validateDef (R.merge annRegion defRegion) pat expr (Just tipe)
@@ -411,18 +408,18 @@ definitionsHelp sourceDefs =
411408validateDef
412409 :: R.Region
413410 -> Pattern.Raw
414− -> Source.Expr
411+ -> Src.RawExpr
415412 -> Maybe Type.Raw
416− -> Result wrn Valid.Def
413+ -> Result wrn Src.ValidDef
417414validateDef region pat expr maybeType =
418415 do validExpr <- expression expr
419416 validateDefPattern pat validExpr
420− return $ Valid.Def region pat validExpr maybeType
417+ return $ Src.Def region pat validExpr maybeType
421418
422419
423−validateDefPattern :: Pattern.Raw -> Valid.Expr -> Result wrn ()
420+validateDefPattern :: Pattern.Raw -> Src.ValidExpr -> Result wrn ()
424421validateDefPattern pattern body =
425− case fst (Expr.collectLambdas body) of
422+ case fst (Src.collectLambdas body) of
426423 [] ->
427424 return ()
428425
@@ -459,59 +456,59 @@ checkArguments funcName args =
459456-- VALIDATE EXPRESSIONS
460457
461458
462−expression :: Source.Expr -> Result wrn Valid.Expr
459+expression :: Src.RawExpr -> Result wrn Src.ValidExpr
463460expression (A.A ann sourceExpression) =
464461 A.A ann <$>
465462 case sourceExpression of
466− Var x ->
467− return (Var x)
463+ Src.Var x ->
464+ return (Src.Var x)
468465
469− Lambda pattern body ->
470− Lambda
471− <$> validatePattern pattern
472− <*> expression body
466+ Src.Lambda pattern body ->
467+ Src.Lambda
468+ <$> validatePattern pattern
469+ <*> expression body
473470
474− Binop op leftExpr rightExpr ->
475− Binop op
476− <$> expression leftExpr
477− <*> expression rightExpr
471+ Src.Binop ops lastExpr ->
472+ Src.Binop
473+ <$> traverse (\(expr,op) -> (,) <$> expression expr <*> pure op) ops
474+ <*> expression lastExpr
478475
479− Case e branches ->
480− Case
476+ Src.Case e branches ->
477+ Src.Case
481478 <$> expression e
482− <*> T.traverse (\(p,b) -> (,) <$> validatePattern p <*> expression b) branches
479+ <*> traverse (\(p,b) -> (,) <$> validatePattern p <*> expression b) branches
483480
484− Data name args ->
485− Data name <$> T.traverse expression args
481+ Src.Ctor name args ->
482+ Src.Ctor name <$> traverse expression args
486483
487− Literal lit ->
488− return (Literal lit)
484+ Src.Literal lit ->
485+ return (Src.Literal lit)
489486
490− ExplicitList expressions ->
491− ExplicitList
492− <$> T.traverse expression expressions
487+ Src.List expressions ->
488+ Src.List
489+ <$> traverse expression expressions
493490
494− App funcExpr argExpr ->
495− App
491+ Src.App funcExpr argExpr ->
492+ Src.App
496493 <$> expression funcExpr
497494 <*> expression argExpr
498495
499− If branches finally ->
500− If
501− <$> T.traverse both branches
496+ Src.If branches finally ->
497+ Src.If
498+ <$> traverse both branches
502499 <*> expression finally
503500
504− Access record field ->
505− Access
501+ Src.Access record field ->
502+ Src.Access
506503 <$> expression record
507504 <*> return field
508505
509− Update record fields ->
510− Update
506+ Src.Update record fields ->
507+ Src.Update
511508 <$> expression record
512− <*> T.traverse second fields
509+ <*> traverse second fields
513510
514− Record fields ->
511+ Src.Record fields ->
515512 let
516513 checkDups seenFields (field,_) =
517514 if Set.member field seenFields then
@@ -521,41 +518,23 @@ expression (A.A ann sourceExpression) =
521518 return (Set.insert field seenFields)
522519 in
523520 do foldM_ checkDups Set.empty fields
524− Record <$> T.traverse second fields
521+ Src.Record <$> traverse second fields
525522
526− Let defs body ->
527− Let
523+ Src.Let defs body ->
524+ Src.Let
528525 <$> definitions defs
529526 <*> expression body
530527
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 ->
550− return (GLShader uid src gltipe)
528+ Src.GLShader uid src gltipe ->
529+ return (Src.GLShader uid src gltipe)
551530
552531
553−second :: (a, Source.Expr) -> Result wrn (a, Valid.Expr)
532+second :: (a, Src.RawExpr) -> Result wrn (a, Src.ValidExpr)
554533second (value, expr) =
555534 (,) value <$> expression expr
556535
557536
558−both :: (Source.Expr, Source.Expr) -> Result wrn (Valid.Expr, Valid.Expr)
537+both :: (Src.RawExpr, Src.RawExpr) -> Result wrn (Src.ValidExpr, Src.ValidExpr)
559538both (expr1, expr2) =
560539 (,) <$> expression expr1 <*> expression expr2
561540
@@ -580,7 +559,7 @@ checkDuplicates (ValidStuff ports (D.Decls defs unions aliases _)) =
580559 -- SIMPLE NAMES
581560
582561 defValues =
583− concatMap (Pattern.boundVars . Valid.getPattern . A.drop) defs
562+ concatMap (Pattern.boundVars . Src.getPattern . A.drop) defs
584563
585564 portValues =
586565 map fromPort ports