2dadd1f · elk · git.iko.soy

git.iko.soy/elk

Allow hints on type constraints, leading to improved error messages

This introduces a code to give a very specific error message when branches in a case expression return different types

commit2dadd1f64c9cbaf1a03342f0ed3e29623376a913 authorEvan Czaplicki <info@elm-lang.org> dateWed 6 May 2015, 14:00 (11 years ago) parent123f867

8 files changed+152−46

compare with master

unifiedsplit

src/Reporting/Error/Type.hs+68−13 src/Reporting/Report.hs+14−10 src/Type/Constrain/Expression.hs+44−10 src/Type/Constrain/Literal.hs+2−1 src/Type/Constrain/Pattern.hs+2−1 src/Type/Solve.hs+3−3 src/Type/Type.hs+3−2 src/Type/Unify.hs+16−6

src/Reporting/Error/Type.hs+68−13

@@ -5,39 +5,57 @@ import qualified Text.PrettyPrint as P

66import qualified AST.Type as T

77import qualified Reporting.PrettyPrint as P

8+import qualified Reporting.Region as Region

89import qualified Reporting.Report as Report

910

1011

1112data Error

12− = Mismatch Mismatch

13+ = Mismatch (Mismatch Hint)

1314 | InfiniteType String T.Canonical

1415 | BadMain T.Canonical

1516

1617

17−data Mismatch = MismatchInfo

18− { _hint :: Maybe String

18+data Mismatch a = MismatchInfo

19+ { _hint :: a

1920 , _leftType :: T.Canonical

2021 , _rightType :: T.Canonical

2122 }

2223

2324

25+data Hint

26+ = None

27+ | Custom String

28+ | CaseBranch Int Region.Region

29+ -- | Then Region.Region

30+ -- | Else Region.Region

31+ -- | IfBranch Int Region.Region

32+

33+

34+mergeHint :: Hint -> Maybe String -> Hint

35+mergeHint hint maybeMessage =

36+ let

37+ promote message =

38+ case hint of

39+ None -> Custom message

40+ _ -> hint

41+ in

42+ maybe hint promote maybeMessage

43+

44+

2445-- TO REPORT

2546

2647toReport :: Error -> Report.Report

2748toReport err =

2849 case err of

29− Mismatch (MismatchInfo maybeHint leftType rightType) ->

50+ Mismatch (MismatchInfo hint leftType rightType) ->

3051 let

31− preHint =

32− maybe "This expression is triggering a type mismatch." id maybeHint

33−

34− postHint =

35− "During type inference, I am seeing a conflict between this type:\n\n"

36− ++ P.render (P.nest 4 (P.pretty False leftType))

37− ++ "\n\nand this type:\n\n"

38− ++ P.render (P.nest 4 (P.pretty False rightType))

52+ (subRegion, preHint) = hintToString hint

3953 in

40− Report.simple preHint postHint

54+ Report.Report subRegion preHint $

55+ "During type inference, I am seeing a conflict between this type:\n\n"

56+ ++ P.render (P.nest 4 (P.pretty False leftType))

57+ ++ "\n\nand this type:\n\n"

58+ ++ P.render (P.nest 4 (P.pretty False rightType))

4159

4260 InfiniteType var tipe ->

4361 Report.simple "This expression is leading me to infer an infinite type." $

@@ -53,3 +71,40 @@ toReport err =

5371 "I need an Element, Html, (Signal Element), or (Signal Html) so I can render it\n"

5472 ++ "on screen, but you gave me:\n\n"

5573 ++ P.render (P.nest 4 (P.pretty False tipe))

74+

75+

76+hintToString :: Hint -> (Maybe Region.Region, String)

77+hintToString hint =

78+ case hint of

79+ None ->

80+ ( Nothing

81+ , "This expression is triggering a type mismatch."

82+ )

83+

84+ Custom message ->

85+ ( Nothing

86+ , message

87+ )

88+

89+ CaseBranch branchNumber region ->

90+ ( Just region

91+ , "The branches of this case-expression return different types of values!\n\n"

92+ ++ "I noticed the mismatch in branch #" ++ show branchNumber ++ ", but go through and make sure every\n"

93+ ++ "branch returns the same type of value."

94+ )

95+{--

96+ Then region ->

97+ ( Just region

98+ , ""

99+ )

100+

101+ Else region ->

102+ ( Just region

103+ , ""

104+ )

105+

106+ IfBranch branchNumber region ->

107+ ( Just region

108+ , ""

109+ )

110+--}

src/Reporting/Report.hs+14−10

@@ -9,7 +9,7 @@ import qualified Reporting.Region as R

1010

1111data Report = Report

12− { highlight :: Maybe (Int,Int)

12+ { highlight :: Maybe R.Region

1313 , preHint :: String

1414 , postHint :: String

1515 }

@@ -43,7 +43,7 @@ messageBar tag location =

4343

4444-- REGIONS

4545

46−grabRegion :: Maybe (Int,Int) -> R.Region -> String -> String

46+grabRegion :: Maybe R.Region -> R.Region -> String -> String

4747grabRegion maybeSubRegion (R.Region start end) source =

4848 let

4949 (R.Position startLine startColumn) = start

@@ -95,16 +95,20 @@ grabRegion maybeSubRegion (R.Region start end) source =

9595 [startLine - 1 .. endLine + 1]

9696 ("" : focusedRelevantLines ++ [""])

9797 in

98− unlines numberedLines ++ "\n"

98+ unlines numberedLines

9999

100100

101−addLineNumber :: Maybe (Int,Int) -> Int -> Int -> String -> String

101+addLineNumber :: Maybe R.Region -> Int -> Int -> String -> String

102102addLineNumber maybeSubRegion width n line =

103103 let

104− number = if n <= 0 then " " else show n

105− spacer =

106− case maybeSubRegion of

107− Just (lo,hi) | lo <= n && n <= hi -> ">"

108− _ -> " "

104+ number =

105+ if n < 0 then " " else show n

106+

107+ spacer (R.Region start end) =

108+ if R.line start <= n && n <= R.line end

109+ then ">"

110+ else " "

109111 in

110− replicate (width - length number) ' ' ++ number ++ "|" ++ spacer ++ line

112+ replicate (width - length number) ' ' ++ number

113+ ++ "|" ++ maybe " " spacer maybeSubRegion

114+ ++ line

src/Type/Constrain/Expression.hs+44−10

@@ -13,6 +13,8 @@ import qualified AST.Pattern as P

1313import qualified AST.Type as ST

1414import qualified AST.Variable as V

1515import qualified Reporting.Annotation as A

16+import qualified Reporting.Error.Type as Error

17+import qualified Reporting.Region as R

1618import qualified Type.Constrain.Literal as Literal

1719import qualified Type.Constrain.Pattern as Pattern

1820import qualified Type.Environment as Env

@@ -27,7 +29,7 @@ constrain

2729 -> IO TypeConstraint

2830constrain env (A.A region expression) tipe =

2931 let list t = Env.get env Env.types "List" <| t

30− (===) = CEqual region

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

3133 (<?) = CInstance region

3234 in

3335 case expression of

@@ -113,15 +115,7 @@ constrain env (A.A region expression) tipe =

113115 return (cb /\ ce)

114116

115117 E.Case expr branches ->

116− exists $ \t ->

117− do exprConstraint <- constrain env expr t

118− branchConstraints <- mapM (branch t) branches

119− return (CAnd (exprConstraint : branchConstraints))

120− where

121− branch t (pattern, branchExpr) =

122− do fragment <- Pattern.constrain env pattern t

123− branchConstraint <- constrain env branchExpr tipe

124− return (CLet [Fragment.toScheme fragment] branchConstraint)

118+ constrainCase env region expr branches tipe

125119

126120 E.Data name exprs ->

127121 do vars <- Monad.forM exprs $ \_ -> variable Flexible

@@ -200,6 +194,46 @@ constrain env (A.A region expression) tipe =

200194 constrain env expr tipe

201195

202196

197+-- CONSTRAIN CASE EXPRESSIONS

198+

199+constrainCase

200+ :: Env.Environment

201+ -> R.Region

202+ -> Canonical.Expr

203+ -> [(P.CanonicalPattern, Canonical.Expr)]

204+ -> Type

205+ -> IO TypeConstraint

206+constrainCase env region expr branches tipe =

207+ do exprVar <- variable Flexible

208+

209+ exprCon <- constrain env expr (varN exprVar)

210+

211+ (branchVars, regions, branchExprCons) <-

212+ unzip3 <$> mapM (branch (varN exprVar)) branches

213+

214+ let branchCons =

215+ zipWith3 branchEqual [1..] branchVars regions

216+

217+ return $

218+ ex (exprVar:branchVars)

219+ (CAnd (exprCon : branchExprCons ++ branchCons))

220+ where

221+ branch patternType (pattern, branchExpr@(A.A branchRegion _)) =

222+ do branchVar <- variable Flexible

223+ fragment <- Pattern.constrain env pattern patternType

224+ branchCon <- constrain env branchExpr (varN branchVar)

225+ return

226+ ( branchVar

227+ , branchRegion

228+ , CLet [Fragment.toScheme fragment] branchCon

229+ )

230+

231+ branchEqual n var branchRegion =

232+ CEqual (Error.CaseBranch n branchRegion) region tipe (varN var)

233+

234+

235+-- EXPAND PATTERNS

236+

203237expandPattern :: Canonical.Def -> [Canonical.Def]

204238expandPattern def@(Canonical.Definition lpattern expr maybeType) =

205239 let (A.A patternRegion pattern) = lpattern

src/Type/Constrain/Literal.hs+2−1

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

11module Type.Constrain.Literal where

33import qualified AST.Literal as L

4+import qualified Reporting.Error.Type as Error

45import qualified Reporting.Region as R

56import qualified Type.Type as T

67import qualified Type.Environment as Env

@@ -14,7 +15,7 @@ constrain

1415 -> IO T.TypeConstraint

1516constrain env region literal tipe =

1617 do tipe' <- litType

17− return (T.CEqual region tipe tipe')

18+ return (T.CEqual Error.None region tipe tipe')

1819 where

1920 prim name =

2021 return (Env.get env Env.types name)

src/Type/Constrain/Pattern.hs+2−1

@@ -9,6 +9,7 @@ import qualified Data.Map as Map

99import qualified AST.Pattern as P

1010import qualified AST.Variable as V

1111import qualified Reporting.Annotation as A

12+import qualified Reporting.Error.Type as Error

1213import qualified Type.Constrain.Literal as Literal

1314import qualified Type.Environment as Env

1415import Type.Fragment

@@ -21,7 +22,7 @@ constrain

2122 -> Type

2223 -> IO Fragment

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

24− let (===) = CEqual region

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

2526 in

2627 case pattern of

2728 P.Anything ->

src/Type/Solve.hs+3−3

@@ -133,10 +133,10 @@ actuallySolve constraint =

133133 CSaveEnv ->

134134 TS.saveLocalEnv

135135

136− CEqual region term1 term2 ->

136+ CEqual hint region term1 term2 ->

137137 do t1 <- TS.flatten term1

138138 t2 <- TS.flatten term2

139− unify region t1 t2

139+ unify hint region t1 t2

140140

141141 CAnd cs ->

142142 mapM_ actuallySolve cs

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

167167 else error ("Could not find '" ++ name ++ "' when solving type constraints.")

168168

169169 t <- TS.flatten term

170− unify region freshCopy t

170+ unify Error.None region freshCopy t

171171

172172

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

src/Type/Type.hs+3−2

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

1313

1414import qualified AST.Type as T

1515import qualified AST.Variable as Var

16+import qualified Reporting.Error.Type as Error

1617import qualified Reporting.Region as R

1718import Type.PrettyPrint

1819

@@ -104,7 +105,7 @@ data SuperType

104105data Constraint a b

105106 = CTrue

106107 | CSaveEnv

107− | CEqual R.Region a a

108+ | CEqual Error.Hint R.Region a a

108109 | CAnd [Constraint a b]

109110 | CLet [Scheme a b] (Constraint a b)

110111 | CInstance R.Region SchemeName a

@@ -307,7 +308,7 @@ instance (PrettyType a, PrettyType b) => PrettyType (Constraint a b) where

307308 CSaveEnv ->

308309 P.text "SaveTheEnvironment!!!"

309310

310− CEqual _region a b ->

311+ CEqual _ _ a b ->

311312 prty a <+> P.text "=" <+> prty b

312313

313314 CAnd [] ->

src/Type/Unify.hs+16−6

@@ -13,25 +13,35 @@ import qualified AST.Variable as Var

1313import qualified Reporting.Region as R

1414import qualified Reporting.Error.Type as Error

1515import qualified Type.State as TS

16−import Type.Type

16+import Type.Type as Type

1717import Type.PrettyPrint

1818import Elm.Utils ((|>))

1919

2020

21−unify :: R.Region -> Variable -> Variable -> StateT TS.SolverState IO ()

22−unify region variable1 variable2 =

21+unify

22+ :: Error.Hint

23+ -> R.Region

24+ -> Variable

25+ -> Variable

26+ -> StateT TS.SolverState IO ()

27+unify hint region variable1 variable2 =

2328 do result <- runExceptT (unifyHelp variable1 variable2)

2429 case result of

2530 Right state ->

2631 return state

2732

28− Left mismatch ->

29− TS.addError region (Error.Mismatch mismatch)

33+ Left (Error.MismatchInfo maybeMessage leftType rightType) ->

34+ let

35+ trueHint = Error.mergeHint hint maybeMessage

36+ in

37+ TS.addError region $ Error.Mismatch $

38+ Error.MismatchInfo trueHint leftType rightType

3039

3140

3241-- ACTUALLY UNIFY STUFF

3342

34−type Unify = ExceptT Error.Mismatch (StateT TS.SolverState IO)

43+type Unify =

44+ ExceptT (Error.Mismatch (Maybe String)) (StateT TS.SolverState IO)

3545

3646

3747typeError