b02b4aa · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Do not expose Description fields / optimize copy and flatten

b02b4aaEvan Czaplicki9 years ago

src/Type/Occurs.hs+2−2

compare with master

unifiedsplit

@@ -23,8 +23,8 @@ occursHelp seen var =

23 return True

25 else

26− do desc <- UF.descriptor var

26+ do (Descriptor content _ _ _) <- UF.descriptor var

27− case _content desc of

27+ case content of

28 Var _ _ _ ->

29 return False

src/Type/Solve.hs+5−5

@@ -199,7 +199,7 @@ actuallySolve constraint =

199 freshCopy <-

200 case Map.lookup name env of

201 Just (A.A _ tipe) ->

202− TS.makeInstance tipe

202+ TS.copy tipe

203

204 Nothing ->

205 if ModuleName.isKernel name then

@@ -248,8 +248,8 @@ solveScheme scheme =

248-- Check that a variable has rank == noRank, meaning that it can be generalized.

249isGeneric :: Variable -> TS.Solver ()

250isGeneric var =

251− do desc <- liftIO $ UF.descriptor var

251+ do (Descriptor _ rank _ _) <- liftIO $ UF.descriptor var

252− if _rank desc == noRank

252+ if rank == noRank

253 then return ()

254 else crash "Unable to generalize a type variable. It is not unranked."

255

@@ -277,7 +277,7 @@ occurs (name, A.A region variable) =

277

278 True ->

279 do overallType <- liftIO $ Type.toSrcType variable

280− infiniteDescriptor <- liftIO $ UF.descriptor variable

280+ (Descriptor _ rank mark copy) <- liftIO $ UF.descriptor variable

281− liftIO $ UF.setDescriptor variable (infiniteDescriptor { _content = Error "∞" })

281+ liftIO $ UF.setDescriptor variable (Descriptor (Error "∞") rank mark copy)

282 TS.addError region (Error.InfiniteType (Right name) overallType)

283

src/Type/State.hs+95−161

@@ -16,8 +16,7 @@ module Type.State

16 , register

17 , introduce

18 , flatten

19− , makeInstance

19+ , copy

20− , makeCopy

21 )

20 )

22 where

21 where

@@ -130,6 +129,13 @@ getPool =

130 return ( sPool state, state )

129 return ( sPool state, state )

131

130

132

131

132+{-# INLINE getMaxRank #-}

133+getMaxRank :: Solver Int

134+getMaxRank =

135+ Solver $ \state@(SS _ _ (Pool maxRank _) _ _) ->

136+ return ( maxRank, state )

137+

138+

133{-# INLINE getEnv #-}

139{-# INLINE getEnv #-}

134getEnv :: Solver Env

140getEnv :: Solver Env

135getEnv =

141getEnv =

@@ -147,23 +153,15 @@ saveLocalEnv =

147{-# INLINE uniqueMark #-}

153{-# INLINE uniqueMark #-}

148uniqueMark :: Solver Int

154uniqueMark :: Solver Int

149uniqueMark =

155uniqueMark =

150− Solver $ \state ->

156+ Solver $ \(SS env savedEnv pool mark errors) ->

151− let

152− mark =

153− sMark state

154− in

155− return ( mark, state { sMark = mark + 1 } )

157+ return ( mark, SS env savedEnv pool (mark + 1) errors )

156

158

157

159

158{-# INLINE nextRankPool #-}

160{-# INLINE nextRankPool #-}

159nextRankPool :: Solver Pool

161nextRankPool :: Solver Pool

160nextRankPool =

162nextRankPool =

161− Solver $ \state ->

163+ Solver $ \state@(SS _ _ (Pool maxRank _) _ _) ->

162− let

163− (Pool maxRank _) =

164− sPool state

165− in

166− return ( Pool (maxRank + 1) [], state )

164+ return ( Pool (maxRank + 1) [], state )

167

165

168

166

169

167

@@ -186,13 +184,10 @@ register variable =

186introduce :: Variable -> Solver Variable

184introduce :: Variable -> Solver Variable

187introduce variable =

185introduce variable =

188 {-# SCC elm_compiler_type_introduce #-}

186 {-# SCC elm_compiler_type_introduce #-}

189− Solver $ \state ->

190− let

191− (Pool maxRank inhabitants) =

187+ Solver $ \(SS env savedEnv (Pool maxRank inhabitants) mark errors) ->

192− sPool state

193− in

194− do UF.modifyDescriptor variable (\desc -> desc { _rank = maxRank })

188+ do UF.modifyDescriptor variable $ \(Descriptor c _ m cp) -> Descriptor c maxRank m cp

195− return ( variable, state { sPool = Pool maxRank (variable : inhabitants) } )

189+ let newPool = Pool maxRank (variable : inhabitants)

190+ return ( variable, SS env savedEnv newPool mark errors )

196

191

197

192

198

193

@@ -202,201 +197,140 @@ introduce variable =

202flatten :: Type -> Solver Variable

197flatten :: Type -> Solver Variable

203flatten term =

198flatten term =

204 {-# SCC elm_compiler_type_flatten #-}

199 {-# SCC elm_compiler_type_flatten #-}

200+ do maxRank <- getMaxRank

205− flattenHelp Map.empty term

201+ flattenHelp maxRank Map.empty term

206

202

207

203

208−flattenHelp :: Map.Map Text Variable -> Type -> Solver Variable

204+flattenHelp :: Int -> Map.Map Text Variable -> Type -> Solver Variable

209−flattenHelp aliasDict termN =

205+flattenHelp maxRank aliasDict termN =

210 case termN of

206 case termN of

211 PlaceHolder name ->

207 PlaceHolder name ->

212 return (aliasDict ! name)

208 return (aliasDict ! name)

213

209

214 AliasN name args realType ->

210 AliasN name args realType ->

215− do flatArgs <- mapM (traverse (flattenHelp aliasDict)) args

211+ do flatArgs <- mapM (traverse (flattenHelp maxRank aliasDict)) args

216− flatVar <- flattenHelp (Map.fromList flatArgs) realType

212+ flatVar <- flattenHelp maxRank (Map.fromList flatArgs) realType

217− makeFlatType (Alias name flatArgs flatVar)

213+ makeFlatType maxRank (Alias name flatArgs flatVar)

218

214

219 VarN v ->

215 VarN v ->

220 return v

216 return v

221

217

222 AppN name args ->

218 AppN name args ->

223− do flatArgs <- traverse (flattenHelp aliasDict) args

219+ do flatArgs <- traverse (flattenHelp maxRank aliasDict) args

224− makeFlatType (Structure (App1 name flatArgs))

220+ makeFlatType maxRank (Structure (App1 name flatArgs))

225

221

226 FunN a b ->

222 FunN a b ->

227− do flatA <- flattenHelp aliasDict a

223+ do flatA <- flattenHelp maxRank aliasDict a

228− flatB <- flattenHelp aliasDict b

224+ flatB <- flattenHelp maxRank aliasDict b

229− makeFlatType (Structure (Fun1 flatA flatB))

225+ makeFlatType maxRank (Structure (Fun1 flatA flatB))

230

226

231 EmptyRecordN ->

227 EmptyRecordN ->

232− makeFlatType (Structure EmptyRecord1)

228+ makeFlatType maxRank (Structure EmptyRecord1)

233

229

234 RecordN fields ext ->

230 RecordN fields ext ->

235− do flatFields <- traverse (flattenHelp aliasDict) fields

231+ do flatFields <- traverse (flattenHelp maxRank aliasDict) fields

236− flatExt <- flattenHelp aliasDict ext

232+ flatExt <- flattenHelp maxRank aliasDict ext

237− makeFlatType (Structure (Record1 flatFields flatExt))

233+ makeFlatType maxRank (Structure (Record1 flatFields flatExt))

238

234

239

235

240−makeFlatType :: Content -> Solver Variable

236+makeFlatType :: Int -> Content -> Solver Variable

241−makeFlatType content =

237+makeFlatType maxRank content =

242− do pool <- getPool

238+ register =<< liftIO (UF.fresh (Descriptor content maxRank noMark Nothing))

243− variable <- liftIO $ UF.fresh $

244− Descriptor

245− { _content = content

246− , _rank = _maxRank pool

247− , _mark = noMark

248− , _copy = Nothing

249− }

250− register variable

251

239

252

240

253

241

254−-- MAKE INSTANCE

242+-- COPY

255

243

256

244

257−makeInstance :: Variable -> Solver Variable

245+copy :: Variable -> Solver Variable

258−makeInstance var =

246+copy var =

259− do alreadyCopiedMark <- uniqueMark

247+ {-# SCC elm_compiler_type_copy #-}

260− freshVar <- makeCopy alreadyCopiedMark var

248+ do maxRank <- getMaxRank

249+ copyVar <- copyHelp maxRank var

261− _ <- restore alreadyCopiedMark var

250+ _ <- restore var

262− return freshVar

251+ return copyVar

263

252

264

253

254+copyHelp :: Int -> Variable -> Solver Variable

255+copyHelp maxRank variable =

256+ do (Descriptor content rank _mark maybeCopy) <- liftIO $ UF.descriptor variable

257+ case maybeCopy of

258+ Just copiedVariable ->

259+ return copiedVariable

265

260

266−-- MAKE COPY

261+ Nothing ->

262+ if rank /= noRank then

263+ return variable

267

264

265+ else

266+ do let mkCopyDesc cont = Descriptor cont maxRank noMark Nothing

267+ newVar <- liftIO $ UF.fresh $ mkCopyDesc content

268+ _ <- register newVar

268

269

269−makeCopy :: Int -> Variable -> Solver Variable

270+ -- Link the original variable to the new variable. This lets us

270−makeCopy alreadyCopiedMark variable =

271+ -- avoid making multiple copies of the variable we are instantiating.

271− {-# SCC elm_compiler_type_copy #-}

272+ --

273+ -- Need to do this before recursively copying the content of

274+ -- the variable to avoid looping on cyclic terms.

272− do desc <- liftIO $ UF.descriptor variable

275+ liftIO $ UF.setDescriptor variable $

273− makeCopyHelp desc alreadyCopiedMark variable

276+ Descriptor content rank noMark (Just newVar)

274

277

278+ -- Now we recursively copy the content of the variable.

279+ -- We have already marked the variable as copied, so we

280+ -- will not repeat this work or crawl this variable again.

281+ case content of

282+ Structure term ->

283+ do newTerm <- traverseFlatType (copyHelp maxRank) term

284+ liftIO $ UF.setDescriptor newVar $ mkCopyDesc (Structure newTerm)

275

285

276−makeCopyHelp :: Descriptor -> Int -> Variable -> Solver Variable

286+ Var Rigid maybeSuper maybeName ->

277−makeCopyHelp (Descriptor content rank mark copy) alreadyCopiedMark variable =

287+ liftIO $ UF.setDescriptor newVar $ mkCopyDesc $ Var Flex maybeSuper maybeName

278− if mark == alreadyCopiedMark then

279− case copy of

280− Just copiedVariable ->

281− return copiedVariable

282

288

283− Nothing ->

284− error

285− "Error copying type variable. This should be impossible.\

286− \ Please report this at <https://github.com/elm-lang/elm-compiler/issues>\

287− \ with a <http://sscce.org> and information on your OS, how you installed,\

288− \ and any other configuration information that might be helpful."

289−

290− else if rank /= noRank || not (needsCopy content) then

291− return variable

292−

293− else

294− do pool <- getPool

295− newVar <-

296− liftIO $ UF.fresh $ Descriptor

297− { _content = content -- place holder!

298− , _rank = _maxRank pool

299− , _mark = noMark

300− , _copy = Nothing

301− }

302− _ <- register newVar

303−

304− -- Link the original variable to the new variable. This lets us

305− -- avoid making multiple copies of the variable we are instantiating.

306− --

307− -- Need to do this before recursively copying the content of

308− -- the variable to avoid looping on cyclic terms.

309− liftIO $ UF.modifyDescriptor variable $ \desc ->

310− desc { _mark = alreadyCopiedMark, _copy = Just newVar }

311−

312−

313− let setContent newContent =

314− liftIO $ UF.modifyDescriptor newVar $ \desc ->

315− desc { _content = newContent }

316−

317− -- Now we recursively copy the content of the variable.

318− -- We have already marked the variable as copied, so we

319− -- will not repeat this work or crawl this variable again.

320− case content of

321− Structure term ->

322− do newTerm <- traverseFlatType (makeCopy alreadyCopiedMark) term

323− setContent (Structure newTerm)

324−

325− Var Rigid maybeSuper maybeName ->

326− setContent (Var Flex maybeSuper maybeName)

327−

328− Var Flex _ _ ->

289+ Var Flex _ _ ->

329− return ()

330−

331− Alias name args realType ->

332− setContent =<< (

333− Alias name

334− <$> mapM (traverse (makeCopy alreadyCopiedMark)) args

335− <*> makeCopy alreadyCopiedMark realType

336− )

337−

338− Error _ ->

339− return ()

290+ return ()

340−

341− return newVar

342−

343−

344−needsCopy :: Content -> Bool

345−needsCopy content =

346− case content of

347− Structure _ ->

348− True

349

291

350− Var _ _ _ ->

292+ Alias name args realType ->

351− True

293+ do newArgs <- mapM (traverse (copyHelp maxRank)) args

294+ newRealType <- copyHelp maxRank realType

295+ liftIO $ UF.setDescriptor newVar $ mkCopyDesc (Alias name newArgs newRealType)

352

296

353− Alias _ _ _ ->

297+ Error _ ->

354− True

298+ return ()

355

299

356− Error _ ->

300+ return newVar

357− False

358

301

359

302

360

303

361-- RESTORE

304-- RESTORE

362

305

363

306

364−restore :: Int -> Variable -> Solver Variable

307+restore :: Variable -> Solver Variable

365−restore alreadyCopiedMark variable =

308+restore variable =

366− do desc <- liftIO $ UF.descriptor variable

309+ do (Descriptor content _rank _mark maybeCopy) <- liftIO $ UF.descriptor variable

367− if _mark desc /= alreadyCopiedMark

310+ case maybeCopy of

368− then

311+ Nothing ->

369 return variable

312 return variable

370

313

371− else

314+ Just _ ->

372− do restoredContent <-

315+ do restoredContent <- restoreContent content

373− restoreContent alreadyCopiedMark (_content desc)

374− liftIO $ UF.setDescriptor variable $ Descriptor

316+ liftIO $ UF.setDescriptor variable $

375− { _content = restoredContent

317+ Descriptor restoredContent noRank noMark Nothing

376− , _rank = noRank

377− , _mark = noMark

378− , _copy = Nothing

379− }

380 return variable

318 return variable

381

319

382

320

383−

384−restoreContent :: Int -> Content -> Solver Content

321+restoreContent :: Content -> Solver Content

385−restoreContent alreadyCopiedMark content =

322+restoreContent content =

386− let

387− go = restore alreadyCopiedMark

388− in

389 case content of

323 case content of

390 Structure term ->

324 Structure term ->

391− Structure <$> traverseFlatType go term

325+ Structure <$> traverseFlatType restore term

392

326

393 Var _ _ _ ->

327 Var _ _ _ ->

394 return content

328 return content

395

329

396 Alias name args var ->

330 Alias name args var ->

397 Alias name

331 Alias name

398− <$> mapM (traverse go) args

332+ <$> mapM (traverse restore) args

399− <*> go var

333+ <*> restore var

400

334

401 Error _ ->

335 Error _ ->

402 return content

336 return content

src/Type/Type.hs+1−1

@@ -4,7 +4,7 @@ module Type.Type

4 ( Variable

5 , FlatType(..)

6 , Type(..)

7− , Descriptor(..)

7+ , Descriptor(Descriptor)

8 , Content(..)

9 , Flex(..)

10 , Super(..)

src/Type/Unify.hs+10−36

@@ -172,24 +172,14 @@ merge (Context _ var1 (Descriptor _ rank1 _ _) var2 (Descriptor _ rank2 _ _)) co

172mergeHelp :: Variable -> Variable -> Content -> Int -> IO ()

173mergeHelp var1 var2 newContent newRank =

174 UF.union var1 var2 $

175− Descriptor

175+ Descriptor newContent newRank noMark Nothing

176− { _content = newContent

177− , _rank = newRank

178− , _mark = noMark

179− , _copy = Nothing

180− }

181

176

182

177

183fresh :: Context -> Content -> Unify Variable

178fresh :: Context -> Content -> Unify Variable

184−fresh (Context _ _ desc1 _ desc2) content =

179+fresh (Context _ _ (Descriptor _ rank1 _ _) _ (Descriptor _ rank2 _ _)) content =

185 do freshVariable <-

180 do freshVariable <-

186 liftIO $ UF.fresh $

181 liftIO $ UF.fresh $

187− Descriptor

182+ Descriptor content (min rank1 rank2) noMark Nothing

188− { _content = content

189− , _rank = min (_rank desc1) (_rank desc2)

190− , _mark = noMark

191− , _copy = Nothing

192− }

193 lift (TS.register freshVariable)

183 lift (TS.register freshVariable)

194

184

195

185

@@ -214,11 +204,7 @@ subUnify context var1 var2 =

214

204

215

205

216actuallyUnify :: Context -> Unify ()

206actuallyUnify :: Context -> Unify ()

217−actuallyUnify context@(Context _ _ firstDesc _ secondDesc) =

207+actuallyUnify context@(Context _ _ (Descriptor firstContent _ _ _) _ (Descriptor secondContent _ _ _)) =

218− let

219− firstContent = _content firstDesc

220− secondContent = _content secondDesc

221− in

222 case firstContent of

208 case firstContent of

223 Error _ ->

209 Error _ ->

224 -- If there was an error, just pretend it is okay. This lets us avoid

210 -- If there was an error, just pretend it is okay. This lets us avoid

@@ -443,16 +429,9 @@ comparableOccursCheck (Context _ _ _ var _) =

443

429

444unifyComparableRecursive :: Orientation -> Variable -> Unify ()

430unifyComparableRecursive :: Orientation -> Variable -> Unify ()

445unifyComparableRecursive orientation var =

431unifyComparableRecursive orientation var =

446− do compVar <-

432+ do compVar <- liftIO $

447− liftIO $

448− do desc <- UF.descriptor var

433+ do (Descriptor _ rank _ _) <- UF.descriptor var

449− UF.fresh $

450− Descriptor

451− { _content = Var Flex (Just Comparable) Nothing

434+ UF.fresh $ Descriptor (Var Flex (Just Comparable) Nothing) rank noMark Nothing

452− , _rank = _rank desc

453− , _mark = noMark

454− , _copy = Nothing

455− }

456

435

457 guardedUnify orientation compVar var

436 guardedUnify orientation compVar var

458

437

@@ -464,7 +443,7 @@ collectArgs variable =

464

443

465collectArgsHelp :: [Variable] -> Variable -> IO [Variable]

444collectArgsHelp :: [Variable] -> Variable -> IO [Variable]

466collectArgsHelp revArgs variable =

445collectArgsHelp revArgs variable =

467− do content <- getContent variable

446+ do (Descriptor content _ _ _) <- UF.descriptor variable

468 case content of

447 case content of

469 Structure (Fun1 arg returnType) ->

448 Structure (Fun1 arg returnType) ->

470 collectArgsHelp (arg : revArgs) returnType

449 collectArgsHelp (arg : revArgs) returnType

@@ -473,11 +452,6 @@ collectArgsHelp revArgs variable =

473 return $ variable : revArgs

452 return $ variable : revArgs

474

453

475

454

476−getContent :: Variable -> IO Content

477−getContent variable =

478− _content <$> UF.descriptor variable

479−

480−

481

455

482-- UNIFY ALIASES

456-- UNIFY ALIASES

483

457

@@ -673,8 +647,8 @@ data ExtensionStructure

673

647

674gatherFields :: Context -> Map.Map Text Variable -> Variable -> IO RecordStructure

648gatherFields :: Context -> Map.Map Text Variable -> Variable -> IO RecordStructure

675gatherFields context fields variable =

649gatherFields context fields variable =

676− do desc <- UF.descriptor variable

650+ do (Descriptor content _ _ _) <- UF.descriptor variable

677− case _content desc of

651+ case content of

678 Structure (Record1 subFields subExt) ->

652 Structure (Record1 subFields subExt) ->

679 gatherFields context (Map.union fields subFields) subExt

653 gatherFields context (Map.union fields subFields) subExt

680

654