eb1f9d6 · elk · git.iko.soy

src/AST/Expression/General.hs+21−48

compare with master

unifiedsplit

@@ -49,14 +49,12 @@ data Expr' ann def var typ

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

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

51 | App (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+ | If [(Expr ann def var typ, Expr ann def var typ)] (Expr ann def var typ)

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

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

55 | Data String [Expr ann def var typ]

56 | Access (Expr ann def var typ) String

57− | Remove (Expr ann def var typ) String

58− | Insert (Expr ann def var typ) String (Expr ann def var typ)

59− | Modify (Expr ann def var typ) [(String, Expr ann def var typ)]

57+ | Update (Expr ann def var typ) [(String, Expr ann def var typ)]

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

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

61 -- for type checking and code gen only

59 -- for type checking and code gen only

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

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

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

163 func:args =

161 func:args =

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

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

165

163

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

164+ If branches finally ->

167− P.parensIf needsParens $ P.sep $

165+ let

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

166+ prettyFinally =

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

170− , P.text "else"

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

167+ P.nest 4 (P.pretty dealiaser False finally)

172− ]

173

168

174− MultiIf branches finally ->

169+ prettyBranch (condition, thenBranch) (firstLine, rest) =

175− P.parensIf needsParens $

170+ ( P.text "if" <+> P.pretty dealiaser False condition <+> P.text "then"

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

171+ ,

177− where

172+ [ P.nest 4 (P.pretty dealiaser False thenBranch)

178− iff (condition, branch) =

173+ , P.text "else" <+> firstLine

179− P.text "|" <+>

174+ ]

180− P.hang

175+ ++ rest

181− (P.pretty dealiaser False condition <+> P.text "->")

176+ )

182− 2

177+ in

183− (P.pretty dealiaser False branch)

178+ P.parensIf needsParens $ P.sep $ uncurry (:) $

184−

179+ foldr

185− final =

180+ prettyBranch

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

181+ ( P.empty, [prettyFinally] )

182+ branches

187

183

188 Let defs body ->

184 Let defs body ->

189 P.parensIf needsParens $

185 P.parensIf needsParens $

@@ -228,30 +224,7 @@ instance (P.Pretty def, P.Pretty var, Var.ToString var) => P.Pretty (Expr' ann d

228 Access record field ->

224 Access record field ->

229 P.pretty dealiaser True record <> P.text "." <> P.text field

225 P.pretty dealiaser True record <> P.text "." <> P.text field

230

226

231− Remove record field ->

232− P.braces (P.pretty dealiaser False record <+> P.text "-" <+> P.text field)

233−

234− Insert (A.A _ (Remove record oldField)) newField expr ->

235− P.braces $

236− P.hsep

237− [ P.pretty dealiaser False record

238− , P.text "-"

239− , P.text oldField

240− , P.text "|"

241− , P.text newField

242− , P.equals

243− , P.pretty dealiaser False expr

244− ]

245−

246− Insert record field expr ->

247− P.braces $

248− P.pretty dealiaser False record

249− <+> P.text "|"

250− <+> P.text field

251− <+> P.equals

252− <+> P.pretty dealiaser False expr

253−

254− Modify record fields ->

227+ Update record fields ->

255 P.braces $

228 P.braces $

256 P.hang

229 P.hang

257 (P.pretty dealiaser False record <+> P.text "|")

230 (P.pretty dealiaser False record <+> P.text "|")

src/Canonicalize.hs+4−10

@@ -393,14 +393,8 @@ expression env (A.A region validExpr) =

393 Access record field ->

394 Access <$> go record <*> Result.ok field

395

396− Remove record field ->

397− flip Remove field <$> go record

398−

399− Insert record field expr ->

400− flip Insert field <$> go record <*> go expr

401−

402− Modify record fields ->

396+ Update record fields ->

403− Modify

397+ Update

404 <$> go record

398 <$> go record

405 <*> T.traverse (\(field,expr) -> (,) field <$> go expr) fields

399 <*> T.traverse (\(field,expr) -> (,) field <$> go expr) fields

406

400

@@ -422,8 +416,8 @@ expression env (A.A region validExpr) =

422 App func arg ->

416 App func arg ->

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

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

424

418

425− MultiIf branches finally ->

419+ If branches finally ->

426− MultiIf

420+ If

427 <$> T.traverse go' branches

421 <$> T.traverse go' branches

428 <*> go finally

422 <*> go finally

429 where

423 where

src/Canonicalize/Declaration.hs+5−13

@@ -38,28 +38,20 @@ toDefs moduleName (A.A (region,_) decl) =

38 in

39 [ definition ctor (buildFunction body vars) region (foldr T.Lambda tbody tipes) ]

40

41− D.TypeAlias name tvars tipe@(T.Record fields ext) ->

41+ D.TypeAlias name tvars tipe@(T.Record fields Nothing) ->

42 [ definition name (buildFunction record vars) region (foldr T.Lambda result args) ]

43 where

44 result =

45 T.Aliased (typeVar name) (zip tvars (map T.Var tvars)) (T.Holey tipe)

46

47 args =

48− map snd fields ++ maybe [] (:[]) ext

48+ map snd fields

49

50− var = loc . E.localVar

50+ vars =

51− vars = take (length args) infiniteArgs

51+ take (length args) infiniteArgs

52−

53− efields =

54− zip (map fst fields) (map var vars)

55

52

56 record =

53 record =

57− case ext of

54+ loc (E.Record (zip (map fst fields) (map (loc . E.localVar) vars)))

58− Nothing ->

59− loc (E.Record efields)

60−

61− Just _ ->

62− foldl (\r (f,v) -> loc (E.Insert r f v)) (var (last vars)) efields

63

55

64 -- Type aliases must be added to an extended equality dictionary,

56 -- Type aliases must be added to an extended equality dictionary,

65 -- but they do not require any basic constraints.

57 -- but they do not require any basic constraints.

src/Canonicalize/Sort.hs+4−15

@@ -74,8 +74,8 @@ reorder (A.A ann expression) =

74 App func arg ->

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

76

77− MultiIf branches finally ->

77+ If branches finally ->

78− MultiIf

78+ If

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

80 <*> reorder finally

81

@@ -84,19 +84,8 @@ reorder (A.A ann expression) =

84 <$> reorder record

85 <*> return field

86

87− Remove record field ->

88− Remove

89− <$> reorder record

90− <*> return field

91−

92− Insert record field expr ->

93− Insert

94− <$> reorder record

95− <*> return field

96− <*> reorder expr

97−

98− Modify record fields ->

87+ Update record fields ->

99− Modify

88+ Update

100 <$> reorder record

89 <$> reorder record

101 <*> mapM (\(field,expr) -> (,) field <$> reorder expr) fields

90 <*> mapM (\(field,expr) -> (,) field <$> reorder expr) fields

102

91

src/Generate/JavaScript.hs+3−12

@@ -161,16 +161,7 @@ exprToCode tcc annotatedExpr@(A.A _ expr) =

161 do record' <- toJsExpr record

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

163

164− Remove record field ->

165− do record' <- toJsExpr record

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

167−

168− Insert record field value ->

169− do value' <- toJsExpr value

170− record' <- toJsExpr record

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

172−

173− Modify record fields ->

164+ Update record fields ->

174 do record' <- toJsExpr record

165 do record' <- toJsExpr record

175 fields' <-

166 fields' <-

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

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

@@ -211,7 +202,7 @@ exprToCode tcc annotatedExpr@(A.A _ expr) =

211 Let defs body ->

202 Let defs body ->

212 generateLet tcc defs body

203 generateLet tcc defs body

213

204

214− MultiIf branches finally ->

205+ If branches finally ->

215 generateIf tcc branches finally

206 generateIf tcc branches finally

216

207

217 Case expr branches ->

208 Case expr branches ->

@@ -419,7 +410,7 @@ crushIfsHelp visitedBranches unvisitedBranches finally =

419 case unvisitedBranches of

410 case unvisitedBranches of

420 [] ->

411 [] ->

421 case finally of

412 case finally of

422− A.A _ (MultiIf subBranches subFinally) ->

413+ A.A _ (If subBranches subFinally) ->

423 crushIfsHelp visitedBranches subBranches subFinally

414 crushIfsHelp visitedBranches subBranches subFinally

424

415

425 _ ->

416 _ ->

src/Nitpick/PatternMatches.hs+2−8

@@ -136,7 +136,7 @@ checkExpression tagDict (A.A region expression) =

136 E.App func arg ->

137 go2 func arg

138

139− E.MultiIf branches finally ->

139+ E.If branches finally ->

140 F.traverse_ (uncurry go2) branches

141 <* go finally

142

@@ -159,13 +159,7 @@ checkExpression tagDict (A.A region expression) =

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

162+ E.Update record fields ->

169 go record

163 go record

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

164 <* F.traverse_ (go . snd) fields

171

165

src/Optimize/Substitute.hs+4−10

@@ -32,8 +32,8 @@ subst old new expression =

32 App func arg ->

33 App (f func) (f arg)

34

35− MultiIf branches finally ->

35+ If branches finally ->

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

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

37

38 Let defs body ->

39 if anyShadow

@@ -75,14 +75,8 @@ subst old new expression =

75 Access record field ->

76 Access (f record) field

77

78− Remove record field ->

78+ Update record fields ->

79− Remove (f record) field

80−

81− Insert record field value ->

82− Insert (f record) field (f value)

83−

84− Modify record fields ->

85− Modify (f record) (map (second f) fields)

79+ Update (f record) (map (second f) fields)

86

80

87 Record fields ->

81 Record fields ->

88 Record (map (second f) fields)

82 Record (map (second f) fields)

src/Optimize/TailCalls.hs+4−15

@@ -147,12 +147,12 @@ findTailCalls context annExpr@(A.A _ expression) =

147 Result isTailCall (List.foldl' apply optFunc optArgs)

148

149

150− MultiIf branches finally ->

150+ If branches finally ->

151 let

152 crawlBranch (cond,branch) =

153 (,) <$> justConvert cond <*> keepLooking branch

154 in

155− MultiIf

155+ If

156 <$> T.traverse crawlBranch branches

157 <*> keepLooking finally

158

@@ -179,19 +179,8 @@ findTailCalls context annExpr@(A.A _ expression) =

179 <$> justConvert record

180 <*> pure field

181

182− Remove record field ->

183− Remove

184− <$> justConvert record

185− <*> pure field

186−

187− Insert record field expr ->

188− Insert

189− <$> justConvert record

190− <*> pure field

191− <*> justConvert expr

192−

193− Modify record fields ->

182+ Update record fields ->

194− Modify

183+ Update

195 <$> justConvert record

184 <$> justConvert record

196 <*> T.traverse (mapSnd justConvert) fields

185 <*> T.traverse (mapSnd justConvert) fields

197

186

src/Parse/Expression.hs+44−86

@@ -18,8 +18,6 @@ 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

21

24

22

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

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

@@ -136,65 +134,40 @@ parensTerm =

136

134

137recordTerm :: IParser Source.Expr

135recordTerm :: IParser Source.Expr

138recordTerm =

136recordTerm =

139− addLocation $

137+ addLocation $ brackets $ choice $

140− brackets (choice [ misc, record ])

141− where

142− record =

143− E.Record <$> commaSep field

144−

145− field =

146− do label <- rLabel

147− patterns <- spacePrefix Pattern.term

148− padded equals

149− body <- expr

150− return (label, makeFunction patterns body)

151−

152− misc =

153− do nextParser <- try miscStarter

154− whitespace

155− nextParser

156−

157− miscStarter =

158− do start <- getMyPosition

159− record <- addLocation (E.rawVar <$> rLabel)

138+ [ do starter <- try (addLocation rLabel)

160 whitespace

139 whitespace

161 choice

140 choice

162− [ string "-" >> return (afterMinus start record)

141+ [ update starter

163− , string "|" >> return (afterBar record)

142+ , literal starter

164 ]

143 ]

144+ , return (E.Record [])

145+ ]

146+ where

147+ update (A.A ann starter) =

148+ do try (string "|")

149+ whitespace

150+ fields <- commaSep1 field

151+ return (E.Update (A.A ann (E.rawVar starter)) fields)

165

152

166− afterMinus start record =

153+ literal (A.A _ starter) =

167− do field <- rLabel

168− end <- getMyPosition

169− let subRecord' = E.Remove record field

170− maybe <- optionMaybe (try (whitespace >> string "|"))

171− case maybe of

172− Nothing ->

173− return subRecord'

174− Just _ ->

175− do whitespace

176− field <- rLabel

177− padded equals

154+ do try equals

178− E.Insert (A.at start end subRecord') field <$> expr

155+ whitespace

179−

156+ value <- expr

180− afterBar record =

181− do field <- rLabel

182 whitespace

157 whitespace

183 choice

158 choice

184− [ do equals

159+ [ do try comma

185 whitespace

160 whitespace

186− E.Insert record field <$> expr

161+ fields <- commaSep field

187− , do leftArrow

162+ return (E.Record ((starter, value) : fields))

188− whitespace

163+ , return (E.Record [(starter, value)])

189− value <- expr

190− updates <- spaceyPrefixBy comma update

191− return (E.Modify record ((field,value) : updates))

192 ]

164 ]

193

165

194− update =

166+ field =

195− do lbl <- rLabel

167+ do key <- rLabel

196− padded leftArrow

168+ padded equals

197− (,) lbl <$> expr

169+ value <- expr

170+ return (key, value)

198

171

199

172

200term :: IParser Source.Expr

173term :: IParser Source.Expr

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

222

195

223expr :: IParser Source.Expr

196expr :: IParser Source.Expr

224expr =

197expr =

225− addLocation (choice [ letExpr, caseExpr ])

198+ addLocation (choice [ letExpr, caseExpr, ifExpr ])

226− <|> ifExpr

227 <|> lambdaExpr

199 <|> lambdaExpr

228 <|> binaryExpr

200 <|> binaryExpr

229 <?> "an expression"

201 <?> "an expression"

@@ -234,45 +206,31 @@ binaryExpr =

234 Binop.binops appExpr lastExpr anyOp

206 Binop.binops appExpr lastExpr anyOp

235 where

207 where

236 lastExpr =

208 lastExpr =

237− addLocation (choice [ letExpr, caseExpr ])

209+ addLocation (choice [ letExpr, caseExpr, ifExpr ])

238− <|> ifExpr

239 <|> lambdaExpr

210 <|> lambdaExpr

240 <?> "an expression"

211 <?> "an expression"

241

212

242

213

243−ifExpr :: IParser Source.Expr

214+ifExpr :: IParser Source.Expr'

244ifExpr =

215ifExpr =

245− do start <- getMyPosition

216+ ifHelp []

246− try (reserved "if")

247− whitespace

248− makeExpr <- normal <|> multiIf

249− end <- getMyPosition

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

251− where

252− normal =

253− do condition <- expr

254− padded (reserved "then")

255− thenBranch <- expr

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

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

258− whitespace

259− elseBranch <- expr

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

261

217

262− multiIf =

263− do branches <- spaceSep1 multiBranch

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

265

218

266− crash region =

219+ifHelp :: [(Source.Expr, Source.Expr)] -> IParser Source.Expr'

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

220+ifHelp branches =

268−

221+ do try (reserved "if")

269− multiBranch =

270− do string "|"

271− whitespace

222+ whitespace

272− condition <- expr

223+ condition <- expr

273− padded rightArrow

224+ padded (reserved "then")

274− branch <- expr

225+ thenBranch <- expr

275− return (condition, branch)

226+ whitespace <?> "an 'else' branch"

227+ reserved "else" <?> "an 'else' branch"

228+ whitespace

229+ let newBranches = (condition, thenBranch) : branches

230+ choice

231+ [ ifHelp newBranches

232+ , E.If (reverse newBranches) <$> expr

233+ ]

276

234

277

235

278lambdaExpr :: IParser Source.Expr

236lambdaExpr :: IParser Source.Expr

src/Parse/Helpers.hs+1−6

@@ -137,11 +137,6 @@ rightArrow =

137 string "->" <|> string "\8594" <?> "->"

138

139

140−leftArrow :: IParser String

141−leftArrow =

142− string "<-" <?> "<- for a record update"

143−

144−

145hasType :: IParser String

140hasType :: IParser String

146hasType =

141hasType =

147 string ":" <?> "the \"has type\" symbol ':'"

142 string ":" <?> "the \"has type\" symbol ':'"

@@ -628,6 +623,6 @@ processAs processor s =

628 , T.opStart = undefined

623 , T.opStart = undefined

629 , T.opLetter = undefined

624 , T.opLetter = undefined

630 , T.reservedNames = reserveds

625 , T.reservedNames = reserveds

631− , T.reservedOpNames = [":", "->", "<-", "|"]

626+ , T.reservedOpNames = [":", "->", "|"]

632 , T.caseSensitive = True

627 , T.caseSensitive = True

633 }

628 }

src/Type/Constrain/Expression.hs+2−19

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

98 in

99 constrainApp env region f args tipe

100

101− E.MultiIf branches finally ->

101+ E.If branches finally ->

102 constrainIf env region branches finally tipe

103

104 E.Case expr branches ->

@@ -118,24 +118,7 @@ constrain env annotatedExpr@(A.A region expression) tipe =

118 exists $ \t ->

119 constrain env expr (record (Map.singleton label [tipe]) t)

120

121− E.Remove expr label ->

122− exists $ \t ->

123− constrain env expr (record (Map.singleton label [t]) tipe)

124−

125− E.Insert expr label value ->

126− exists $ \valueType ->

127− exists $ \recordType ->

128− do valueCon <- constrain env value valueType

129− recordCon <- constrain env expr recordType

130− let newRecordType =

131− record (Map.singleton label [valueType]) recordType

132− return $ CAnd

133− [ valueCon

134− , recordCon

135− , CEqual Error.Record region tipe newRecordType

136− ]

137−

138− E.Modify expr fields ->

121+ E.Update expr fields ->

139 exists $ \t ->

122 exists $ \t ->

140 do oldVars <- Monad.forM fields $ \_ -> variable Flexible

123 do oldVars <- Monad.forM fields $ \_ -> variable Flexible

141 let oldFields = ST.fieldMap (zip (map fst fields) (map varN oldVars))

124 let oldFields = ST.fieldMap (zip (map fst fields) (map varN oldVars))

src/Validate.hs+4−15

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

213 <$> expression funcExpr

214 <*> expression argExpr

215

216− MultiIf branches finally ->

216+ If branches finally ->

217− MultiIf

217+ If

218 <$> T.traverse both branches

219 <*> expression finally

220

@@ -223,19 +223,8 @@ expression (A.A ann sourceExpression) =

223 <$> expression record

224 <*> return field

225

226− Remove record field ->

227− Remove

228− <$> expression record

229− <*> return field

230−

231− Insert record field expr ->

232− Insert

233− <$> expression record

234− <*> return field

235− <*> expression expr

236−

237− Modify record fields ->

226+ Update record fields ->

238− Modify

227+ Update

239 <$> expression record

228 <$> expression record

240 <*> T.traverse second fields

229 <*> T.traverse second fields

241

230