896c502 · elk · git.iko.soy

src/AST/Declaration.hs+10−6

compare with master

unifiedsplit

@@ -13,11 +13,12 @@ import Text.PrettyPrint as P

13

14-- DECLARATIONS

15

16−data Declaration' portType def var

16+data Declaration' portType def var expr

17 = Definition def

18 | Datatype String [String] [(String, [T.Type var])]

19 | TypeAlias String [String] (T.Type var)

20 | Port String portType

21+ | Perform Int expr

21 | Fixity Assoc Int String

22 | Fixity Assoc Int String

22

23

24

@@ -28,15 +29,15 @@ data Assoc = L | N | R

28-- DECLARATION PHASES

29-- DECLARATION PHASES

29

30

30type SourceDecl =

31type SourceDecl =

31− Declaration' T.RawType Source.Def Var.Raw

32+ Declaration' T.RawType Source.Def Var.Raw Source.Expr

32

33

34

34type ValidDecl =

35type ValidDecl =

35− Declaration' T.RawType Valid.Def Var.Raw

36+ Declaration' T.RawType Valid.Def Var.Raw Valid.Expr

36

37

38

38type CanonicalDecl =

39type CanonicalDecl =

39− Declaration' (T.PortType Var.Canonical) Canonical.Def Var.Canonical

40+ Declaration' (T.PortType Var.Canonical) Canonical.Def Var.Canonical Canonical.Expr

40

41

42

42-- BINARY CONVERSION

43-- BINARY CONVERSION

@@ -68,8 +69,8 @@ assocToString assoc =

68 R -> "right"

69 R -> "right"

69

70

71

71−instance (Pretty portType, Pretty def, Pretty var, Var.ToString var) =>

72+instance (Pretty portType, Pretty def, Pretty var, Var.ToString var, Pretty expr) =>

72− Pretty (Declaration' portType def var) where

73+ Pretty (Declaration' portType def var expr) where

73 pretty decl =

74 pretty decl =

74 case decl of

75 case decl of

75 Definition def -> pretty def

76 Definition def -> pretty def

@@ -98,6 +99,9 @@ instance (Pretty portType, Pretty def, Pretty var, Var.ToString var) =>

98 Port name tipe ->

99 Port name tipe ->

99 P.text "port" <+> P.text name <+> P.colon <+> pretty tipe

100 P.text "port" <+> P.text name <+> P.colon <+> pretty tipe

100

101

102+ Perform _ expr ->

103+ P.text "perform" <+> pretty expr

104+

101 Fixity assoc prec op ->

105 Fixity assoc prec op ->

102 P.text "infix" <> assoc' <+> P.int prec <+> P.text op

106 P.text "infix" <> assoc' <+> P.int prec <+> P.text op

103 where

107 where

src/AST/Expression/General.hs+47−42

@@ -10,7 +10,7 @@ module AST.Expression.General where

10

11import AST.PrettyPrint

12import Text.PrettyPrint as P

13−import AST.Type (Type, PortType)

13+import AST.Type (PortType)

14

15import qualified AST.Annotation as Annotation

16import qualified AST.Helpers as Help

@@ -59,6 +59,7 @@ data Expr' ann def var

59 | Record [(String, Expr ann def var)]

60 -- for type checking and code gen only

61 | Port String (PortType var)

62+ | Perform (Expr ann def var)

62 | GLShader String String Literal.GLShaderTipe

63 | GLShader String String Literal.GLShaderTipe

63 deriving (Show)

64 deriving (Show)

64

65

@@ -91,58 +92,59 @@ dummyLet defs =

91

92

93

93instance (Pretty def, Pretty var, Var.ToString var) => Pretty (Expr' ann def var) where

94instance (Pretty def, Pretty var, Var.ToString var) => Pretty (Expr' ann def var) where

94− pretty expr =

95+ pretty expression =

95− case expr of

96+ case expression of

96− Literal lit ->

97+ Literal literal ->

97− pretty lit

98+ pretty literal

98

99

99 Var x ->

100 Var x ->

100 pretty x

101 pretty x

101

102

102− Range e1 e2 ->

103+ Range lowExpr highExpr ->

103− P.brackets (pretty e1 <> P.text ".." <> pretty e2)

104+ P.brackets (pretty lowExpr <> P.text ".." <> pretty highExpr)

104

105

105− ExplicitList es ->

106+ ExplicitList elements ->

106− P.brackets (commaCat (map pretty es))

107+ P.brackets (commaCat (map pretty elements))

107

108

108− Binop op (Annotation.A _ (Literal (Literal.IntNum 0))) e

109+ Binop op (Annotation.A _ (Literal (Literal.IntNum 0))) expr

109 | Var.toString op == "-" ->

110 | Var.toString op == "-" ->

110− P.text "-" <> prettyParens e

111+ P.text "-" <> prettyParens expr

111

112

112− Binop op e1 e2 ->

113+ Binop op leftExpr rightExpr ->

113− P.hang (prettyParens e1) 2 (P.text op'' <+> prettyParens e2)

114+ P.hang (prettyParens leftExpr) 2 (P.text op'' <+> prettyParens rightExpr)

114 where

115 where

115 op' = Var.toString op

116 op' = Var.toString op

116 op'' = if Help.isOp op' then op' else "`" ++ op' ++ "`"

117 op'' = if Help.isOp op' then op' else "`" ++ op' ++ "`"

117

118

118− Lambda p e ->

119+ Lambda pattern expr ->

119 P.text "\\" <> args <+> P.text "->" <+> pretty body

120 P.text "\\" <> args <+> P.text "->" <+> pretty body

120 where

121 where

121− (ps,body) = collectLambdas (Annotation.A undefined $ Lambda p e)

122+ (patterns, body) = collectLambdas expr

122− args = P.sep (map Pattern.prettyParens ps)

123+ args = P.sep (map Pattern.prettyParens (pattern : patterns))

123

124

124− App _ _ ->

125+ App expr arg ->

125 P.hang func 2 (P.sep args)

126 P.hang func 2 (P.sep args)

126 where

127 where

127 func:args =

128 func:args =

128− map prettyParens (collectApps (Annotation.A undefined expr))

129+ map prettyParens (collectApps expr ++ [arg])

129

130

130 MultiIf branches ->

131 MultiIf branches ->

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

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

132 where

133 where

133 iff (b,e) = P.text "|" <+> P.hang (pretty b <+> P.text "->") 2 (pretty e)

134 iff (b,e) = P.text "|" <+> P.hang (pretty b <+> P.text "->") 2 (pretty e)

134

135

135− Let defs e ->

136+ Let defs body ->

136 P.sep

137 P.sep

137 [ P.hang (P.text "let") 4 (P.vcat (map pretty defs))

138 [ P.hang (P.text "let") 4 (P.vcat (map pretty defs))

138− , P.text "in" <+> pretty e

139+ , P.text "in" <+> pretty body

139 ]

140 ]

140

141

141− Case e pats ->

142+ Case expr branches ->

142− P.hang pexpr 2 (P.vcat (map pretty' pats))

143+ P.hang pexpr 2 (P.vcat (map pretty' branches))

143 where

144 where

144− pexpr = P.sep [ P.text "case" <+> pretty e, P.text "of" ]

145+ pexpr = P.sep [ P.text "case" <+> pretty expr, P.text "of" ]

146+ pretty' (pattern, branch) =

145− pretty' (p,b) = pretty p <+> P.text "->" <+> pretty b

147+ pretty pattern <+> P.text "->" <+> pretty branch

146

148

147 Data "::" [hd,tl] ->

149 Data "::" [hd,tl] ->

148 pretty hd <+> P.text "::" <+> pretty tl

150 pretty hd <+> P.text "::" <+> pretty tl

@@ -150,45 +152,45 @@ instance (Pretty def, Pretty var, Var.ToString var) => Pretty (Expr' ann def var

150 Data "[]" [] ->

152 Data "[]" [] ->

151 P.text "[]"

153 P.text "[]"

152

154

153− Data name es

155+ Data name exprs

154 | Help.isTuple name ->

156 | Help.isTuple name ->

155− P.parens (commaCat (map pretty es))

157+ P.parens (commaCat (map pretty exprs))

156 | otherwise ->

158 | otherwise ->

157− P.hang (P.text name) 2 (P.sep (map prettyParens es))

159+ P.hang (P.text name) 2 (P.sep (map prettyParens exprs))

158

160

159− Access e x ->

161+ Access record field ->

160− prettyParens e <> P.text "." <> variable x

162+ prettyParens record <> P.text "." <> variable field

161

163

162− Remove e x ->

164+ Remove record field ->

163− P.braces (pretty e <+> P.text "-" <+> variable x)

165+ P.braces (pretty record <+> P.text "-" <+> variable field)

164

166

165− Insert (Annotation.A _ (Remove e y)) x v ->

167+ Insert (Annotation.A _ (Remove record y)) x v ->

166 P.braces $

168 P.braces $

167 P.hsep

169 P.hsep

168− [ pretty e, P.text "-", variable y, P.text "|"

170+ [ pretty record, P.text "-", variable y, P.text "|"

169 , variable x, P.equals, pretty v

171 , variable x, P.equals, pretty v

170 ]

172 ]

171

173

172− Insert e x v ->

174+ Insert record field expr ->

173− P.braces (pretty e <+> P.text "|" <+> variable x <+> P.equals <+> pretty v)

175+ P.braces (pretty record <+> P.text "|" <+> variable field <+> P.equals <+> pretty expr)

174

176

175− Modify e fs ->

177+ Modify record fields ->

176 P.braces $

178 P.braces $

177 P.hang

179 P.hang

178− (pretty e <+> P.text "|")

180+ (pretty record <+> P.text "|")

179 4

181 4

180− (commaSep $ map field fs)

182+ (commaSep $ map field fields)

181 where

183 where

182 field (k,v) = variable k <+> P.text "<-" <+> pretty v

184 field (k,v) = variable k <+> P.text "<-" <+> pretty v

183

185

184− Record fs ->

186+ Record fields ->

185 P.sep

187 P.sep

186− [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map field fs))

188+ [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map field fields))

187 , P.rbrace

189 , P.rbrace

188 ]

190 ]

189 where

191 where

190− field (name, value) =

192+ field (name, expr) =

191− variable name <+> P.equals <+> pretty value

193+ variable name <+> P.equals <+> pretty expr

192

194

193 GLShader _ _ _ ->

195 GLShader _ _ _ ->

194 P.text "[glsl| ... |]"

196 P.text "[glsl| ... |]"

@@ -196,6 +198,9 @@ instance (Pretty def, Pretty var, Var.ToString var) => Pretty (Expr' ann def var

196 Port name _ ->

198 Port name _ ->

197 P.text ("<port:" ++ name ++ ">")

199 P.text ("<port:" ++ name ++ ">")

198

200

201+ Perform expr ->

202+ P.text "perform" <+> pretty expr

203+

199

204

200collectApps :: Expr ann def var -> [Expr ann def var]

205collectApps :: Expr ann def var -> [Expr ann def var]

201collectApps annExpr@(Annotation.A _ expr) =

206collectApps annExpr@(Annotation.A _ expr) =

src/Docs.hs+11−6

@@ -189,7 +189,9 @@ collectInfo (comment, decl) info =

189 case decl of

190 Decl.Definition def ->

191 case def of

192− Source.Definition _ _ -> error errorMessage

192+ Source.Definition _ _ ->

193+ error (errorMessage "unannotated definitions")

194+

193 Source.TypeAnnotation name tipe ->

195 Source.TypeAnnotation name tipe ->

194 let value = Docs.Value name comment (Type.fromInternalType tipe) Nothing

196 let value = Docs.Value name comment (Type.fromInternalType tipe) Nothing

195 in

197 in

@@ -212,13 +214,16 @@ collectInfo (comment, decl) info =

212 info { infixes = Map.insert name infixInfo (infixes info) }

214 info { infixes = Map.insert name infixInfo (infixes info) }

213

215

214 Decl.Port _ _ ->

216 Decl.Port _ _ ->

215− error errorMessage

217+ error (errorMessage "ports")

218+

219+ Decl.Perform _ _ ->

220+ error (errorMessage "perform declarations")

216

221

217

222

218−errorMessage :: String

223+errorMessage :: String -> String

219−errorMessage =

224+errorMessage name =

220− "there appears to be a bug in this tool.\n" ++

225+ "Unable to deal with annotations on " ++ name ++ " at this time.\n" ++

221− "Please report it to <https://github.com/elm-lang/Elm/issues>"

226+ "Please report your use case to <https://github.com/elm-lang/elm-compiler/issues>"

222

227

223

228

224-- FILTER OUT UNEXPORTED VALUES, ALIASES, and UNIONS

229-- FILTER OUT UNEXPORTED VALUES, ALIASES, and UNIONS

src/Elm/Compiler/Type.hs+6−1

@@ -67,6 +67,11 @@ toDoc context tipe =

67 (ADT, _ : _) -> P.parens adt

68 _ -> adt

69

70+ App _ _ ->

71+ error $

72+ "Somehow ended up with an unexpected type, please post a minimal example that\n"

73+ ++ "reproduces this error to <https://github.com/elm-lang/elm-compiler/issues>"

74+

70 Record _ _ ->

75 Record _ _ ->

71 case flattenRecord tipe of

76 case flattenRecord tipe of

72 ([], Nothing) ->

77 ([], Nothing) ->

@@ -137,7 +142,7 @@ instance Json.ToJSON Type where

137 , "name" .= Json.toJSON name

142 , "name" .= Json.toJSON name

138 ]

143 ]

139

144

140− App t ts ->

145+ App t ts ->

141 [ "tag" .= ("app" :: Text.Text)

146 [ "tag" .= ("app" :: Text.Text)

142 , "func" .= Json.toJSON t

147 , "func" .= Json.toJSON t

143 , "args" .= Json.toJSON ts

148 , "args" .= Json.toJSON ts

src/Generate/JavaScript.hs+3

@@ -218,6 +218,9 @@ expression (A region expr) =

218 T.Outbound tipe ->

219 return (Port.outbound name tipe)

220

221+ Perform expr ->

222+ do expr' <- expression expr

223+ return (useLazy ["Elm","Native","Task"] "perform" <| expr')

221

224

222

225

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

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

src/Parse/Declaration.hs+14−2

@@ -2,7 +2,10 @@

2module Parse.Declaration where

3

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

5+import Text.Parsec

6+ ( (<|>), (<?>), choice, digit, getPosition

5−import Text.Parsec ((<|>), (<?>), choice, digit, optionMaybe, string, try)

7+ , optionMaybe, sourceLine, string, try

8+ )

6

9

7import qualified AST.Declaration as D

10import qualified AST.Declaration as D

8import qualified Parse.Expression as Expr

11import qualified Parse.Expression as Expr

@@ -12,7 +15,7 @@ import qualified Parse.Type as Type

12

15

13declaration :: IParser D.SourceDecl

16declaration :: IParser D.SourceDecl

14declaration =

17declaration =

15− typeDecl <|> infixDecl <|> port <|> definition

18+ typeDecl <|> infixDecl <|> port <|> definition <|> perform

16

19

17

20

18definition :: IParser D.SourceDecl

21definition :: IParser D.SourceDecl

@@ -62,3 +65,12 @@ port =

62 whitespace

65 whitespace

63 tipe <- Type.expr <?> "a type"

66 tipe <- Type.expr <?> "a type"

64 return (D.Port name tipe)

67 return (D.Port name tipe)

68+

69+

70+perform :: IParser D.SourceDecl

71+perform =

72+ do try (reserved "perform")

73+ line <- sourceLine <$> getPosition

74+ whitespace

75+ D.Perform line <$> Expr.expr

76+

src/Parse/Helpers.hs+1

@@ -32,6 +32,7 @@ reserveds =

32 , "module", "where"

33 , "import", "as", "hiding", "exposing"

34 , "port", "export", "foreign"

35+ , "perform"

35 , "deriving"

36 , "deriving"

36 ]

37 ]

37

38

src/Transform/Canonicalize.hs+10−2

@@ -203,12 +203,17 @@ declaration env decl =

203 return (D.TypeAlias name tvars expanded')

204

205 D.Port name tipe ->

206− do Env.uses ["Native","Ports"]

206+ do Env.uses ["Native","Port"]

207− Env.uses ["Native","Json"]

207+ Env.uses ["Native","JavaScript"]

208 tipe' <- canonicalize Canonicalize.tipe "port" name env tipe

209 portType <- Port.check name tipe'

210 return $ D.Port name portType

211

212+ D.Perform line expr ->

213+ do Env.uses ["Native","Task"]

214+ expr' <- expression env expr

215+ return $ D.Perform line expr'

216+

212 D.Fixity assoc prec op ->

217 D.Fixity assoc prec op ->

213 return $ D.Fixity assoc prec op

218 return $ D.Fixity assoc prec op

214

219

@@ -306,6 +311,9 @@ expression env (A.A ann validExpr) =

306 Type.Internal tipe -> Type.Internal <$> tipe' env tipe

311 Type.Internal tipe -> Type.Internal <$> tipe' env tipe

307 Type.Outbound tipe -> Type.Outbound <$> tipe' env tipe

312 Type.Outbound tipe -> Type.Outbound <$> tipe' env tipe

308

313

314+ Perform expr ->

315+ Perform <$> go expr

316+

309 GLShader uid src tipe ->

317 GLShader uid src tipe ->

310 return (GLShader uid src tipe)

318 return (GLShader uid src tipe)

311

319

src/Transform/Canonicalize/Setup.hs+5−2

@@ -245,12 +245,12 @@ addTypeAlias moduleName env scc =

245 ]

246

247

248−typeAlias :: (String, [String], Type.Type var) -> D.Declaration' pk def var

248+typeAlias :: (String, [String], Type.Type var) -> D.Declaration' pk def var expr

249typeAlias (n,ts,t) =

250 D.TypeAlias n ts t

251

252

253−datatype :: (String, [String], Type.Type var) -> D.Declaration' pk def var

253+datatype :: (String, [String], Type.Type var) -> D.Declaration' pk def var expr

254datatype (n,ts,t) =

255 D.Datatype n ts [(n,[t])]

256

@@ -328,5 +328,8 @@ addDecl moduleName info@(nodes,env) decl =

328 addLocal name (_values env)

329 }

330

331+ D.Perform _ _ ->

332+ info

333+

331 D.Fixity _ _ _ ->

334 D.Fixity _ _ _ ->

332 info

335 info

src/Transform/Declaration.hs+9

@@ -47,6 +47,10 @@ combineAnnotations =

47 D.Port name tipe : rest ->

48 (:) (D.Port name tipe) <$> go rest

49

50+ D.Perform line expr : rest ->

51+ do expr' <- exprCombineAnnotations expr

52+ (:) (D.Perform line expr') <$> go rest

53+

50 -- combine definitions

54 -- combine definitions

51 D.Definition def : defRest ->

55 D.Definition def : defRest ->

52 case def of

56 case def of

@@ -115,6 +119,11 @@ toDefs moduleName decl =

115 D.Port name tipe ->

119 D.Port name tipe ->

116 [ definition name (A.none $ E.Port name tipe) (T.portTypeToType tipe) ]

120 [ definition name (A.none $ E.Port name tipe) (T.portTypeToType tipe) ]

117

121

122+ D.Perform line expr ->

123+ let name = "$perform$" ++ show line

124+ in

125+ [ Canonical.Definition (P.Var name) (A.none $ E.Perform expr) Nothing ]

126+

118 -- no constraints are needed for fixity declarations

127 -- no constraints are needed for fixity declarations

119 D.Fixity _ _ _ ->

128 D.Fixity _ _ _ ->

120 []

129 []

src/Transform/Expression.hs+3

@@ -71,3 +71,6 @@ crawlLet defsTransform annotatedExpression =

71

72 Port name tipe ->

73 return $ Port name tipe

74+

75+ Perform expr ->

76+ Perform <$> go expr

src/Transform/SortDefinitions.hs+3

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

118 Port name tipe ->

119 return $ Port name tipe

120

121+ Perform expr ->

122+ Perform <$> reorder expr

123+

121 -- Actually do some reordering

124 -- Actually do some reordering

122 Let defs body ->

125 Let defs body ->

123 do body' <- reorder body

126 do body' <- reorder body

src/Transform/Substitute.hs+3

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

85

86 Port _ _ ->

87 expression

88+

89+ Perform expr ->

90+ Perform (f expr)

src/Type/Constrain/Expression.hs+3

@@ -180,6 +180,9 @@ constrain env (A region expression) tipe =

180 Port _ _ ->

181 return true

182

183+ Perform expr ->

184+ constrain env expr tipe

185+

183

186

184expandPattern :: Canonical.Def -> [Canonical.Def]

187expandPattern :: Canonical.Def -> [Canonical.Def]

185expandPattern def@(Canonical.Definition pattern lexpr@(A r _) maybeType) =

188expandPattern def@(Canonical.Definition pattern lexpr@(A r _) maybeType) =