0d10d2f · elk · git.iko.soy

git.iko.soy/elk

Bail out of unification on first failure

commit0d10d2fc67e4b12835f92a56340ba533c12830ba authorEvan Czaplicki <info@elm-lang.org> dateMon 15 Dec 2014, 18:49 (12 years ago) parentf1c61a6

8 files changed+144−87

compare with master

unifiedsplit

elm-compiler.cabal+1 src/AST/PrettyPrint.hs+4 src/Type/ExtraChecks.hs+4−2 src/Type/Hint.hs+35 src/Type/Inference.hs+3−3 src/Type/Solve.hs+22−9 src/Type/State.hs+9−32 src/Type/Unify.hs+66−41

elm-compiler.cabal+1

@@ -98,6 +98,7 @@ Library

9898 Type.Environment,

9999 Type.ExtraChecks,

100100 Type.Fragment,

101+ Type.Hint,

101102 Type.Inference,

102103 Type.PrettyPrint,

103104 Type.Solve,

src/AST/PrettyPrint.hs+4

@@ -38,5 +38,9 @@ eightyCharLines indent message = answer

3838 | slen + wlen > 79 = (sentence ++ "\n" ++ spaces ++ word, indent + wlen, " ")

3939 | otherwise = (sentence ++ space ++ word, slen + wlen + length space, " ")

4040

41+instance Error Doc where

42+ noMsg = P.empty

43+ strMsg = P.text

44+

4145instance ErrorList Doc where

4246 listMsg str = [ P.text str ]

src/Type/ExtraChecks.hs+4−2

@@ -20,6 +20,7 @@ import qualified AST.PrettyPrint as PP

2020import qualified AST.Type as ST

2121import qualified AST.Variable as V

2222import qualified Transform.Expression as Expr

23+import qualified Type.Hint as Hint

2324import qualified Type.Type as TT

2425import qualified Type.State as TS

2526

@@ -143,12 +144,13 @@ occurs (name, variable) =

143144 do desc <- liftIO $ UF.descriptor var

144145 case TT.structure desc of

145146 Nothing ->

146− modify $ \s -> s { TS.sErrors = P.text msg : TS.sErrors s }

147+ TS.addHint (P.text msg)

147148

148149 Just _ ->

149150 do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })

150151 var' <- liftIO $ UF.fresh desc

151− TS.addError (A.None (P.text name)) (Just msg) var var'

152+ hint <- liftIO $ Hint.create (A.None (P.text name)) (Just msg) var var'

153+ TS.addHint hint

152154 where

153155 msg = "Infinite types are not allowed"

154156

src/Type/Hint.hsnew file+35

@@ -0,0 +1,35 @@

1+module Type.Hint where

3+import Control.Applicative ( (<$>) )

4+import qualified Data.UnionFind.IO as UF

5+import Text.PrettyPrint as P

7+import qualified AST.Annotation as A

8+import AST.PrettyPrint (pretty)

9+import Type.Type (Descriptor, toSrcType)

10+

11+

12+type Hint = Doc

13+

14+

15+create

16+ :: A.Region

17+ -> Maybe String

18+ -> UF.Point Descriptor

19+ -> UF.Point Descriptor

20+ -> IO Hint

21+create region hint t1 t2 =

22+ do t1' <- pretty <$> toSrcType t1

23+ t2' <- pretty <$> toSrcType t2

24+ return . foldr ($+$) P.empty $

25+ [ P.text "Type mismatch between the following types" <+> pretty region <> P.text ":"

26+ , P.text ""

27+ , P.nest 8 t1'

28+ , P.text ""

29+ , P.nest 8 t2'

30+ , P.text ""

31+ , maybe P.empty (P.nest 4 . P.text) hint

32+ , P.text " It is related to the following expression:"

33+ , P.text ""

34+ , P.nest 8 $ A.getRegionDocs region

35+ ]

src/Type/Inference.hs+3−3

@@ -29,9 +29,9 @@ infer interfaces modul =

2929

3030 state <- liftIO $ execStateT (Solve.solve constraint) TS.initialState

3131

32− () <- case TS.sErrors state of

33− errors@(_:_) -> throwError errors

34− [] -> return ()

32+ () <- case TS.sHint state of

33+ hints@(_:_) -> throwError hints

34+ [] -> return ()

3535

3636 () <- Check.portTypes (program (body modul))

3737

src/Type/Solve.hs+22−9

@@ -9,6 +9,7 @@ import qualified Data.UnionFind.IO as UF

99import Type.Type

1010import Type.Unify

1111import qualified Type.ExtraChecks as Check

12+import qualified Type.Hint as Hint

1213import qualified Type.State as TS

1314import qualified AST.Annotation as A

1415

@@ -169,6 +170,17 @@ solveScheme region scheme =

169170 return header'

170171

171172

173+addHint

174+ :: A.Region

175+ -> Maybe String

176+ -> UF.Point Descriptor

177+ -> UF.Point Descriptor

178+ -> StateT TS.SolverState IO ()

179+addHint region hint t1 t2 =

180+ do msg <- liftIO (Hint.create region hint t1 t2)

181+ TS.addHint msg

182+

183+

172184-- Checks that all of the given variables belong to distinct equivalence classes.

173185-- Also checks that their structure is Nothing, so they represent a variable, not

174186-- a more complex term.

@@ -178,15 +190,16 @@ allDistinct region vars =

178190 forM_ vars $ \var ->

179191 do desc <- liftIO $ UF.descriptor var

180192 case structure desc of

181− Just _ -> TS.addError region (Just msg) var var

182− where msg = "Cannot generalize something that is not a type variable."

193+ Just _ ->

194+ let msg = "Cannot generalize something that is not a type variable."

195+ in

196+ addHint region (Just msg) var var

183197

184− Nothing -> do

185− if mark desc == seen

186− then let msg = "Duplicate variable during generalization."

187− in TS.addError region (Just msg) var var

188− else return ()

189− liftIO $ UF.setDescriptor var (desc { mark = seen })

198+ Nothing ->

199+ do when (mark desc == seen) $

200+ do let msg = "Duplicate variable during generalization."

201+ addHint region (Just msg) var var

202+ liftIO $ UF.setDescriptor var (desc { mark = seen })

190203

191204

192205-- Check that a variable has rank == noRank, meaning that it can be generalized.

@@ -197,4 +210,4 @@ isGeneric region var =

197210 then return ()

198211 else

199212 let msg = "Unable to generalize a type variable. It is not unranked."

200− in TS.addError region (Just msg) var var

213+ in addHint region (Just msg) var var

src/Type/State.hs+9−32

@@ -7,11 +7,10 @@ import qualified Data.Map as Map

77import qualified Data.Traversable as Traversable

88import qualified Data.UnionFind.IO as UF

10−import qualified AST.Annotation as A

11−import AST.PrettyPrint

12−import Text.PrettyPrint as P

10+import qualified Type.Hint as Hint

1311import Type.Type

1412

13+

1514-- Pool

1615-- Holds a bunch of variables

1716-- The rank of each variable is less than or equal to the pool's "maxRank"

@@ -40,7 +39,7 @@ data SolverState = SS

4039 , sSavedEnv :: Env

4140 , sPool :: Pool

4241 , sMark :: Int

43− , sErrors :: [P.Doc]

42+ , sHint :: [Hint.Hint]

4443 }

4544

4645

@@ -51,7 +50,7 @@ initialState =

5150 , sSavedEnv = Map.empty

5251 , sPool = emptyPool

5352 , sMark = noMark + 1 -- The mark must never be equal to noMark!

54− , sErrors = []

53+ , sHint = []

5554 }

5655

5756

@@ -65,31 +64,9 @@ modifyPool f =

6564 modify $ \state -> state { sPool = f (sPool state) }

6665

6766

68−addError

69− :: A.Region

70− -> Maybe String

71− -> UF.Point Descriptor

72− -> UF.Point Descriptor

73− -> StateT SolverState IO ()

74−addError region hint t1 t2 =

75− do err <- liftIO makeError

76− modify $ \state -> state { sErrors = err : sErrors state }

77− where

78− makeError = do

79− t1' <- pretty <$> toSrcType t1

80− t2' <- pretty <$> toSrcType t2

81− return . foldr ($+$) P.empty $

82− [ P.text "Type mismatch between the following types" <+> pretty region <> P.text ":"

83− , P.text ""

84− , P.nest 8 t1'

85− , P.text ""

86− , P.nest 8 t2'

87− , P.text ""

88− , maybe P.empty (P.nest 4 . P.text) hint

89− , P.text " It is related to the following expression:"

90− , P.text ""

91− , P.nest 8 $ A.getRegionDocs region

92− ]

67+addHint :: Hint.Hint -> StateT SolverState IO ()

68+addHint hint =

69+ modify $ \state -> state { sHint = hint : sHint state }

9370

9471

9572switchToPool :: (MonadState SolverState m) => Pool -> m ()

@@ -109,8 +86,8 @@ getEnv =

10986

11087saveLocalEnv :: StateT SolverState IO ()

11188saveLocalEnv =

112− do env <- sEnv <$> get

113− modify $ \state -> state { sSavedEnv = env }

89+ do currentEnv <- getEnv

90+ modify $ \state -> state { sSavedEnv = currentEnv }

11491

11592

11693uniqueMark :: StateT SolverState IO Int

src/Type/Unify.hs+66−41

@@ -1,37 +1,62 @@

11module Type.Unify (unify) where

33import Control.Applicative ((<|>))

4−import Control.Monad.State

4+import Control.Monad.Error (ErrorT, throwError, runErrorT)

5+import Control.Monad.State as State

56import qualified Data.List as List

67import qualified Data.Map as Map

78import qualified Data.Maybe as Maybe

89import qualified Data.UnionFind.IO as UF

10+import Text.PrettyPrint (render)

11+

912import qualified AST.Annotation as A

1013import qualified AST.Variable as Var

1114import qualified Type.State as TS

1215import Type.Type

1316import Type.PrettyPrint

14−import Text.PrettyPrint (render)

17+import qualified Type.Hint as Hint

1518import Elm.Utils ((|>))

1619

1720

1821unify :: A.Region -> Variable -> Variable -> StateT TS.SolverState IO ()

19−unify region variable1 variable2 = do

22+unify region variable1 variable2 =

23+ do result <- runErrorT (unifyHelp region variable1 variable2)

24+ either TS.addHint return result

25+

26+

27+-- ACTUALLY UNIFY STUFF

28+

29+type Unify = ErrorT Hint.Hint (StateT TS.SolverState IO)

30+

31+

32+typeError

33+ :: A.Region

34+ -> Maybe String

35+ -> UF.Point Descriptor

36+ -> UF.Point Descriptor

37+ -> Unify a

38+typeError region hint t1 t2 =

39+ do msg <- liftIO (Hint.create region hint t1 t2)

40+ throwError msg

41+

42+

43+unifyHelp :: A.Region -> Variable -> Variable -> Unify ()

44+unifyHelp region variable1 variable2 = do

2045 equivalent <- liftIO $ UF.equivalent variable1 variable2

2146 if equivalent

2247 then return ()

2348 else actuallyUnify region variable1 variable2

2449

2550

26−actuallyUnify :: A.Region -> Variable -> Variable -> StateT TS.SolverState IO ()

51+actuallyUnify :: A.Region -> Variable -> Variable -> Unify ()

2752actuallyUnify region variable1 variable2 = do

2853 desc1 <- liftIO $ UF.descriptor variable1

2954 desc2 <- liftIO $ UF.descriptor variable2

30− let unify' = unify region

55+ let unifyHelp' = unifyHelp region

3156

3257 (name', flex', rank', alias') = combinedDescriptors desc1 desc2

3358

34− merge1 :: StateT TS.SolverState IO ()

59+ merge1 :: Unify ()

3560 merge1 = liftIO $ do

3661 if rank desc1 < rank desc2 then UF.union variable2 variable1

3762 else UF.union variable1 variable2

@@ -42,7 +67,7 @@ actuallyUnify region variable1 variable2 = do

4267 , alias = alias'

4368 }

4469

45− merge2 :: StateT TS.SolverState IO ()

70+ merge2 :: Unify ()

4671 merge2 = liftIO $ do

4772 if rank desc1 < rank desc2 then UF.union variable2 variable1

4873 else UF.union variable1 variable2

@@ -55,7 +80,7 @@ actuallyUnify region variable1 variable2 = do

5580

5681 merge = if rank desc1 < rank desc2 then merge1 else merge2

5782

58− fresh :: Maybe (Term1 Variable) -> StateT TS.SolverState IO Variable

83+ fresh :: Maybe (Term1 Variable) -> Unify Variable

5984 fresh structure = do

6085 v <- liftIO . UF.fresh $ Descriptor

6186 { structure = structure

@@ -66,11 +91,11 @@ actuallyUnify region variable1 variable2 = do

6691 , mark = noMark

6792 , alias = alias'

6893 }

69− TS.register v

94+ lift (TS.register v)

7095

7196 flexAndUnify v = do

7297 liftIO $ UF.modifyDescriptor v $ \desc -> desc { flex = Flexible }

73− unify' variable1 variable2

98+ unifyHelp' variable1 variable2

7499

75100 unifyNumber svar (Var.Canonical home name) =

76101 case home of

@@ -79,17 +104,17 @@ actuallyUnify region variable1 variable2 = do

79104 _ ->

80105 let hint = "Looks like something besides an Int or Float is being used as a number."

81106 in

82− TS.addError region (Just hint) variable1 variable2

107+ typeError region (Just hint) variable1 variable2

83108

84109 comparableError maybe =

85− TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2

110+ typeError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2

86111 where

87112 msg =

88113 "Looks like you want something comparable, but the only valid comparable\n\

89114 \types are Int, Float, Char, String, lists, or tuples."

90115

91116 appendableError maybe =

92− TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2

117+ typeError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2

93118 where

94119 msg =

95120 "Looks like you want something appendable, but the only Strings, Lists,\n\

@@ -106,14 +131,14 @@ actuallyUnify region variable1 variable2 = do

106131 case struct of

107132 Other -> comparableError Nothing

108133 List v -> do flexAndUnify varSuper

109− unify' v =<< liftIO (variable $ Is Comparable)

134+ unifyHelp' v =<< liftIO (variable $ Is Comparable)

110135 Tuple vs

111136 | length vs > 6 ->

112137 comparableError $ Just "Cannot compare a tuple with more than 6 elements."

113138 | otherwise ->

114139 do flexAndUnify varSuper

115140 cmpVars <- liftIO $ forM [1..length vs] $ \_ -> variable (Is Comparable)

116− zipWithM_ unify' vs cmpVars

141+ zipWithM_ unifyHelp' vs cmpVars

117142

118143 unifyAppendable varSuper varFlex =

119144 do struct <- liftIO $ collectApps varFlex

@@ -122,7 +147,7 @@ actuallyUnify region variable1 variable2 = do

122147 _ -> appendableError Nothing

123148

124149 rigidError var =

125− TS.addError region (Just hint) variable1 variable2

150+ typeError region (Just hint) variable1 variable2

126151 where

127152 hint =

128153 "Could not unify rigid type variable '" ++ render (pretty Never var) ++ "'.\n" ++

@@ -153,15 +178,15 @@ actuallyUnify region variable1 variable2 = do

153178

154179 (Rigid, _, _, _) -> rigidError variable1

155180 (_, Rigid, _, _) -> rigidError variable2

156− _ -> TS.addError region Nothing variable1 variable2

181+ _ -> typeError region Nothing variable1 variable2

157182

158183 case (structure desc1, structure desc2) of

159184 (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible -> merge

160185 (Nothing, _) | flex desc1 == Flexible -> merge2

161186 (_, Nothing) | flex desc2 == Flexible -> merge1

162187

163− (Just (Var1 v), _) -> unify' v variable2

164− (_, Just (Var1 v)) -> unify' v variable1

188+ (Just (Var1 v), _) -> unifyHelp' v variable2

189+ (_, Just (Var1 v)) -> unifyHelp' v variable1

165190

166191 (Nothing, _) -> superUnify

167192 (_, Nothing) -> superUnify

@@ -170,33 +195,33 @@ actuallyUnify region variable1 variable2 = do

170195 case (type1,type2) of

171196 (App1 term1 term2, App1 term1' term2') ->

172197 do merge

173− unify' term1 term1'

174− unify' term2 term2'

198+ unifyHelp' term1 term1'

199+ unifyHelp' term2 term2'

175200 (Fun1 term1 term2, Fun1 term1' term2') ->

176201 do merge

177− unify' term1 term1'

178− unify' term2 term2'

202+ unifyHelp' term1 term1'

203+ unifyHelp' term2 term2'

179204

180205 (EmptyRecord1, EmptyRecord1) ->

181206 return ()

182207

183− (Record1 fields ext, EmptyRecord1) | Map.null fields -> unify' ext variable2

184− (EmptyRecord1, Record1 fields ext) | Map.null fields -> unify' ext variable1

208+ (Record1 fields ext, EmptyRecord1) | Map.null fields -> unifyHelp' ext variable2

209+ (EmptyRecord1, Record1 fields ext) | Map.null fields -> unifyHelp' ext variable1

185210

186211 (Record1 _ _, Record1 _ _) ->

187212 recordUnify region fresh variable1 variable2

188213

189− _ -> TS.addError region Nothing variable1 variable2

214+ _ -> typeError region Nothing variable1 variable2

190215

191216

192217-- RECORD UNIFICATION

193218

194219recordUnify

195220 :: A.Region

196− -> (Maybe (Term1 Variable) -> StateT TS.SolverState IO Variable)

221+ -> (Maybe (Term1 Variable) -> Unify Variable)

197222 -> Variable

198223 -> Variable

199− -> StateT TS.SolverState IO ()

224+ -> Unify ()

200225recordUnify region fresh variable1 variable2 =

201226 do (ExpandedRecord fields1 ext1) <- liftIO (gatherFields variable1)

202227 (ExpandedRecord fields2 ext2) <- liftIO (gatherFields variable2)

@@ -212,57 +237,57 @@ recordUnify region fresh variable1 variable2 =

212237 let addFieldMismatchError missingFields =

213238 let msg = fieldMismatchError missingFields

214239 in

215− TS.addError region (Just msg) variable1 variable2

240+ typeError region (Just msg) variable1 variable2

216241

217242 case (ext1, ext2) of

218243 (Empty _, Empty _) ->

219244 case Map.null uniqueFields1 && Map.null uniqueFields2 of

220245 True -> return ()

221− False -> TS.addError region Nothing variable1 variable2

246+ False -> typeError region Nothing variable1 variable2

222247

223248 (Empty var1, Extension var2) ->

224249 case (Map.null uniqueFields1, Map.null uniqueFields2) of

225250 (_, False) -> addFieldMismatchError uniqueFields2

226− (True, True) -> unify region var1 var2

251+ (True, True) -> unifyHelp region var1 var2

227252 (False, True) ->

228253 do subRecord <- freshRecord uniqueFields1 var1

229− unify region subRecord var2

254+ unifyHelp region subRecord var2

230255

231256 (Extension var1, Empty var2) ->

232257 case (Map.null uniqueFields1, Map.null uniqueFields2) of

233258 (False, _) -> addFieldMismatchError uniqueFields1

234− (True, True) -> unify region var1 var2

259+ (True, True) -> unifyHelp region var1 var2

235260 (True, False) ->

236261 do subRecord <- freshRecord uniqueFields2 var2

237− unify region var1 subRecord

262+ unifyHelp region var1 subRecord

238263

239264 (Extension var1, Extension var2) ->

240265 case (Map.null uniqueFields1, Map.null uniqueFields2) of

241266 (True, True) ->

242− unify region var1 var2

267+ unifyHelp region var1 var2

243268

244269 (True, False) ->

245270 do subRecord <- freshRecord uniqueFields2 var2

246− unify region var1 subRecord

271+ unifyHelp region var1 subRecord

247272

248273 (False, True) ->

249274 do subRecord <- freshRecord uniqueFields1 var1

250− unify region subRecord var2

275+ unifyHelp region subRecord var2

251276

252277 (False, False) ->

253278 do record1' <- freshRecord uniqueFields1 =<< fresh Nothing

254279 record2' <- freshRecord uniqueFields2 =<< fresh Nothing

255− unify region record1' var2

256− unify region var1 record2'

280+ unifyHelp region record1' var2

281+ unifyHelp region var1 record2'

257282

258283

259284unifyOverlappingFields

260285 :: A.Region

261286 -> Map.Map String [Variable]

262287 -> Map.Map String [Variable]

263− -> StateT TS.SolverState IO ()

288+ -> Unify ()

264289unifyOverlappingFields region fields1 fields2 =

265− Map.intersectionWith (zipWith (unify region)) fields1 fields2

290+ Map.intersectionWith (zipWith (unifyHelp region)) fields1 fields2

266291 |> Map.elems

267292 |> concat

268293 |> sequence_