2dadd1f · elk · git.iko.soy

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

compare with master

unifiedsplit

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

5

6import qualified AST.Type as T

7import qualified Reporting.PrettyPrint as P

8+import qualified Reporting.Region as Region

8import qualified Reporting.Report as Report

9import qualified Reporting.Report as Report

9

10

11

11data Error

12data Error

12− = Mismatch Mismatch

13+ = Mismatch (Mismatch Hint)

13 | InfiniteType String T.Canonical

14 | InfiniteType String T.Canonical

14 | BadMain T.Canonical

15 | BadMain T.Canonical

15

16

17

17−data Mismatch = MismatchInfo

18+data Mismatch a = MismatchInfo

18− { _hint :: Maybe String

19+ { _hint :: a

19 , _leftType :: T.Canonical

20 , _leftType :: T.Canonical

20 , _rightType :: T.Canonical

21 , _rightType :: T.Canonical

21 }

22 }

22

23

24

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+

24-- TO REPORT

45-- TO REPORT

25

46

26toReport :: Error -> Report.Report

47toReport :: Error -> Report.Report

27toReport err =

48toReport err =

28 case err of

49 case err of

29− Mismatch (MismatchInfo maybeHint leftType rightType) ->

50+ Mismatch (MismatchInfo hint leftType rightType) ->

30 let

51 let

31− preHint =

52+ (subRegion, preHint) = hintToString hint

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

39 in

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

41

59

42 InfiniteType var tipe ->

60 InfiniteType var tipe ->

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

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

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

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

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

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

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

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

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

9

10

11data Report = Report

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

12+ { highlight :: Maybe R.Region

13 , preHint :: String

14 , postHint :: String

15 }

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

43

44-- REGIONS

45

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

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

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

48 let

49 (R.Position startLine startColumn) = start

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

95 [startLine - 1 .. endLine + 1]

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

97 in

98− unlines numberedLines ++ "\n"

98+ unlines numberedLines

99

100

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

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

102addLineNumber maybeSubRegion width n line =

103 let

104+ number =

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

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

106+

105− spacer =

107+ spacer (R.Region start end) =

106− case maybeSubRegion of

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

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

109+ then ">"

108− _ -> " "

110+ else " "

109 in

111 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

13import qualified AST.Type as ST

14import qualified AST.Variable as V

15import qualified Reporting.Annotation as A

16+import qualified Reporting.Error.Type as Error

17+import qualified Reporting.Region as R

16import qualified Type.Constrain.Literal as Literal

18import qualified Type.Constrain.Literal as Literal

17import qualified Type.Constrain.Pattern as Pattern

19import qualified Type.Constrain.Pattern as Pattern

18import qualified Type.Environment as Env

20import qualified Type.Environment as Env

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

27 -> IO TypeConstraint

29 -> IO TypeConstraint

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

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

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

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

30− (===) = CEqual region

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

31 (<?) = CInstance region

33 (<?) = CInstance region

32 in

34 in

33 case expression of

35 case expression of

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

113 return (cb /\ ce)

115 return (cb /\ ce)

114

116

115 E.Case expr branches ->

117 E.Case expr branches ->

116− exists $ \t ->

118+ constrainCase env region expr branches tipe

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)

125

119

126 E.Data name exprs ->

120 E.Data name exprs ->

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

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

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

200 constrain env expr tipe

194 constrain env expr tipe

201

195

202

196

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+

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

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

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

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

205 let (A.A patternRegion pattern) = lpattern

239 let (A.A patternRegion pattern) = lpattern

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

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

1module Type.Constrain.Literal where

2

3import qualified AST.Literal as L

4+import qualified Reporting.Error.Type as Error

4import qualified Reporting.Region as R

5import qualified Reporting.Region as R

5import qualified Type.Type as T

6import qualified Type.Type as T

6import qualified Type.Environment as Env

7import qualified Type.Environment as Env

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

14 -> IO T.TypeConstraint

15 -> IO T.TypeConstraint

15constrain env region literal tipe =

16constrain env region literal tipe =

16 do tipe' <- litType

17 do tipe' <- litType

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

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

18 where

19 where

19 prim name =

20 prim name =

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

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

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

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

9import qualified AST.Pattern as P

10import qualified AST.Variable as V

11import qualified Reporting.Annotation as A

12+import qualified Reporting.Error.Type as Error

12import qualified Type.Constrain.Literal as Literal

13import qualified Type.Constrain.Literal as Literal

13import qualified Type.Environment as Env

14import qualified Type.Environment as Env

14import Type.Fragment

15import Type.Fragment

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

21 -> Type

22 -> Type

22 -> IO Fragment

23 -> IO Fragment

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

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

24− let (===) = CEqual region

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

25 in

26 in

26 case pattern of

27 case pattern of

27 P.Anything ->

28 P.Anything ->

src/Type/Solve.hs+3−3

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

133 CSaveEnv ->

134 TS.saveLocalEnv

135

136− CEqual region term1 term2 ->

136+ CEqual hint region term1 term2 ->

137 do t1 <- TS.flatten term1

138 t2 <- TS.flatten term2

139− unify region t1 t2

139+ unify hint region t1 t2

140

141 CAnd cs ->

142 mapM_ actuallySolve cs

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

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

168

169 t <- TS.flatten term

170− unify region freshCopy t

170+ unify Error.None region freshCopy t

171

172

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

src/Type/Type.hs+3−2

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

13

14import qualified AST.Type as T

15import qualified AST.Variable as Var

16+import qualified Reporting.Error.Type as Error

16import qualified Reporting.Region as R

17import qualified Reporting.Region as R

17import Type.PrettyPrint

18import Type.PrettyPrint

18

19

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

104data Constraint a b

105data Constraint a b

105 = CTrue

106 = CTrue

106 | CSaveEnv

107 | CSaveEnv

107− | CEqual R.Region a a

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

108 | CAnd [Constraint a b]

109 | CAnd [Constraint a b]

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

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

110 | CInstance R.Region SchemeName a

111 | CInstance R.Region SchemeName a

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

307 CSaveEnv ->

308 CSaveEnv ->

308 P.text "SaveTheEnvironment!!!"

309 P.text "SaveTheEnvironment!!!"

309

310

310− CEqual _region a b ->

311+ CEqual _ _ a b ->

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

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

312

313

313 CAnd [] ->

314 CAnd [] ->

src/Type/Unify.hs+16−6

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

13import qualified Reporting.Region as R

14import qualified Reporting.Error.Type as Error

15import qualified Type.State as TS

16−import Type.Type

16+import Type.Type as Type

17import Type.PrettyPrint

18import Elm.Utils ((|>))

19

20

21+unify

22+ :: Error.Hint

23+ -> R.Region

24+ -> Variable

25+ -> Variable

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

26+ -> StateT TS.SolverState IO ()

22−unify region variable1 variable2 =

27+unify hint region variable1 variable2 =

23 do result <- runExceptT (unifyHelp variable1 variable2)

28 do result <- runExceptT (unifyHelp variable1 variable2)

24 case result of

29 case result of

25 Right state ->

30 Right state ->

26 return state

31 return state

27

32

28− Left mismatch ->

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

34+ let

35+ trueHint = Error.mergeHint hint maybeMessage

36+ in

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

37+ TS.addError region $ Error.Mismatch $

38+ Error.MismatchInfo trueHint leftType rightType

30

39

31

40

32-- ACTUALLY UNIFY STUFF

41-- ACTUALLY UNIFY STUFF

33

42

43+type Unify =

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

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

35

45

36

46

37typeError

47typeError