4c2e9ad · elk · git.iko.soy

git.iko.soy/elk

Fix #832, compiler hangs on certain infinite types

It seems that all the type inference stuff was going fine, but when it came time to actually print out the type, things were recursing infinitely. So this adds some checks on Type.toSrcType to make sure that you cannot go totally off the rails.

commit4c2e9adb0912cbe670995cd83273a8c64a3d705d authorEvan Czaplicki <info@elm-lang.org> dateWed 28 Oct 2015, 01:30 (11 years ago) parentb091dea

3 files changed+96−99

compare with master

unifiedsplit

src/Reporting/Error/Type.hs+12−45 src/Type/Solve.hs+15−18 src/Type/Type.hs+69−36

src/Reporting/Error/Type.hs+12−45

@@ -22,11 +22,7 @@ import qualified Reporting.Report as Report

2222data Error

2323 = Mismatch Mismatch

2424 | BadMain Type.Canonical

25− | InfiniteType

26− { _name :: String

27− , _overallType :: Type.Canonical

28− , _infiniteType :: Type.Canonical

29− }

25+ | InfiniteType String Type.Canonical

3026

3127

3228data Mismatch = MismatchInfo

@@ -94,8 +90,8 @@ toReport localizer err =

9490 Mismatch info ->

9591 mismatchToReport localizer info

9692

97− InfiniteType name overallType infiniteType ->

98− infiniteTypeToReport localizer name overallType infiniteType

93+ InfiniteType name overallType ->

94+ infiniteTypeToReport localizer name overallType

9995

10096 BadMain tipe ->

10197 Report.report

@@ -576,51 +572,22 @@ infiniteTypeToReport

576572 :: RenderType.Localizer

577573 -> String

578574 -> Type.Canonical

579− -> Type.Canonical

580575 -> Report.Report

581−infiniteTypeToReport localizer name overallType infiniteType =

576+infiniteTypeToReport localizer name overallType =

582577 Report.report

583578 "INFINITE TYPE"

584579 Nothing

585580 ( "I am inferring a weird self-referential type for " ++ Help.functionName name

586581 )

587− ( Help.stack $

588− explainInfiniteType localizer name overallType infiniteType

589− ++

590− [ text $

591− "This can be very tricky to figure out, so definitely read the debugging hints:\n"

582+ ( Help.stack

583+ [ Help.reflowParagraph $

584+ "Here is my best effort at writing down the type. You will see ? and ∞ for\

585+ \ parts of the type that repeat something already printed out infinitely."

586+ , indent 4 (RenderType.toDoc localizer overallType)

587+ , Help.reflowParagraph $

588+ "Usually staring at the type is not so helpful in these cases, so definitely\

589+ \ read the debugging hints for ideas on how to figure this out: "

592590 ++ Help.hintLink "infinite-type"

593591 ]

594592 )

595593

596−

597−explainInfiniteType

598− :: RenderType.Localizer

599− -> String

600− -> Type.Canonical

601− -> Type.Canonical

602− -> [Doc]

603−explainInfiniteType localizer name overallType infiniteType =

604− let

605− selfReference =

606− text "?" <+> equals <+> RenderType.toDoc localizer infiniteType

607− in

608− case overallType of

609− Type.Var "?" ->

610− [ Help.reflowParagraph $

611− "I cannot write down the actual type of " ++ Help.functionName name ++

612− " because it is infinitely large (that's the problem!) so here it\

613− \ is as an equation where `?` represents the type:"

614− , indent 4 selfReference

615− ]

616−

617− _ ->

618− [ Help.reflowParagraph $

619− "I am inferring that " ++ Help.functionName name ++ " has this type:"

620− , indent 4 (RenderType.toDoc localizer overallType)

621− , Help.reflowParagraph $

622− "The problem is in the `?` which seems to contain itself. I cannot show\

623− \ you that type directly (because it is infinitely large!) so here it is\

624− \ as an equation:"

625− , indent 4 selfReference

626− ]

src/Type/Solve.hs+15−18

@@ -1,6 +1,5 @@

11module Type.Solve (solve) where

3−import Control.Applicative ((<|>))

43import Control.Monad

54import Control.Monad.State (execStateT, liftIO)

65import Control.Monad.Except (ExceptT, throwError)

@@ -296,40 +295,38 @@ crash msg =

296295

297296occurs :: (String, A.Located Variable) -> TS.Solver ()

298297occurs (name, A.A region variable) =

299− do maybeInfinite <- liftIO $ occursHelp [] variable

300− case maybeInfinite of

301− Nothing ->

298+ do isInfinite <- liftIO $ occursHelp [] variable

299+ case isInfinite of

300+ False ->

302301 return ()

303302

304− Just infiniteType ->

303+ True ->

305304 do overallType <- liftIO (Type.toSrcType variable)

306− TS.addError region (Error.InfiniteType name overallType infiniteType)

305+ TS.addError region (Error.InfiniteType name overallType)

307306

308307

309−occursHelp :: [Variable] -> Variable -> IO (Maybe Type.Canonical)

308+occursHelp :: [Variable] -> Variable -> IO Bool

310309occursHelp seen var =

311310 if elem var seen then

312311 do infiniteDescriptor <- UF.descriptor var

313− structureVar <- UF.fresh infiniteDescriptor

314312 UF.setDescriptor var (infiniteDescriptor { _content = Error })

315− srcVar <- Type.toSrcType structureVar

316− return (Just srcVar)

313+ return True

317314

318315 else

319316 do desc <- UF.descriptor var

320317 case _content desc of

321318 Atom _ ->

322− return Nothing

319+ return False

323320

324321 Var _ _ _ ->

325− return Nothing

322+ return False

326323

327324 Error ->

328− return Nothing

325+ return False

329326

330327 Alias _ args _ ->

331328 -- TODO is it okay to only check args?

332− F.asum <$> mapM (occursHelp (var:seen) . snd) args

329+ or <$> mapM (occursHelp (var:seen) . snd) args

333330

334331 Structure term ->

335332 let

@@ -337,13 +334,13 @@ occursHelp seen var =

337334 in

338335 case term of

339336 App1 a b ->

340− (<|>) <$> go a <*> go b

337+ (||) <$> go a <*> go b

341338

342339 Fun1 a b ->

343− (<|>) <$> go a <*> go b

340+ (||) <$> go a <*> go b

344341

345342 EmptyRecord1 ->

346− return Nothing

343+ return False

347344

348345 Record1 fields ext ->

349− F.asum <$> mapM go (ext : Map.elems fields)

346+ or <$> mapM go (ext : Map.elems fields)

src/Type/Type.hs+69−36

@@ -1,7 +1,7 @@

11{-# OPTIONS_GHC -Wall #-}

22module Type.Type where

4−import Control.Monad.State (StateT)

4+import Control.Monad.State (StateT, liftIO)

55import qualified Control.Monad.State as State

66import qualified Data.List as List

77import qualified Data.Map as Map

@@ -108,6 +108,16 @@ initialMark :: Int

108108initialMark = 1

109109

110110

111+occursMark :: Int

112+occursMark =

113+ -1

114+

115+

116+getVarNamesMark :: Int

117+getVarNamesMark =

118+ -2

119+

120+

111121

112122-- CONSTRAINTS

113123

@@ -255,30 +265,43 @@ toSrcType variable =

255265

256266variableToSrcType :: Variable -> StateT NameState IO T.Canonical

257267variableToSrcType variable =

258− do descriptor <- State.liftIO (UF.descriptor variable)

259− case _content descriptor of

260− Structure term ->

261− termToSrcType term

268+ do descriptor <- liftIO $ UF.descriptor variable

269+ if _mark descriptor == occursMark

270+ then

271+ return (T.Var "∞")

272+

273+ else

274+ do liftIO $ UF.setDescriptor variable (descriptor { _mark = occursMark })

275+ srcType <- contentToSrcType variable (_content descriptor)

276+ liftIO $ UF.setDescriptor variable descriptor

277+ return srcType

278+

262279

263− Atom name ->

264− return (T.Type name)

280+contentToSrcType :: Variable -> Content -> StateT NameState IO T.Canonical

281+contentToSrcType variable content =

282+ case content of

283+ Structure term ->

284+ termToSrcType term

265285

266− Var _ _ (Just name) ->

267− return (T.Var name)

286+ Atom name ->

287+ return (T.Type name)

268288

269− Var flex maybeSuper Nothing ->

270− do freshName <- getFreshName maybeSuper

271− State.liftIO $ UF.modifyDescriptor variable $ \desc ->

272− desc { _content = Var flex maybeSuper (Just freshName) }

273− return (T.Var freshName)

289+ Var _ _ (Just name) ->

290+ return (T.Var name)

274291

275− Alias name args realVariable ->

276− do srcArgs <- mapM (\(arg,tvar) -> (,) arg <$> variableToSrcType tvar) args

277− srcType <- variableToSrcType realVariable

278− return (T.Aliased name srcArgs (T.Filled srcType))

292+ Var flex maybeSuper Nothing ->

293+ do freshName <- getFreshName maybeSuper

294+ liftIO $ UF.modifyDescriptor variable $ \desc ->

295+ desc { _content = Var flex maybeSuper (Just freshName) }

296+ return (T.Var freshName)

279297

280− Error ->

281− return (T.Var "?")

298+ Alias name args realVariable ->

299+ do srcArgs <- mapM (\(arg,tvar) -> (,) arg <$> variableToSrcType tvar) args

300+ srcType <- variableToSrcType realVariable

301+ return (T.Aliased name srcArgs (T.Filled srcType))

302+

303+ Error ->

304+ return (T.Var "?")

282305

283306

284307termToSrcType :: Term1 Variable -> StateT NameState IO T.Canonical

@@ -381,28 +404,38 @@ getFreshName maybeSuper =

381404getVarNames :: Variable -> IO (Set.Set String)

382405getVarNames var =

383406 do desc <- UF.descriptor var

407+ if _mark desc == getVarNamesMark

408+ then

409+ return Set.empty

410+

411+ else

412+ do UF.setDescriptor var (desc { _mark = getVarNamesMark })

413+ getVarNamesHelp (_content desc)

414+

384415

385− case _content desc of

386− Var _ _ (Just name) ->

387− return (Set.singleton name)

416+getVarNamesHelp :: Content -> IO (Set.Set String)

417+getVarNamesHelp content =

418+ case content of

419+ Var _ _ (Just name) ->

420+ return (Set.singleton name)

388421

389− Var _ _ Nothing ->

390− return Set.empty

422+ Var _ _ Nothing ->

423+ return Set.empty

391424

392− Structure term ->

393− getVarNamesTerm term

425+ Structure term ->

426+ getVarNamesTerm term

394427

395− Alias _name args realVar ->

396− do let argSet = Set.fromList (map fst args)

397− realSet <- getVarNames realVar

398− sets <- mapM (getVarNames . snd) args

399− return (Set.unions (realSet : argSet : sets))

428+ Alias _name args realVar ->

429+ do let argSet = Set.fromList (map fst args)

430+ realSet <- getVarNames realVar

431+ sets <- mapM (getVarNames . snd) args

432+ return (Set.unions (realSet : argSet : sets))

400433

401− Atom _ ->

402− return Set.empty

434+ Atom _ ->

435+ return Set.empty

403436

404− Error ->

405− return Set.empty

437+ Error ->

438+ return Set.empty

406439

407440

408441getVarNamesTerm :: Term1 Variable -> IO (Set.Set String)