896c502 · elk · git.iko.soy

src/AST/Declaration.hs+10−6

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

1313

1414-- DECLARATIONS

1515

16−data Declaration' portType def var

16+data Declaration' portType def var expr

1717 = Definition def

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

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

2020 | Port String portType

21+ | Perform Int expr

2122 | Fixity Assoc Int String

2223

2324

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

2829-- DECLARATION PHASES

2930

3031type SourceDecl =

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

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

3233

3334

3435type ValidDecl =

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

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

3637

3738

3839type CanonicalDecl =

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

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

4041

4142

4243-- BINARY CONVERSION

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

6869 R -> "right"

6970

7071

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

72− Pretty (Declaration' portType def var) where

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

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

7374 pretty decl =

7475 case decl of

7576 Definition def -> pretty def

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

9899 Port name tipe ->

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

100101

102+ Perform _ expr ->

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

104+

101105 Fixity assoc prec op ->

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

103107 where

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

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

1010

1111import AST.PrettyPrint

1212import Text.PrettyPrint as P

13−import AST.Type (Type, PortType)

13+import AST.Type (PortType)

1414

1515import qualified AST.Annotation as Annotation

1616import qualified AST.Helpers as Help

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

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

6060 -- for type checking and code gen only

6161 | Port String (PortType var)

62+ | Perform (Expr ann def var)

6263 | GLShader String String Literal.GLShaderTipe

6364 deriving (Show)

6465

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

9192

9293

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

94− pretty expr =

95− case expr of

96− Literal lit ->

97− pretty lit

95+ pretty expression =

96+ case expression of

97+ Literal literal ->

98+ pretty literal

9899

99100 Var x ->

100101 pretty x

101102

102− Range e1 e2 ->

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

103+ Range lowExpr highExpr ->

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

104105

105− ExplicitList es ->

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

106+ ExplicitList elements ->

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

107108

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

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

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

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

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

111112

112− Binop op e1 e2 ->

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

113+ Binop op leftExpr rightExpr ->

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

114115 where

115116 op' = Var.toString op

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

117118

118− Lambda p e ->

119+ Lambda pattern expr ->

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

120121 where

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

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

122+ (patterns, body) = collectLambdas expr

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

123124

124− App _ _ ->

125+ App expr arg ->

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

126127 where

127128 func:args =

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

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

129130

130131 MultiIf branches ->

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

132133 where

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

134135

135− Let defs e ->

136+ Let defs body ->

136137 P.sep

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

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

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

139140 ]

140141

141− Case e pats ->

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

142+ Case expr branches ->

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

143144 where

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

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

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

146+ pretty' (pattern, branch) =

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

146148

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

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

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

150152 Data "[]" [] ->

151153 P.text "[]"

152154

153− Data name es

155+ Data name exprs

154156 | Help.isTuple name ->

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

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

156158 | 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))

158160

159− Access e x ->

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

161+ Access record field ->

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

161163

162− Remove e x ->

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

164+ Remove record field ->

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

164166

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

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

166168 P.braces $

167169 P.hsep

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

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

169171 , variable x, P.equals, pretty v

170172 ]

171173

172− Insert e x v ->

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

174+ Insert record field expr ->

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

174176

175− Modify e fs ->

177+ Modify record fields ->

176178 P.braces $

177179 P.hang

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

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

179181 4

180− (commaSep $ map field fs)

182+ (commaSep $ map field fields)

181183 where

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

183185

184− Record fs ->

186+ Record fields ->

185187 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))

187189 , P.rbrace

188190 ]

189191 where

190− field (name, value) =

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

192+ field (name, expr) =

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

192194

193195 GLShader _ _ _ ->

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

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

196198 Port name _ ->

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

198200

201+ Perform expr ->

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

203+

199204

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

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

src/Docs.hs+11−6

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

189189 case decl of

190190 Decl.Definition def ->

191191 case def of

192− Source.Definition _ _ -> error errorMessage

192+ Source.Definition _ _ ->

193+ error (errorMessage "unannotated definitions")

194+

193195 Source.TypeAnnotation name tipe ->

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

195197 in

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

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

213215

214216 Decl.Port _ _ ->

215− error errorMessage

217+ error (errorMessage "ports")

218+

219+ Decl.Perform _ _ ->

220+ error (errorMessage "perform declarations")

216221

217222

218−errorMessage :: String

219−errorMessage =

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

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

223+errorMessage :: String -> String

224+errorMessage name =

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

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

222227

223228

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

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

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

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

6868 _ -> adt

6969

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+

7075 Record _ _ ->

7176 case flattenRecord tipe of

7277 ([], Nothing) ->

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

137142 , "name" .= Json.toJSON name

138143 ]

139144

140− App t ts ->

145+ App t ts ->

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

142147 , "func" .= Json.toJSON t

143148 , "args" .= Json.toJSON ts

src/Generate/JavaScript.hs+3

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

218218 T.Outbound tipe ->

219219 return (Port.outbound name tipe)

220220

221+ Perform expr ->

222+ do expr' <- expression expr

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

221224

222225

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

src/Parse/Declaration.hs+14−2

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

22module Parse.Declaration where

33

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

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

5+import Text.Parsec

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

7+ , optionMaybe, sourceLine, string, try

8+ )

69

710import qualified AST.Declaration as D

811import qualified Parse.Expression as Expr

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

1215

1316declaration :: IParser D.SourceDecl

1417declaration =

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

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

1619

1720

1821definition :: IParser D.SourceDecl

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

6265 whitespace

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

6467 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 =

3232 , "module", "where"

3333 , "import", "as", "hiding", "exposing"

3434 , "port", "export", "foreign"

35+ , "perform"

3536 , "deriving"

3637 ]

3738

src/Transform/Canonicalize.hs+10−2

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

203203 return (D.TypeAlias name tvars expanded')

204204

205205 D.Port name tipe ->

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

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

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

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

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

209209 portType <- Port.check name tipe'

210210 return $ D.Port name portType

211211

212+ D.Perform line expr ->

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

214+ expr' <- expression env expr

215+ return $ D.Perform line expr'

216+

212217 D.Fixity assoc prec op ->

213218 return $ D.Fixity assoc prec op

214219

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

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

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

308313

314+ Perform expr ->

315+ Perform <$> go expr

316+

309317 GLShader uid src tipe ->

310318 return (GLShader uid src tipe)

311319

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

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

245245 ]

246246

247247

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

249249typeAlias (n,ts,t) =

250250 D.TypeAlias n ts t

251251

252252

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

254254datatype (n,ts,t) =

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

256256

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

328328 addLocal name (_values env)

329329 }

330330

331+ D.Perform _ _ ->

332+ info

333+

331334 D.Fixity _ _ _ ->

332335 info

src/Transform/Declaration.hs+9

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

4747 D.Port name tipe : rest ->

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

4949

50+ D.Perform line expr : rest ->

51+ do expr' <- exprCombineAnnotations expr

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

53+

5054 -- combine definitions

5155 D.Definition def : defRest ->

5256 case def of

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

115119 D.Port name tipe ->

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

117121

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+

118127 -- no constraints are needed for fixity declarations

119128 D.Fixity _ _ _ ->

120129 []

src/Transform/Expression.hs+3

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

7171

7272 Port name tipe ->

7373 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) =

118118 Port name tipe ->

119119 return $ Port name tipe

120120

121+ Perform expr ->

122+ Perform <$> reorder expr

123+

121124 -- Actually do some reordering

122125 Let defs body ->

123126 do body' <- reorder body

src/Transform/Substitute.hs+3

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

8585

8686 Port _ _ ->

8787 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 =

180180 Port _ _ ->

181181 return true

182182

183+ Perform expr ->

184+ constrain env expr tipe

185+

183186

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

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