c62bea9 · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Show proper errors for infinite types again

c62bea9Evan Czaplicki11 years ago

src/Reporting/Error/Type.hs+28−9

compare with master

unifiedsplit

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

1{-# OPTIONS_GHC -Wall #-}

2module Reporting.Error.Type where

4+import Text.PrettyPrint ((<+>))

4import qualified Text.PrettyPrint as P

5import qualified Text.PrettyPrint as P

6import qualified AST.Helpers as Help

7import qualified AST.Helpers as Help

@@ -13,7 +14,7 @@ import qualified Reporting.Report as Report

14data Error

15data Error

15 = Mismatch Mismatch

16 = Mismatch Mismatch

16− | InfiniteType String Type.Canonical

17+ | InfiniteType InfiniteType

17 | BadMain Type.Canonical

18 | BadMain Type.Canonical

@@ -25,6 +26,13 @@ data Mismatch = MismatchInfo

25 }

26 }

29+data InfiniteType = InfiniteTypeInfo

30+ { _name :: String

31+ , _var :: Type.Canonical

32+ , _type :: Type.Canonical

33+ }

34+

35+

28data Hint

36data Hint

29 = None

37 = None

30 | CaseBranch Int Region.Region

38 | CaseBranch Int Region.Region

@@ -73,14 +81,25 @@ toReport dealiaser err =

73 PostNote msg ->

81 PostNote msg ->

74 Report.Report "TYPE MISMATCH" subRegion preHint (postHint ++ "\n\n" ++ msg)

82 Report.Report "TYPE MISMATCH" subRegion preHint (postHint ++ "\n\n" ++ msg)

76− InfiniteType var tipe ->

84+ InfiniteType (InfiniteTypeInfo name var tipe) ->

85+ let

86+ prettyVar =

87+ P.pretty dealiaser False var

88+

89+ prettyType =

90+ P.pretty dealiaser False tipe

91+ in

77− Report.simple "INFINITE TYPE" "This expression is leading me to infer an infinite type." $

92+ Report.simple "INFINITE TYPE"

78− "Maybe you are trying to do some tricky recursion? Try breaking the expression\n"

93+ ( "I am inferring weird self-referential type for '" ++ name ++ "'"

94+ )

95+ ( "The bit of the type that is self-referential looks like this:\n\n"

96+ ++ P.render (P.nest 4 (prettyVar <+> P.equals <+> prettyType))

97+ ++ "\n\nThe cause is often that the usage of '" ++ name ++ "' is flipped around.\n\n"

98+ ++ "Maybe you are inserting a data structure into an element? Maybe you are giving\n"

99+ ++ "a function to an argument? Either way, something is probably backwards!\n\n"

100+ ++ "Try breaking the code related to '" ++ name ++ "' into smaller pieces.\n"

79− ++ "into smaller pieces. Give each piece a name and try to write down its type.\n\n"

101+ ++ "Give each piece a name and try to write down its type."

80− ++ "Type inference got stuck when type '" ++ var ++ "' needed equal to:\n\n"

102+ )

81− ++ P.render (P.nest 4 (P.pretty dealiaser False tipe))

82− ++ "\n\nNotice that type variable '" ++ var ++ "' appears there too, so if we\n"

83− ++ "expanded this type, it would just keep getting bigger and bigger."

103

85 BadMain tipe ->

104 BadMain tipe ->

86 Report.simple "BAD MAIN TYPE" "The 'main' value has an unsupported type." $

105 Report.simple "BAD MAIN TYPE" "The 'main' value has an unsupported type." $

src/Type/Constrain/Expression.hs+14−11

@@ -175,7 +175,8 @@ constrain env (A.A region expression) tipe =

175 (Info [] [] [] Map.empty CTrue CTrue)

176 (concatMap expandPattern defs)

177

178+ let letScheme =

178− let letScheme = [ Scheme rqs fqs (CLet [monoscheme headers] c2) headers ]

179+ [ Scheme rqs fqs (CLet [monoscheme headers] c2) headers ]

179

180

180 return $ CLet schemes (CLet letScheme (c1 /\ bodyCon))

181 return $ CLet schemes (CLet letScheme (c1 /\ bodyCon))

181

182

@@ -409,22 +410,22 @@ data Info = Info

409 { iSchemes :: [TypeScheme]

410 { iSchemes :: [TypeScheme]

410 , iRigid :: [Variable]

411 , iRigid :: [Variable]

411 , iFlex :: [Variable]

412 , iFlex :: [Variable]

412− , iHeaders :: Map.Map String Type

413+ , iHeaders :: Map.Map String (A.Located Type)

413 , iC2 :: TypeConstraint

414 , iC2 :: TypeConstraint

414 , iC1 :: TypeConstraint

415 , iC1 :: TypeConstraint

415 }

416 }

416

417

418

418constrainDef :: Env.Environment -> Info -> Canonical.Def -> IO Info

419constrainDef :: Env.Environment -> Info -> Canonical.Def -> IO Info

419−constrainDef env info (Canonical.Definition (A.A _ pattern) expr maybeTipe) =

420+constrainDef env info (Canonical.Definition (A.A patternRegion pattern) expr maybeTipe) =

420 let qs = [] -- should come from the def, but I'm not sure what would live there...

421 let qs = [] -- should come from the def, but I'm not sure what would live there...

421 in

422 in

422 case (pattern, maybeTipe) of

423 case (pattern, maybeTipe) of

423− (P.Var name, Just (A.A region tipe)) ->

424+ (P.Var name, Just (A.A typeRegion tipe)) ->

424− constrainAnnotatedDef env info qs region name expr tipe

425+ constrainAnnotatedDef env info qs patternRegion typeRegion name expr tipe

425

426

426 (P.Var name, Nothing) ->

427 (P.Var name, Nothing) ->

427− constrainUnannotatedDef env info qs name expr

428+ constrainUnannotatedDef env info qs patternRegion name expr

428

429

429 _ -> error ("problem in constrainDef with " ++ show pattern)

430 _ -> error ("problem in constrainDef with " ++ show pattern)

430

431

@@ -434,11 +435,12 @@ constrainAnnotatedDef

434 -> Info

435 -> Info

435 -> [String]

436 -> [String]

436 -> R.Region

437 -> R.Region

438+ -> R.Region

437 -> String

439 -> String

438 -> Canonical.Expr

440 -> Canonical.Expr

439 -> ST.Canonical

441 -> ST.Canonical

440 -> IO Info

442 -> IO Info

441−constrainAnnotatedDef env info qs region name expr tipe =

443+constrainAnnotatedDef env info qs patternRegion typeRegion name expr tipe =

442 do -- Some mistake may be happening here. Currently, qs is always [].

444 do -- Some mistake may be happening here. Currently, qs is always [].

443 rigidVars <- Monad.forM qs (\_ -> variable Rigid)

445 rigidVars <- Monad.forM qs (\_ -> variable Rigid)

444

446

@@ -455,13 +457,13 @@ constrainAnnotatedDef env info qs region name expr tipe =

455 { rigidQuantifiers = []

457 { rigidQuantifiers = []

456 , flexibleQuantifiers = flexiVars ++ vars

458 , flexibleQuantifiers = flexiVars ++ vars

457 , constraint = CTrue

459 , constraint = CTrue

458− , header = Map.singleton name typ

460+ , header = Map.singleton name (A.A patternRegion typ)

459 }

461 }

460

462

461 var <- variable Flexible

463 var <- variable Flexible

462 defCon <- constrain env' expr (varN var)

464 defCon <- constrain env' expr (varN var)

463 let annCon =

465 let annCon =

464− CEqual (Error.BadTypeAnnotation name) region typ (varN var)

466+ CEqual (Error.BadTypeAnnotation name) typeRegion typ (varN var)

465

467

466 return $ info

468 return $ info

467 { iSchemes = scheme : iSchemes info

469 { iSchemes = scheme : iSchemes info

@@ -473,10 +475,11 @@ constrainUnannotatedDef

473 :: Env.Environment

475 :: Env.Environment

474 -> Info

476 -> Info

475 -> [String]

477 -> [String]

478+ -> R.Region

476 -> String

479 -> String

477 -> Canonical.Expr

480 -> Canonical.Expr

478 -> IO Info

481 -> IO Info

479−constrainUnannotatedDef env info qs name expr =

482+constrainUnannotatedDef env info qs patternRegion name expr =

480 do -- Some mistake may be happening here. Currently, qs is always [].

483 do -- Some mistake may be happening here. Currently, qs is always [].

481 rigidVars <- Monad.forM qs (\_ -> variable Rigid)

484 rigidVars <- Monad.forM qs (\_ -> variable Rigid)

482

485

@@ -493,6 +496,6 @@ constrainUnannotatedDef env info qs name expr =

493 return $ info

496 return $ info

494 { iRigid = rigidVars ++ iRigid info

497 { iRigid = rigidVars ++ iRigid info

495 , iFlex = v : iFlex info

498 , iFlex = v : iFlex info

496− , iHeaders = Map.insert name tipe (iHeaders info)

499+ , iHeaders = Map.insert name (A.A patternRegion tipe) (iHeaders info)

497 , iC2 = con /\ iC2 info

500 , iC2 = con /\ iC2 info

498 }

501 }

src/Type/Constrain/Pattern.hs+9−5

@@ -22,7 +22,11 @@ constrain

22 -> Type

23 -> IO Fragment

24constrain env (A.A region pattern) tipe =

25+ let

25− let (===) = CEqual Error.None region

26+ (===) = CEqual Error.None region

27+

28+ rvar v =

29+ A.A region (varN v)

26 in

30 in

27 case pattern of

31 case pattern of

28 P.Anything ->

32 P.Anything ->

@@ -35,7 +39,7 @@ constrain env (A.A region pattern) tipe =

35 P.Var name ->

39 P.Var name ->

36 do v <- variable Flexible

40 do v <- variable Flexible

37 return $ Fragment

41 return $ Fragment

38− { typeEnv = Map.singleton name (varN v)

42+ { typeEnv = Map.singleton name (rvar v)

39 , vars = [v]

43 , vars = [v]

40 , typeConstraint = varN v === tipe

44 , typeConstraint = varN v === tipe

41 }

45 }

@@ -44,7 +48,7 @@ constrain env (A.A region pattern) tipe =

44 do v <- variable Flexible

48 do v <- variable Flexible

45 fragment <- constrain env p tipe

49 fragment <- constrain env p tipe

46 return $ fragment

50 return $ fragment

47− { typeEnv = Map.insert name (varN v) (typeEnv fragment)

51+ { typeEnv = Map.insert name (rvar v) (typeEnv fragment)

48 , vars = v : vars fragment

52 , vars = v : vars fragment

49 , typeConstraint = varN v === tipe /\ typeConstraint fragment

53 , typeConstraint = varN v === tipe /\ typeConstraint fragment

50 }

54 }

@@ -62,8 +66,8 @@ constrain env (A.A region pattern) tipe =

63 P.Record fields ->

67 P.Record fields ->

64 do pairs <- mapM (\name -> (,) name <$> variable Flexible) fields

68 do pairs <- mapM (\name -> (,) name <$> variable Flexible) fields

65− let tenv = Map.fromList (map (second varN) pairs)

69+ let tenv = Map.fromList (map (second rvar) pairs)

66− c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)

70+ c <- exists $ \t -> return (tipe === record (Map.map (\v -> [A.drop v]) tenv) t)

67 return $ Fragment

71 return $ Fragment

68 { typeEnv = tenv

72 { typeEnv = tenv

69 , vars = map snd pairs

73 , vars = map snd pairs

src/Type/Fragment.hs+2−1

@@ -4,11 +4,12 @@ module Type.Fragment where

4import qualified Data.List as List

5import qualified Data.Map as Map

7+import Reporting.Annotation as A

7import Type.Type

8import Type.Type

10data Fragment = Fragment

11data Fragment = Fragment

11− { typeEnv :: Map.Map String Type

12+ { typeEnv :: Map.Map String (A.Located Type)

12 , vars :: [Variable]

13 , vars :: [Variable]

13 , typeConstraint :: TypeConstraint

14 , typeConstraint :: TypeConstraint

14 }

15 }

src/Type/Inference.hs+2−2

@@ -33,7 +33,7 @@ infer interfaces modul =

33 state <- Solve.solve constraint

35 let header' = Map.delete "::" header

36− let types = Map.difference (TS.sSavedEnv state) header'

36+ let types = Map.map A.drop (Map.difference (TS.sSavedEnv state) header')

38 liftIO (Traverse.traverse T.toSrcType types)

@@ -57,7 +57,7 @@ genConstraints interfaces modul =

57 let allTypes = concat (ctors : importedVars)

58 let vars = concatMap (fst . snd) allTypes

59 let header = Map.map snd (Map.fromList allTypes)

60− let environ = T.CLet [ T.Scheme vars [] T.CTrue header ]

60+ let environ = T.CLet [ T.Scheme vars [] T.CTrue (Map.map (A.A undefined) header) ]

62 fvar <- T.variable T.Flexible

src/Type/Solve.hs+53−37

@@ -1,14 +1,16 @@

1module Type.Solve (solve) where

3−import Control.Applicative ((<$>), (<*>))

3+import Control.Applicative ((<$>), (<*>), (<|>))

4import Control.Monad

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

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

7+import qualified Data.Foldable as F

7import qualified Data.List as List

8import qualified Data.List as List

8import qualified Data.Map as Map

9import qualified Data.Map as Map

9−import qualified Data.Traversable as Traversable

10+import qualified Data.Traversable as T

10import qualified Data.UnionFind.IO as UF

11import qualified Data.UnionFind.IO as UF

13+import qualified AST.Type as Type

12import qualified Reporting.Annotation as A

14import qualified Reporting.Annotation as A

13import qualified Reporting.Error.Type as Error

15import qualified Reporting.Error.Type as Error

14import qualified Type.State as TS

16import qualified Type.State as TS

@@ -45,7 +47,7 @@ generalize youngPool =

45 if isRedundant then return var else TS.register var

47 if isRedundant then return var else TS.register var

47 let rankDict' = Map.delete youngRank rankDict

49 let rankDict' = Map.delete youngRank rankDict

48− Traversable.traverse (mapM registerIfNotRedundant) rankDict'

50+ T.traverse (mapM registerIfNotRedundant) rankDict'

50 -- For variables with rank youngRank

52 -- For variables with rank youngRank

51 -- If rank < youngRank: register in oldPool

53 -- If rank < youngRank: register in oldPool

@@ -159,8 +161,9 @@ actuallySolve constraint =

159 do env <- TS.getEnv

161 do env <- TS.getEnv

160 freshCopy <-

162 freshCopy <-

161 case Map.lookup name env of

163 case Map.lookup name env of

162− Just tipe ->

164+ Just (A.A _ tipe) ->

163 TS.makeInstance tipe

165 TS.makeInstance tipe

166+

164 Nothing ->

167 Nothing ->

165 if List.isPrefixOf "Native." name

168 if List.isPrefixOf "Native." name

166 then liftIO (variable Flexible)

169 then liftIO (variable Flexible)

@@ -170,12 +173,18 @@ actuallySolve constraint =

170 unify Error.None region freshCopy t

173 unify Error.None region freshCopy t

171

174

172

175

176+solveScheme

177+ :: TypeScheme

173−solveScheme :: TypeScheme -> StateT TS.SolverState IO (Map.Map String Variable)

178+ -> StateT TS.SolverState IO (Map.Map String (A.Located Variable))

174solveScheme scheme =

179solveScheme scheme =

180+ let

181+ flatten (A.A region term) =

182+ A.A region <$> TS.flatten term

183+ in

175 case scheme of

184 case scheme of

176 Scheme [] [] constraint header ->

185 Scheme [] [] constraint header ->

177 do actuallySolve constraint

186 do actuallySolve constraint

178− Traversable.traverse TS.flatten header

187+ T.traverse flatten header

179

188

180 Scheme rigidQuantifiers flexibleQuantifiers constraint header ->

189 Scheme rigidQuantifiers flexibleQuantifiers constraint header ->

181 do let quantifiers = rigidQuantifiers ++ flexibleQuantifiers

190 do let quantifiers = rigidQuantifiers ++ flexibleQuantifiers

@@ -185,7 +194,7 @@ solveScheme scheme =

185 freshPool <- TS.nextRankPool

194 freshPool <- TS.nextRankPool

186 TS.switchToPool freshPool

195 TS.switchToPool freshPool

187 mapM TS.introduce quantifiers

196 mapM TS.introduce quantifiers

188− header' <- Traversable.traverse TS.flatten header

197+ header' <- T.traverse flatten header

189 actuallySolve constraint

198 actuallySolve constraint

190

199

191 allDistinct rigidQuantifiers

200 allDistinct rigidQuantifiers

@@ -234,46 +243,53 @@ crash msg =

234 ++ "<https://github.com/elm-lang/elm-compiler/issues>"

243 ++ "<https://github.com/elm-lang/elm-compiler/issues>"

235

244

236

245

237−occurs :: (String, Variable) -> StateT TS.SolverState IO ()

246+occurs :: (String, A.Located Variable) -> StateT TS.SolverState IO ()

238−occurs (_name, variable) =

247+occurs (name, A.A region variable) =

239− do vars <- liftIO $ infiniteVars [] variable

248+ do maybePair <- liftIO $ occursHelp [] variable

240− case vars of

249+ case maybePair of

241− [] ->

250+ Nothing ->

242− return ()

251+ return ()

243−

252+

244− var : _ ->

253+ Just (t1, t2) ->

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

254+ let

246− let region = error "TODO:occurs"

255+ info = Error.InfiniteTypeInfo name t1 t2

247− case structure desc of

248− Nothing ->

249− TS.addError region (Error.InfiniteType undefined (error "TODO:occurs"))

250−

251− Just _ ->

252− TS.addError region (Error.InfiniteType undefined (error "TODO:occurs"))

253− where

254− infiniteVars :: [Variable] -> Variable -> IO [Variable]

255− infiniteVars seen var =

256− let go = infiniteVars (var:seen)

257− in

256+ in

257+ TS.addError region (Error.InfiniteType info)

258+

259+

260+occursHelp

261+ :: [Variable]

262+ -> Variable

263+ -> IO (Maybe (Type.Canonical, Type.Canonical))

264+occursHelp seen var =

258− if var `elem` seen

265+ if elem var seen then

259− then return [var]

266+ do desc <- UF.descriptor var

267+ UF.setDescriptor var (desc { structure = Nothing })

268+ var' <- UF.fresh desc

269+ srcVar <- toSrcType var

270+ srcVar' <- toSrcType var'

271+ return (Just (srcVar, srcVar'))

260− else do

272+ else

261− desc <- UF.descriptor var

273+ do desc <- UF.descriptor var

262 case structure desc of

274 case structure desc of

263− Nothing -> return []

275+ Nothing ->

276+ return Nothing

277+

264 Just struct ->

278 Just struct ->

279+ let go = occursHelp (var:seen)

280+ in

265 case struct of

281 case struct of

266 App1 a b ->

282 App1 a b ->

267− (++) <$> go a <*> go b

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

268

284

269 Fun1 a b ->

285 Fun1 a b ->

270− (++) <$> go a <*> go b

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

271

287

272 Var1 a ->

288 Var1 a ->

273 go a

289 go a

274

290

275 EmptyRecord1 ->

291 EmptyRecord1 ->

276− return []

292+ return Nothing

277

293

278 Record1 fields ext ->

294 Record1 fields ext ->

279− concat <$> mapM go (ext : concat (Map.elems fields))

295+ F.asum <$> mapM go (ext : concat (Map.elems fields))

src/Type/State.hs+1−1

@@ -33,7 +33,7 @@ emptyPool =

33 }

36−type Env = Map.Map String Variable

36+type Env = Map.Map String (A.Located Variable)

39-- Keeps track of the environment, type variable pool, and a list of errors

src/Type/Type.hs+5−4

@@ -13,6 +13,7 @@ import System.IO.Unsafe

14import qualified AST.Type as T

15import qualified AST.Variable as Var

16+import qualified Reporting.Annotation as A

16import qualified Reporting.Error.Type as Error

17import qualified Reporting.Error.Type as Error

17import qualified Reporting.Region as R

18import qualified Reporting.Region as R

18import Type.PrettyPrint

19import Type.PrettyPrint

@@ -118,7 +119,7 @@ data Scheme a b = Scheme

118 { rigidQuantifiers :: [b]

119 { rigidQuantifiers :: [b]

119 , flexibleQuantifiers :: [b]

120 , flexibleQuantifiers :: [b]

120 , constraint :: Constraint a b

121 , constraint :: Constraint a b

121− , header :: Map.Map String a

122+ , header :: Map.Map String (A.Located a)

122 }

123 }

123

124

125

@@ -164,7 +165,7 @@ variable flex = UF.fresh $ Descriptor

164

165

165-- CONSTRAINT HELPERS

166-- CONSTRAINT HELPERS

166

167

167−monoscheme :: Map.Map String a -> Scheme a b

168+monoscheme :: Map.Map String (A.Located a) -> Scheme a b

168monoscheme headers =

169monoscheme headers =

169 Scheme [] [] CTrue headers

170 Scheme [] [] CTrue headers

170

171

@@ -373,8 +374,8 @@ instance (PrettyType a, PrettyType b) => PrettyType (Scheme a b) where

373 dict =

374 dict =

374 P.parens . commaSep . map prettyPair $ Map.toList headers

375 P.parens . commaSep . map prettyPair $ Map.toList headers

375

376

376− prettyPair (n,t) =

377+ prettyPair (fieldName, A.A _ tipe) =

377− P.text n <+> P.text ":" <+> pretty Never t

378+ P.text fieldName <+> P.text ":" <+> pretty Never tipe

378

379

380

380-- CONVERT TO SOURCE TYPES

381-- CONVERT TO SOURCE TYPES