git.iko.soy/elk
on master help sign in
Merge branch 'case-compiler'
ef92a1dEvan Czaplicki
elm-compiler.cabal+5−6
compare with master
unifiedsplit
@@ -78,7 +78,6 @@ Library
78 Elm.Compiler.Version,
78 Elm.Compiler.Version,
79 Generate.JavaScript,
79 Generate.JavaScript,
80 Generate.JavaScript.BuiltIn,
80 Generate.JavaScript.BuiltIn,
81− Generate.JavaScript.Crash,
82 Generate.JavaScript.Helpers,
81 Generate.JavaScript.Helpers,
83 Generate.JavaScript.Literal,
82 Generate.JavaScript.Literal,
84 Generate.JavaScript.Port,
83 Generate.JavaScript.Port,
@@ -87,9 +86,9 @@ Library
87 Nitpick.PatternMatches,
86 Nitpick.PatternMatches,
88 Nitpick.TopLevelTypes,
87 Nitpick.TopLevelTypes,
89 Optimize,
88 Optimize,
90− Optimize.Cases,
89+ Optimize.Environment,
91− Optimize.Substitute,
90+ Optimize.Patterns,
92− Optimize.TailCalls,
91+ Optimize.Patterns.DecisionTree,
93 Parse.Binop,
92 Parse.Binop,
94 Parse.Declaration,
93 Parse.Declaration,
95 Parse.Expression,
94 Parse.Expression,
@@ -100,7 +99,6 @@ Library
100 Parse.Pattern,
99 Parse.Pattern,
101 Parse.Type,
100 Parse.Type,
102 Reporting.Annotation,
101 Reporting.Annotation,
103− Reporting.Crash,
104 Reporting.Error,
102 Reporting.Error,
105 Reporting.Error.Canonicalize,
103 Reporting.Error.Canonicalize,
106 Reporting.Error.Docs,
104 Reporting.Error.Docs,
@@ -150,7 +148,8 @@ Library
150 text >= 1 && < 2,
148 text >= 1 && < 2,
151 transformers >= 0.2 && < 0.5,
149 transformers >= 0.2 && < 0.5,
152 union-find >= 0.2 && < 0.3,
150 union-find >= 0.2 && < 0.3,
153− unordered-containers >= 0.1 && < 0.3
151+ unordered-containers >= 0.1 && < 0.3,
152+ wl-pprint
154
153
155
154
156Executable elm
155Executable elm
src/AST/Expression/General.hs−5
@@ -16,7 +16,6 @@ import qualified AST.Pattern as Pattern
16import qualified AST.Type as Type
16import qualified AST.Type as Type
17import qualified AST.Variable as Var
17import qualified AST.Variable as Var
18import qualified Reporting.Annotation as A
18import qualified Reporting.Annotation as A
19−import qualified Reporting.Crash as Crash
20import qualified Reporting.PrettyPrint as P
19import qualified Reporting.PrettyPrint as P
21
20
22
21
@@ -59,7 +58,6 @@ data Expr' ann def var typ
59 -- for type checking and code gen only
58 -- for type checking and code gen only
60 | Port (PortImpl (Expr ann def var typ) typ)
59 | Port (PortImpl (Expr ann def var typ) typ)
61 | GLShader String String Literal.GLShaderTipe
60 | GLShader String String Literal.GLShaderTipe
62− | Crash Crash.Details
63 deriving (Show)
61 deriving (Show)
64
62
65
63
@@ -249,9 +247,6 @@ instance (P.Pretty def, P.Pretty var, Var.ToString var) => P.Pretty (Expr' ann d
249 Port portImpl ->
247 Port portImpl ->
250 P.pretty dealiaser needsParens portImpl
248 P.pretty dealiaser needsParens portImpl
251
249
252− Crash details ->
253− P.text ("<crash:" ++ Crash.summary details ++ ">")
254−
255
250
256instance P.Pretty (PortImpl expr tipe) where
251instance P.Pretty (PortImpl expr tipe) where
257 pretty _ _ impl =
252 pretty _ _ impl =
src/AST/Expression/Optimized.hs+46−15
@@ -1,36 +1,67 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2module AST.Expression.Optimized
2module AST.Expression.Optimized
3− ( Expr, Expr'
4− , Def(..)
5− , Facts(..), dummyFacts
3+ ( Def(..), Facts(..), dummyFacts
4+ , Expr(..), Jump(..), Branch(..)
6 ) where
5 ) where
7
6
8import qualified AST.Expression.General as General
7import qualified AST.Expression.General as General
9−import qualified AST.Pattern as Pattern
8+import qualified AST.Literal as Literal
9+import qualified AST.Module.Name as ModuleName
10import qualified AST.Type as Type
10import qualified AST.Type as Type
11import qualified AST.Variable as Var
11import qualified AST.Variable as Var
12+import qualified Optimize.Patterns.DecisionTree as DT
13+import qualified Reporting.Region as R
12
14
13
15
14−type Expr =
15− General.Expr () Def Var.Canonical Type.Canonical
16−
17−
18−type Expr' =
19− General.Expr' () Def Var.Canonical Type.Canonical
20
16
17+-- DEFINITIONS
21
18
22data Def
19data Def
23− = Definition Facts Pattern.Optimized Expr
20+ = Def Facts String Expr
24− deriving (Show)
21+ | TailDef Facts String [String] Expr
25
22
26
23
27data Facts = Facts
24data Facts = Facts
28− { tailRecursionDetails :: Maybe String
25+ { home :: Maybe ModuleName.Canonical
29 , dependencies :: [Var.TopLevel]
26 , dependencies :: [Var.TopLevel]
30 }
27 }
31− deriving (Show)
32
28
33
29
34dummyFacts :: Facts
30dummyFacts :: Facts
35dummyFacts =
31dummyFacts =
36− Facts Nothing []
32+ Facts Nothing []
33+
34+
35+-- EXPRESSIONS
36+
37+data Expr
38+ = Literal Literal.Literal
39+ | Var Var.Canonical
40+ | Range Expr Expr
41+ | ExplicitList [Expr]
42+ | Binop Var.Canonical Expr Expr
43+ | Function [String] Expr
44+ | Call Expr [Expr]
45+ | TailCall String [String] [Expr]
46+ | If [(Expr, Expr)] Expr
47+ | Let [Def] Expr
48+ | Case String (DT.DecisionTree Jump) [(Int, Branch)]
49+ | Data String [Expr]
50+ | DataAccess Expr Int
51+ | Access Expr String
52+ | Update Expr [(String, Expr)]
53+ | Record [(String, Expr)]
54+ | Port (General.PortImpl Expr Type.Canonical)
55+ | GLShader String String Literal.GLShaderTipe
56+ | Crash R.Region (Maybe String)
57+
58+
59+data Jump
60+ = Inline Branch
61+ | Jump Int
62+
63+
64+data Branch = Branch
65+ { _substitutions :: [(String, DT.Path)]
66+ , _branch :: Expr
67+ }
src/AST/Module.hs+1−1
@@ -60,7 +60,7 @@ type CanonicalModule =
60
60
61
61
62type Optimized =
62type Optimized =
63− Module Docs.Centralized [Name.Raw] [Var.Value] (Body Optimized.Expr)
63+ [Optimized.Def]
64
64
65
65
66data Module docs imports exports body = Module
66data Module docs imports exports body = Module
src/AST/Pattern.hs−4
@@ -38,10 +38,6 @@ type CanonicalPattern =
38 Pattern R.Region Var.Canonical
38 Pattern R.Region Var.Canonical
39
39
40
40
41−type Optimized =
42− Pattern () Var.Canonical
43−
44−
45list :: R.Position -> [RawPattern] -> RawPattern
41list :: R.Position -> [RawPattern] -> RawPattern
46list end patterns =
42list end patterns =
47 case patterns of
43 case patterns of
src/AST/Variable.hs+16
@@ -71,6 +71,22 @@ inCore home name =
71
71
72-- VARIABLE RECOGNIZERS
72-- VARIABLE RECOGNIZERS
73
73
74+isLocalHome :: Home -> Bool
75+isLocalHome home =
76+ case home of
77+ BuiltIn ->
78+ False
79+
80+ Module _ ->
81+ False
82+
83+ TopLevel _ ->
84+ True
85+
86+ Local ->
87+ True
88+
89+
74is :: ModuleName.Raw -> String -> Canonical -> Bool
90is :: ModuleName.Raw -> String -> Canonical -> Bool
75is home name var =
91is home name var =
76 var == inCore home name
92 var == inCore home name
src/Canonicalize.hs−3
@@ -487,9 +487,6 @@ expression env (A.A region validExpr) =
487 GLShader uid src tipe ->
487 GLShader uid src tipe ->
488 Result.ok (GLShader uid src tipe)
488 Result.ok (GLShader uid src tipe)
489
489
490− Crash details ->
491− Result.ok (Crash details)
492−
493
490
494pattern
491pattern
495 :: Env.Environment
492 :: Env.Environment
src/Canonicalize/Sort.hs−3
@@ -108,9 +108,6 @@ reorder (A.A ann expression) =
108 Task name expr tipe ->
108 Task name expr tipe ->
109 (\e -> Task name e tipe) <$> reorder expr
109 (\e -> Task name e tipe) <$> reorder expr
110
110
111− Crash _ ->
112− return expression
113−
114 -- Actually do some reordering
111 -- Actually do some reordering
115 Let defs body ->
112 Let defs body ->
116 do body' <- reorder body
113 do body' <- reorder body
src/Generate/JavaScript.hs+189−409
@@ -2,34 +2,34 @@ module Generate.JavaScript (generate) where
2
2
3import Control.Applicative ((<$>),(<*>))
3import Control.Applicative ((<$>),(<*>))
4import Control.Arrow (first, second, (***))
4import Control.Arrow (first, second, (***))
5−import Control.Monad.State
5+import Control.Monad.State as State
6import qualified Data.List as List
6import qualified Data.List as List
7import qualified Data.Map as Map
7import qualified Data.Map as Map
8−import qualified Data.Maybe as Maybe
8+import Language.ECMAScript3.PrettyPrint as ES
9import Language.ECMAScript3.Syntax
9import Language.ECMAScript3.Syntax
10+import qualified Text.PrettyPrint.Leijen as PP
10
11
11−import AST.Expression.General as Expr
12+import qualified AST.Expression.General as Expr
12−import qualified AST.Expression.Optimized as Opt
13+import AST.Expression.Optimized as Opt
13−import qualified AST.Helpers as Help
14+import qualified AST.Literal as L
14−import AST.Literal
15import qualified AST.Module as Module
15import qualified AST.Module as Module
16import qualified AST.Module.Name as ModuleName
16import qualified AST.Module.Name as ModuleName
17−import qualified AST.Pattern as P
18import qualified AST.Variable as Var
17import qualified AST.Variable as Var
19import Generate.JavaScript.Helpers as Help
18import Generate.JavaScript.Helpers as Help
20import qualified Generate.JavaScript.BuiltIn as BuiltIn
19import qualified Generate.JavaScript.BuiltIn as BuiltIn
21−import qualified Generate.JavaScript.Crash as Crash
22import qualified Generate.JavaScript.Literal as Literal
20import qualified Generate.JavaScript.Literal as Literal
23import qualified Generate.JavaScript.Port as Port
21import qualified Generate.JavaScript.Port as Port
24import qualified Generate.JavaScript.Variable as Var
22import qualified Generate.JavaScript.Variable as Var
25−import qualified Optimize.Cases as Case
23+import qualified Optimize.Patterns.DecisionTree as DT
26−import qualified Reporting.Annotation as A
27−import qualified Reporting.Crash as Crash
28
24
29
25
30generate :: Module.Optimized -> String
26generate :: Module.Optimized -> String
31−generate modul =
27+generate definitions =
32− error "TODO" modul exprToCode
28+ let
29+ stmts =
30+ State.evalState (mapM generateDef definitions) 0
31+ in
32+ PP.displayS (PP.renderPretty 0.4 120 (ES.prettyPrint stmts)) ""
33
33
34
34
35-- CODE CHUNKS
35-- CODE CHUNKS
@@ -81,39 +81,35 @@ toExpr code =
81 case code of
81 case code of
82 JsExpr expr ->
82 JsExpr expr ->
83 expr
83 expr
84+
84 JsBlock stmts ->
85 JsBlock stmts ->
85 function [] stmts `call` []
86 function [] stmts `call` []
86
87
87
88
88−-- TAIL CALL CONTEXT
89+-- DEFINITIONS
89
90
90−type TailCallContext =
91+generateDef :: Opt.Def -> State Int (Statement ())
91− Maybe (String, [String], Label)
92+generateDef def =
93+ do (home, name, jsBody) <-
94+ case def of
95+ Opt.TailDef (Opt.Facts home _) name argNames body ->
96+ (,,) home name <$> generateTailFunction name argNames body
92
97
98+ Opt.Def (Opt.Facts home _) name body ->
99+ (,,) home name <$> generateJsExpr body
93
100
94−type Label =
101+ return (VarDeclStmt () [ varDecl (Var.defName home name) jsBody ])
95− Id ()
96
102
97
103
98-- EXPRESSIONS
104-- EXPRESSIONS
99
105
100−toJsExpr :: Opt.Expr -> State Int (Expression ())
106+generateJsExpr :: Opt.Expr -> State Int (Expression ())
101−toJsExpr =
107+generateJsExpr optExpr =
102− exprToJsExpr Nothing
108+ toExpr <$> generateCode optExpr
103−
104
109
105−toCode :: Opt.Expr -> State Int Code
106−toCode =
107− exprToCode Nothing
108
110
109−
110−exprToJsExpr :: TailCallContext -> Opt.Expr -> State Int (Expression ())
111−exprToJsExpr tcc canonicalExpr =
112− toExpr <$> exprToCode tcc canonicalExpr
113−
114−
115−exprToCode :: TailCallContext -> Opt.Expr -> State Int Code
111+generateCode :: Opt.Expr -> State Int Code
116−exprToCode tcc annotatedExpr@(A.A _ expr) =
112+generateCode expr =
117 case expr of
113 case expr of
118 Var var ->
114 Var var ->
119 jsExpr $ Var.canonical var
115 jsExpr $ Var.canonical var
@@ -122,28 +118,28 @@ exprToCode tcc annotatedExpr@(A.A _ expr) =
122 jsExpr (Literal.literal lit)
118 jsExpr (Literal.literal lit)
123
119
124 Range lo hi ->
120 Range lo hi ->
125− do lo' <- toJsExpr lo
121+ do lo' <- generateJsExpr lo
126− hi' <- toJsExpr hi
122+ hi' <- generateJsExpr hi
127 jsExpr $ BuiltIn.range lo' hi'
123 jsExpr $ BuiltIn.range lo' hi'
128
124
129 Access record field ->
125 Access record field ->
130− do record' <- toJsExpr record
126+ do record' <- generateJsExpr record
131 jsExpr $ DotRef () record' (var (Var.safe field))
127 jsExpr $ DotRef () record' (var (Var.safe field))
132
128
133 Update record fields ->
129 Update record fields ->
134 let
130 let
135 fieldToJs (field, value) =
131 fieldToJs (field, value) =
136− do jsValue <- toJsExpr value
132+ do jsValue <- generateJsExpr value
137 return (Var.safe field, jsValue)
133 return (Var.safe field, jsValue)
138 in
134 in
139− do jsRecord <- toJsExpr record
135+ do jsRecord <- generateJsExpr record
140 jsFields <- mapM fieldToJs fields
136 jsFields <- mapM fieldToJs fields
141 jsExpr $ BuiltIn.recordUpdate jsRecord jsFields
137 jsExpr $ BuiltIn.recordUpdate jsRecord jsFields
142
138
143 Record fields ->
139 Record fields ->
144 do fields' <-
140 do fields' <-
145 forM fields $ \(field, e) ->
141 forM fields $ \(field, e) ->
146− (,) (Var.safe field) <$> toJsExpr e
142+ (,) (Var.safe field) <$> generateJsExpr e
147
143
148 let fieldMap =
144 let fieldMap =
149 List.foldl' combine Map.empty fields'
145 List.foldl' combine Map.empty fields'
@@ -163,70 +159,96 @@ exprToCode tcc annotatedExpr@(A.A _ expr) =
163 Binop op leftExpr rightExpr ->
159 Binop op leftExpr rightExpr ->
164 binop op leftExpr rightExpr
160 binop op leftExpr rightExpr
165
161
166− Lambda _ _ ->
162+ Function args body ->
167− generateFunction (Expr.collectLambdas annotatedExpr)
163+ generateFunction args body
168
164
169− App _ _ ->
165+ Call func args ->
170− generateApplication tcc annotatedExpr
166+ let
167+ arity = length args
168+ aN = "A" ++ show arity
169+ in
170+ do jsFunc <- generateJsExpr func
171+ jsArgs <- mapM generateJsExpr args
172+ jsExpr $
173+ if 2 <= arity && arity <= 9 then
174+ ref aN `call` (jsFunc:jsArgs)
175+ else
176+ foldl1 (<|) (jsFunc:jsArgs)
177+
178+ TailCall name argNames args ->
179+ let
180+ reassign name tempName =
181+ ExprStmt () (AssignExpr () OpAssign (LVar () name) (ref tempName))
182+ in
183+ do args' <- mapM generateJsExpr args
184+ tempNames <- mapM (\_ -> Var.fresh) args
185+ jsBlock $
186+ VarDeclStmt () (zipWith varDecl tempNames args')
187+ : zipWith reassign argNames tempNames
188+ ++ [ContinueStmt () (Just (Id () name))]
171
189
172 Let defs body ->
190 Let defs body ->
173− generateLet tcc defs body
191+ do stmts <- mapM generateDef defs
192+ code <- generateCode body
193+ jsBlock (stmts ++ toStatementList code)
174
194
175 If branches finally ->
195 If branches finally ->
176− generateIf tcc branches finally
196+ generateIf branches finally
177
197
178− Case expr branches ->
198+ Case root decisionTree branches ->
179− generateCase tcc expr branches
199+ JsBlock <$> generateCase root decisionTree branches
180
200
181 ExplicitList elements ->
201 ExplicitList elements ->
182− do jsElements <- mapM toJsExpr elements
202+ do jsElements <- mapM generateJsExpr elements
183 jsExpr $ BuiltIn.list jsElements
203 jsExpr $ BuiltIn.list jsElements
184
204
185 Data tag members ->
205 Data tag members ->
186− do jsMembers <- mapM toJsExpr members
206+ do jsMembers <- mapM generateJsExpr members
187 jsExpr $ ObjectLit () (ctor : fields jsMembers)
207 jsExpr $ ObjectLit () (ctor : fields jsMembers)
188 where
208 where
189 ctor = (prop "ctor", string tag)
209 ctor = (prop "ctor", string tag)
190 fields =
210 fields =
191 zipWith (\n e -> (prop ("_" ++ show n), e)) [ 0 :: Int .. ]
211 zipWith (\n e -> (prop ("_" ++ show n), e)) [ 0 :: Int .. ]
192
212
213+ DataAccess dataExpr index ->
214+ do jsDataExpr <- generateJsExpr dataExpr
215+ jsExpr $ DotRef () jsDataExpr (var ("_" ++ show index))
216+
193 GLShader _uid src _tipe ->
217 GLShader _uid src _tipe ->
194− jsExpr $ ObjectLit () [(PropString () "src", Literal.literal (Str src))]
218+ jsExpr $ ObjectLit () [(PropString () "src", Literal.literal (L.Str src))]
195
219
196 Port impl ->
220 Port impl ->
197 case impl of
221 case impl of
198− In name portType ->
222+ Expr.In name portType ->
199 jsExpr (Port.inbound name portType)
223 jsExpr (Port.inbound name portType)
200
224
201− Out name expr portType ->
225+ Expr.Out name expr portType ->
202− do expr' <- toJsExpr expr
226+ do expr' <- generateJsExpr expr
203 jsExpr (Port.outbound name expr' portType)
227 jsExpr (Port.outbound name expr' portType)
204
228
205− Task name expr portType ->
229+ Expr.Task name expr portType ->
206− do expr' <- toJsExpr expr
230+ do expr' <- generateJsExpr expr
207 jsExpr (Port.task name expr' portType)
231 jsExpr (Port.task name expr' portType)
208
232
209− Crash details ->
233+ Crash region maybeCaseCrashValue ->
210− jsExpr $ Crash.crash details
234+ jsExpr $ BuiltIn.crash region maybeCaseCrashValue
211
235
212
236
213-- FUNCTIONS
237-- FUNCTIONS
214
238
215−generateFunction :: ([P.Optimized], Opt.Expr) -> State Int Code
239+generateFunction :: [String] -> Opt.Expr -> State Int Code
216−generateFunction (args, initialBody) =
240+generateFunction args body =
217− do (argVars, patternDefs) <- destructuredArgs args
241+ do code <- generateCode body
218− code <- generateLet Nothing patternDefs initialBody
219− jsExpr (generateFunctionWithArity argVars code)
242+ jsExpr (generateFunctionWithArity args code)
220
243
221
244
222−generateTailFunction :: String -> ([P.Optimized], Opt.Expr) -> State Int (Expression ())
245+generateTailFunction :: String -> [String] -> Opt.Expr -> State Int (Expression ())
223−generateTailFunction name (args, initialBody) =
246+generateTailFunction name args body =
224− do (argVars, patternDefs) <- destructuredArgs args
247+ do code <- generateCode body
225− label <- Id () <$> Case.newVar
248+ return $ generateFunctionWithArity args $ JsBlock $ (:[]) $
226− code <- generateLet (Just (name, argVars, label)) patternDefs initialBody
249+ LabelledStmt ()
227− let whileLoop =
250+ (Id () name)
228− JsBlock [ LabelledStmt () label (WhileStmt () (BoolLit () True) (toStatement code)) ]
251+ (WhileStmt () (BoolLit () True) (toStatement code))
229− return (generateFunctionWithArity argVars whileLoop)
230
252
231
253
232generateFunctionWithArity :: [String] -> Code -> Expression ()
254generateFunctionWithArity :: [String] -> Code -> Expression ()
@@ -247,105 +269,16 @@ generateFunctionWithArity args code =
247 foldl (\body arg -> function [arg] [ret body]) innerBody otherArgs
269 foldl (\body arg -> function [arg] [ret body]) innerBody otherArgs
248
270
249
271
250−destructuredArgs :: [P.Optimized] -> State Int ([String], [Opt.Def])
251−destructuredArgs args =
252− do (argVars, maybePatternDefs) <- unzip <$> mapM destructPattern args
253− return (argVars, Maybe.catMaybes maybePatternDefs)
254−
255−
256−destructPattern :: P.Optimized -> State Int (String, Maybe Opt.Def)
257−destructPattern pattern@(A.A ann pat) =
258− case pat of
259− P.Var x ->
260− return (Var.safe x, Nothing)
261−
262− _ ->
263− do arg <- Case.newVar
264− return
265− ( arg
266− , Just $ Opt.Definition Opt.dummyFacts pattern (A.A ann (localVar arg))
267− )
268−
269−
270−-- APPLICATIONS
271−
272−generateApplication :: TailCallContext -> Opt.Expr -> State Int Code
273−generateApplication tcc expr =
274− let
275− (func:args) =
276− Expr.collectApps expr
277−
278− arity =
279− length args
280−
281− reassign name tempName =
282− ExprStmt () (AssignExpr () OpAssign (LVar () name) (ref tempName))
283−
284− aN =
285− "A" ++ show arity
286− in
287− case isTailCall tcc func arity of
288− Just (argNames, label) ->
289− do args' <- mapM toJsExpr args
290− tempNames <- mapM (\_ -> Case.newVar) args
291− jsBlock $
292− VarDeclStmt () (zipWith varDecl tempNames args')
293− : zipWith reassign argNames tempNames
294− ++ [ContinueStmt () (Just label)]
295−
296− _ ->
297− do func' <- toJsExpr func
298− args' <- mapM toJsExpr args
299− jsExpr $
300− if 2 <= arity && arity <= 9 then
301− ref aN `call` (func':args')
302− else
303− foldl1 (<|) (func':args')
304−
305−
306−isTailCall :: TailCallContext -> Opt.Expr -> Int -> Maybe ([String], Label)
307−isTailCall tcc (A.A _ func) arity =
308− case (func, tcc) of
309− (Var (Var.Canonical Var.Local name), Just (tcName, tcArgs, tcLabel)) ->
310− if name == tcName && length tcArgs == arity then
311− Just (tcArgs, tcLabel)
312− else
313− Nothing
314−
315− (Var (Var.Canonical (Var.TopLevel _) name), Just (tcName, tcArgs, tcLabel)) ->
316− if name == tcName && length tcArgs == arity then
317− Just (tcArgs, tcLabel)
318− else
319− Nothing
320−
321− _ ->
322− Nothing
323−
324−
325−-- LET EXPRESSIONS
326−
327−generateLet
328− :: TailCallContext
329− -> [Opt.Def]
330− -> Opt.Expr
331− -> State Int Code
332−generateLet tcc givenDefs givenBody =
333− do let (defs, body) = flattenLets givenDefs givenBody
334− stmts <- concat <$> mapM defToStatements defs
335− code <- exprToCode tcc body
336− jsBlock (stmts ++ toStatementList code)
337−
338−
339-- GENERATE IFS
272-- GENERATE IFS
340
273
341−generateIf :: TailCallContext -> [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code
274+generateIf :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code
342−generateIf tcc givenBranches givenFinally =
275+generateIf givenBranches givenFinally =
343 let
276 let
344 (branches, finally) =
277 (branches, finally) =
345 crushIfs givenBranches givenFinally
278 crushIfs givenBranches givenFinally
346
279
347 convertBranch (condition, expr) =
280 convertBranch (condition, expr) =
348− (,) <$> toJsExpr condition <*> exprToCode tcc expr
281+ (,) <$> generateJsExpr condition <*> generateCode expr
349
282
350 ifExpression (condition, branch) otherwise =
283 ifExpression (condition, branch) otherwise =
351 CondExpr () condition branch otherwise
284 CondExpr () condition branch otherwise
@@ -354,7 +287,7 @@ generateIf tcc givenBranches givenFinally =
354 IfStmt () condition branch otherwise
287 IfStmt () condition branch otherwise
355 in
288 in
356 do jsBranches <- mapM convertBranch branches
289 do jsBranches <- mapM convertBranch branches
357− jsFinally <- exprToCode tcc finally
290+ jsFinally <- generateCode finally
358
291
359 if any isBlock (jsFinally : map snd jsBranches)
292 if any isBlock (jsFinally : map snd jsBranches)
360 then
293 then
@@ -380,263 +313,146 @@ crushIfsHelp visitedBranches unvisitedBranches finally =
380 case unvisitedBranches of
313 case unvisitedBranches of
381 [] ->
314 [] ->
382 case finally of
315 case finally of
383− A.A _ (If subBranches subFinally) ->
316+ If subBranches subFinally ->
384 crushIfsHelp visitedBranches subBranches subFinally
317 crushIfsHelp visitedBranches subBranches subFinally
385
318
386 _ ->
319 _ ->
387 (reverse visitedBranches, finally)
320 (reverse visitedBranches, finally)
388
321
389− (A.A _ (Literal (Boolean True)), branch) : _ ->
322+ (Literal (L.Boolean True), branch) : _ ->
390 crushIfsHelp visitedBranches [] branch
323 crushIfsHelp visitedBranches [] branch
391
324
392 visiting : unvisited ->
325 visiting : unvisited ->
393 crushIfsHelp (visiting : visitedBranches) unvisited finally
326 crushIfsHelp (visiting : visitedBranches) unvisited finally
394
327
395
328
329+-- CASE EXPRESSIONS
396
330
397−-- DEFINITIONS
331+generateCase
398−
332+ :: String
333+ -> DT.DecisionTree Opt.Jump
334+ -> [(Int, Opt.Branch)]
399−defToStatements :: Opt.Def -> State Int [Statement ()]
335+ -> State Int [Statement ()]
400−defToStatements (Opt.Definition facts pattern expr) =
336+generateCase root decisionTree jumpBranches =
401− case Opt.tailRecursionDetails facts of
337+ do decider <- generateDecisionTree root decisionTree
402− Just name ->
338+ foldM (goto root) decider jumpBranches
403− do func <- generateTailFunction name (Expr.collectLambdas expr)
404− return [ VarDeclStmt () [ varDecl name func ] ]
405−
406− Nothing ->
407− defToStatementsHelp facts pattern =<< toJsExpr expr
408
339
409
340
410−defToStatementsHelp
411− :: Opt.Facts
412− -> P.Optimized
413− -> Expression ()
414− -> State Int [Statement ()]
341+goto :: String -> [Statement ()] -> (Int, Opt.Branch) -> State Int [Statement ()]
415−defToStatementsHelp facts annPattern@(A.A _ pattern) jsExpr =
342+goto root decider (target, branch) =
416 let
343 let
417− define x =
344+ deciderStmt =
418− varDecl x jsExpr
345+ LabelledStmt ()
346+ (targetLabel root target)
347+ (DoWhileStmt () (BlockStmt () decider) (BoolLit () False))
419 in
348 in
420− case pattern of
349+ do stmts <- generateBranch root branch
421− P.Var x ->
350+ return (deciderStmt : stmts)
422− if Help.isOp x then
423− let
424− op = LBracket () (ref "_op") (string x)
425− in
426− return [ ExprStmt () $ AssignExpr () OpAssign op jsExpr ]
427− else
428− return [ VarDeclStmt () [ define (Var.safe x) ] ]
429−
430− P.Record fields ->
431− let
432− setField name =
433− varDecl name (obj ["$",name])
434− in
435− return [ VarDeclStmt () (define "$" : map setField fields) ]
436−
437− P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->
438− return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
439− where
440− vars = getVars patterns
441− getVars patterns =
442− case patterns of
443− A.A _ (P.Var x) : rest ->
444− (Var.safe x :) `fmap` getVars rest
445− [] ->
446− Just []
447− _ ->
448− Nothing
449−
450− decl x n = varDecl x (obj ["$","_" ++ show n])
451− setup vars
452− | Help.isTuple name = define "$" : vars
453− | otherwise = define "_raw" : safeAssign : vars
454−
455− safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception)
456− if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name)
457− exception = Crash.crash (Crash.IncompletePatternMatch (error "TODO"))
458−
459− _ ->
460− do defs' <- concat <$> mapM toDef vars
461− return (VarDeclStmt () [define "_"] : defs')
462− where
463− vars = P.boundVarList annPattern
464− mkVar = A.A () . localVar
465− toDef y =
466− let expr = A.A () $ Case (mkVar "_") [(annPattern, mkVar y)]
467− pat = A.A () (P.Var y)
468− in
469− defToStatements (Opt.Definition facts pat expr)
470
351
471
352
472−-- CASE EXPRESSIONS
353+targetLabel :: String -> Int -> Id ()
354+targetLabel root target =
355+ Id () (root ++ "_" ++ show target)
473
356
474−generateCase :: TailCallContext -> Opt.Expr -> [(P.Optimized, Opt.Expr)] -> State Int Code
475−generateCase tcc expr branches =
476− do (tempVar, initialMatch) <-
477− Case.toMatch branches
478−
479− (revisedMatch, stmt) <-
480− case expr of
481− A.A _ (Var (Var.Canonical Var.Local x)) ->
482− return (Case.matchSubst [(tempVar, Var.safe x)] initialMatch, [])
483−
484− A.A _ (Var (Var.Canonical (Var.TopLevel _) x)) ->
485− return (Case.matchSubst [(tempVar, Var.safe x)] initialMatch, [])
486−
487− _ ->
488− do expr' <- toJsExpr expr
489− return (initialMatch, [VarDeclStmt () [varDecl tempVar expr']])
490−
491− match' <- match tcc revisedMatch
492−
493− jsBlock (stmt ++ match')
494−
495−
496−match :: TailCallContext -> Case.Match -> State Int [Statement ()]
497−match tcc mtch =
498− case mtch of
499− Case.Match name clauses mtch' ->
500− do (isChars, clauses') <- unzip <$> mapM (clause tcc name) clauses
501− mtch'' <- match tcc mtch'
502− return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
503− where
504− isLiteral p =
505− case p of
506− Case.Clause (Right _) _ _ ->
507− True
508− _ ->
509− False
510−
511− access name =
512− if any isLiteral clauses then
513− obj [name]
514− else
515− obj (Help.splitDots name ++ ["ctor"])
516−
517− format isChars expr =
518− if or isChars then
519− InfixExpr () OpAdd expr (string "")
520− else
521− expr
522−
523− Case.Fail ->
524− return [ ExprStmt () (Crash.crash (Crash.IncompletePatternMatch (error "TODO"))) ]
525−
526− Case.Break ->
527− return [BreakStmt () Nothing]
528−
529− Case.Other expr ->
530− toStatementList <$> exprToCode tcc expr
531−
532− Case.Seq ms ->
533− concat <$> mapM (match tcc) (dropEnd [] ms)
534− where
535− dropEnd acc [] = acc
536− dropEnd acc (m:ms) =
537− case m of
538− Case.Other _ -> acc ++ [m]
539− _ -> dropEnd (acc ++ [m]) ms
540−
541−
542−clause :: TailCallContext -> String -> Case.Clause -> State Int (Bool, CaseClause ())
543−clause tcc variable (Case.Clause value vars mtch) =
544− do statemens <- match tcc (Case.matchSubst (zip vars vars') mtch)
545− return ((,) isChar (CaseClause () pattern statemens))
546− where
547− vars' =
548− map (\n -> variable ++ "._" ++ show n) [0..]
549
357
550− (isChar, pattern) =
358+generateDecisionTree :: String -> DT.DecisionTree Opt.Jump -> State Int [Statement ()]
551− case value of
359+generateDecisionTree root decisionTree =
552− Right (Chr c) -> (True, string [c])
553− _ ->
554− (,) False $
555− case value of
360+ case decisionTree of
556− Right (Boolean b) -> BoolLit () b
361+ DT.Match (Opt.Inline branch) ->
557− Right lit -> Literal.literal lit
362+ generateBranch root branch
558− Left (Var.Canonical _ name) ->
559− string name
560
363
364+ DT.Match (Opt.Jump target) ->
365+ return [ BreakStmt () (Just (targetLabel root target)) ]
561
366
562−flattenLets :: [Opt.Def] -> Opt.Expr -> ([Opt.Def], Opt.Expr)
367+ DT.Decision testPath edges fallback ->
563−flattenLets defs lexpr@(A.A _ expr) =
368+ do accessExpr <- generateJsExpr (pathToExpr root testPath)
564− case expr of
565− Let ds body -> flattenLets (defs ++ ds) body
566− _ -> (defs, lexpr)
567
369
370+ let testExpr =
371+ case fst (head edges) of
372+ DT.Constructor _ ->
373+ DotRef () accessExpr (Id () "ctor")
568
374
569−-- BINARY OPERATORS
375+ DT.Literal _ ->
376+ accessExpr
570
377
571−binop
378+ caseClauses <- mapM (edgeToCaseClause root) edges
572− :: Var.Canonical
379+ caseDefault <- fallbackToDefault root fallback
573− -> Opt.Expr
574− -> Opt.Expr
575− -> State Int Code
576−binop func left right
577− | func == Var.Canonical Var.BuiltIn "::" =
578− toCode (A.A () (Data "::" [left,right]))
579
380
580− | func == forwardCompose =
381+ return [ SwitchStmt () testExpr (caseClauses ++ caseDefault) ]
581− compose (collectLeftAssoc forwardCompose left right)
582
382
583− | func == backwardCompose =
584− compose (collectRightAssoc backwardCompose left right)
585
383
586− | func == forwardApply =
384+edgeToCaseClause :: String -> (DT.Test, DT.DecisionTree Opt.Jump) -> State Int (CaseClause ())
587− pipe (collectLeftAssoc forwardApply left right)
385+edgeToCaseClause root (test, subTree) =
386+ CaseClause () (testToExpr test) <$> generateDecisionTree root subTree
588
387
589− | func == backwardApply =
590− pipe (collectRightAssoc backwardApply left right)
591
388
592− | otherwise =
389+testToExpr :: DT.Test -> Expression ()
593− do jsLeft <- toJsExpr left
390+testToExpr test =
594− jsRight <- toJsExpr right
391+ case test of
595− jsExpr (makeExpr func jsLeft jsRight)
392+ DT.Constructor (Var.Canonical _ tag) ->
393+ StringLit () tag
596
394
395+ DT.Literal (L.Chr char) ->
396+ StringLit () [char]
597
397
598−-- CONTROL FLOW OPERATOR HELPERS
398+ DT.Literal lit ->
399+ Literal.literal lit
599
400
600−apply :: Expression () -> Expression () -> Expression ()
601−apply arg func =
602− func <| arg
603
401
402+fallbackToDefault :: String -> Maybe (DT.DecisionTree Opt.Jump) -> State Int [CaseClause ()]
403+fallbackToDefault root fallback =
404+ case fallback of
405+ Nothing ->
406+ return []
604
407
605−compose :: [Opt.Expr] -> State Int Code
408+ Just subTree ->
606−compose functions =
409+ do stmts <- generateDecisionTree root subTree
607− do jsFunctions <- mapM toJsExpr functions
410+ return [ CaseDefault () stmts ]
608− jsExpr $ ["$"] ==> List.foldl' apply (ref "$") jsFunctions
609
411
610
412
611−pipe :: [Opt.Expr] -> State Int Code
413+generateBranch :: String -> Opt.Branch -> State Int [Statement ()]
612−pipe expressions =
414+generateBranch root (Opt.Branch substitutions expr) =
613− do (value:functions) <- mapM toJsExpr expressions
415+ do subts <- mapM (loadPath root) substitutions
614− jsExpr $ List.foldl' apply value functions
416+ code <- generateCode expr
417+ return (subts ++ toStatementList code)
615
418
616
419
617−forwardCompose :: Var.Canonical
420+loadPath :: String -> (String, DT.Path) -> State Int (Statement ())
618−forwardCompose =
421+loadPath root (name, path) =
619− inBasics ">>"
422+ do jsAccessExpr <- generateJsExpr (pathToExpr root path)
423+ return $ VarDeclStmt () [ varDecl name jsAccessExpr ]
620
424
621
425
622−backwardCompose :: Var.Canonical
426+pathToExpr :: String -> DT.Path -> Opt.Expr
623−backwardCompose =
427+pathToExpr root fullPath =
624− inBasics "<<"
428+ go (Opt.Var (Var.local root)) fullPath
429+ where
430+ go expr path =
431+ case path of
432+ DT.Position index subpath ->
433+ go (Opt.DataAccess expr index) subpath
625
434
435+ DT.Field field subpath ->
436+ go (Opt.Access expr field) subpath
626
437
627−forwardApply :: Var.Canonical
438+ DT.Empty ->
628−forwardApply =
439+ expr
629− inBasics "|>"
630
440
441+ DT.Alias ->
442+ expr
631
443
632−backwardApply :: Var.Canonical
633−backwardApply =
634− inBasics "<|"
635
444
445+-- BINARY OPERATORS
636
446
447+binop
637−inBasics :: String -> Var.Canonical
448+ :: Var.Canonical
638−inBasics name =
449+ -> Opt.Expr
639− Var.inCore ["Basics"] name
450+ -> Opt.Expr
451+ -> State Int Code
452+binop func left right =
453+ do jsLeft <- generateJsExpr left
454+ jsRight <- generateJsExpr right
455+ jsExpr (makeExpr func jsLeft jsRight)
640
456
641
457
642-- BINARY OPERATOR HELPERS
458-- BINARY OPERATOR HELPERS
@@ -676,7 +492,6 @@ infixOps =
676specialOps :: [(String, Expression () -> Expression () -> Expression ())]
492specialOps :: [(String, Expression () -> Expression () -> Expression ())]
677specialOps =
493specialOps =
678 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
494 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
679− , (,) "|>" $ flip (<|)
680 , (,) "==" $ \a b -> BuiltIn.eq a b
495 , (,) "==" $ \a b -> BuiltIn.eq a b
681 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (BuiltIn.eq a b)
496 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (BuiltIn.eq a b)
682 , (,) "<" $ cmp OpLT 0
497 , (,) "<" $ cmp OpLT 0
@@ -690,38 +505,3 @@ specialOps =
690cmp :: InfixOp -> Int -> Expression () -> Expression () -> Expression ()
505cmp :: InfixOp -> Int -> Expression () -> Expression () -> Expression ()
691cmp op n a b =
506cmp op n a b =
692 InfixExpr () op (BuiltIn.compare a b) (IntLit () n)
507 InfixExpr () op (BuiltIn.compare a b) (IntLit () n)
693−
694−
695−-- BINARY OPERATOR COLLECTORS
696−
697−-- (h << g << f) becomes [f, g, h] which is the order you want for doing stuff
698−collectRightAssoc :: Var.Canonical -> Opt.Expr -> Opt.Expr -> [Opt.Expr]
699−collectRightAssoc desiredOp left right =
700− collectRightAssocHelp desiredOp [left] right
701−
702−
703−collectRightAssocHelp :: Var.Canonical -> [Opt.Expr] -> Opt.Expr -> [Opt.Expr]
704−collectRightAssocHelp desiredOp exprList expr =
705− case expr of
706− A.A _ (Binop op left right) | op == desiredOp ->
707− collectRightAssocHelp desiredOp (left : exprList) right
708−
709− _ ->
710− expr : exprList
711−
712−
713−-- (f >> g >> h) becomes [f, g, h] which is the order you want for doing stuff
714−collectLeftAssoc :: Var.Canonical -> Opt.Expr -> Opt.Expr -> [Opt.Expr]
715−collectLeftAssoc desiredOp left right =
716− collectLeftAssocHelp desiredOp [right] left
717−
718−
719−collectLeftAssocHelp :: Var.Canonical -> [Opt.Expr] -> Opt.Expr -> [Opt.Expr]
720−collectLeftAssocHelp desiredOp exprList expr =
721− case expr of
722− A.A _ (Binop op left right) | op == desiredOp ->
723− collectLeftAssocHelp desiredOp (right : exprList) left
724−
725− _ ->
726− expr : exprList
727−
src/Generate/JavaScript/BuiltIn.hs+47−6
@@ -2,12 +2,20 @@ module Generate.JavaScript.BuiltIn where
2
2
3import qualified Language.ECMAScript3.Syntax as JS
3import qualified Language.ECMAScript3.Syntax as JS
4
4
5+import Generate.JavaScript.Helpers
6+import qualified Reporting.Region as R
7+
8+
9+utils :: String -> [JS.Expression ()] -> JS.Expression ()
10+utils func args =
11+ error "TODO"
12+
5
13
6-- LITERALS
14-- LITERALS
7
15
8character :: Char -> JS.Expression ()
16character :: Char -> JS.Expression ()
9character char =
17character char =
10− error "TODO - utils.chr" JS.StringLit () [char]
18+ utils "chr" [ JS.StringLit () [char] ]
11
19
12
20
13string :: String -> JS.Expression ()
21string :: String -> JS.Expression ()
@@ -19,28 +27,61 @@ string str =
19
27
20list :: [JS.Expression ()] -> JS.Expression ()
28list :: [JS.Expression ()] -> JS.Expression ()
21list elements =
29list elements =
22− error "TODO - utils.list" (JS.ArrayLit () elements)
30+ utils "list" [ JS.ArrayLit () elements ]
23
31
24
32
25range :: JS.Expression () -> JS.Expression () -> JS.Expression ()
33range :: JS.Expression () -> JS.Expression () -> JS.Expression ()
26range low high =
34range low high =
27− error "TODO - utils.range" low high
35+ utils "range" [ low, high ]
28
36
29
37
30-- RECORDS
38-- RECORDS
31
39
32recordUpdate :: JS.Expression () -> [(String, JS.Expression ())] -> JS.Expression ()
40recordUpdate :: JS.Expression () -> [(String, JS.Expression ())] -> JS.Expression ()
33recordUpdate record fields =
41recordUpdate record fields =
34− error "TODO - utils.update" record fields
42+ utils "update" [ record, JS.ArrayLit () (map toKeyValue fields) ]
43+
44+
45+toKeyValue :: (String, JS.Expression ()) -> JS.Expression ()
46+toKeyValue (key, value) =
47+ JS.ArrayLit () [ JS.StringLit () key, value ]
35
48
36
49
37-- COMPARISIONS
50-- COMPARISIONS
38
51
39eq :: JS.Expression () -> JS.Expression () -> JS.Expression ()
52eq :: JS.Expression () -> JS.Expression () -> JS.Expression ()
40eq left right =
53eq left right =
41− error "TODO - utils.eq" left right
54+ utils "eq" [ left, right ]
42
55
43
56
44compare :: JS.Expression () -> JS.Expression () -> JS.Expression ()
57compare :: JS.Expression () -> JS.Expression () -> JS.Expression ()
45compare left right =
58compare left right =
46− error "TODO - utils.compare" left right
59+ utils "compare" [ left, right ]
60+
61+
62+-- CRASH
63+
64+crash :: R.Region -> Maybe String -> JS.Expression ()
65+crash region maybeCaseCrashValue =
66+ case maybeCaseCrashValue of
67+ Nothing ->
68+ utils "crash" [ regionToJs region ]
69+
70+ Just crashValue ->
71+ utils "caseCrash" [ regionToJs region, ref crashValue ]
72+
73+
74+regionToJs :: R.Region -> JS.Expression ()
75+regionToJs (R.Region start end) =
76+ JS.ObjectLit ()
77+ [ ( prop "start", positionToJs start )
78+ , ( prop "end", positionToJs end )
79+ ]
80+
81+
82+positionToJs :: R.Position -> JS.Expression ()
83+positionToJs (R.Position line column) =
84+ JS.ObjectLit ()
85+ [ ( prop "line", JS.IntLit () line )
86+ , ( prop "column", JS.IntLit () column )
87+ ]
src/Generate/JavaScript/Crash.hsdeleted−32
@@ -1,32 +0,0 @@
1−module Generate.JavaScript.Crash where
2−
3−import Language.ECMAScript3.Syntax (Expression)
4−
5−import Generate.JavaScript.Helpers (call, obj, ref, string)
6−import qualified Reporting.Crash as Crash
7−import qualified Reporting.Region as R
8−
9−
10−localModuleName :: String
11−localModuleName =
12− "$moduleName"
13−
14−
15−crash :: Crash.Details -> Expression ()
16−crash details =
17− case details of
18− Crash.IncompleteMultiIf region ->
19− obj ["_U","badIf"]
20− `call`
21− [ ref localModuleName
22− , string (R.toString region)
23− ]
24−
25− Crash.IncompletePatternMatch _region ->
26− obj ["_U","badCase"]
27− `call`
28− [ ref localModuleName
29− , string "bugs in reporting the exact location right now" -- TODO
30− ]
31−
32−
src/Generate/JavaScript/Variable.hs+28−6
@@ -1,5 +1,6 @@
1−module Generate.JavaScript.Variable (canonical, safe) where
1+module Generate.JavaScript.Variable (fresh, canonical, defName, safe) where
2
2
3+import qualified Control.Monad.State as State
3import qualified Data.List as List
4import qualified Data.List as List
4import qualified Data.Set as Set
5import qualified Data.Set as Set
5import qualified Language.ECMAScript3.Syntax as JS
6import qualified Language.ECMAScript3.Syntax as JS
@@ -11,6 +12,27 @@ import qualified Elm.Package as Pkg
11import qualified Generate.JavaScript.Helpers as JS
12import qualified Generate.JavaScript.Helpers as JS
12
13
13
14
15+-- FRESH NAMES
16+
17+fresh :: State.State Int String
18+fresh =
19+ do n <- State.get
20+ State.modify (+1)
21+ return ("_v" ++ show n)
22+
23+
24+-- DEF NAMES
25+
26+defName :: Maybe ModuleName.Canonical -> String -> String
27+defName maybeHome name =
28+ case maybeHome of
29+ Nothing ->
30+ safe name
31+
32+ Just home ->
33+ canonicalPrefix home (safe name)
34+
35+
14-- INSTANTIATE VARIABLES
36-- INSTANTIATE VARIABLES
15
37
16canonical :: Var.Canonical -> JS.Expression ()
38canonical :: Var.Canonical -> JS.Expression ()
@@ -29,21 +51,21 @@ addRoot home name =
29 name
51 name
30
52
31 Var.TopLevel moduleName ->
53 Var.TopLevel moduleName ->
32− canonicalName moduleName name
54+ canonicalPrefix moduleName name
33
55
34 Var.BuiltIn ->
56 Var.BuiltIn ->
35 name
57 name
36
58
37 Var.Module moduleName ->
59 Var.Module moduleName ->
38− canonicalName moduleName name
60+ canonicalPrefix moduleName name
39
61
40
62
41−canonicalName :: ModuleName.Canonical -> String -> String
63+canonicalPrefix :: ModuleName.Canonical -> String -> String
42−canonicalName (ModuleName.Canonical (Pkg.Name user project) moduleName) name =
64+canonicalPrefix (ModuleName.Canonical (Pkg.Name user project) moduleName) name =
43 map (swap '-' '_') user
65 map (swap '-' '_') user
44 ++ '$' : map (swap '-' '_') project
66 ++ '$' : map (swap '-' '_') project
45 ++ '$' : List.intercalate "$" moduleName
67 ++ '$' : List.intercalate "$" moduleName
46− ++ '$' : name
68+ ++ '$' : safe name
47
69
48
70
49swap :: Char -> Char -> Char -> Char
71swap :: Char -> Char -> Char -> Char
src/Nitpick/PatternMatches.hs−3
@@ -181,9 +181,6 @@ checkExpression tagDict (A.A region expression) =
181 E.GLShader _ _ _ ->
181 E.GLShader _ _ _ ->
182 Result.ok ()
182 Result.ok ()
183
183
184− E.Crash _ ->
185− Result.ok ()
186−
187
184
188-- CHECK PATTERNS
185-- CHECK PATTERNS
189
186
src/Optimize.hs+456−12
@@ -1,19 +1,463 @@
1−module Optimize where
1+module Optimize (optimize) where
2
2
3+import Control.Applicative
3−import qualified AST.Module as M
4+import qualified Control.Monad as M
4−import qualified Optimize.TailCalls as TC
5+import qualified Data.Map as Map
6+import qualified Data.Traversable as T
5
7
8+import qualified AST.Expression.General as Expr
9+import qualified AST.Expression.Canonical as Can
10+import qualified AST.Expression.Optimized as Opt
11+import qualified AST.Module as Module
12+import qualified AST.Module.Name as ModuleName
13+import qualified AST.Pattern as P
14+import qualified AST.Variable as Var
15+import Elm.Utils ((|>))
16+import qualified Optimize.Environment as Env
17+import qualified Optimize.Patterns as Patterns
18+import qualified Reporting.Annotation as A
19+import qualified Reporting.Region as R
6
20
21+
22+-- OPTIMIZE - turn a canonical module into a list of optimized defs
23+
7−optimize :: M.CanonicalModule -> M.Optimized
24+optimize :: Module.CanonicalModule -> Module.Optimized
8−optimize modul =
25+optimize (Module.Module home _ _ _ _ body) =
26+ let
27+ (defs, _) =
28+ flattenLets [] (Module.program body)
29+
30+ variantInfo (_, tags) =
31+ let
32+ variants = length tags
33+ in
34+ map (\(tag, _) -> (Var.fromModule home tag, variants)) tags
35+
36+ variantDict =
37+ Module.datatypes body
38+ |> Map.elems
39+ |> concatMap variantInfo
40+ |> Map.fromList
41+ |> Map.insert (Var.builtin "_Tuple2") 1
42+ in
43+ Env.run variantDict (concat <$> mapM (optimizeDef (Just home)) defs)
44+
45+
46+flattenLets :: [Can.Def] -> Can.Expr -> ([Can.Def], Can.Expr)
47+flattenLets defs annExpr@(A.A _ expr) =
48+ case expr of
49+ Expr.Let ds body ->
50+ flattenLets (defs ++ ds) body
51+
52+ _ ->
53+ (defs, annExpr)
54+
55+
56+-- CONVERT DEFINITIONS
57+
58+optimizeDef :: Maybe ModuleName.Canonical -> Can.Def -> Env.Optimizer [Opt.Def]
59+optimizeDef home (Can.Definition (Can.Facts deps) pattern@(A.A _ ptrn) expression _) =
60+ let
61+ (args, rawBody) =
62+ Expr.collectLambdas expression
63+ in
64+ case (ptrn, args) of
65+ (P.Var name, _ : _) ->
66+
67+ do htc <- Env.getTailCall
68+ Env.setTailCall False
69+
70+ (args, body) <- optimizeFunction (Just name) args rawBody
71+
72+ isTailCall <- Env.getTailCall
73+ Env.setTailCall htc
74+
75+ let facts = Opt.Facts home deps
76+
77+ return $
78+ if isTailCall then
79+
80+ [ Opt.TailDef facts name args body ]
81+
82+ else
83+
84+ [ Opt.Def facts name (Opt.Function args body) ]
85+
86+ (P.Var name, []) ->
87+
88+ do hasTailCall <- Env.getTailCall
89+ body <- optimizeExpr Nothing rawBody
90+ Env.setTailCall hasTailCall
91+ return [ Opt.Def (Opt.Facts home deps) name body ]
92+
93+ (_, []) ->
94+
95+ do name <- Env.freshName
96+ optBody <- optimizeExpr Nothing rawBody
97+ let optDef = Opt.Def (Opt.Facts home deps) name optBody
98+ return (optDef : patternToDefs home name pattern)
99+
100+ _ ->
101+ error "there should never be a function where the name is not a P.Var"
102+
103+
104+-- OPTIMIZE FUNCTION
105+
106+optimizeFunction
107+ :: Maybe String
108+ -> [P.CanonicalPattern]
109+ -> Can.Expr
110+ -> Env.Optimizer ([String], Opt.Expr)
111+optimizeFunction maybeName patterns givenBody =
112+ do (argNames, body) <- M.foldM depatternArgs ([], givenBody) (reverse patterns)
113+ optBody <- optimizeExpr (makeContext argNames =<< maybeName) body
114+ return (argNames, optBody)
115+
116+
117+makeContext :: [String] -> String -> Context
118+makeContext argNames name =
119+ Just (name, length argNames, argNames)
120+
121+
122+depatternArgs
123+ :: ([String], Can.Expr)
124+ -> P.CanonicalPattern
125+ -> Env.Optimizer ([String], Can.Expr)
126+depatternArgs (names, rawExpr) ptrn =
127+ do (name, expr) <- depattern ptrn rawExpr
128+ return (name : names, expr)
129+
130+
131+patternToDefs
132+ :: Maybe ModuleName.Canonical
133+ -> String
134+ -> P.CanonicalPattern
135+ -> [Opt.Def]
136+patternToDefs home rootName pattern =
9 let
137 let
10− canonicalBody =
138+ (deps, rootExpr) =
11− M.body modul
139+ case home of
140+ Nothing ->
141+ ( []
142+ , Opt.Var (Var.local rootName)
143+ )
12
144
13− optimizedProgram =
145+ Just moduleName ->
14− TC.optimize (M.program canonicalBody)
146+ ( [ Var.TopLevelVar moduleName rootName ]
147+ , Opt.Var (Var.topLevel moduleName rootName)
148+ )
15
149
16− optimizedBody =
150+ toDef (name, accessExpr) =
17− canonicalBody { M.program = optimizedProgram }
151+ Opt.Def (Opt.Facts home deps) name accessExpr
18 in
152 in
19− modul { M.body = optimizedBody }
153+ map toDef (substitutions rootExpr pattern)
154+
155+
156+substitutions :: Opt.Expr -> P.CanonicalPattern -> [(String, Opt.Expr)]
157+substitutions expr (A.A _ pattern) =
158+ case pattern of
159+ P.Var name ->
160+ [ (name, expr) ]
161+
162+ P.Literal _ ->
163+ []
164+
165+ P.Record fields ->
166+ map (\name -> (name, Opt.Access expr name)) fields
167+
168+ P.Anything ->
169+ []
170+
171+ P.Alias alias realPattern ->
172+ (alias, expr) : substitutions expr realPattern
173+
174+ P.Data _ patterns ->
175+ concat (zipWith (substitutions . Opt.DataAccess expr) [0..] patterns)
176+
177+
178+-- OPTIMIZE EXPRESSIONS
179+
180+type Context = Maybe (String, Int, [String])
181+
182+
183+{-| This optimizer detects tail calls. The `Context` holds a function name,
184+function arity, and list of argument names. If a tail call is possible, the
185+`Context` will be filled in and we check any function we run into. If we go
186+down a route that cannot possibly have tail calls, we remove the context.
187+-}
188+optimizeExpr :: Context -> Can.Expr -> Env.Optimizer Opt.Expr
189+optimizeExpr context annExpr@(A.A region expression) =
190+ let
191+ keepLooking =
192+ optimizeExpr context
193+ -- this *might* find a tail call, use this when something is a potential
194+ -- tail call
195+
196+ justConvert =
197+ optimizeExpr Nothing
198+ -- this will never find tail calls, use this when you are working with
199+ -- expressions that cannot be turned into tail calls
200+ in
201+ case expression of
202+ Expr.Literal lit ->
203+ pure (Opt.Literal lit)
204+
205+ Expr.Var name ->
206+ if name == Var.inCore ["Debug"] "crash" then
207+ pure (Opt.Crash region Nothing)
208+
209+ else
210+ pure (Opt.Var name)
211+
212+ Expr.Range lowExpr highExpr ->
213+ Opt.Range
214+ <$> justConvert lowExpr
215+ <*> justConvert highExpr
216+
217+ Expr.ExplicitList elements ->
218+ Opt.ExplicitList
219+ <$> T.traverse justConvert elements
220+
221+ Expr.Binop op leftExpr rightExpr ->
222+ optimizeBinop context region op leftExpr rightExpr
223+
224+ Expr.Lambda _ _ ->
225+ let
226+ (patterns, body) =
227+ Expr.collectLambdas annExpr
228+ in
229+ uncurry Opt.Function <$> optimizeFunction Nothing patterns body
230+
231+ Expr.App _ _ ->
232+ let
233+ (func:args) =
234+ Expr.collectApps annExpr
235+ in
236+ case isTailCall context func (length args) of
237+ Just (name, argNames) ->
238+ do optArgs <- T.traverse justConvert args
239+ Env.setTailCall True
240+ return (Opt.TailCall name argNames optArgs)
241+
242+ Nothing ->
243+ do hasTailCall <- Env.getTailCall
244+ optFunc <- justConvert func
245+ optArgs <- T.traverse justConvert args
246+ Env.setTailCall hasTailCall
247+ return (Opt.Call optFunc optArgs)
248+
249+ Expr.If branches finally ->
250+ let
251+ crawlBranch (cond,branch) =
252+ (,) <$> justConvert cond <*> keepLooking branch
253+ in
254+ Opt.If
255+ <$> T.traverse crawlBranch branches
256+ <*> keepLooking finally
257+
258+ Expr.Let defs body ->
259+ do optDefs <- concat <$> T.traverse (optimizeDef Nothing) defs
260+ Opt.Let optDefs <$> keepLooking body
261+
262+ Expr.Case expr branches ->
263+ do optExpr <- optimizeExpr Nothing expr
264+ optBranches <- T.traverse (mapSnd (optimizeExpr context)) branches
265+ variantDict <- Env.getVariantDict
266+ Patterns.optimize variantDict region optExpr optBranches
267+
268+ Expr.Data name exprs ->
269+ Opt.Data name <$> T.traverse justConvert exprs
270+
271+ Expr.Access record field ->
272+ Opt.Access
273+ <$> justConvert record
274+ <*> pure field
275+
276+ Expr.Update record fields ->
277+ Opt.Update
278+ <$> justConvert record
279+ <*> T.traverse (mapSnd justConvert) fields
280+
281+ Expr.Record fields ->
282+ Opt.Record
283+ <$> T.traverse (mapSnd justConvert) fields
284+
285+ Expr.GLShader uid src gltipe ->
286+ pure (Opt.GLShader uid src gltipe)
287+
288+ Expr.Port impl ->
289+ Opt.Port <$>
290+ case impl of
291+ Expr.In name tipe ->
292+ pure (Expr.In name tipe)
293+
294+ Expr.Out name expr tipe ->
295+ (\e -> Expr.Out name e tipe) <$> justConvert expr
296+
297+ Expr.Task name expr tipe ->
298+ (\e -> Expr.Task name e tipe) <$> justConvert expr
299+
300+
301+mapSnd :: M.Functor box => (a -> box b) -> (x, a) -> box (x, b)
302+mapSnd func (x, a) =
303+ (,) x <$> func a
304+
305+
306+-- DETECT TAIL CALL
307+
308+isTailCall :: Context -> Can.Expr -> Int -> Maybe (String, [String])
309+isTailCall context (A.A _ function) arity =
310+ case (context, function) of
311+ ( Just (ctxName, ctxArity, argNames), Expr.Var (Var.Canonical home name) ) ->
312+
313+ if name == ctxName && arity == ctxArity && Var.isLocalHome home then
314+ Just (name, argNames)
315+
316+ else
317+ Nothing
318+
319+ _ ->
320+ Nothing
321+
322+
323+-- DEPATTERN
324+-- given a pattern and an expression, push the actual pattern matching into the
325+-- expression as a case-expression if necessary. The pattern compiler will work
326+-- it out from there
327+
328+depattern :: P.CanonicalPattern -> Can.Expr -> Env.Optimizer (String, Can.Expr)
329+depattern canPattern@(A.A _ pattern) expr =
330+ let
331+ ann =
332+ A.A (error "the annotation added in 'depattern' should not be observed!")
333+
334+ caseExpr e branches =
335+ ann (Expr.Case e branches)
336+
337+ var name =
338+ ann (Expr.Var (Var.local name))
339+
340+ caseify =
341+ do name <- Env.freshName
342+ return
343+ ( name
344+ , caseExpr (var name) [ (canPattern, expr) ]
345+ )
346+ in
347+ case pattern of
348+ P.Var name ->
349+ return (name, expr)
350+
351+ P.Literal _ ->
352+ caseify
353+
354+ P.Record _ ->
355+ caseify
356+
357+ P.Anything ->
358+ do name <- Env.freshName
359+ return (name, expr)
360+
361+ P.Alias _ _ ->
362+ caseify
363+
364+ P.Data _ _ ->
365+ caseify
366+
367+
368+-- OPTIMIZE BINOPS
369+
370+optimizeBinop
371+ :: Context
372+ -> R.Region
373+ -> Var.Canonical
374+ -> Can.Expr
375+ -> Can.Expr
376+ -> Env.Optimizer Opt.Expr
377+optimizeBinop context region op leftExpr rightExpr =
378+ let
379+ ann = A.A region
380+ binop = ann (Expr.Binop op leftExpr rightExpr)
381+ in
382+ if op == forwardApply then
383+
384+ optimizeExpr context (collect id left forwardApply binop)
385+
386+ else if op == backwardApply then
387+
388+ optimizeExpr context (collect id right backwardApply binop)
389+
390+ else if op == forwardCompose then
391+
392+ do var <- Env.freshName
393+ let makeRoot func = ann (Expr.App func (ann (Expr.Var (Var.local var))))
394+ let body = collect makeRoot left forwardCompose binop
395+ optimizeExpr context (ann (Expr.Lambda (ann (P.Var var)) body))
396+
397+ else if op == backwardCompose then
398+
399+ do var <- Env.freshName
400+ let makeRoot func = ann (Expr.App func (ann (Expr.Var (Var.local var))))
401+ let body = collect makeRoot right backwardCompose binop
402+ optimizeExpr context (ann (Expr.Lambda (ann (P.Var var)) body))
403+
404+ else if op == Var.Canonical Var.BuiltIn "::" then
405+
406+ optimizeExpr context (ann (Expr.Data "::" [ leftExpr, rightExpr ]))
407+
408+ else
409+
410+ Opt.Binop op
411+ <$> optimizeExpr Nothing leftExpr
412+ <*> optimizeExpr Nothing rightExpr
413+
414+
415+-- left-associative ((x |> f) |> g)
416+forwardApply :: Var.Canonical
417+forwardApply =
418+ Var.inCore ["Basics"] "|>"
419+
420+
421+-- right-associative (g <| (f <| x))
422+backwardApply :: Var.Canonical
423+backwardApply =
424+ Var.inCore ["Basics"] "<|"
425+
426+
427+-- left-associative ((f >> g) >> h)
428+forwardCompose :: Var.Canonical
429+forwardCompose =
430+ Var.inCore ["Basics"] ">>"
431+
432+
433+-- right-associative (h << (g << f))
434+backwardCompose :: Var.Canonical
435+backwardCompose =
436+ Var.inCore ["Basics"] "<<"
437+
438+
439+type Assoc =
440+ Can.Expr -> Can.Expr -> (Can.Expr, Can.Expr)
441+
442+
443+left :: Assoc
444+left =
445+ flip (,)
446+
447+
448+right :: Assoc
449+right =
450+ (,)
451+
452+
453+collect :: (Can.Expr -> Can.Expr) -> Assoc -> Var.Canonical -> Can.Expr -> Can.Expr
454+collect makeRoot assoc desiredOp annExpr@(A.A ann expr) =
455+ case expr of
456+ Expr.Binop op leftExpr rightExpr | op == desiredOp ->
457+ let
458+ (func, arg) = assoc leftExpr rightExpr
459+ in
460+ A.A ann (Expr.App func (collect makeRoot assoc desiredOp arg))
461+
462+ _ ->
463+ makeRoot annExpr
src/Optimize/Cases.hsdeleted−266
@@ -1,266 +0,0 @@
1−module Optimize.Cases (toMatch, Match (..), Clause (..), matchSubst, newVar) where
2−
3−import Control.Applicative ((<$>))
4−import Control.Arrow (first)
5−import Control.Monad.State (State)
6−import qualified Control.Monad.State as State
7−import qualified Data.List as List
8−import Data.Maybe (fromMaybe)
9−
10−import qualified AST.Expression.General as Expr
11−import qualified AST.Expression.Optimized as Optimized
12−import qualified AST.Literal as Literal
13−import qualified AST.Pattern as P
14−import qualified AST.Variable as Var
15−import qualified Optimize.Substitute as S
16−import qualified Reporting.Annotation as A
17−
18−
19−-- MATCHES
20−
21−data Match
22− = Match String [Clause] Match
23− | Break
24− | Fail
25− | Other Optimized.Expr
26− | Seq [Match]
27− deriving (Show)
28−
29−
30−data Clause =
31− Clause (Either Var.Canonical Literal.Literal) [String] Match
32− deriving (Show)
33−
34−
35−type Branch =
36− ([P.Optimized], Optimized.Expr)
37−
38−
39−-- PUBLIC FUNCTIONS
40−
41−toMatch :: [(P.Optimized, Optimized.Expr)] -> State Int (String, Match)
42−toMatch patterns =
43− do v <- newVar
44− (,) v <$> buildMatch [v] (map (first (:[])) patterns) Fail
45−
46−
47−newVar :: State Int String
48−newVar =
49− do n <- State.get
50− State.modify (+1)
51− return $ "_v" ++ show n
52−
53−
54−matchSubst :: [(String,String)] -> Match -> Match
55−matchSubst pairs match =
56− case match of
57− Break -> Break
58−
59− Fail -> Fail
60−
61− Seq ms ->
62− Seq (map (matchSubst pairs) ms)
63−
64− Other (A.A ann expr) ->
65− let
66− substitutions =
67− map (\(x,y) -> S.subst x (Expr.localVar y)) pairs
68− in
69− Other $ A.A ann $ foldr ($) expr substitutions
70−
71− Match n cs m ->
72− Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)
73− where
74− varSubst v = fromMaybe v (lookup v pairs)
75− clauseSubst (Clause c vs m) =
76− Clause c (map varSubst vs) (matchSubst pairs m)
77−
78−
79−-- BUILD MATCHES
80−
81−buildMatch :: [String] -> [Branch] -> Match -> State Int Match
82−buildMatch variables branches match =
83− case (variables, branches, match) of
84− ([], [], _) ->
85− return match
86−
87− ([], [([], expr)], Fail) ->
88− return $ Other expr
89−
90− ([], [([], expr)], Break) ->
91− return $ Other expr
92−
93− ([], _, _) ->
94− return $ Seq (map (Other . snd) branches ++ [match])
95−
96− (var:_, _, _)
97− | all isVar branches' -> matchVar variables branches' match
98− | all isCon branches' -> matchCon variables branches' match
99− | otherwise -> matchMix variables branches' match
100− where
101− branches' = map (dealias var) branches
102−
103−
104−dealias :: String -> Branch -> Branch
105−dealias _ ([], _) = noMatch "dealias"
106−dealias var branch@(p:ps, A.A ann e) =
107− case p of
108− A.A _ (P.Alias alias pattern) ->
109− ( pattern:ps
110− , A.A ann (S.subst alias (Expr.localVar var) e)
111− )
112−
113− _ ->
114− branch
115−
116−
117−isCon :: ([P.Pattern ann var], expr) -> Bool
118−isCon ([], _) = noMatch "isCon"
119−isCon (A.A _ pattern : _, _) =
120− case pattern of
121− P.Data _ _ -> True
122− P.Literal _ -> True
123− _ -> False
124−
125−
126−isVar :: ([P.Pattern ann var], expr) -> Bool
127−isVar p =
128− not (isCon p)
129−
130−
131−-- VARIABLE MATCHES
132−
133−matchVar :: [String] -> [Branch] -> Match -> State Int Match
134−matchVar [] _ _ = noMatch "matchVar"
135−matchVar (var:vars) branches match =
136− buildMatch vars (map subVar branches) match
137− where
138− subVar ([], _) = noMatch "matchVar.subVar"
139− subVar (A.A _ pattern : patterns, (A.A ann expr)) =
140− ( patterns
141− , A.A ann (subOnePattern pattern expr)
142− )
143− where
144− subOnePattern pattern expr =
145− case pattern of
146− P.Anything ->
147− expr
148−
149− P.Var x ->
150− S.subst x (Expr.localVar var) expr
151−
152− P.Record fields ->
153− let access = Expr.Access (A.A ann (Expr.localVar var))
154− in
155− foldr (\x -> S.subst x (access x)) expr fields
156−
157− _ ->
158− noMatch "matchVar.subVar"
159−
160−
161−-- CONSTRUCTOR MATCHES
162−
163−matchCon :: [String] -> [Branch] -> Match -> State Int Match
164−matchCon variables branches match =
165− case variables of
166− [] -> noMatch "matchCon"
167−
168− var : _vars ->
169− flip (Match var) match <$> mapM toClause caseGroups
170− where
171− caseGroups :: [[Branch]]
172− caseGroups =
173− List.groupBy branchEq (List.sortBy branchCmp branches)
174−
175− toClause :: [Branch] -> State Int Clause
176− toClause branches =
177− case head branches of
178− (A.A _ (P.Data name _) : _, _) ->
179− matchClause (Left name) variables branches Break
180−
181− (A.A _ (P.Literal lit) : _, _) ->
182− matchClause (Right lit) variables branches Break
183−
184− _ -> noMatch "matchCon"
185−
186−
187−matchClause
188− :: Either Var.Canonical Literal.Literal
189− -> [String]
190− -> [Branch]
191− -> Match
192− -> State Int Clause
193−matchClause _ [] _ _ = noMatch "matchClause"
194−matchClause c (_:vs) branches match =
195− do vs' <- getVars
196− Clause c vs' <$> buildMatch (vs' ++ vs) (map flatten branches) match
197− where
198− flatten ([], _) = noMatch "matchClause.flatten"
199− flatten (A.A _ pattern : patterns, expr) =
200− case pattern of
201− P.Data _ argPatterns ->
202− (argPatterns ++ patterns, expr)
203−
204− P.Literal _ ->
205− (patterns, expr)
206−
207− _ ->
208− noMatch "matchClause.flatten"
209−
210− getVars :: State Int [String]
211− getVars =
212− case head branches of
213− (A.A _ (P.Data _ argPatterns) : _, _) ->
214− State.forM argPatterns (const newVar)
215−
216− (A.A _ (P.Literal _) : _, _) ->
217− return []
218−
219− _ ->
220− noMatch "matchClause.getVars"
221−
222−
223−branchEq :: Branch -> Branch -> Bool
224−branchEq (A.A _ pattern : _, _) (A.A _ pattern' : _, _) =
225− case (pattern, pattern') of
226− (P.Data name _, P.Data name' _) ->
227− name == name'
228−
229− (P.Literal lit, P.Literal lit') ->
230− lit == lit'
231−
232− (_, _) ->
233− noMatch "matchCon.branchEq"
234−
235−branchEq _ _ = noMatch "matchCon.branchEq"
236−
237−
238−branchCmp :: Branch -> Branch -> Ordering
239−branchCmp (A.A _ pattern : _, _) (A.A _ pattern' : _, _) =
240− case (pattern, pattern') of
241− (P.Data name _, P.Data name' _) ->
242− compare name name'
243−
244− (P.Literal lit, P.Literal lit') ->
245− compare lit lit'
246−
247− (_, _) ->
248− noMatch "matchCon.branchCmp"
249−
250−branchCmp _ _ = noMatch "matchCon.branchCmp"
251−
252−
253−-- MIX MATCHES
254−
255−matchMix :: [String] -> [Branch] -> Match -> State Int Match
256−matchMix vs branches def =
257− State.foldM (flip $ buildMatch vs) def (reverse branchGroups)
258− where
259− branchGroups =
260− List.groupBy (\p1 p2 -> isCon p1 == isCon p2) branches
261−
262−
263−noMatch :: String -> a
264−noMatch name =
265− error $ "unexpected pattern in `" ++ name ++
266− "` function. Report a compiler issue to <https://github.com/elm-lang/Elm>."
src/Optimize/Environment.hsnew file+50
@@ -0,0 +1,50 @@
1+module Optimize.Environment
2+ ( Optimizer, run
3+ , Env
4+ , getVariantDict
5+ , getTailCall, setTailCall
6+ , freshName
7+ ) where
8+
9+import qualified Control.Monad.State as State
10+
11+import qualified Optimize.Patterns.DecisionTree as DT
12+
13+
14+type Optimizer a =
15+ State.State Env a
16+
17+
18+run :: DT.VariantDict -> Optimizer a -> a
19+run variantDict optimizer =
20+ State.evalState optimizer (Env False 0 variantDict)
21+
22+
23+data Env = Env
24+ { _hasTailCall :: Bool
25+ , _uid :: Int
26+ , _variantDict :: DT.VariantDict
27+ }
28+
29+
30+getVariantDict :: Optimizer DT.VariantDict
31+getVariantDict =
32+ State.gets _variantDict
33+
34+
35+getTailCall :: Optimizer Bool
36+getTailCall =
37+ State.gets _hasTailCall
38+
39+
40+setTailCall :: Bool -> Optimizer ()
41+setTailCall bool =
42+ do env <- State.get
43+ State.put (env { _hasTailCall = bool })
44+
45+
46+freshName :: Optimizer String
47+freshName =
48+ do (Env htc uid vd) <- State.get
49+ State.put (Env htc (uid + 1) vd)
50+ return ("_p" ++ show uid)
src/Optimize/Patterns.hsnew file+124
@@ -0,0 +1,124 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Optimize.Patterns (optimize) where
3+
4+import Control.Arrow (second)
5+import qualified Data.Map as Map
6+import Data.Map ((!))
7+import qualified Data.Maybe as Maybe
8+
9+import qualified AST.Expression.Optimized as Opt
10+import qualified AST.Pattern as P
11+import Elm.Utils ((|>))
12+import qualified Optimize.Environment as Env
13+import qualified Optimize.Patterns.DecisionTree as DT
14+import qualified Reporting.Annotation as A
15+import qualified Reporting.Region as R
16+
17+
18+optimize
19+ :: DT.VariantDict
20+ -> R.Region
21+ -> Opt.Expr
22+ -> [(P.CanonicalPattern, Opt.Expr)]
23+ -> Env.Optimizer Opt.Expr
24+optimize variantDict region optExpr optBranches =
25+ let
26+ indexify index (pattern, branch) =
27+ ( (pattern, index)
28+ , (index, branch)
29+ )
30+ in
31+ do crashBranches <-
32+ case last optBranches of
33+ (A.A ann P.Anything, Opt.Call (Opt.Crash _ _) [arg]) ->
34+ do name <- Env.freshName
35+ let newPattern = A.A ann (P.Var name)
36+ let newCall = Opt.Call (Opt.Crash region (Just name)) [arg]
37+ return (init optBranches ++ [(newPattern, newCall)])
38+
39+ _ ->
40+ return optBranches
41+
42+ let (patterns, indexedBranches) =
43+ unzip (zipWith indexify [0..] crashBranches)
44+
45+ let decisionTree =
46+ DT.compile variantDict patterns
47+
48+ tempName <- Env.freshName
49+
50+ return $
51+ Opt.Let
52+ [ Opt.Def Opt.dummyFacts tempName optExpr ]
53+ (inlinedCase tempName decisionTree indexedBranches)
54+
55+
56+inlinedCase
57+ :: String
58+ -> DT.DecisionTree DT.Jump
59+ -> [(Int, Opt.Expr)]
60+ -> Opt.Expr
61+inlinedCase name decisionTree jumpTargets =
62+ let
63+ substitutionDict =
64+ gatherSubstitutions decisionTree
65+
66+ (jumps, sharedBranches) =
67+ unzip (map (toJumps substitutionDict) jumpTargets)
68+ in
69+ Opt.Case
70+ name
71+ (inlineJumps (Map.fromList jumps) decisionTree)
72+ (Maybe.catMaybes sharedBranches)
73+
74+
75+gatherSubstitutions
76+ :: DT.DecisionTree DT.Jump
77+ -> Map.Map Int [[(String, DT.Path)]]
78+gatherSubstitutions decisionTree =
79+ case decisionTree of
80+ DT.Decision _ edges fallback ->
81+ map snd edges
82+ |> maybe id (:) fallback
83+ |> map gatherSubstitutions
84+ |> Map.unionsWith (++)
85+
86+ DT.Match (DT.Jump target substitutions) ->
87+ Map.singleton target [substitutions]
88+
89+
90+toJumps
91+ :: Map.Map Int [[(String, DT.Path)]]
92+ -> (Int, Opt.Expr)
93+ -> ( (Int, Opt.Jump), Maybe (Int, Opt.Branch) )
94+toJumps substitutionDict (target, branch) =
95+ case substitutionDict ! target of
96+ [substitutions] ->
97+ ( (target, Opt.Inline (Opt.Branch substitutions branch))
98+ , Nothing
99+ )
100+
101+ substitutions : _ ->
102+ ( (target, Opt.Jump target)
103+ , Just (target, Opt.Branch substitutions branch)
104+ )
105+
106+ _ ->
107+ error "it is not possible for there to be no substitutions"
108+
109+
110+inlineJumps
111+ :: Map.Map Int Opt.Jump
112+ -> DT.DecisionTree DT.Jump
113+ -> DT.DecisionTree Opt.Jump
114+inlineJumps jumpDict decisionTree =
115+ let
116+ go =
117+ inlineJumps jumpDict
118+ in
119+ case decisionTree of
120+ DT.Decision test edges fallback ->
121+ DT.Decision test (map (second go) edges) (fmap go fallback)
122+
123+ DT.Match (DT.Jump target _) ->
124+ DT.Match (jumpDict ! target)
src/Optimize/Patterns/DecisionTree.hsnew file+430
@@ -0,0 +1,430 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Optimize.Patterns.DecisionTree where
3+{- To learn more about how this works, definitely read through:
4+
5+ "When Do Match-Compilation Heuristics Matter?"
6+
7+by Kevin Scott and Norman Ramsey. The rough idea is that we start with a simple
8+list of patterns and expressions, and then turn that into a "decision tree"
9+that requires as few tests as possible to make it to a leaf. Read the paper, it
10+explains this extraordinarily well! We are currently using the same heuristics
11+as SML/NJ to get nice trees.
12+-}
13+
14+import Control.Arrow (second)
15+import Data.Function (on)
16+import qualified Data.List as List
17+import qualified Data.Map as Map
18+import qualified Data.Set as Set
19+import Data.Map ((!))
20+import qualified Data.Maybe as Maybe
21+
22+import qualified AST.Literal as L
23+import qualified AST.Pattern as P
24+import qualified AST.Variable as Var
25+import qualified Reporting.Annotation as A
26+
27+
28+type CPattern = P.CanonicalPattern
29+
30+
31+-- COMPILE CASES
32+
33+{-| Users of this module will mainly interact with this function. It takes
34+some normal branches and gives out a decision tree that has "labels" at all
35+the leafs and a dictionary that maps these "labels" to the code that should
36+run.
37+
38+If 2 or more leaves point to the same label, we need to do some tricks in JS to
39+make that work nicely. When is JS getting goto?! ;) That is outside the scope
40+of this module though.
41+-}
42+compile :: VariantDict -> [(CPattern, Int)] -> DecisionTree Jump
43+compile variantDict rawBranches =
44+ let
45+ format (pattern, index) =
46+ Branch index [(Empty, pattern)]
47+ in
48+ toDecisionTree variantDict (map format rawBranches)
49+
50+
51+{-| When a certain union type is defined, you specify a certain number of tags.
52+This helps us do a few optimizations:
53+
54+ * If there is only one possible tag, we can always skip checking what it is.
55+ Tuples are a common example of this.
56+ * If we use all possible tags, we can skip doing the last test. If we have
57+ checked N-1 of N tags, there is no need to test the Nth, we know its the
58+ one we want
59+
60+So this dictionary maps tags to the number of variants that exist, so it'll
61+contain things like [ ("Just", 2), ("Nothing", 2), ("_Tuple2", 1), ... ] which
62+we can use for these optimizations.
63+-}
64+type VariantDict =
65+ Map.Map Var.Canonical Int
66+
67+
68+-- DECISION TREES
69+
70+data DecisionTree a
71+ = Match a
72+ | Decision
73+ { _test :: Path
74+ , _edges :: [(Test, DecisionTree a)]
75+ , _default :: Maybe (DecisionTree a)
76+ }
77+
78+
79+data Jump = Jump
80+ { _result :: Int
81+ , _substitutions :: [(String, Path)]
82+ }
83+
84+
85+data Test
86+ = Constructor Var.Canonical
87+ | Literal L.Literal
88+ deriving (Eq, Ord)
89+
90+
91+data Path
92+ = Position Int Path
93+ | Field String Path
94+ | Empty
95+ | Alias
96+ deriving (Eq)
97+
98+
99+-- PATH HELPERS
100+
101+add :: Path -> Path -> Path
102+add path finalLink =
103+ case path of
104+ Empty ->
105+ finalLink
106+
107+ Alias ->
108+ error "nothing should be added to an alias path"
109+
110+ Position index subpath ->
111+ Position index (add subpath finalLink)
112+
113+ Field name subpath ->
114+ Field name (add subpath finalLink)
115+
116+
117+subPositions :: Path -> [CPattern] -> [(Path, CPattern)]
118+subPositions path patterns =
119+ zipWith
120+ (\index pattern -> (add path (Position index Empty), pattern))
121+ [0..]
122+ patterns
123+
124+
125+-- ACTUALLY BUILD DECISION TREES
126+
127+data Branch =
128+ Branch
129+ { _goal :: Int
130+ , _patterns :: [(Path, CPattern)]
131+ }
132+
133+
134+toDecisionTree :: VariantDict -> [Branch] -> DecisionTree Jump
135+toDecisionTree variantDict rawBranches =
136+ let
137+ branches =
138+ map (flattenPatterns variantDict) rawBranches
139+ in
140+ case checkForMatch branches of
141+ Just (goal, substitutions) ->
142+ Match (Jump goal substitutions)
143+
144+ Nothing ->
145+ let
146+ path =
147+ smallDefaults branches
148+
149+ relevantTests =
150+ testsAtPath path branches
151+
152+ allRawEdges =
153+ map (edgesFor path branches) relevantTests
154+
155+ (rawEdges, unexplored) =
156+ if isComplete variantDict relevantTests then
157+ ( init allRawEdges
158+ , snd (last allRawEdges)
159+ )
160+
161+ else
162+ ( allRawEdges
163+ , filter (isIrrelevantTo path) branches
164+ )
165+
166+ edges =
167+ map (second (toDecisionTree variantDict)) rawEdges
168+ in
169+ case (edges, unexplored) of
170+ ([(_tag, decisionTree)], []) ->
171+ decisionTree
172+
173+ (_, []) ->
174+ Decision path edges Nothing
175+
176+ (_, _) ->
177+ Decision path edges (Just (toDecisionTree variantDict unexplored))
178+
179+
180+isComplete :: VariantDict -> [Test] -> Bool
181+isComplete variantDict tests =
182+ case head tests of
183+ Constructor name ->
184+ (variantDict ! name) == length tests
185+
186+ Literal (L.Boolean _) ->
187+ length tests == 2
188+
189+ _ ->
190+ False
191+
192+
193+
194+-- FLATTEN PATTERNS
195+
196+{-| Flatten type aliases and use the VariantDict to figure out when a tag is
197+the only variant so we can skip doing any tests on it.
198+-}
199+flattenPatterns :: VariantDict -> Branch -> Branch
200+flattenPatterns variantDict (Branch goal pathPatterns) =
201+ Branch goal (concatMap (flatten variantDict) pathPatterns)
202+
203+
204+flatten :: VariantDict -> (Path, CPattern) -> [(Path, CPattern)]
205+flatten variantDict pathPattern@(path, A.A ann pattern) =
206+ case pattern of
207+ P.Var _ ->
208+ [pathPattern]
209+
210+ P.Anything ->
211+ [pathPattern]
212+
213+ P.Alias alias realPattern ->
214+ [ (add path Alias, A.A ann (P.Var alias))
215+ , (path, realPattern)
216+ ]
217+
218+ P.Record _ ->
219+ [pathPattern]
220+
221+ P.Data tag patterns ->
222+ if variantDict ! tag == 1 then
223+ concatMap (flatten variantDict) (subPositions path patterns)
224+
225+ else
226+ [pathPattern]
227+
228+ P.Literal _ ->
229+ [pathPattern]
230+
231+
232+-- SUCCESSFULLY MATCH
233+
234+{-| If the first branch has no more "decision points" we can finally take that
235+path. If that is the case we give the resulting label and a mapping from free
236+variables to "how to get their value". So a pattern like (Just (x,_)) will give
237+us something like ("x" => value.0.0)
238+-}
239+checkForMatch :: [Branch] -> Maybe (Int, [(String, Path)])
240+checkForMatch branches =
241+ case branches of
242+ Branch goal patterns : _ ->
243+ (,) goal `fmap` concat `fmap` mapM getSubstitution patterns
244+
245+ _ ->
246+ Nothing
247+
248+
249+getSubstitution :: (Path, CPattern) -> Maybe [(String, Path)]
250+getSubstitution (path, A.A _ pattern) =
251+ case pattern of
252+ P.Var x ->
253+ Just [(x, path)]
254+
255+ P.Anything ->
256+ Just []
257+
258+ P.Alias _ _ ->
259+ error "aliases should never reach 'getSubstitution' function"
260+
261+ P.Record fields ->
262+ Just (map (\name -> (name, add path (Field name Empty))) fields)
263+
264+ P.Data _ _ ->
265+ Nothing
266+
267+ P.Literal _ ->
268+ Nothing
269+
270+
271+-- FIND RELEVANT TESTS
272+
273+testsAtPath :: Path -> [Branch] -> [Test]
274+testsAtPath selectedPath branches =
275+ let
276+ allTests =
277+ Maybe.mapMaybe (testAtPath selectedPath) branches
278+
279+ skipVisited test curr@(uniqueTests, visitedTests) =
280+ if Set.member test visitedTests then
281+ curr
282+ else
283+ ( test : uniqueTests
284+ , Set.insert test visitedTests
285+ )
286+ in
287+ fst (foldr skipVisited ([], Set.empty) allTests)
288+
289+
290+testAtPath :: Path -> Branch -> Maybe Test
291+testAtPath selectedPath (Branch _ pathPatterns) =
292+ case List.lookup selectedPath pathPatterns of
293+ Nothing ->
294+ Nothing
295+
296+ Just (A.A _ pattern) ->
297+ case pattern of
298+ P.Data name _ ->
299+ Just (Constructor name)
300+
301+ P.Literal lit ->
302+ Just (Literal lit)
303+
304+ P.Var _ ->
305+ Nothing
306+
307+ P.Alias _ _ ->
308+ error "aliases should never reach 'testAtPath' function"
309+
310+ P.Anything ->
311+ Nothing
312+
313+ P.Record _ ->
314+ Nothing
315+
316+
317+-- BUILD EDGES
318+
319+edgesFor :: Path -> [Branch] -> Test -> (Test, [Branch])
320+edgesFor path branches test =
321+ ( test
322+ , Maybe.mapMaybe (toRelevantBranch test path) branches
323+ )
324+
325+
326+toRelevantBranch :: Test -> Path -> Branch -> Maybe Branch
327+toRelevantBranch test path branch@(Branch goal pathPatterns) =
328+ case extract path pathPatterns of
329+ Just (start, A.A _ pattern, end) ->
330+ case pattern of
331+ P.Data name patterns ->
332+ if test == Constructor name then
333+ Just (Branch goal (start ++ subPositions path patterns ++ end))
334+
335+ else
336+ Nothing
337+
338+ P.Literal lit ->
339+ if test == Literal lit then
340+ Just (Branch goal (start ++ end))
341+
342+ else
343+ Nothing
344+
345+ _ ->
346+ Just branch
347+
348+ _ ->
349+ Just branch
350+
351+
352+extract
353+ :: Path
354+ -> [(Path, CPattern)]
355+ -> Maybe ([(Path, CPattern)], CPattern, [(Path, CPattern)])
356+extract selectedPath pathPatterns =
357+ case pathPatterns of
358+ [] ->
359+ Nothing
360+
361+ first@(path, pattern) : rest ->
362+ if path == selectedPath then
363+ Just ([], pattern, rest)
364+
365+ else
366+ case extract selectedPath rest of
367+ Nothing ->
368+ Nothing
369+
370+ Just (start, foundPattern, end) ->
371+ Just (first : start, foundPattern, end)
372+
373+
374+-- FIND IRRELEVANT BRANCHES
375+
376+isIrrelevantTo :: Path -> Branch -> Bool
377+isIrrelevantTo selectedPath (Branch _ pathPatterns) =
378+ case List.lookup selectedPath pathPatterns of
379+ Nothing ->
380+ True
381+
382+ Just pattern ->
383+ not (needsTests pattern)
384+
385+
386+needsTests :: CPattern -> Bool
387+needsTests (A.A _ pattern) =
388+ case pattern of
389+ P.Var _ ->
390+ False
391+
392+ P.Anything ->
393+ False
394+
395+ P.Alias _ _ ->
396+ error "aliases should never reach 'isIrrelevantTo' function"
397+
398+ P.Record _ ->
399+ False
400+
401+ P.Data _ _ ->
402+ True
403+
404+ P.Literal _ ->
405+ True
406+
407+
408+-- PATH PICKING HEURISTICS
409+
410+smallDefaults :: [Branch] -> Path
411+smallDefaults branches =
412+ let
413+ allPaths =
414+ Maybe.mapMaybe isChoicePath (concatMap _patterns branches)
415+
416+ weightedPaths =
417+ map (\path -> (path, length (filter (isIrrelevantTo path) branches))) allPaths
418+ in
419+ fst (List.minimumBy (compare `on` snd) weightedPaths)
420+
421+
422+isChoicePath :: (Path, CPattern) -> Maybe Path
423+isChoicePath (path, pattern) =
424+ if needsTests pattern then
425+ Just path
426+ else
427+ Nothing
428+
429+
430+-- smallBranchingFactor :: [Branch] -> Path
src/Optimize/TailCalls.hsdeleted−235
@@ -1,235 +0,0 @@
1−module Optimize.TailCalls where
2−
3−import Control.Applicative
4−import Control.Arrow (first)
5−import qualified Control.Monad as M
6−import qualified Data.List as List
7−import qualified Data.Traversable as T
8−
9−import AST.Expression.General as Expr
10−import qualified AST.Expression.Canonical as Can
11−import qualified AST.Expression.Optimized as Opt
12−import qualified AST.Pattern as P
13−import qualified AST.Variable as Var
14−import qualified Reporting.Annotation as A
15−
16−
17−-- OPTIMIZE FOR TAIL CALLS
18−
19−optimize :: Can.Expr -> Opt.Expr
20−optimize expression =
21− let
22− (Result _ optExpr) =
23− findTailCalls Nothing expression
24− in
25− optExpr
26−
27−
28−-- TRACKER TO THREAD FINDINGS THROUGH TRAVERSAL
29−
30−data Result a = Result Bool a
31−
32−
33−instance M.Functor Result where
34− fmap func (Result hasTailCall value) =
35− Result hasTailCall (func value)
36−
37−
38−instance Applicative Result where
39− pure value =
40− Result False value
41−
42− (<*>) (Result hasTailCall func) (Result hasTailCall' value) =
43− Result (hasTailCall || hasTailCall') (func value)
44−
45−
46−mapSnd :: M.Functor box => (a -> box b) -> (x, a) -> box (x, b)
47−mapSnd func (x, a) =
48− (,) x <$> func a
49−
50−
51−-- CONVERT DEFINITIONS
52−
53−detectTailRecursion :: Can.Def -> Opt.Def
54−detectTailRecursion (Can.Definition canonFacts pattern expression _) =
55− let
56− (args, body) =
57− Expr.collectLambdas expression
58−
59− context :: Context
60− context =
61− case (pattern, args) of
62− -- detect if it is a function
63− (A.A _ (P.Var name), _ : _) ->
64− Just (name, length args)
65−
66− _ ->
67− Nothing
68−
69− (Result isTailCall optExpr) =
70− findTailCalls context body
71−
72− lambda x e =
73− A.A () (Lambda x e)
74−
75− facts =
76− Opt.Facts
77− (if isTailCall then fmap fst context else Nothing)
78− (Can.dependencies canonFacts)
79− in
80− Opt.Definition
81− facts
82− (removeAnnotations pattern)
83− (foldr lambda optExpr (map removeAnnotations args))
84−
85−
86−-- CONVERT EXPRESSIONS
87−
88−type Context = Maybe (String, Int)
89−
90−
91−findTailCalls :: Context -> Can.Expr -> Result Opt.Expr
92−findTailCalls context annExpr@(A.A _ expression) =
93− let
94− keepLooking =
95− findTailCalls context
96− -- this *might* find a tail call, use this when something is a potential
97− -- tail call
98−
99− justConvert =
100− findTailCalls Nothing
101− -- this will never find tail calls, use this when you are working with
102− -- expressions that cannot be turned into tail calls
103− in
104− A.A () <$>
105− case expression of
106− Literal lit ->
107− pure (Literal lit)
108−
109− Var name ->
110− pure (Var name)
111−
112− Range lowExpr highExpr ->
113− Range
114− <$> justConvert lowExpr
115− <*> justConvert highExpr
116−
117− ExplicitList elements ->
118− ExplicitList
119− <$> T.traverse justConvert elements
120−
121− Binop op leftExpr rightExpr ->
122− Binop op
123− <$> justConvert leftExpr
124− <*> justConvert rightExpr
125−
126− Lambda pattern body ->
127− Lambda (removeAnnotations pattern) <$> justConvert body
128−
129− App _ _ ->
130− let
131− (func:args) =
132− Expr.collectApps annExpr
133−
134− isTailCall =
135− case (context, func) of
136− ( Just (name, argNum), A.A _ (Var (Var.Canonical Var.Local name')) ) ->
137− name == name' && length args == argNum
138− ( Just (name, argNum), A.A _ (Var (Var.Canonical (Var.TopLevel _) name')) ) ->
139− name == name' && length args == argNum
140− _ ->
141− False
142−
143− (Result _ (A.A _ optFunc)) =
144− justConvert func
145−
146− (Result _ optArgs) =
147− T.traverse justConvert args
148−
149− apply f arg =
150− App (A.A () f) arg
151− in
152− Result isTailCall (List.foldl' apply optFunc optArgs)
153−
154−
155− If branches finally ->
156− let
157− crawlBranch (cond,branch) =
158− (,) <$> justConvert cond <*> keepLooking branch
159− in
160− If
161− <$> T.traverse crawlBranch branches
162− <*> keepLooking finally
163−
164− Let defs body ->
165− let
166− optDefs = map detectTailRecursion defs
167− in
168− Let optDefs <$> keepLooking body
169−
170− Case expr cases ->
171− let
172− preppedCases =
173− map (first removeAnnotations) cases
174− in
175− Case
176− <$> justConvert expr
177− <*> T.traverse (mapSnd keepLooking) preppedCases
178−
179− Data name exprs ->
180− Data name <$> T.traverse justConvert exprs
181−
182− Access record field ->
183− Access
184− <$> justConvert record
185− <*> pure field
186−
187− Update record fields ->
188− Update
189− <$> justConvert record
190− <*> T.traverse (mapSnd justConvert) fields
191−
192− Record fields ->
193− Record
194− <$> T.traverse (mapSnd justConvert) fields
195−
196− GLShader uid src gltipe ->
197− pure (GLShader uid src gltipe)
198−
199− Port impl ->
200− Port <$>
201− case impl of
202− In name tipe ->
203− pure (In name tipe)
204−
205− Out name expr tipe ->
206− (\e -> Out name e tipe) <$> justConvert expr
207−
208− Task name expr tipe ->
209− (\e -> Task name e tipe) <$> justConvert expr
210−
211− Crash details ->
212− pure (Crash details)
213−
214−
215−removeAnnotations :: P.CanonicalPattern -> P.Optimized
216−removeAnnotations (A.A _ pattern) =
217− A.A () $
218− case pattern of
219− P.Var x ->
220− P.Var x
221−
222− P.Literal lit ->
223− P.Literal lit
224−
225− P.Record fields ->
226− P.Record fields
227−
228− P.Anything ->
229− P.Anything
230−
231− P.Alias alias realPattern ->
232− P.Alias alias (removeAnnotations realPattern)
233−
234− P.Data name patterns ->
235− P.Data name (map removeAnnotations patterns)
src/Reporting/Crash.hsdeleted−20
@@ -1,20 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module Reporting.Crash where
3−
4−import qualified Reporting.Region as R
5−
6−
7−data Details
8− = IncompleteMultiIf R.Region
9− | IncompletePatternMatch R.Region
10− deriving (Show)
11−
12−
13−summary :: Details -> String
14−summary details =
15− case details of
16− IncompleteMultiIf _ ->
17− "incomplete-multi-if"
18−
19− IncompletePatternMatch _ ->
20− "incomplete-pattern-match"
src/Type/Constrain/Expression.hs−3
@@ -168,9 +168,6 @@ constrain env annotatedExpr@(A.A region expression) tipe =
168 E.Task _ expr _ ->
168 E.Task _ expr _ ->
169 constrain env expr tipe
169 constrain env expr tipe
170
170
171− E.Crash _ ->
172− return CTrue
173−
174
171
175-- CONSTRAIN APP
172-- CONSTRAIN APP
176
173
src/Validate.hs−3
@@ -254,9 +254,6 @@ expression (A.A ann sourceExpression) =
254 do expr' <- expression expr
254 do expr' <- expression expr
255 return (Task name expr' tipe)
255 return (Task name expr' tipe)
256
256
257− Crash details ->
258− return (Crash details)
259−
260
257
261second :: (a, Source.Expr) -> Result.Result wrn Error.Error (a, Valid.Expr)
258second :: (a, Source.Expr) -> Result.Result wrn Error.Error (a, Valid.Expr)
262second (value, expr) =
259second (value, expr) =