086c50d · elk · git.iko.soy

git.iko.soy/elk

Merge pull request #1136 from elm-lang/dev

Fix infinite type issues

commit086c50d7bdfbd3b135dcf0475428d1092878cd28 authorEvan Czaplicki <info@elm-lang.org> dateWed 28 Oct 2015, 03:20 (11 years ago) parent0206049 4c2e9ad

4 files changed+105−104

compare with master

unifiedsplit

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

src/Reporting/Error/Pattern.hs+9−5

@@ -47,7 +47,7 @@ toReport _localizer err =

4747 "MISSING PATTERNS"

4848 Nothing

4949 "This `case` does not have branches for all possibilities."

50− (text (unhandledError unhandled newTagsMessage))

50+ (text (unhandledError unhandled (missingBranchesMessage (length unhandled))))

5151

5252 Redundant ->

5353 Report.report

@@ -74,7 +74,7 @@ unhandledError unhandledPatterns relevantMessage =

7474 ++ "\n"

7575 ++ "If you are seeing this error for the first time, check out these hints:\n"

7676 ++ Help.hintLink "missing-patterns" ++ "\n"

77− ++ "The recommendations about `Debug.crash` and wildcard patterns are important!"

77+ ++ "The recommendations about wildcard patterns and `Debug.crash` are important!"

7878

7979

8080toCaseMessage :: String

@@ -82,7 +82,11 @@ toCaseMessage =

8282 "Switch to a `case` expression to handle all possible patterns."

8383

8484

85−newTagsMessage :: String

86−newTagsMessage =

87− "Did you add a new tag to a union type? Add a branch for it here!"

85+missingBranchesMessage :: Int -> String

86+missingBranchesMessage numUnhandled =

87+ if numUnhandled == 1 then

88+ "Add a branch to cover this pattern!"

89+

90+ else

91+ "Add branches to cover each of these patterns!"

8892

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)