086c50d · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Merge pull request #1136 from elm-lang/dev

086c50dEvan Czaplicki11 years ago

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

compare with master

unifiedsplit

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

47 "MISSING PATTERNS"

48 Nothing

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

50− (text (unhandledError unhandled newTagsMessage))

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

52 Redundant ->

53 Report.report

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

74 ++ "\n"

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

76 ++ 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!"

80toCaseMessage :: String

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

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

85−newTagsMessage :: String

85+missingBranchesMessage :: Int -> String

86−newTagsMessage =

86+missingBranchesMessage numUnhandled =

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

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

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

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

22data Error

23 = Mismatch Mismatch

24 | BadMain Type.Canonical

25− | InfiniteType

25+ | InfiniteType String Type.Canonical

26− { _name :: String

27− , _overallType :: Type.Canonical

28− , _infiniteType :: Type.Canonical

29− }

32data Mismatch = MismatchInfo

28data Mismatch = MismatchInfo

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

94 Mismatch info ->

90 Mismatch info ->

95 mismatchToReport localizer info

91 mismatchToReport localizer info

97− InfiniteType name overallType infiniteType ->

93+ InfiniteType name overallType ->

98− infiniteTypeToReport localizer name overallType infiniteType

94+ infiniteTypeToReport localizer name overallType

100 BadMain tipe ->

96 BadMain tipe ->

101 Report.report

97 Report.report

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

576 :: RenderType.Localizer

572 :: RenderType.Localizer

577 -> String

573 -> String

578 -> Type.Canonical

574 -> Type.Canonical

579− -> Type.Canonical

580 -> Report.Report

575 -> Report.Report

581−infiniteTypeToReport localizer name overallType infiniteType =

576+infiniteTypeToReport localizer name overallType =

582 Report.report

577 Report.report

583 "INFINITE TYPE"

578 "INFINITE TYPE"

584 Nothing

579 Nothing

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

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

586 )

581 )

587− ( Help.stack $

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

588− explainInfiniteType localizer name overallType infiniteType

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

589− ++

587+ , Help.reflowParagraph $

590− [ text $

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

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

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

592 ++ Help.hintLink "infinite-type"

590 ++ Help.hintLink "infinite-type"

593 ]

591 ]

594 )

592 )

595

593

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

1module Type.Solve (solve) where

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

4import Control.Monad

3import Control.Monad

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

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

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

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

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

296

295

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

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

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

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

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

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

300− case maybeInfinite of

299+ case isInfinite of

301− Nothing ->

300+ False ->

302 return ()

301 return ()

303

302

304− Just infiniteType ->

303+ True ->

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

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

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

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

307

306

308

307

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

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

310occursHelp seen var =

309occursHelp seen var =

311 if elem var seen then

310 if elem var seen then

312 do infiniteDescriptor <- UF.descriptor var

311 do infiniteDescriptor <- UF.descriptor var

313− structureVar <- UF.fresh infiniteDescriptor

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

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

315− srcVar <- Type.toSrcType structureVar

316− return (Just srcVar)

313+ return True

317

314

318 else

315 else

319 do desc <- UF.descriptor var

316 do desc <- UF.descriptor var

320 case _content desc of

317 case _content desc of

321 Atom _ ->

318 Atom _ ->

322− return Nothing

319+ return False

323

320

324 Var _ _ _ ->

321 Var _ _ _ ->

325− return Nothing

322+ return False

326

323

327 Error ->

324 Error ->

328− return Nothing

325+ return False

329

326

330 Alias _ args _ ->

327 Alias _ args _ ->

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

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

333

330

334 Structure term ->

331 Structure term ->

335 let

332 let

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

337 in

334 in

338 case term of

335 case term of

339 App1 a b ->

336 App1 a b ->

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

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

341

338

342 Fun1 a b ->

339 Fun1 a b ->

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

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

344

341

345 EmptyRecord1 ->

342 EmptyRecord1 ->

346− return Nothing

343+ return False

347

344

348 Record1 fields ext ->

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

1{-# OPTIONS_GHC -Wall #-}

2module Type.Type where

4−import Control.Monad.State (StateT)

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

5import qualified Control.Monad.State as State

6import qualified Data.List as List

7import qualified Data.Map as Map

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

108initialMark = 1

109

110

111+occursMark :: Int

112+occursMark =

113+ -1

114+

115+

116+getVarNamesMark :: Int

117+getVarNamesMark =

118+ -2

119+

120+

111

121

112-- CONSTRAINTS

122-- CONSTRAINTS

113

123

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

255

265

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

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

257variableToSrcType variable =

267variableToSrcType variable =

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

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

259− case _content descriptor of

275+ srcType <- contentToSrcType variable (_content descriptor)

260− Structure term ->

276+ liftIO $ UF.setDescriptor variable descriptor

261− termToSrcType term

277+ return srcType

278+

262

279

263− Atom name ->

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

264− return (T.Type name)

281+contentToSrcType variable content =

282+ case content of

283+ Structure term ->

284+ termToSrcType term

265

285

266− Var _ _ (Just name) ->

286+ Atom name ->

267− return (T.Var name)

287+ return (T.Type name)

268

288

269− Var flex maybeSuper Nothing ->

289+ Var _ _ (Just name) ->

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)

290+ return (T.Var name)

274

291

275− Alias name args realVariable ->

292+ Var flex maybeSuper Nothing ->

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

293+ do freshName <- getFreshName maybeSuper

277− srcType <- variableToSrcType realVariable

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

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

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

296+ return (T.Var freshName)

279

297

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+

280− Error ->

303+ Error ->

281− return (T.Var "?")

304+ return (T.Var "?")

282

305

283

306

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

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

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

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

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

382getVarNames var =

405getVarNames var =

383 do desc <- UF.descriptor var

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

384

415

385− case _content desc of

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

417+getVarNamesHelp content =

418+ case content of

386− Var _ _ (Just name) ->

419+ Var _ _ (Just name) ->

387− return (Set.singleton name)

420+ return (Set.singleton name)

388

421

389− Var _ _ Nothing ->

422+ Var _ _ Nothing ->

390− return Set.empty

423+ return Set.empty

391

424

392− Structure term ->

425+ Structure term ->

393− getVarNamesTerm term

426+ getVarNamesTerm term

394

427

395− Alias _name args realVar ->

428+ Alias _name args realVar ->

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

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

397− realSet <- getVarNames realVar

430+ realSet <- getVarNames realVar

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

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

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

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

400

433

401− Atom _ ->

434+ Atom _ ->

402− return Set.empty

435+ return Set.empty

403

436

404− Error ->

437+ Error ->

405− return Set.empty

438+ return Set.empty

406

439

407

440

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

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