5baaacf · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Merge branch 'pattern-warnings'

5baaacfEvan Czaplicki11 years ago

elm-compiler.cabal+9−2

compare with master

unifiedsplit

@@ -49,6 +49,7 @@ Library

49 AST.Declaration,

50 AST.Expression.Canonical,

51 AST.Expression.General,

52+ AST.Expression.Optimized,

52 AST.Expression.Source,

53 AST.Expression.Source,

53 AST.Expression.Valid,

54 AST.Expression.Valid,

54 AST.Helpers,

55 AST.Helpers,

@@ -73,13 +74,18 @@ Library

73 Elm.Compiler.Imports,

74 Elm.Compiler.Imports,

74 Elm.Compiler.Type.Extract,

75 Elm.Compiler.Type.Extract,

75 Elm.Compiler.Version,

76 Elm.Compiler.Version,

76− Generate.Cases,

77 Generate.JavaScript,

78+ Generate.JavaScript.Crash,

78 Generate.JavaScript.Helpers,

79 Generate.JavaScript.Helpers,

79 Generate.JavaScript.Port,

80 Generate.JavaScript.Port,

80 Generate.JavaScript.Variable,

81 Generate.JavaScript.Variable,

81− Generate.Substitute,

82+ Nitpick.Pattern,

83+ Nitpick.PatternMatches,

82 Nitpick.TopLevelTypes,

84 Nitpick.TopLevelTypes,

85+ Optimize,

86+ Optimize.Cases,

87+ Optimize.Substitute,

88+ Optimize.TailCalls,

83 Parse.Binop,

89 Parse.Binop,

84 Parse.Declaration,

90 Parse.Declaration,

85 Parse.Expression,

91 Parse.Expression,

@@ -90,6 +96,7 @@ Library

90 Parse.Pattern,

96 Parse.Pattern,

91 Parse.Type,

97 Parse.Type,

92 Reporting.Annotation,

98 Reporting.Annotation,

99+ Reporting.Crash,

93 Reporting.Error,

100 Reporting.Error,

94 Reporting.Error.Canonicalize,

101 Reporting.Error.Canonicalize,

95 Reporting.Error.Docs,

102 Reporting.Error.Docs,

src/AST/Expression/General.hs+19−3

@@ -16,6 +16,7 @@ import qualified AST.Pattern as Pattern

16import qualified AST.Type as Type

17import qualified AST.Variable as Var

18import qualified Reporting.Annotation as A

19+import qualified Reporting.Crash as Crash

19import qualified Reporting.PrettyPrint as P

20import qualified Reporting.PrettyPrint as P

@@ -48,7 +49,7 @@ data Expr' ann def var typ

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

49 | Binop var (Expr ann def var typ) (Expr ann def var typ)

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

50 | Lambda (Pattern.Pattern ann var) (Expr ann def var typ)

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

51 | App (Expr ann def var typ) (Expr ann def var typ)

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

52+ | MultiIf [(Expr ann def var typ, Expr ann def var typ)] (Expr ann def var typ)

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

53 | Let [def] (Expr ann def var typ)

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

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

54 | Data String [Expr ann def var typ]

55 | Data String [Expr ann def var typ]

@@ -60,6 +61,7 @@ data Expr' ann def var typ

60 -- for type checking and code gen only

61 -- for type checking and code gen only

61 | Port (PortImpl (Expr ann def var typ) typ)

62 | Port (PortImpl (Expr ann def var typ) typ)

62 | GLShader String String Literal.GLShaderTipe

63 | GLShader String String Literal.GLShaderTipe

64+ | Crash Crash.Details

63 deriving (Show)

65 deriving (Show)

@@ -161,9 +163,17 @@ instance (P.Pretty def, P.Pretty var, Var.ToString var) => P.Pretty (Expr' ann d

161 func:args =

163 func:args =

162 map (P.pretty dealiaser True) (collectApps expr ++ [arg])

164 map (P.pretty dealiaser True) (collectApps expr ++ [arg])

163

165

166+ MultiIf [(condition, thenBranch)] elseBranch ->

167+ P.parensIf needsParens $ P.sep $

168+ [ P.text "if" <+> P.pretty dealiaser False condition <+> P.text "then"

169+ , P.nest 4 (P.pretty dealiaser False thenBranch)

170+ , P.text "else"

171+ , P.nest 4 (P.pretty dealiaser False elseBranch)

172+ ]

173+

164− MultiIf branches ->

174+ MultiIf branches finally ->

165 P.parensIf needsParens $

175 P.parensIf needsParens $

166− P.text "if" $$ nest 3 (vcat $ map iff branches)

176+ P.text "if" $$ nest 3 (vcat $ map iff branches ++ [final])

167 where

177 where

168 iff (condition, branch) =

178 iff (condition, branch) =

169 P.text "|" <+>

179 P.text "|" <+>

@@ -172,6 +182,9 @@ instance (P.Pretty def, P.Pretty var, Var.ToString var) => P.Pretty (Expr' ann d

172 2

182 2

173 (P.pretty dealiaser False branch)

183 (P.pretty dealiaser False branch)

174

184

185+ final =

186+ P.hang (P.text "| True -> ") 2 (P.pretty dealiaser False finally)

187+

175 Let defs body ->

188 Let defs body ->

176 P.parensIf needsParens $

189 P.parensIf needsParens $

177 P.sep

190 P.sep

@@ -263,6 +276,9 @@ instance (P.Pretty def, P.Pretty var, Var.ToString var) => P.Pretty (Expr' ann d

263 Port portImpl ->

276 Port portImpl ->

264 P.pretty dealiaser needsParens portImpl

277 P.pretty dealiaser needsParens portImpl

265

278

279+ Crash details ->

280+ P.text ("<crash:" ++ Crash.summary details ++ ">")

281+

266

282

267instance P.Pretty (PortImpl expr tipe) where

283instance P.Pretty (PortImpl expr tipe) where

268 pretty _ _ impl =

284 pretty _ _ impl =

src/AST/Expression/Optimized.hsnew file+35

@@ -0,0 +1,35 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module AST.Expression.Optimized

3+ ( Expr, Expr'

4+ , Def(..)

5+ , Facts(..), dummyFacts

6+ ) where

8+import qualified AST.Expression.General as General

9+import qualified AST.Pattern as Pattern

10+import qualified AST.Type as Type

11+import qualified AST.Variable as Var

12+

13+

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+

21+

22+data Def

23+ = Definition Facts Pattern.Optimized Expr

24+ deriving (Show)

25+

26+

27+data Facts = Facts

28+ { tailRecursionDetails :: Maybe String

29+ }

30+ deriving (Show)

31+

32+

33+dummyFacts :: Facts

34+dummyFacts =

35+ Facts Nothing

src/AST/Literal.hs+10−5

@@ -18,12 +18,17 @@ data Literal

19instance P.Pretty Literal where

20 pretty _ _ literal =

21+ P.text (toString literal)

22+

23+

24+toString :: Literal -> String

25+toString literal =

21 case literal of

26 case literal of

22− IntNum n -> P.int n

27+ IntNum n -> show n

23− FloatNum n -> P.double n

28+ FloatNum n -> show n

24− Chr c -> P.text . show $ c

29+ Chr c -> show c

25− Str s -> P.text . show $ s

30+ Str s -> show s

26− Boolean bool -> P.text (show bool)

31+ Boolean bool -> show bool

29data GLTipe

34data GLTipe

src/AST/Module.hs+10−5

@@ -2,8 +2,8 @@ module AST.Module

2 ( Interfaces

3 , Types, Aliases, ADTs

4 , AdtInfo, CanonicalAdt

5− , SourceModule, ValidModule, CanonicalModule

5+ , SourceModule, ValidModule, CanonicalModule, Optimized

6− , Module(..), CanonicalBody(..)

6+ , Module(..), Body(..)

7 , Header(..)

8 , Name, nameToString, nameIsNative

9 , Interface(..), toInterface

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

18import qualified AST.Declaration as Decl

19import qualified AST.Expression.Canonical as Canonical

20+import qualified AST.Expression.Optimized as Optimized

20import qualified AST.Type as Type

21import qualified AST.Type as Type

21import qualified AST.Variable as Var

22import qualified AST.Variable as Var

22import qualified Docs.AST as Docs

23import qualified Docs.AST as Docs

@@ -55,7 +56,11 @@ type ValidModule =

57type CanonicalModule =

58type CanonicalModule =

58− Module Docs.Centralized [Name] [Var.Value] CanonicalBody

59+ Module Docs.Centralized [Name] [Var.Value] (Body Canonical.Expr)

60+

61+

62+type Optimized =

63+ Module Docs.Centralized [Name] [Var.Value] (Body Optimized.Expr)

61data Module docs imports exports body = Module

66data Module docs imports exports body = Module

@@ -68,8 +73,8 @@ data Module docs imports exports body = Module

68 }

73 }

71−data CanonicalBody = CanonicalBody

76+data Body expr = Body

72− { program :: Canonical.Expr

77+ { program :: expr

73 , types :: Types

78 , types :: Types

74 , fixities :: [(Decl.Assoc, Int, String)]

79 , fixities :: [(Decl.Assoc, Int, String)]

75 , aliases :: Aliases

80 , aliases :: Aliases

src/AST/Pattern.hs+4

@@ -38,6 +38,10 @@ type CanonicalPattern =

38 Pattern R.Region Var.Canonical

41+type Optimized =

42+ Pattern () Var.Canonical

43+

44+

41list :: R.Position -> [RawPattern] -> RawPattern

45list :: R.Position -> [RawPattern] -> RawPattern

42list end patterns =

46list end patterns =

43 case patterns of

47 case patterns of

src/Canonicalize.hs+11−6

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

8import qualified Data.Traversable as T

10import AST.Expression.General (Expr'(..), dummyLet)

11−import AST.Module (CanonicalBody(..))

11+import AST.Module (Body(..))

13import qualified AST.Declaration as D

14import qualified AST.Expression.General as E

@@ -61,7 +61,7 @@ type AlmostCanonicalModule =

61 Docs.Centralized

62 ([Module.DefaultImport], [Module.UserImport])

63 [Var.Value]

64− Module.CanonicalBody

64+ (Module.Body Canonical.Expr)

67moduleHelp

@@ -89,11 +89,11 @@ moduleHelp interfaces modul@(Module.Module _ _ comment exports _ decls) =

89 Setup.environment interfaces modul

90 `Result.andThen` \env -> (,) env <$> T.traverse (declaration env) decls

92− body :: [D.CanonicalDecl] -> Module.CanonicalBody

92+ body :: [D.CanonicalDecl] -> Module.Body Canonical.Expr

93 body decls =

94 let nakedDecls = map A.drop decls

95 in

96− Module.CanonicalBody

96+ Module.Body

97 { program =

98 let expr = Decls.toExpr (Module.names modul) decls

99 in

@@ -367,8 +367,10 @@ expression env (A.A region validExpr) =

367 App func arg ->

368 App <$> go func <*> go arg

369

370− MultiIf branches ->

370+ MultiIf branches finally ->

371+ MultiIf

371− MultiIf <$> T.traverse go' branches

372+ <$> T.traverse go' branches

373+ <*> go finally

372 where

374 where

373 go' (condition, branch) =

375 go' (condition, branch) =

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

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

@@ -427,6 +429,9 @@ expression env (A.A region validExpr) =

427 GLShader uid src tipe ->

429 GLShader uid src tipe ->

428 Result.ok (GLShader uid src tipe)

430 Result.ok (GLShader uid src tipe)

429

431

432+ Crash details ->

433+ Result.ok (Crash details)

434+

430

435

431pattern

436pattern

432 :: Env.Environment

437 :: Env.Environment

src/Canonicalize/Sort.hs+17−5

@@ -73,17 +73,26 @@ reorder (A.A ann expression) =

73 App func arg ->

74 App <$> reorder func <*> reorder arg

76− MultiIf branches ->

76+ MultiIf branches finally ->

77+ MultiIf

77− MultiIf <$> mapM (\(cond,branch) -> (,) <$> reorder cond <*> reorder branch) branches

78+ <$> mapM (\(cond,branch) -> (,) <$> reorder cond <*> reorder branch) branches

79+ <*> reorder finally

79 Access record field ->

81 Access record field ->

82+ Access

80− Access <$> reorder record <*> return field

83+ <$> reorder record

84+ <*> return field

82 Remove record field ->

86 Remove record field ->

87+ Remove

83− Remove <$> reorder record <*> return field

88+ <$> reorder record

89+ <*> return field

85 Insert record field expr ->

91 Insert record field expr ->

92+ Insert

86− Insert <$> reorder record <*> return field <*> reorder expr

93+ <$> reorder record

94+ <*> return field

95+ <*> reorder expr

88 Modify record fields ->

97 Modify record fields ->

89 Modify

98 Modify

@@ -109,6 +118,9 @@ reorder (A.A ann expression) =

109 Task name expr tipe ->

118 Task name expr tipe ->

110 (\e -> Task name e tipe) <$> reorder expr

119 (\e -> Task name e tipe) <$> reorder expr

111

120

121+ Crash _ ->

122+ return expression

123+

112 -- Actually do some reordering

124 -- Actually do some reordering

113 Let defs body ->

125 Let defs body ->

114 do body' <- reorder body

126 do body' <- reorder body

src/Compile.hs+3

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

5import qualified AST.Module as Module

6import qualified Canonicalize

7import Elm.Utils ((|>))

8+import qualified Nitpick.PatternMatches as Nitpick

8import qualified Nitpick.TopLevelTypes as Nitpick

9import qualified Nitpick.TopLevelTypes as Nitpick

9import qualified Parse.Helpers as Parse

10import qualified Parse.Helpers as Parse

10import qualified Parse.Parse as Parse

11import qualified Parse.Parse as Parse

@@ -47,6 +48,8 @@ compile user projectName isRoot interfaces source =

47 Result.mapError Error.Type $

48 Result.mapError Error.Type $

48 Nitpick.topLevelTypes types (Module.body validModule)

49 Nitpick.topLevelTypes types (Module.body validModule)

51+ Nitpick.patternMatches interfaces canonicalModule

52+

50 -- Add the real list of types

53 -- Add the real list of types

51 let body = (Module.body canonicalModule) { Module.types = types }

54 let body = (Module.body canonicalModule) { Module.types = types }

src/Elm/Compiler.hs+7−1

@@ -18,6 +18,7 @@ import qualified Elm.Compiler.Module as PublicModule

18import qualified Elm.Compiler.Version as Version

19import qualified Elm.Docs as Docs

20import qualified Generate.JavaScript as JS

21+import qualified Optimize

21import qualified Parse.Module as Parse

22import qualified Parse.Module as Parse

22import qualified Parse.Parse as Parse

23import qualified Parse.Parse as Parse

23import qualified Reporting.Annotation as A

24import qualified Reporting.Annotation as A

@@ -80,7 +81,12 @@ compile context source interfaces =

80 (Result.Result (dealiaser, warnings) rawResult) =

81 (Result.Result (dealiaser, warnings) rawResult) =

81 do modul <- Compile.compile user packageName isRoot unwrappedInterfaces source

82 do modul <- Compile.compile user packageName isRoot unwrappedInterfaces source

82 docs <- docsGen isExposed modul

83 docs <- docsGen isExposed modul

84+

83− return (Result docs (Module.toInterface modul) (JS.generate modul))

85+ let interface = Module.toInterface modul

86+ let optModule = Optimize.optimize modul

87+ let javascript = JS.generate optModule

88+

89+ return (Result docs interface javascript)

84 in

90 in

85 ( maybe dummyDealiaser Dealiaser dealiaser

91 ( maybe dummyDealiaser Dealiaser dealiaser

86 , map Warning warnings

92 , map Warning warnings

src/Generate/JavaScript.hs+602−268

@@ -1,17 +1,18 @@

1module Generate.JavaScript (generate) where

3import Control.Applicative ((<$>),(<*>))

4−import Control.Arrow (first,(***))

4+import Control.Arrow (first, second, (***))

5import Control.Monad.State

6import qualified Data.List as List

7import qualified Data.Map as Map

8+import qualified Data.Maybe as Maybe

8import qualified Data.Set as Set

9import qualified Data.Set as Set

9import Language.ECMAScript3.PrettyPrint

10import Language.ECMAScript3.PrettyPrint

10import Language.ECMAScript3.Syntax

11import Language.ECMAScript3.Syntax

12import AST.Module

13import AST.Module

13−import AST.Expression.General

14+import AST.Expression.General as Expr

14−import qualified AST.Expression.Canonical as Canonical

15+import qualified AST.Expression.Optimized as Opt

15import qualified AST.Helpers as Help

16import qualified AST.Helpers as Help

16import AST.Literal

17import AST.Literal

17import qualified AST.Module as Module

18import qualified AST.Module as Module

@@ -19,19 +20,22 @@ import qualified AST.Pattern as P

19import qualified AST.Variable as Var

20import qualified AST.Variable as Var

20import Elm.Utils ((|>))

21import Elm.Utils ((|>))

21import Generate.JavaScript.Helpers as Help

22import Generate.JavaScript.Helpers as Help

22−import qualified Generate.Cases as Case

23+import qualified Generate.JavaScript.Crash as Crash

23import qualified Generate.JavaScript.Port as Port

24import qualified Generate.JavaScript.Port as Port

24import qualified Generate.JavaScript.Variable as Var

25import qualified Generate.JavaScript.Variable as Var

26+import qualified Optimize.Cases as Case

25import qualified Reporting.Annotation as A

27import qualified Reporting.Annotation as A

26−import qualified Reporting.Region as R

28+import qualified Reporting.Crash as Crash

31+-- HELPERS

32+

29internalImports :: Module.Name -> [VarDecl ()]

33internalImports :: Module.Name -> [VarDecl ()]

30internalImports name =

34internalImports name =

31 [ varDecl "_N" (obj ["Elm","Native"])

35 [ varDecl "_N" (obj ["Elm","Native"])

32 , include "_U" "Utils"

36 , include "_U" "Utils"

33 , include "_L" "List"

37 , include "_L" "List"

34− , varDecl Help.localModuleName (string (Module.nameToString name))

38+ , varDecl Crash.localModuleName (string (Module.nameToString name))

35 ]

39 ]

36 where

40 where

37 include :: String -> String -> VarDecl ()

41 include :: String -> String -> VarDecl ()

@@ -59,51 +63,131 @@ literal lit =

59 Boolean b -> BoolLit () b

63 Boolean b -> BoolLit () b

66+-- CODE CHUNKS

67+

68+data Code

69+ = JsExpr (Expression ())

70+ | JsBlock [Statement ()]

71+

72+

73+jsExpr :: Expression () -> State Int Code

74+jsExpr exp =

75+ return (JsExpr exp)

76+

77+

78+jsBlock :: [Statement ()] -> State Int Code

79+jsBlock exp =

80+ return (JsBlock exp)

81+

82+

83+isBlock :: Code -> Bool

84+isBlock code =

85+ case code of

86+ JsBlock _ -> True

87+ JsExpr _ -> False

88+

89+

90+toStatementList :: Code -> [Statement ()]

91+toStatementList code =

92+ case code of

93+ JsExpr expr ->

94+ [ ret expr ]

95+ JsBlock stmts ->

96+ stmts

97+

98+

99+toStatement :: Code -> Statement ()

100+toStatement code =

101+ case code of

102+ JsExpr expr ->

103+ ret expr

104+ JsBlock [stmt] ->

105+ stmt

106+ JsBlock stmts ->

107+ BlockStmt () stmts

108+

109+

110+toExpr :: Code -> Expression ()

111+toExpr code =

112+ case code of

113+ JsExpr expr ->

114+ expr

115+ JsBlock stmts ->

116+ function [] stmts `call` []

117+

118+

119+-- TAIL CALL CONTEXT

120+

121+type TailCallContext =

122+ Maybe (String, [String], Label)

123+

124+

125+type Label =

126+ Id ()

127+

128+

129+-- EXPRESSIONS

130+

62−expression :: Canonical.Expr -> State Int (Expression ())

131+toJsExpr :: Opt.Expr -> State Int (Expression ())

63−expression (A.A region expr) =

132+toJsExpr =

133+ exprToJsExpr Nothing

134+

135+

136+toCode :: Opt.Expr -> State Int Code

137+toCode =

138+ exprToCode Nothing

139+

140+

141+exprToJsExpr :: TailCallContext -> Opt.Expr -> State Int (Expression ())

142+exprToJsExpr tcc canonicalExpr =

143+ toExpr <$> exprToCode tcc canonicalExpr

144+

145+

146+exprToCode :: TailCallContext -> Opt.Expr -> State Int Code

147+exprToCode tcc annotatedExpr@(A.A _ expr) =

64 case expr of

148 case expr of

65 Var var ->

149 Var var ->

66− return $ Var.canonical var

150+ jsExpr $ Var.canonical var

151

68 Literal lit ->

152 Literal lit ->

69− return $ literal lit

153+ jsExpr $ literal lit

154

71 Range lo hi ->

155 Range lo hi ->

72− do lo' <- expression lo

156+ do lo' <- toJsExpr lo

73− hi' <- expression hi

157+ hi' <- toJsExpr hi

74− return $ _List "range" `call` [lo',hi']

158+ jsExpr $ _List "range" `call` [lo',hi']

159

76− Access e field ->

160+ Access record field ->

77− do e' <- expression e

161+ do record' <- toJsExpr record

78− return $ DotRef () e' (var (Var.varName field))

162+ jsExpr $ DotRef () record' (var (Var.varName field))

163

80− Remove e field ->

164+ Remove record field ->

81− do e' <- expression e

165+ do record' <- toJsExpr record

82− return $ _Utils "remove" `call` [ string (Var.varName field), e' ]

166+ jsExpr $ _Utils "remove" `call` [ string (Var.varName field), record' ]

167

84− Insert e field value ->

168+ Insert record field value ->

85− do value' <- expression value

169+ do value' <- toJsExpr value

86− e' <- expression e

170+ record' <- toJsExpr record

87− return $ _Utils "insert" `call` [ string (Var.varName field), value', e' ]

171+ jsExpr $ _Utils "insert" `call` [ string (Var.varName field), value', record' ]

172

89− Modify e fields ->

173+ Modify record fields ->

90− do e' <- expression e

174+ do record' <- toJsExpr record

91 fields' <-

175 fields' <-

92 forM fields $ \(field, value) ->

176 forM fields $ \(field, value) ->

93− do value' <- expression value

177+ do value' <- toJsExpr value

94 return $ ArrayLit () [ string (Var.varName field), value' ]

178 return $ ArrayLit () [ string (Var.varName field), value' ]

179

96− return $ _Utils "replace" `call` [ArrayLit () fields', e']

180+ jsExpr $ _Utils "replace" `call` [ArrayLit () fields', record']

181

98 Record fields ->

182 Record fields ->

99 do fields' <-

183 do fields' <-

100 forM fields $ \(field, e) ->

184 forM fields $ \(field, e) ->

101− (,) (Var.varName field) <$> expression e

185+ (,) (Var.varName field) <$> toJsExpr e

102

186

103 let fieldMap =

187 let fieldMap =

104 List.foldl' combine Map.empty fields'

188 List.foldl' combine Map.empty fields'

105

189

106− return $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap

190+ jsExpr $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap

107 where

191 where

108 combine record (field, value) =

192 combine record (field, value) =

109 Map.insertWith (++) field [value] record

193 Map.insertWith (++) field [value] record

@@ -115,201 +199,370 @@ expression (A.A region expr) =

115 visible fs =

199 visible fs =

116 map (first prop) (Map.toList (Map.map head fs))

200 map (first prop) (Map.toList (Map.map head fs))

117

201

118− Binop op e1 e2 ->

202+ Binop op leftExpr rightExpr ->

119− binop region op e1 e2

203+ binop op leftExpr rightExpr

120

204

121− Lambda pattern rawBody@(A.A ann _) ->

205+ Lambda _ _ ->

122− do (args, body) <- foldM depattern ([], innerBody) (reverse patterns)

206+ generateFunction (Expr.collectLambdas annotatedExpr)

123− body' <- expression body

207+

124− return $

125− case length args < 2 || length args > 9 of

126− True -> foldr (==>) body' (map (:[]) args)

127− False -> ref ("F" ++ show (length args)) <| (args ==> body')

128− where

129− depattern (args, body) pattern =

130− case pattern of

131− A.A _ (P.Var x) ->

132− return (args ++ [ Var.varName x ], body)

133−

134− _ ->

135− do arg <- Case.newVar

136− return

137− ( args ++ [arg]

138− , A.A ann (Case (A.A ann (localVar arg)) [(pattern, body)])

139− )

140−

141− (patterns, innerBody) =

142− collect [pattern] rawBody

143−

144− collect patterns lexpr@(A.A _ expr) =

145− case expr of

146− Lambda p e -> collect (p:patterns) e

147− _ -> (patterns, lexpr)

148−

149− App e1 e2 ->

208+ App _ _ ->

150− do func' <- expression func

209+ generateApplication tcc annotatedExpr

151− args' <- mapM expression args

210+

152− return $

153− case args' of

154− [arg] -> func' <| arg

155− _ | length args' <= 9 -> ref aN `call` (func':args')

156− | otherwise -> foldl1 (<|) (func':args')

157− where

158− aN = "A" ++ show (length args)

159− (func, args) = getArgs e1 [e2]

160− getArgs func args =

161− case func of

162− (A.A _ (App f arg)) -> getArgs f (arg : args)

163− _ -> (func, args)

164−

165− Let defs e ->

211+ Let defs body ->

166− do let (defs',e') = flattenLets defs e

212+ generateLet tcc defs body

167− stmts <- concat <$> mapM definition defs'

213+

168− exp <- expression e'

169− return $ function [] (stmts ++ [ ret exp ]) `call` []

170−

171− MultiIf branches ->

214+ MultiIf branches finally ->

172− do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e

173− return $

174− case last branches of

175− (A.A _ (Var (Var.Canonical (Var.Module ["Basics"]) "otherwise")), _) ->

176− safeIfs branches'

177− (A.A _ (Literal (Boolean True)), _) ->

178− safeIfs branches'

179− _ ->

180− ifs branches' (throw "badIf" region)

181− where

182− safeIfs branches = ifs (init branches) (snd (last branches))

183− ifs branches finally = foldr iff finally branches

215+ generateIf tcc branches finally

184− iff (if', then') else' = CondExpr () if' then' else'

216+

185−

217+ Case expr branches ->

186− Case e cases ->

218+ generateCase tcc expr branches

187− do (tempVar,initialMatch) <- Case.toMatch cases

219+

188− (revisedMatch, stmt) <-

189− case e of

190− A.A _ (Var (Var.Canonical Var.Local x)) ->

191− return (Case.matchSubst [(tempVar, Var.varName x)] initialMatch, [])

192− _ ->

193− do e' <- expression e

194− return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])

195− match' <- match region revisedMatch

196− return (function [] (stmt ++ match') `call` [])

197−

198− ExplicitList es ->

220+ ExplicitList elements ->

199− do es' <- mapM expression es

221+ do jsElements <- mapM toJsExpr elements

200− return $ _List "fromArray" <| ArrayLit () es'

222+ jsExpr $ _List "fromArray" <| ArrayLit () jsElements

201−

223+

202− Data name es ->

224+ Data tag members ->

203− do es' <- mapM expression es

225+ do jsMembers <- mapM toJsExpr members

204− return $ ObjectLit () (ctor : fields es')

226+ jsExpr $ ObjectLit () (ctor : fields jsMembers)

205 where

227 where

206− ctor = (prop "ctor", string name)

228+ ctor = (prop "ctor", string tag)

207 fields =

229 fields =

208 zipWith (\n e -> (prop ("_" ++ show n), e)) [ 0 :: Int .. ]

230 zipWith (\n e -> (prop ("_" ++ show n), e)) [ 0 :: Int .. ]

209

231

210 GLShader _uid src _tipe ->

232 GLShader _uid src _tipe ->

211− return $ ObjectLit () [(PropString () "src", literal (Str src))]

233+ jsExpr $ ObjectLit () [(PropString () "src", literal (Str src))]

212

234

213 Port impl ->

235 Port impl ->

214 case impl of

236 case impl of

215 In name portType ->

237 In name portType ->

216− return (Port.inbound name portType)

238+ jsExpr (Port.inbound name portType)

217

239

218 Out name expr portType ->

240 Out name expr portType ->

219− do expr' <- expression expr

241+ do expr' <- toJsExpr expr

220− return (Port.outbound name expr' portType)

242+ jsExpr (Port.outbound name expr' portType)

221

243

222 Task name expr portType ->

244 Task name expr portType ->

223− do expr' <- expression expr

245+ do expr' <- toJsExpr expr

224− return (Port.task name expr' portType)

246+ jsExpr (Port.task name expr' portType)

225−

247+

226−

248+ Crash details ->

227−definition :: Canonical.Def -> State Int [Statement ()]

249+ jsExpr $ Crash.crash details

228−definition (Canonical.Definition annPattern expr@(A.A region _) _) =

250+

229− do expr' <- expression expr

251+

230− let assign x = varDecl x expr'

252+-- FUNCTIONS

231− let (A.A patternRegion pattern) = annPattern

253+

232− case pattern of

254+generateFunction :: ([P.Optimized], Opt.Expr) -> State Int Code

233− P.Var x

255+generateFunction (args, initialBody) =

234− | Help.isOp x ->

256+ do (argVars, patternDefs) <- destructuredArgs args

235− let op = LBracket () (ref "_op") (string x) in

257+ code <- generateLet Nothing patternDefs initialBody

258+ jsExpr (generateFunctionWithArity argVars code)

259+

260+

261+generateTailFunction :: String -> ([P.Optimized], Opt.Expr) -> State Int (Expression ())

262+generateTailFunction name (args, initialBody) =

263+ do (argVars, patternDefs) <- destructuredArgs args

264+ label <- Id () <$> Case.newVar

265+ code <- generateLet (Just (name, argVars, label)) patternDefs initialBody

266+ let whileLoop =

267+ JsBlock [ LabelledStmt () label (WhileStmt () (BoolLit () True) (toStatement code)) ]

268+ return (generateFunctionWithArity argVars whileLoop)

269+

270+

271+generateFunctionWithArity :: [String] -> Code -> Expression ()

272+generateFunctionWithArity args code =

273+ let

274+ arity = length args

275+ in

276+ if 2 <= arity && arity <= 9 then

277+ let

278+ fN = "F" ++ show arity

279+ in

280+ ref fN <| function args (toStatementList code)

281+ else

282+ let

283+ (lastArg:otherArgs) = reverse args

284+ innerBody = function [lastArg] (toStatementList code)

285+ in

286+ foldl (\body arg -> function [arg] [ret body]) innerBody otherArgs

287+

288+

289+destructuredArgs :: [P.Optimized] -> State Int ([String], [Opt.Def])

290+destructuredArgs args =

291+ do (argVars, maybePatternDefs) <- unzip <$> mapM destructPattern args

292+ return (argVars, Maybe.catMaybes maybePatternDefs)

293+

294+

295+destructPattern :: P.Optimized -> State Int (String, Maybe Opt.Def)

296+destructPattern pattern@(A.A ann pat) =

297+ case pat of

298+ P.Var x ->

299+ return (Var.varName x, Nothing)

300+

301+ _ ->

302+ do arg <- Case.newVar

303+ return

304+ ( arg

305+ , Just $ Opt.Definition Opt.dummyFacts pattern (A.A ann (localVar arg))

306+ )

307+

308+

309+-- APPLICATIONS

310+

311+generateApplication :: TailCallContext -> Opt.Expr -> State Int Code

312+generateApplication tcc expr =

313+ let

314+ (func:args) =

315+ Expr.collectApps expr

316+

317+ arity =

318+ length args

319+

320+ reassign name tempName =

236− return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]

321+ ExprStmt () (AssignExpr () OpAssign (LVar () name) (ref tempName))

237−

322+

238− | otherwise ->

323+ aN =

239− return [ VarDeclStmt () [ assign (Var.varName x) ] ]

324+ "A" ++ show arity

240−

325+ in

241− P.Record fields ->

326+ case isTailCall tcc func arity of

242− let setField f = varDecl f (obj ["$",f]) in

327+ Just (argNames, label) ->

243− return [ VarDeclStmt () (assign "$" : map setField fields) ]

328+ do args' <- mapM toJsExpr args

244−

329+ tempNames <- mapM (\_ -> Case.newVar) args

245− P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->

330+ jsBlock $

246− return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]

331+ VarDeclStmt () (zipWith varDecl tempNames args')

247− where

332+ : zipWith reassign argNames tempNames

248− vars = getVars patterns

333+ ++ [ContinueStmt () (Just label)]

249− getVars patterns =

250− case patterns of

251− A.A _ (P.Var x) : rest ->

252− (Var.varName x :) `fmap` getVars rest

253− [] ->

254− Just []

255− _ ->

256− Nothing

257−

258− decl x n = varDecl x (obj ["$","_" ++ show n])

259− setup vars

260− | Help.isTuple name = assign "$" : vars

261− | otherwise = assign "_raw" : safeAssign : vars

262−

263− safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception)

264− if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name)

265− exception = Help.throw "badCase" region

266

334

267− _ ->

335+ _ ->

336+ do func' <- toJsExpr func

337+ args' <- mapM toJsExpr args

338+ jsExpr $

339+ if 2 <= arity && arity <= 9 then

340+ ref aN `call` (func':args')

341+ else

342+ foldl1 (<|) (func':args')

343+

344+

345+isTailCall :: TailCallContext -> Opt.Expr -> Int -> Maybe ([String], Label)

346+isTailCall tcc (A.A _ func) arity =

347+ case (func, tcc) of

348+ (Var (Var.Canonical Var.Local name), Just (tcName, tcArgs, tcLabel)) ->

349+ if name == tcName && length tcArgs == arity then

350+ Just (tcArgs, tcLabel)

351+ else

352+ Nothing

353+

354+ _ ->

355+ Nothing

356+

357+

358+-- LET EXPRESSIONS

359+

360+generateLet

361+ :: TailCallContext

362+ -> [Opt.Def]

363+ -> Opt.Expr

364+ -> State Int Code

365+generateLet tcc givenDefs givenBody =

366+ do let (defs, body) = flattenLets givenDefs givenBody

367+ stmts <- concat <$> mapM defToStatements defs

368+ code <- exprToCode tcc body

369+ jsBlock (stmts ++ toStatementList code)

370+

371+

372+-- GENERATE IFS

373+

374+generateIf :: TailCallContext -> [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code

375+generateIf tcc givenBranches givenFinally =

376+ let

377+ (branches, finally) =

378+ crushIfs givenBranches givenFinally

379+

380+ convertBranch (condition, expr) =

381+ (,) <$> toJsExpr condition <*> exprToCode tcc expr

382+

383+ ifExpression (condition, branch) otherwise =

384+ CondExpr () condition branch otherwise

385+

386+ ifStatement (condition, branch) otherwise =

387+ IfStmt () condition branch otherwise

388+ in

389+ do jsBranches <- mapM convertBranch branches

390+ jsFinally <- exprToCode tcc finally

391+

392+ if any isBlock (jsFinally : map snd jsBranches)

393+ then

394+ jsBlock [ foldr ifStatement (toStatement jsFinally) (map (second toStatement) jsBranches) ]

395+ else

396+ jsExpr (foldr ifExpression (toExpr jsFinally) (map (second toExpr) jsBranches))

397+

398+

399+crushIfs

400+ :: [(Opt.Expr, Opt.Expr)]

401+ -> Opt.Expr

402+ -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)

403+crushIfs branches finally =

404+ crushIfsHelp [] branches finally

405+

406+

407+crushIfsHelp

408+ :: [(Opt.Expr, Opt.Expr)]

409+ -> [(Opt.Expr, Opt.Expr)]

410+ -> Opt.Expr

411+ -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)

412+crushIfsHelp visitedBranches unvisitedBranches finally =

413+ case unvisitedBranches of

414+ [] ->

415+ case finally of

416+ A.A _ (MultiIf subBranches subFinally) ->

417+ crushIfsHelp visitedBranches subBranches subFinally

418+

419+ _ ->

420+ (reverse visitedBranches, finally)

421+

422+ (A.A _ (Literal (Boolean True)), branch) : _ ->

423+ crushIfsHelp visitedBranches [] branch

424+

425+ (A.A _ (Var (Var.Canonical (Var.Module ["Basics"]) "otherwise")), branch) : _ ->

426+ crushIfsHelp visitedBranches [] branch

427+

428+ visiting : unvisited ->

429+ crushIfsHelp (visiting : visitedBranches) unvisited finally

430+

431+

432+

433+-- DEFINITIONS

434+

435+defToStatements :: Opt.Def -> State Int [Statement ()]

436+defToStatements (Opt.Definition facts pattern expr) =

437+ case Opt.tailRecursionDetails facts of

438+ Just name ->

439+ do func <- generateTailFunction name (Expr.collectLambdas expr)

440+ return [ VarDeclStmt () [ varDecl name func ] ]

441+

442+ Nothing ->

443+ defToStatementsHelp facts pattern =<< toJsExpr expr

444+

445+

446+defToStatementsHelp

447+ :: Opt.Facts

448+ -> P.Optimized

449+ -> Expression ()

450+ -> State Int [Statement ()]

451+defToStatementsHelp facts annPattern@(A.A _ pattern) jsExpr =

452+ let

453+ define x =

454+ varDecl x jsExpr

455+ in

456+ case pattern of

457+ P.Var x ->

458+ if Help.isOp x then

459+ let

460+ op = LBracket () (ref "_op") (string x)

461+ in

462+ return [ ExprStmt () $ AssignExpr () OpAssign op jsExpr ]

463+ else

464+ return [ VarDeclStmt () [ define (Var.varName x) ] ]

465+

466+ P.Record fields ->

467+ let

468+ setField name =

469+ varDecl name (obj ["$",name])

470+ in

471+ return [ VarDeclStmt () (define "$" : map setField fields) ]

472+

473+ P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->

474+ return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]

475+ where

476+ vars = getVars patterns

477+ getVars patterns =

478+ case patterns of

479+ A.A _ (P.Var x) : rest ->

480+ (Var.varName x :) `fmap` getVars rest

481+ [] ->

482+ Just []

483+ _ ->

484+ Nothing

485+

486+ decl x n = varDecl x (obj ["$","_" ++ show n])

487+ setup vars

488+ | Help.isTuple name = define "$" : vars

489+ | otherwise = define "_raw" : safeAssign : vars

490+

491+ safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception)

492+ if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name)

493+ exception = Crash.crash (Crash.IncompletePatternMatch (error "TODO"))

494+

495+ _ ->

268− do defs' <- concat <$> mapM toDef vars

496+ do defs' <- concat <$> mapM toDef vars

269− return (VarDeclStmt () [assign "_"] : defs')

497+ return (VarDeclStmt () [define "_"] : defs')

270− where

498+ where

271− vars = P.boundVarList annPattern

499+ vars = P.boundVarList annPattern

272− mkVar = A.A region . localVar

500+ mkVar = A.A () . localVar

273− toDef y =

501+ toDef y =

274− let expr = A.A region $ Case (mkVar "_") [(annPattern, mkVar y)]

502+ let expr = A.A () $ Case (mkVar "_") [(annPattern, mkVar y)]

275− pat = A.A patternRegion (P.Var y)

503+ pat = A.A () (P.Var y)

276− in

504+ in

277− definition (Canonical.Definition pat expr Nothing)

505+ defToStatements (Opt.Definition facts pat expr)

278−

506+

279−

507+

508+-- CASE EXPRESSIONS

509+

510+generateCase :: TailCallContext -> Opt.Expr -> [(P.Optimized, Opt.Expr)] -> State Int Code

511+generateCase tcc expr branches =

512+ do (tempVar, initialMatch) <-

513+ Case.toMatch branches

514+

515+ (revisedMatch, stmt) <-

516+ case expr of

517+ A.A _ (Var (Var.Canonical Var.Local x)) ->

518+ return (Case.matchSubst [(tempVar, Var.varName x)] initialMatch, [])

519+ _ ->

520+ do expr' <- toJsExpr expr

521+ return (initialMatch, [VarDeclStmt () [varDecl tempVar expr']])

522+

523+ match' <- match tcc revisedMatch

524+

525+ jsBlock (stmt ++ match')

526+

527+

280−match :: R.Region -> Case.Match -> State Int [Statement ()]

528+match :: TailCallContext -> Case.Match -> State Int [Statement ()]

281−match region mtch =

529+match tcc mtch =

282 case mtch of

530 case mtch of

283 Case.Match name clauses mtch' ->

531 Case.Match name clauses mtch' ->

284− do (isChars, clauses') <- unzip <$> mapM (clause region name) clauses

532+ do (isChars, clauses') <- unzip <$> mapM (clause tcc name) clauses

285− mtch'' <- match region mtch'

533+ mtch'' <- match tcc mtch'

286 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')

534 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')

287 where

535 where

288 isLiteral p =

536 isLiteral p =

289 case p of

537 case p of

290− Case.Clause (Right _) _ _ -> True

538+ Case.Clause (Right _) _ _ ->

539+ True

540+ _ ->

291− _ -> False

541+ False

292−

542+

293− access name

543+ access name =

294− | any isLiteral clauses = obj [name]

544+ if any isLiteral clauses then

545+ obj [name]

546+ else

295− | otherwise = obj (Help.splitDots name ++ ["ctor"])

547+ obj (Help.splitDots name ++ ["ctor"])

296−

548+

297− format isChars e

549+ format isChars expr =

550+ if or isChars then

298− | or isChars = InfixExpr () OpAdd e (string "")

551+ InfixExpr () OpAdd expr (string "")

299− | otherwise = e

552+ else

553+ expr

300

554

301 Case.Fail ->

555 Case.Fail ->

302− return [ ExprStmt () (Help.throw "badCase" region) ]

556+ return [ ExprStmt () (Crash.crash (Crash.IncompletePatternMatch (error "TODO"))) ]

303

557

304 Case.Break ->

558 Case.Break ->

305 return [BreakStmt () Nothing]

559 return [BreakStmt () Nothing]

306

560

307− Case.Other e ->

561+ Case.Other expr ->

308− do e' <- expression e

562+ toStatementList <$> exprToCode tcc expr

309− return [ ret e' ]

310

563

311 Case.Seq ms ->

564 Case.Seq ms ->

312− concat <$> mapM (match region) (dropEnd [] ms)

565+ concat <$> mapM (match tcc) (dropEnd [] ms)

313 where

566 where

314 dropEnd acc [] = acc

567 dropEnd acc [] = acc

315 dropEnd acc (m:ms) =

568 dropEnd acc (m:ms) =

@@ -318,9 +571,10 @@ match region mtch =

318 _ -> dropEnd (acc ++ [m]) ms

571 _ -> dropEnd (acc ++ [m]) ms

319

572

320

573

321−clause :: R.Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())

574+clause :: TailCallContext -> String -> Case.Clause -> State Int (Bool, CaseClause ())

322−clause region variable (Case.Clause value vars mtch) =

575+clause tcc variable (Case.Clause value vars mtch) =

323− (,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch)

576+ do statemens <- match tcc (Case.matchSubst (zip vars vars') mtch)

577+ return ((,) isChar (CaseClause () pattern statemens))

324 where

578 where

325 vars' =

579 vars' =

326 map (\n -> variable ++ "._" ++ show n) [0..]

580 map (\n -> variable ++ "._" ++ show n) [0..]

@@ -337,14 +591,14 @@ clause region variable (Case.Clause value vars mtch) =

337 string name

591 string name

338

592

339

593

340−flattenLets :: [Canonical.Def] -> Canonical.Expr -> ([Canonical.Def], Canonical.Expr)

594+flattenLets :: [Opt.Def] -> Opt.Expr -> ([Opt.Def], Opt.Expr)

341flattenLets defs lexpr@(A.A _ expr) =

595flattenLets defs lexpr@(A.A _ expr) =

342 case expr of

596 case expr of

343 Let ds body -> flattenLets (defs ++ ds) body

597 Let ds body -> flattenLets (defs ++ ds) body

344 _ -> (defs, lexpr)

598 _ -> (defs, lexpr)

345

599

346

600

347−generate :: Module.CanonicalModule -> String

601+generate :: Module.Optimized -> String

348generate modul =

602generate modul =

349 show . prettyPrint $ setup "Elm" (names ++ ["make"]) ++

603 show . prettyPrint $ setup "Elm" (names ++ ["make"]) ++

350 [ assign ("Elm" : names ++ ["make"]) (function [localRuntime] programStmts) ]

604 [ assign ("Elm" : names ++ ["make"]) (function [localRuntime] programStmts) ]

@@ -393,7 +647,7 @@ generate modul =

393 Module.program (Module.body modul)

647 Module.program (Module.body modul)

394 |> flattenLets []

648 |> flattenLets []

395 |> fst

649 |> fst

396− |> mapM definition

650+ |> mapM defToStatements

397

651

398 setup namespace path =

652 setup namespace path =

399 map create paths

653 map create paths

@@ -430,63 +684,104 @@ generate modul =

430 AssignExpr () OpAssign (LDot () (obj (init path)) (last path)) expr

684 AssignExpr () OpAssign (LDot () (obj (init path)) (last path)) expr

431

685

432

686

687+-- BINARY OPERATORS

688+

433binop

689binop

434− :: R.Region

435− -> Var.Canonical

690+ :: Var.Canonical

436− -> Canonical.Expr

691+ -> Opt.Expr

437− -> Canonical.Expr

692+ -> Opt.Expr

438− -> State Int (Expression ())

693+ -> State Int Code

439−binop region func@(Var.Canonical home op) e1 e2 =

694+binop func left right

440− case (home, op) of

441− (Var.Module ["Basics"], ">>") ->

442− do es <- mapM expression (collectLeftAssoc [e2] e1)

443− return $ ["$"] ==> List.foldl' (\e f -> f <| e) (ref "$") es

444−

445− (Var.Module ["Basics"], "<<") ->

446− do es <- mapM expression (e1 : collectRightAssoc [] e2)

447− return $ ["$"] ==> foldr (<|) (ref "$") es

448−

449− (Var.Module ["Basics"], "<|") ->

450− do e2' <- expression e2

451− es <- mapM expression (collectRightAssoc [] e1)

452− return $ foldr (<|) e2' es

453−

454− (Var.BuiltIn, "::") ->

695+ | func == Var.Canonical Var.BuiltIn "::" =

455− expression (A.A region (Data "::" [e1,e2]))

696+ toCode (A.A () (Data "::" [left,right]))

456−

457− (Var.Module ["Basics"], _) ->

458− do e1' <- expression e1

459− e2' <- expression e2

460− case Map.lookup op basicOps of

461− Just f ->

462− return (f e1' e2')

463−

464− Nothing ->

465− return (ref "A2" `call` [ Var.canonical func, e1', e2' ])

466

697

467− _ ->

698+ | func == forwardCompose =

468− do e1' <- expression e1

699+ compose (collectLeftAssoc forwardCompose left right)

469− e2' <- expression e2

470− return (ref "A2" `call` [ Var.canonical func, e1', e2' ])

471

700

472− where

701+ | func == backwardCompose =

473− collectRightAssoc es e =

702+ compose (collectRightAssoc backwardCompose left right)

474− case e of

703+

475− A.A _ (Binop (Var.Canonical (Var.Module ["Basics"]) "<<") e1 e2) ->

704+ | func == forwardApply =

476− collectRightAssoc (es ++ [e1]) e2

705+ pipe (collectLeftAssoc forwardApply left right)

477− _ -> es ++ [e]

706+

478−

707+ | func == backwardApply =

479− collectLeftAssoc es e =

708+ pipe (collectRightAssoc backwardApply left right)

480− case e of

709+

710+ | otherwise =

711+ do jsLeft <- toJsExpr left

712+ jsRight <- toJsExpr right

713+ jsExpr (makeExpr func jsLeft jsRight)

714+

715+

716+-- CONTROL FLOW OPERATOR HELPERS

717+

718+apply :: Expression () -> Expression () -> Expression ()

719+apply arg func =

720+ func <| arg

721+

722+

723+compose :: [Opt.Expr] -> State Int Code

724+compose functions =

725+ do jsFunctions <- mapM toJsExpr functions

726+ jsExpr $ ["$"] ==> List.foldl' apply (ref "$") jsFunctions

727+

728+

729+pipe :: [Opt.Expr] -> State Int Code

730+pipe expressions =

731+ do (value:functions) <- mapM toJsExpr expressions

732+ jsExpr $ List.foldl' apply value functions

733+

734+

735+forwardCompose :: Var.Canonical

736+forwardCompose =

737+ inBasics ">>"

738+

739+

740+backwardCompose :: Var.Canonical

741+backwardCompose =

742+ inBasics "<<"

743+

744+

745+forwardApply :: Var.Canonical

746+forwardApply =

747+ inBasics "|>"

748+

749+

750+backwardApply :: Var.Canonical

751+backwardApply =

752+ inBasics "<|"

753+

754+

755+inBasics :: String -> Var.Canonical

756+inBasics name =

757+ Var.Canonical (Var.Module ["Basics"]) name

758+

759+

760+-- BINARY OPERATOR HELPERS

761+

762+makeExpr :: Var.Canonical -> (Expression () -> Expression () -> Expression ())

763+makeExpr qualifiedOp@(Var.Canonical home op) =

764+ let

765+ simpleMake left right =

766+ ref "A2" `call` [ Var.canonical qualifiedOp, left, right ]

767+ in

481− A.A _ (Binop (Var.Canonical (Var.Module ["Basics"]) ">>") e1 e2) ->

768+ if home == Var.Module ["Basics"] then

482− collectLeftAssoc (e2 : es) e1

769+ Map.findWithDefault simpleMake op basicOps

483− _ -> e : es

770+ else

484−

771+ simpleMake

772+

773+

774+basicOps :: Map.Map String (Expression () -> Expression () -> Expression ())

485− basicOps =

775+basicOps =

486− Map.fromList (infixOps ++ specialOps)

776+ Map.fromList (infixOps ++ specialOps)

487−

777+

488− infixOps =

778+

779+infixOps :: [(String, Expression () -> Expression () -> Expression ())]

780+infixOps =

781+ let

782+ infixOp str op =

489− let infixOp str op = (str, InfixExpr () op) in

783+ (str, InfixExpr () op)

784+ in

490 [ infixOp "+" OpAdd

785 [ infixOp "+" OpAdd

491 , infixOp "-" OpSub

786 , infixOp "-" OpSub

492 , infixOp "*" OpMul

787 , infixOp "*" OpMul

@@ -495,17 +790,56 @@ binop region func@(Var.Canonical home op) e1 e2 =

495 , infixOp "||" OpLOr

790 , infixOp "||" OpLOr

496 ]

791 ]

497

792

498− specialOps =

499− [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]

500− , (,) "|>" $ flip (<|)

501− , (,) "==" $ \a b -> _Utils "eq" `call` [a,b]

502− , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (_Utils "eq" `call` [a,b])

503− , (,) "<" $ cmp OpLT 0

504− , (,) ">" $ cmp OpGT 0

505− , (,) "<=" $ cmp OpLT 1

506− , (,) ">=" $ cmp OpGT (-1)

507− , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)

508− ]

509

793

794+specialOps :: [(String, Expression () -> Expression () -> Expression ())]

795+specialOps =

796+ [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]

797+ , (,) "|>" $ flip (<|)

798+ , (,) "==" $ \a b -> _Utils "eq" `call` [a,b]

799+ , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (_Utils "eq" `call` [a,b])

800+ , (,) "<" $ cmp OpLT 0

801+ , (,) ">" $ cmp OpGT 0

802+ , (,) "<=" $ cmp OpLT 1

803+ , (,) ">=" $ cmp OpGT (-1)

804+ , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)

805+ ]

806+

807+

808+cmp :: InfixOp -> Int -> Expression () -> Expression () -> Expression ()

510− cmp op n a b =

809+cmp op n a b =

511− InfixExpr () op (_Utils "cmp" `call` [a,b]) (IntLit () n)

810+ InfixExpr () op (_Utils "cmp" `call` [a,b]) (IntLit () n)

811+

812+

813+-- BINARY OPERATOR COLLECTORS

814+

815+-- (h << g << f) becomes [f, g, h] which is the order you want for doing stuff

816+collectRightAssoc :: Var.Canonical -> Opt.Expr -> Opt.Expr -> [Opt.Expr]

817+collectRightAssoc desiredOp left right =

818+ collectRightAssocHelp desiredOp [left] right

819+

820+

821+collectRightAssocHelp :: Var.Canonical -> [Opt.Expr] -> Opt.Expr -> [Opt.Expr]

822+collectRightAssocHelp desiredOp exprList expr =

823+ case expr of

824+ A.A _ (Binop op left right) | op == desiredOp ->

825+ collectRightAssocHelp desiredOp (left : exprList) right

826+

827+ _ ->

828+ expr : exprList

829+

830+

831+-- (f >> g >> h) becomes [f, g, h] which is the order you want for doing stuff

832+collectLeftAssoc :: Var.Canonical -> Opt.Expr -> Opt.Expr -> [Opt.Expr]

833+collectLeftAssoc desiredOp left right =

834+ collectLeftAssocHelp desiredOp [right] left

835+

836+

837+collectLeftAssocHelp :: Var.Canonical -> [Opt.Expr] -> Opt.Expr -> [Opt.Expr]

838+collectLeftAssocHelp desiredOp exprList expr =

839+ case expr of

840+ A.A _ (Binop op left right) | op == desiredOp ->

841+ collectLeftAssocHelp desiredOp (right : exprList) left

842+

843+ _ ->

844+ expr : exprList

845+

src/Generate/JavaScript/Crash.hsnew file+32

@@ -0,0 +1,32 @@

1+module Generate.JavaScript.Crash where

3+import Language.ECMAScript3.Syntax (Expression)

5+import Generate.JavaScript.Helpers (call, obj, ref, string)

6+import qualified Reporting.Crash as Crash

7+import qualified Reporting.Region as R

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/Helpers.hs−19

@@ -2,8 +2,6 @@ module Generate.JavaScript.Helpers where

3import Language.ECMAScript3.Syntax

5−import qualified Reporting.Region as R

6−

8localRuntime :: String

6localRuntime :: String

9localRuntime =

7localRuntime =

@@ -52,23 +50,6 @@ obj vars =

52 [] -> error "dotSep must be called on a non-empty list of variables"

50 [] -> error "dotSep must be called on a non-empty list of variables"

55−-- Specific Utilities

56−

57−localModuleName :: String

58−localModuleName =

59− "$moduleName"

60−

61−

62−throw :: String -> R.Region -> Expression ()

63−throw kind region =

64− let args =

65− [ ref localModuleName

66− , string (R.toString region)

67− ]

68− in

69− obj ["_U",kind] `call` args

70−

71−

72-- Function Calls

53-- Function Calls

74(<|) :: Expression () -> Expression () -> Expression ()

55(<|) :: Expression () -> Expression () -> Expression ()

src/Nitpick/Pattern.hsnew file+71

@@ -0,0 +1,71 @@

1+module Nitpick.Pattern where

3+import qualified Data.List as List

4+import qualified Data.Set as Set

6+import qualified AST.Literal as L

7+import qualified AST.Pattern as P

8+import qualified AST.Variable as Var

9+import qualified Reporting.Annotation as A

10+

11+

12+data Pattern

13+ = Data Var.Canonical [Pattern]

14+ | Record [String]

15+ | Alias String Pattern

16+ | Var String

17+ | Anything

18+ | Literal L.Literal

19+ | AnythingBut (Set.Set L.Literal)

20+ deriving (Show, Eq)

21+

22+

23+fromCanonicalPattern :: P.CanonicalPattern -> Pattern

24+fromCanonicalPattern (A.A _ pattern) =

25+ case pattern of

26+ P.Data tag patterns ->

27+ Data tag (map fromCanonicalPattern patterns)

28+

29+ P.Record fields ->

30+ Record fields

31+

32+ P.Alias name pattern ->

33+ Alias name (fromCanonicalPattern pattern)

34+

35+ P.Var name ->

36+ Var name

37+

38+ P.Anything ->

39+ Anything

40+

41+ P.Literal literal ->

42+ Literal literal

43+

44+

45+-- TO STRING

46+

47+toString :: Pattern -> String

48+toString pattern =

49+ case pattern of

50+ Data tag args ->

51+ List.intercalate " " (Var.toString tag : map toString args)

52+

53+ Record fields ->

54+ "{ " ++ List.intercalate ", " fields ++ " }"

55+

56+ Alias alias realPattern ->

57+ toString realPattern ++ " as " ++ alias

58+

59+ Var name ->

60+ name

61+

62+ Anything ->

63+ "_"

64+

65+ Literal literal ->

66+ L.toString literal

67+

68+ AnythingBut literalSet ->

69+ List.intercalate " " ("<values besides:" : map L.toString (Set.toList literalSet))

70+

71+

src/Nitpick/PatternMatches.hsnew file+370

@@ -0,0 +1,370 @@

1+module Nitpick.PatternMatches (patternMatches) where

3+import Control.Applicative ((<$>), (<*))

4+import Control.Arrow (second)

5+import qualified Data.Foldable as F

6+import qualified Data.Map as Map

7+import qualified Data.Maybe as Maybe

8+import qualified Data.Set as Set

10+import qualified AST.Expression.General as E

11+import qualified AST.Expression.Canonical as Canonical

12+import qualified AST.Helpers as Help

13+import qualified AST.Module as Module

14+import qualified AST.Pattern as Pattern

15+import qualified AST.Variable as Var

16+import Elm.Utils ((|>))

17+import Nitpick.Pattern (Pattern(..), fromCanonicalPattern)

18+import qualified Reporting.Annotation as A

19+import qualified Reporting.Region as Region

20+import qualified Reporting.Result as Result

21+import qualified Reporting.Warning as Warning

22+

23+

24+patternMatches

25+ :: Module.Interfaces

26+ -> Module.CanonicalModule

27+ -> Result.Result Warning.Warning e ()

28+patternMatches interfaces modul =

29+ let

30+ name = Module.names modul

31+ body = Module.body modul

32+ in

33+ checkExpression

34+ (toTagDict interfaces name (Module.datatypes body))

35+ (Module.program body)

36+

37+

38+-- TAG DICT

39+

40+type TagDict =

41+ Map.Map Var.Home (Map.Map Tag [(Tag, Int)])

42+

43+

44+type Tag = String

45+

46+

47+toTagDict :: Module.Interfaces -> Module.Name -> Module.ADTs -> TagDict

48+toTagDict interfaces localName localAdts =

49+ let

50+ listTags =

51+ [ ("::", 2), ("[]", 0) ]

52+

53+ builtinDict =

54+ Map.singleton Var.BuiltIn $

55+ Map.fromList

56+ [ ("::", listTags)

57+ , ("[]", listTags)

58+ ]

59+

60+ interfaceDict =

61+ interfaces

62+ |> Map.map (toTagMapping . Module.iAdts)

63+ |> Map.mapKeysMonotonic Var.Module

64+ |> Map.insert (Var.Module localName) (toTagMapping localAdts)

65+ in

66+ Map.union builtinDict interfaceDict

67+

68+

69+toTagMapping :: Module.ADTs -> Map.Map Tag ([(Tag,Int)])

70+toTagMapping adts =

71+ let

72+ toTagAndArity (_tvars, tagInfoList) =

73+ let

74+ info = map (\(tag, args) -> (tag, length args)) tagInfoList

75+ in

76+ map (second (const info)) tagInfoList

77+ in

78+ Map.elems adts

79+ |> concatMap toTagAndArity

80+ |> Map.fromList

81+

82+

83+lookupOtherTags :: Var.Canonical -> TagDict -> [(Tag, Int)]

84+lookupOtherTags (Var.Canonical home name) tagDict =

85+ case Map.lookup name =<< Map.lookup home tagDict of

86+ Just otherTags ->

87+ otherTags

88+

89+ Nothing ->

90+ if Help.isTuple name then

91+ [(name, read (drop 6 name))]

92+ else

93+ error

94+ "Since the Nitpick phase happens after canonicalization and type \

95+ \inference, it is impossible that a pattern in a case cannot be \

96+ \found."

97+

98+

99+-- CHECK EXPRESSIONS

100+

101+checkExpression

102+ :: TagDict

103+ -> Canonical.Expr

104+ -> Result.Result Warning.Warning e ()

105+checkExpression tagDict (A.A region expression) =

106+ let

107+ go =

108+ checkExpression tagDict

109+

110+ go2 a b =

111+ go a <* go b

112+

113+ goPattern =

114+ checkPatterns tagDict region

115+ in

116+ case expression of

117+ E.Literal _ ->

118+ Result.ok ()

119+

120+ E.Var _ ->

121+ Result.ok ()

122+

123+ E.Range low high ->

124+ go2 low high

125+

126+ E.ExplicitList listExprs ->

127+ F.traverse_ go listExprs

128+

129+ E.Binop _ leftExpr rightExpr ->

130+ go2 leftExpr rightExpr

131+

132+ E.Lambda pattern body ->

133+ goPattern [pattern]

134+ <* go body

135+

136+ E.App func arg ->

137+ go2 func arg

138+

139+ E.MultiIf branches finally ->

140+ F.traverse_ (uncurry go2) branches

141+ <* go finally

142+

143+ E.Let defs body ->

144+ go body

145+ <* F.traverse_ goDef defs

146+ where

147+ goDef (Canonical.Definition pattern expr _) =

148+ goPattern [pattern]

149+ <* go expr

150+

151+ E.Case expr branches ->

152+ go expr

153+ <* goPattern (map fst branches)

154+ <* F.traverse_ (go . snd) branches

155+

156+ E.Data _ctor exprs ->

157+ F.traverse_ go exprs

158+

159+ E.Access record _field ->

160+ go record

161+

162+ E.Remove record _field ->

163+ go record

164+

165+ E.Insert record _field value ->

166+ go2 record value

167+

168+ E.Modify record fields ->

169+ go record

170+ <* F.traverse_ (go . snd) fields

171+

172+ E.Record fields ->

173+ F.traverse_ (go . snd) fields

174+

175+ E.Port impl ->

176+ case impl of

177+ E.In _ _ ->

178+ Result.ok ()

179+

180+ E.Out _ expr _ ->

181+ go expr

182+

183+ E.Task _ expr _ ->

184+ go expr

185+

186+ E.GLShader _ _ _ ->

187+ Result.ok ()

188+

189+ E.Crash _ ->

190+ Result.ok ()

191+

192+

193+-- CHECK PATTERNS

194+

195+checkPatterns

196+ :: TagDict

197+ -> Region.Region

198+ -> [Pattern.CanonicalPattern]

199+ -> Result.Result Warning.Warning e ()

200+checkPatterns tagDict region patterns =

201+ checkPatternsHelp tagDict region [Anything] patterns

202+

203+

204+checkPatternsHelp

205+ :: TagDict

206+ -> Region.Region

207+ -> [Pattern]

208+ -> [Pattern.CanonicalPattern]

209+ -> Result.Result Warning.Warning e ()

210+checkPatternsHelp tagDict region unhandled patterns =

211+ case (unhandled, patterns) of

212+ ([], []) ->

213+ return ()

214+

215+ (_:_, []) ->

216+ Result.warn region (Warning.InexhaustivePatternMatch unhandled)

217+

218+ (_, pattern@(A.A localRegion _) : remainingPatterns) ->

219+ do newUnhandled <- filterPatterns tagDict localRegion pattern unhandled

220+ checkPatternsHelp tagDict region newUnhandled remainingPatterns

221+

222+

223+filterPatterns

224+ :: TagDict

225+ -> Region.Region

226+ -> Pattern.CanonicalPattern

227+ -> [Pattern]

228+ -> Result.Result Warning.Warning e [Pattern]

229+filterPatterns tagDict region pattern unhandled =

230+ let

231+ nitPattern =

232+ fromCanonicalPattern pattern

233+

234+ noIntersection pat =

235+ intersection pat nitPattern == Nothing

236+ in

237+ if all noIntersection unhandled then

238+ do Result.warn region Warning.RedundantPatternMatch

239+ return unhandled

240+ else

241+ do let complementPatterns = complement tagDict nitPattern

242+ return $

243+ concatMap

244+ (\p -> Maybe.mapMaybe (intersection p) complementPatterns)

245+ unhandled

246+

247+

248+-- PATTERN INTERSECTION

249+

250+intersection :: Pattern -> Pattern -> Maybe Pattern

251+intersection pattern1 pattern2 =

252+ case (pattern1, pattern2) of

253+ (Alias _ pattern1', _) ->

254+ intersection pattern1' pattern2

255+

256+ (_, Alias _ pattern2') ->

257+ intersection pattern1 pattern2'

258+

259+ (Anything, _) ->

260+ Just pattern2

261+

262+ (Var _, _) ->

263+ Just pattern2

264+

265+ (_, Anything) ->

266+ Just pattern1

267+

268+ (_, Var _) ->

269+ Just pattern1

270+

271+ (Data ctor1 args1, Data ctor2 args2) ->

272+ if ctor1 /= ctor2 then

273+ Nothing

274+ else

275+ Data ctor1 <$> sequence (zipWith intersection args1 args2)

276+

277+ (Record _, Record _) ->

278+ Just pattern1

279+

280+ (Literal lit1, Literal lit2) ->

281+ if lit1 == lit2 then

282+ Just pattern1

283+ else

284+ Nothing

285+

286+ (AnythingBut literals, Literal lit) ->

287+ if Set.member lit literals then

288+ Nothing

289+ else

290+ Just pattern2

291+

292+ (Literal lit, AnythingBut literals) ->

293+ if Set.member lit literals then

294+ Nothing

295+ else

296+ Just pattern1

297+

298+ (AnythingBut literals1, AnythingBut literals2) ->

299+ Just (AnythingBut (Set.union literals1 literals2))

300+

301+ _ ->

302+ Nothing

303+

304+

305+-- PATTERN COMPLEMENT

306+

307+complement :: TagDict -> Pattern -> [Pattern]

308+complement tagDict nitPattern =

309+ case nitPattern of

310+ Record _fields ->

311+ []

312+

313+ Alias _name pattern ->

314+ complement tagDict pattern

315+

316+ Var _name ->

317+ []

318+

319+ Anything ->

320+ []

321+

322+ Literal lit ->

323+ [AnythingBut (Set.singleton lit)]

324+

325+ AnythingBut literals ->

326+ map Literal (Set.toList literals)

327+

328+ Data ctor patterns ->

329+ complementData tagDict ctor patterns

330+

331+

332+complementData :: TagDict -> Var.Canonical -> [Pattern] -> [Pattern]

333+complementData tagDict tag patterns =

334+ let

335+ otherTags =

336+ lookupOtherTags tag tagDict

337+

338+ tagComplements =

339+ Maybe.mapMaybe (tagToPattern tag) otherTags

340+

341+ arity =

342+ length patterns

343+

344+ argComplements =

345+ concat (zipWith (makeArgComplements tagDict tag arity) [0..] patterns)

346+ in

347+ tagComplements ++ argComplements

348+

349+

350+tagToPattern :: Var.Canonical -> (Tag, Int) -> Maybe Pattern

351+tagToPattern (Var.Canonical home rootTag) (tag, arity) =

352+ if rootTag == tag then

353+ Nothing

354+ else

355+ Just (Data (Var.Canonical home tag) (replicate arity Anything))

356+

357+

358+makeArgComplements :: TagDict -> Var.Canonical -> Int -> Int -> Pattern -> [Pattern]

359+makeArgComplements tagDict tag arity index argPattern =

360+ let

361+ complementList =

362+ complement tagDict argPattern

363+

364+ padArgs pattern =

365+ replicate index Anything

366+ ++ pattern

367+ : replicate (arity - index - 1) Anything

368+ in

369+ map (Data tag . padArgs) complementList

370+

src/Optimize.hsnew file+19

@@ -0,0 +1,19 @@

1+module Optimize where

3+import qualified AST.Module as M

4+import qualified Optimize.TailCalls as TC

7+optimize :: M.CanonicalModule -> M.Optimized

8+optimize modul =

9+ let

10+ canonicalBody =

11+ M.body modul

12+

13+ optimizedProgram =

14+ TC.optimize (M.program canonicalBody)

15+

16+ optimizedBody =

17+ canonicalBody { M.program = optimizedProgram }

18+ in

19+ modul { M.body = optimizedBody }

src/Generate/Cases.hs → src/Optimize/Cases.hsrenamed+14−10

@@ -1,4 +1,4 @@

1−module Generate.Cases (toMatch, Match (..), Clause (..), matchSubst, newVar) where

1+module Optimize.Cases (toMatch, Match (..), Clause (..), matchSubst, newVar) where

3import Control.Applicative ((<$>))

4import Control.Arrow (first)

@@ -8,11 +8,11 @@ import qualified Data.List as List

8import Data.Maybe (fromMaybe)

10import qualified AST.Expression.General as Expr

11−import qualified AST.Expression.Canonical as Canonical

11+import qualified AST.Expression.Optimized as Optimized

12import qualified AST.Literal as Literal

13import qualified AST.Pattern as P

14import qualified AST.Variable as Var

15−import qualified Generate.Substitute as S

15+import qualified Optimize.Substitute as S

16import qualified Reporting.Annotation as A

@@ -22,23 +22,23 @@ data Match

22 = Match String [Clause] Match

23 | Break

24 | Fail

25− | Other Canonical.Expr

25+ | Other Optimized.Expr

26 | Seq [Match]

27− deriving Show

27+ deriving (Show)

30data Clause =

31 Clause (Either Var.Canonical Literal.Literal) [String] Match

32− deriving Show

32+ deriving (Show)

35type Branch =

36− ([P.CanonicalPattern], Canonical.Expr)

36+ ([P.Optimized], Optimized.Expr)

39-- PUBLIC FUNCTIONS

41−toMatch :: [(P.CanonicalPattern, Canonical.Expr)] -> State Int (String, Match)

41+toMatch :: [(P.Optimized, Optimized.Expr)] -> State Int (String, Match)

42toMatch patterns =

43 do v <- newVar

44 (,) v <$> buildMatch [v] (map (first (:[])) patterns) Fail

@@ -61,8 +61,12 @@ matchSubst pairs match =

61 Seq ms ->

62 Seq (map (matchSubst pairs) ms)

64− Other (A.A a e) ->

64+ Other (A.A ann expr) ->

65+ let

66+ substitutions =

65− Other . A.A a $ foldr ($) e $ map (\(x,y) -> S.subst x (Expr.localVar y)) pairs

67+ map (\(x,y) -> S.subst x (Expr.localVar y)) pairs

68+ in

69+ Other $ A.A ann $ foldr ($) expr substitutions

67 Match n cs m ->

71 Match n cs m ->

68 Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)

72 Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)

src/Generate/Substitute.hs → src/Optimize/Substitute.hsrenamed+17−14

@@ -1,50 +1,50 @@

1{-# OPTIONS_GHC -Wall #-}

2−module Generate.Substitute (subst) where

2+module Optimize.Substitute (subst) where

4import Control.Arrow (second, (***))

6import AST.Expression.General (Expr'(..), PortImpl(..))

7−import qualified AST.Expression.Canonical as Canonical

7+import qualified AST.Expression.Optimized as Optimized

8import qualified AST.Pattern as Pattern

9import qualified AST.Variable as V

10import Elm.Utils ((|>))

11import qualified Reporting.Annotation as A

14−subst :: String -> Canonical.Expr' -> Canonical.Expr' -> Canonical.Expr'

14+subst :: String -> Optimized.Expr' -> Optimized.Expr' -> Optimized.Expr'

15subst old new expression =

16 let f (A.A a e) = A.A a (subst old new e) in

17 case expression of

18− Range e1 e2 ->

18+ Range lo hi ->

19− Range (f e1) (f e2)

19+ Range (f lo) (f hi)

21 ExplicitList exprs ->

22 ExplicitList (map f exprs)

24− Binop op e1 e2 ->

24+ Binop op left right ->

25− Binop op (f e1) (f e2)

25+ Binop op (f left) (f right)

27 Lambda pattern body ->

28 if Pattern.member old pattern

29 then expression

30 else Lambda pattern (f body)

32− App e1 e2 ->

32+ App func arg ->

33− App (f e1) (f e2)

33+ App (f func) (f arg)

35− MultiIf branches ->

35+ MultiIf branches finally ->

36− MultiIf (map (f *** f) branches)

36+ MultiIf (map (f *** f) branches) (f finally)

38 Let defs body ->

39 if anyShadow

40 then expression

41 else Let (map substDef defs) (f body)

42 where

43− substDef (Canonical.Definition p e t) =

43+ substDef (Optimized.Definition facts pattern expr) =

44− Canonical.Definition p (f e) t

44+ Optimized.Definition facts pattern (f expr)

46 anyShadow =

47− map (\(Canonical.Definition p _ _) -> p) defs

47+ map (\(Optimized.Definition _ p _) -> p) defs

48 |> any (Pattern.member old)

50 Var (V.Canonical home x) ->

@@ -101,3 +101,6 @@ subst old new expression =

101

102 Task name expr tipe ->

103 Task name (f expr) tipe

104+

105+ Crash _ ->

106+ expression

src/Optimize/TailCalls.hsnew file+239

@@ -0,0 +1,239 @@

1+module Optimize.TailCalls where

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

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 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+ in

75+ Opt.Definition

76+ (Opt.Facts (if isTailCall then fmap fst context else Nothing))

77+ (removeAnnotations pattern)

78+ (foldr lambda optExpr (map removeAnnotations args))

79+

80+

81+-- CONVERT EXPRESSIONS

82+

83+type Context = Maybe (String, Int)

84+

85+

86+findTailCalls :: Context -> Can.Expr -> Result Opt.Expr

87+findTailCalls context annExpr@(A.A _ expression) =

88+ let

89+ keepLooking =

90+ findTailCalls context

91+ -- this *might* find a tail call, use this when something is a potential

92+ -- tail call

93+

94+ justConvert =

95+ findTailCalls Nothing

96+ -- this will never find tail calls, use this when you are working with

97+ -- expressions that cannot be turned into tail calls

98+ in

99+ A.A () <$>

100+ case expression of

101+ Literal lit ->

102+ pure (Literal lit)

103+

104+ Var name ->

105+ pure (Var name)

106+

107+ Range lowExpr highExpr ->

108+ Range

109+ <$> justConvert lowExpr

110+ <*> justConvert highExpr

111+

112+ ExplicitList elements ->

113+ ExplicitList

114+ <$> T.traverse justConvert elements

115+

116+ Binop op leftExpr rightExpr ->

117+ Binop op

118+ <$> justConvert leftExpr

119+ <*> justConvert rightExpr

120+

121+ Lambda pattern body ->

122+ Lambda (removeAnnotations pattern) <$> justConvert body

123+

124+ App _ _ ->

125+ let

126+ (func:args) =

127+ Expr.collectApps annExpr

128+

129+ isTailCall =

130+ case (context, func) of

131+ ( Just (name, argNum), A.A _ (Var (Var.Canonical Var.Local name')) ) ->

132+ name == name' && length args == argNum

133+ _ ->

134+ False

135+

136+ (Result _ (A.A _ optFunc)) =

137+ justConvert func

138+

139+ (Result _ optArgs) =

140+ T.traverse justConvert args

141+

142+ apply f arg =

143+ App (A.A () f) arg

144+ in

145+ Result isTailCall (List.foldl' apply optFunc optArgs)

146+

147+

148+ MultiIf branches finally ->

149+ let

150+ crawlBranch (cond,branch) =

151+ (,) <$> justConvert cond <*> keepLooking branch

152+ in

153+ MultiIf

154+ <$> T.traverse crawlBranch branches

155+ <*> keepLooking finally

156+

157+ Let defs body ->

158+ let

159+ optDefs = map detectTailRecursion defs

160+ in

161+ Let optDefs <$> keepLooking body

162+

163+ Case expr cases ->

164+ let

165+ preppedCases =

166+ map (first removeAnnotations) cases

167+ in

168+ Case

169+ <$> justConvert expr

170+ <*> T.traverse (mapSnd keepLooking) preppedCases

171+

172+ Data name exprs ->

173+ Data name <$> T.traverse justConvert exprs

174+

175+ Access record field ->

176+ Access

177+ <$> justConvert record

178+ <*> pure field

179+

180+ Remove record field ->

181+ Remove

182+ <$> justConvert record

183+ <*> pure field

184+

185+ Insert record field expr ->

186+ Insert

187+ <$> justConvert record

188+ <*> pure field

189+ <*> justConvert expr

190+

191+ Modify record fields ->

192+ Modify

193+ <$> justConvert record

194+ <*> T.traverse (mapSnd justConvert) fields

195+

196+ Record fields ->

197+ Record

198+ <$> T.traverse (mapSnd justConvert) fields

199+

200+ GLShader uid src gltipe ->

201+ pure (GLShader uid src gltipe)

202+

203+ Port impl ->

204+ Port <$>

205+ case impl of

206+ In name tipe ->

207+ pure (In name tipe)

208+

209+ Out name expr tipe ->

210+ (\e -> Out name e tipe) <$> justConvert expr

211+

212+ Task name expr tipe ->

213+ (\e -> Task name e tipe) <$> justConvert expr

214+

215+ Crash details ->

216+ pure (Crash details)

217+

218+

219+removeAnnotations :: P.CanonicalPattern -> P.Optimized

220+removeAnnotations (A.A _ pattern) =

221+ A.A () $

222+ case pattern of

223+ P.Var x ->

224+ P.Var x

225+

226+ P.Literal lit ->

227+ P.Literal lit

228+

229+ P.Record fields ->

230+ P.Record fields

231+

232+ P.Anything ->

233+ P.Anything

234+

235+ P.Alias alias realPattern ->

236+ P.Alias alias (removeAnnotations realPattern)

237+

238+ P.Data name patterns ->

239+ P.Data name (map removeAnnotations patterns)

src/Parse/Expression.hs+27−18

@@ -18,6 +18,8 @@ import qualified AST.Literal as L

18import qualified AST.Pattern as P

19import qualified AST.Variable as Var

20import qualified Reporting.Annotation as A

21+import qualified Reporting.Crash as Crash

22+import qualified Reporting.Region as R

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

25-------- Basic Terms --------

@@ -220,7 +222,8 @@ appExpr =

220

222

221expr :: IParser Source.Expr

223expr :: IParser Source.Expr

222expr =

224expr =

223− addLocation (choice [ ifExpr, letExpr, caseExpr ])

225+ addLocation (choice [ letExpr, caseExpr ])

226+ <|> ifExpr

224 <|> lambdaExpr

227 <|> lambdaExpr

225 <|> binaryExpr

228 <|> binaryExpr

226 <?> "an expression"

229 <?> "an expression"

@@ -231,39 +234,45 @@ binaryExpr =

231 Binop.binops appExpr lastExpr anyOp

234 Binop.binops appExpr lastExpr anyOp

232 where

235 where

233 lastExpr =

236 lastExpr =

234− addLocation (choice [ ifExpr, letExpr, caseExpr ])

237+ addLocation (choice [ letExpr, caseExpr ])

238+ <|> ifExpr

235 <|> lambdaExpr

239 <|> lambdaExpr

236 <?> "an expression"

240 <?> "an expression"

237

241

238

242

239−ifExpr :: IParser Source.Expr'

243+ifExpr :: IParser Source.Expr

240ifExpr =

244ifExpr =

245+ do start <- getMyPosition

241− do try (reserved "if")

246+ try (reserved "if")

242 whitespace

247 whitespace

243− normal <|> multiIf

248+ makeExpr <- normal <|> multiIf

249+ end <- getMyPosition

250+ return (makeExpr (R.Region start end))

244 where

251 where

245 normal =

252 normal =

246− do bool <- expr

253+ do condition <- expr

247 padded (reserved "then")

254 padded (reserved "then")

248 thenBranch <- expr

255 thenBranch <- expr

249 whitespace <?> "an 'else' branch"

256 whitespace <?> "an 'else' branch"

250 reserved "else" <?> "an 'else' branch"

257 reserved "else" <?> "an 'else' branch"

251 whitespace

258 whitespace

252 elseBranch <- expr

259 elseBranch <- expr

253− return $ E.MultiIf

260+ return $ \region -> A.A region (E.MultiIf [(condition, thenBranch)] elseBranch)

254− [ (bool, thenBranch)

255− , (A.sameAs elseBranch (E.Literal . L.Boolean $ True), elseBranch)

256− ]

257

261

258 multiIf =

262 multiIf =

259− E.MultiIf <$> spaceSep1 iff

263+ do branches <- spaceSep1 multiBranch

260− where

264+ return $ \region -> A.A region (E.MultiIf branches (crash region))

261− iff =

265+

266+ crash region =

267+ A.A region (E.Crash (Crash.IncompleteMultiIf region))

268+

269+ multiBranch =

262− do string "|"

270+ do string "|"

263− whitespace

271+ whitespace

264− b <- expr

272+ condition <- expr

265− padded rightArrow

273+ padded rightArrow

266− (,) b <$> expr

274+ branch <- expr

275+ return (condition, branch)

267

276

268

277

269lambdaExpr :: IParser Source.Expr

278lambdaExpr :: IParser Source.Expr

src/Reporting/Crash.hsnew file+20

@@ -0,0 +1,20 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Reporting.Crash where

4+import qualified Reporting.Region as R

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/Reporting/Error/Type.hs+7

@@ -37,6 +37,7 @@ data InfiniteType = InfiniteTypeInfo

37data Hint

38 = CaseBranch Int Region.Region

39 | Case

40+ | IfCondition

40 | IfBranches

41 | IfBranches

41 | MultiIfBranch Int Region.Region

42 | MultiIfBranch Int Region.Region

42 | If

43 | If

@@ -128,6 +129,12 @@ hintToString hint =

128 , Nothing

129 , Nothing

129 )

130 )

130

131

132+ IfCondition ->

133+ ( Nothing

134+ , "This condition does not evaluate to a boolean value, True or False."

135+ , Just "Elm does not have \"truthiness\" such that ints and strings and lists are\nautomatically converted to booleans. Do that conversion explicitly."

136+ )

137+

131 IfBranches ->

138 IfBranches ->

132 ( Nothing

139 ( Nothing

133 , "The branches of this `if` result in different types of values."

140 , "The branches of this `if` result in different types of values."

src/Reporting/Warning.hs+42

@@ -9,6 +9,7 @@ import Text.PrettyPrint ((<+>))

10import qualified AST.Module as Module

11import qualified AST.Type as Type

12+import qualified Nitpick.Pattern as Pattern

12import qualified Reporting.Annotation as A

13import qualified Reporting.Annotation as A

13import qualified Reporting.PrettyPrint as P

14import qualified Reporting.PrettyPrint as P

14import qualified Reporting.Report as Report

15import qualified Reporting.Report as Report

@@ -19,6 +20,8 @@ import qualified Reporting.Report as Report

19data Warning

20data Warning

20 = UnusedImport Module.Name

21 = UnusedImport Module.Name

21 | MissingTypeAnnotation String Type.Canonical

22 | MissingTypeAnnotation String Type.Canonical

23+ | InexhaustivePatternMatch [Pattern.Pattern]

24+ | RedundantPatternMatch

24-- TO STRING

27-- TO STRING

@@ -56,6 +59,32 @@ toReport dealiaser warning =

56 4

59 4

57 (P.pretty dealiaser False inferredType)

60 (P.pretty dealiaser False inferredType)

62+ InexhaustivePatternMatch unhandled ->

63+ Report.simple

64+ "missing pattern"

65+ "The following case expression does not handle all possible inputs."

66+ ( "The following patterns are not being handled:\n"

67+ ++ viewPatternList unhandled

68+ ++ "\n\n"

69+ ++ "If we get values like this, we have no choice but to crash! Normally this means\n"

70+ ++ "you just added a new tag to a union type, but sometimes it can be because there\n"

71+ ++ "is something very odd about the data you are modeling. In those rare cases, you\n"

72+ ++ "probably want to either:\n"

73+ ++ "\n"

74+ ++ " 1. Rethink the model. Maybe some cases are \"impossible\" but it is still\n"

75+ ++ " possible to construct such cases. Is there a way to model the values more\n"

76+ ++ " precisely such that \"impossible\" values truly are impossible?\n"

77+ ++ " 2. End the pattern match with a wildcard match that leads to an expression\n"

78+ ++ " like: Debug.crash \"If you are reading this, I have made a mistake!\"\n"

79+ ++ " Generally speaking, you do not want it to have to be this way."

80+ )

81+

82+ RedundantPatternMatch ->

83+ Report.simple

84+ "redundant pattern"

85+ "The following pattern is redundant."

86+ "Any value with this shape will be handled by a previous pattern."

87+

60-- TO JSON

89-- TO JSON

@@ -71,3 +100,16 @@ toJson dealiaser filePath (A.A region warning) =

71 , "type" .= ("warning" :: String)

100 , "type" .= ("warning" :: String)

72 ]

101 ]

73 ++ additionalFields

102 ++ additionalFields

103+

104+

105+-- PATTERN WARNINGS

106+

107+viewPatternList :: [Pattern.Pattern] -> String

108+viewPatternList unhandledPatterns =

109+ let

110+ (showPatterns, rest) =

111+ splitAt 4 unhandledPatterns

112+ in

113+ concatMap ((++) "\n ") $

114+ map Pattern.toString showPatterns

115+ ++ if null rest then [] else ["..."]

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

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

2module Type.Constrain.Expression where

4import Control.Applicative ((<$>))

5+import Control.Arrow (second)

5import qualified Control.Monad as Monad

6import qualified Control.Monad as Monad

6import qualified Data.List as List

7import qualified Data.List as List

7import qualified Data.Map as Map

8import qualified Data.Map as Map

@@ -97,8 +98,8 @@ constrain env annotatedExpr@(A.A region expression) tipe =

97 in

98 in

98 constrainApp env region f args tipe

99 constrainApp env region f args tipe

100

100− E.MultiIf branches ->

101+ E.MultiIf branches finally ->

101− constrainIf env region branches tipe

102+ constrainIf env region branches finally tipe

102

103

103 E.Case expr branches ->

104 E.Case expr branches ->

104 constrainCase env region expr branches tipe

105 constrainCase env region expr branches tipe

@@ -184,6 +185,9 @@ constrain env annotatedExpr@(A.A region expression) tipe =

184 E.Task _ expr _ ->

185 E.Task _ expr _ ->

185 constrain env expr tipe

186 constrain env expr tipe

186

187

188+ E.Crash _ ->

189+ return CTrue

190+

187

191

188-- CONSTRAIN APP

192-- CONSTRAIN APP

189

193

@@ -333,25 +337,38 @@ constrainIf

333 :: Env.Environment

337 :: Env.Environment

334 -> R.Region

338 -> R.Region

335 -> [(Canonical.Expr, Canonical.Expr)]

339 -> [(Canonical.Expr, Canonical.Expr)]

340+ -> Canonical.Expr

336 -> Type

341 -> Type

337 -> IO TypeConstraint

342 -> IO TypeConstraint

338−constrainIf env region branches tipe =

343+constrainIf env region branches finally tipe =

344+ do let (conditions, branchExprs) =

345+ second (++ [finally]) (unzip branches)

346+

347+ (condVars, condCons) <-

348+ unzip <$> mapM constrainCondition conditions

349+

339− do (branchInfo, branchExprCons) <-

350+ (branchInfo, branchExprCons) <-

340− unzip <$> mapM constrainBranch branches

351+ unzip <$> mapM constrainBranch branchExprs

341

352

342 (vars,cons) <- branchCons branchInfo

353 (vars,cons) <- branchCons branchInfo

343

354

344− return $ ex vars (CAnd (branchExprCons ++ cons))

355+ return $ ex (condVars ++ vars) (CAnd (condCons ++ branchExprCons ++ cons))

345 where

356 where

357+ bool =

346− bool = Env.get env Env.types "Bool"

358+ Env.get env Env.types "Bool"

359+

360+ constrainCondition condition@(A.A condRegion _) =

361+ do condVar <- variable Flexible

362+ condCon <- constrain env condition (varN condVar)

363+ let boolCon = CEqual Error.IfCondition condRegion (varN condVar) bool

364+ return (condVar, CAnd [ condCon, boolCon ])

347

365

348− constrainBranch (cond, expr@(A.A branchRegion _)) =

366+ constrainBranch expr@(A.A branchRegion _) =

349 do branchVar <- variable Flexible

367 do branchVar <- variable Flexible

350− condCon <- constrain env cond bool

351 exprCon <- constrain env expr (varN branchVar)

368 exprCon <- constrain env expr (varN branchVar)

352 return

369 return

353 ( (branchVar, branchRegion)

370 ( (branchVar, branchRegion)

354− , condCon /\ exprCon

371+ , exprCon

355 )

372 )

356

373

357 branchCons branchInfo =

374 branchCons branchInfo =

@@ -368,7 +385,7 @@ constrainIf env region branches tipe =

368 pairCons region Error.MultiIfBranch varToCon branchInfo

385 pairCons region Error.MultiIfBranch varToCon branchInfo

369

386

370 varToCon var =

387 varToCon var =

371− CEqual Error.If region tipe (varN var)

388+ CEqual Error.If region (varN var) tipe

372

389

373

390

374-- CONSTRAIN CASE EXPRESSIONS

391-- CONSTRAIN CASE EXPRESSIONS

src/Validate.hs+7−2

@@ -213,8 +213,10 @@ expression (A.A ann sourceExpression) =

213 <$> expression funcExpr

214 <*> expression argExpr

215

216− MultiIf branches ->

216+ MultiIf branches finally ->

217+ MultiIf

217− MultiIf <$> T.traverse both branches

218+ <$> T.traverse both branches

219+ <*> expression finally

218

220

219 Access record field ->

221 Access record field ->

220 Access

222 Access

@@ -263,6 +265,9 @@ expression (A.A ann sourceExpression) =

263 do expr' <- expression expr

265 do expr' <- expression expr

264 return (Task name expr' tipe)

266 return (Task name expr' tipe)

265

267

268+ Crash details ->

269+ return (Crash details)

270+

266

271

267second :: (a, Source.Expr) -> Result.Result wrn Error.Error (a, Valid.Expr)

272second :: (a, Source.Expr) -> Result.Result wrn Error.Error (a, Valid.Expr)

268second (value, expr) =

273second (value, expr) =