ca77056 · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Improve quality of error messages.

ca77056Evan Czaplicki13 years ago

Elm.cabal+2−4

compare with master

unifiedsplit

@@ -69,8 +69,7 @@ Library

69 Types.Unify,

70 Paths_Elm

72− Build-depends: ansi-terminal,

72+ Build-depends: base >=4.2 && <5,

73− base >=4.2 && <5,

74 blaze-html == 0.5.* || == 0.6.*,

73 blaze-html == 0.5.* || == 0.6.*,

75 blaze-markup == 0.5.1.*,

74 blaze-markup == 0.5.1.*,

76 bytestring,

75 bytestring,

@@ -131,8 +130,7 @@ Executable elm

131 Types.Unify,

130 Types.Unify,

132 Paths_Elm

131 Paths_Elm

133

132

134− Build-depends: ansi-terminal,

133+ Build-depends: base >=4.2 && <5,

135− base >=4.2 && <5,

136 blaze-html == 0.5.* || == 0.6.*,

134 blaze-html == 0.5.* || == 0.6.*,

137 blaze-markup == 0.5.1.*,

135 blaze-markup == 0.5.1.*,

138 bytestring,

136 bytestring,

compiler/Type/Constrain/Expression.hs+4−5

@@ -34,14 +34,13 @@ test str =

34 env <- Env.initialEnvironment

35 var <- flexibleVar

36 constraint <- constrain env expression (VarN var)

37− prettyNames constraint

38− --print (pretty constraint)

39− --print (P.text "Solving for:" <+> pretty var)

40 (env,_,_,errors) <- execStateT (solve constraint) TS.initialState

37 (env,_,_,errors) <- execStateT (solve constraint) TS.initialState

38+ forM (Map.toList env) $ \(n,t) -> do

39+ pt <- extraPretty t

41− mapM_ (\(n,t) -> print $ P.text n <+> P.text ":" <+> pretty t) $ Map.toList env

40+ print $ P.text n <+> P.text ":" <+> pt

42 if null errors then return () else do

41 if null errors then return () else do

43 putStrLn "\n"

42 putStrLn "\n"

44− mapM_ print errors

43+ mapM_ print =<< sequence errors

45{-- todo: remove testing code --}

44{-- todo: remove testing code --}

47constrain :: Env.Environment -> LExpr a b -> Type -> IO TypeConstraint

46constrain :: Env.Environment -> LExpr a b -> Type -> IO TypeConstraint

compiler/Type/Solve.hs+3−3

@@ -160,10 +160,10 @@ allDistinct vars = do

160 desc <- liftIO $ UF.descriptor var

161 case structure desc of

162 Just _ ->

163− TS.addError "Cannot generalize something that is not a type variable" () var

163+ TS.addError "Cannot generalize something that is not a type variable" var var

164 Nothing -> do

165 if mark desc == seen

166− then TS.addError "Duplicate variable during generalization" var ()

166+ then TS.addError "Duplicate variable during generalization" var var

167 else return ()

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

169 mapM_ check vars

@@ -174,4 +174,4 @@ isGeneric var = do

174 desc <- liftIO $ UF.descriptor var

175 if rank desc == noRank

176 then return ()

177− else TS.addError "Cannot generalize. Variable must have not have a rank." () var

177+ else TS.addError "Cannot generalize. Variable must have not have a rank." var var

compiler/Type/State.hs+18−13

@@ -27,23 +27,31 @@ data Pool = Pool {

27emptyPool = Pool { maxRank = 0, inhabitants = [] }

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

30−type SolverState = (Map.Map String Variable, Pool, Int, [P.Doc])

30+type SolverState = (Map.Map String Variable, Pool, Int, [IO P.Doc])

32-- The mark must never be equal to noMark!

33initialState = (Map.empty, emptyPool, noMark + 1, [])

35modifyEnv f = modify $ \(env, pool, mark, errors) -> (f env, pool, mark, errors)

36modifyPool f = modify $ \(env, pool, mark, errors) -> (env, f pool, mark, errors)

37+addError message t1 t2 =

37−addError message t1 t2 = modify $ \(env, pool, mark, errors) -> (env, pool, mark, err:errors)

38+ modify $ \(env, pool, mark, errors) -> (env, pool, mark, err : errors)

39+

38 where

40 where

39− msg = P.fsep . map P.text $ words message

41+ wordify = P.fsep . map P.text . words

42+ msg = wordify message

40 width = maximum . map length . lines $ render msg

43 width = maximum . map length . lines $ render msg

44+ spaces = List.replicate (width - 15 - 3) ' '

45+ err = makeError <$> extraPretty t1 <*> extraPretty t2

46+ makeError pt1 pt2 =

41− err = P.vcat [ P.text $ "Type error on line ???"

47+ P.vcat [ P.text $ "Type error" ++ spaces ++ "line ???"

42− , P.text (List.replicate width '-')

48+ , P.text (List.replicate width '-')

43− , msg <> P.text "\n"

49+ , msg <> P.text "\n"

44− , P.text " Expected Type:" <+> pretty t1

50+ , P.text " Expected Type:" <+> pt1

45− , P.text " Actual Type:" <+> pretty t2 <> P.text "\n"

51+ , P.text " Actual Type:" <+> pt2 <> P.text "\n"

52+ , wordify "The error comes from:" <> P.text "\n"

53+ , P.nest 3 (P.text "???")

46− ]

54+ ]

48switchToPool pool = modifyPool (\_ -> pool)

56switchToPool pool = modifyPool (\_ -> pool)

@@ -98,17 +106,14 @@ flatten term =

106

99makeInstance :: Variable -> StateT SolverState IO Variable

107makeInstance :: Variable -> StateT SolverState IO Variable

100makeInstance var = do

108makeInstance var = do

101−-- liftIO $ putStrLn ""

102−-- liftIO $ print $ pretty var

103 alreadyCopied <- uniqueMark

109 alreadyCopied <- uniqueMark

104 freshVar <- makeCopy alreadyCopied var

110 freshVar <- makeCopy alreadyCopied var

105 restore alreadyCopied var

111 restore alreadyCopied var

106−-- liftIO $ print $ pretty freshVar

107 return freshVar

112 return freshVar

108

113

109makeCopy :: Int -> Variable -> StateT SolverState IO Variable

114makeCopy :: Int -> Variable -> StateT SolverState IO Variable

110makeCopy alreadyCopied variable = do

115makeCopy alreadyCopied variable = do

111−-- liftIO $ putStr "Copying: "

116+ debug $ putStr "Copying: "

112 desc <- liftIO $ UF.descriptor variable

117 desc <- liftIO $ UF.descriptor variable

113 if | mark desc == alreadyCopied ->

118 if | mark desc == alreadyCopied ->

114 do debug $ putStrLn "Already Copied"

119 do debug $ putStrLn "Already Copied"

compiler/Type/Type.hs+62−40

@@ -197,15 +197,16 @@ instance (Pretty a, Pretty b) => Pretty (Scheme a b) where

197 dict = P.parens . P.sep . P.punctuate P.comma . map prettyPair $ Map.toList headers

198 prettyPair (n,t) = P.text n <+> P.text ":" <+> pretty t

199

200−

200+extraPretty :: (Pretty t, Crawl t) => t -> IO Doc

201−prettyNames constraint = do

201+extraPretty value = do

202− (_, rawVars) <- fold constraint [] getNames

202+ (_, rawVars) <- runStateT (crawl getNames value) []

203 let vars = map head . List.group $ List.sort rawVars

204 letters = map (:[]) ['a'..'z']

205 suffix s = map (++s)

206 allVars = letters ++ suffix "'" letters ++ concatMap (\n -> suffix (show n) letters) [0..]

207 okayVars = filter (`notElem` vars) allVars

208− fold constraint okayVars rename

208+ runStateT (crawl rename value) okayVars

209+ return (pretty value)

209 where

210 where

210 getNames name vars =

211 getNames name vars =

211 case name of

212 case name of

@@ -217,39 +218,60 @@ prettyNames constraint = do

217 Just var -> (name, vars)

218 Just var -> (name, vars)

218 Nothing -> (Just (head vars), tail vars)

219 Nothing -> (Just (head vars), tail vars)

219

220

220−fold constraint initialState func =

221+

221− runStateT (prettyName constraint) initialState

222+-- Code for traversing all the type data-structures and giving

222− where

223+-- names to the variables embedded deep in there.

223− prettyName constraint =

224+class Crawl t where

225+ crawl :: (Maybe TypeName -> [String] -> (Maybe TypeName, [String]))

226+ -> t

227+ -> StateT [String] IO t

228+

229+instance (Crawl t, Crawl v) => Crawl (Constraint t v) where

230+ crawl nextState constraint =

231+ let rnm = crawl nextState in

224− case constraint of

232+ case constraint of

225− CTrue -> return CTrue

233+ CTrue -> return CTrue

226− CEqual a b -> CEqual <$> prettyTypeName a <*> prettyTypeName b

234+ CEqual a b -> CEqual <$> rnm a <*> rnm b

227− CAnd cs -> CAnd <$> mapM prettyName cs

235+ CAnd cs -> CAnd <$> crawl nextState cs

228− CLet schemes c -> CLet <$> mapM prettySchemeName schemes <*> prettyName c

236+ CLet schemes c -> CLet <$> crawl nextState schemes <*> crawl nextState c

229− CInstance name tipe -> CInstance name <$> prettyTypeName tipe

237+ CInstance name tipe -> CInstance name <$> rnm tipe

230−

238+

231− prettySchemeName (Scheme rqs fqs c headers) =

239+instance Crawl a => Crawl [a] where

232− Scheme <$> mapM prettyVarName rqs <*> mapM prettyVarName fqs <*> prettyName c <*> return headers

240+ crawl nextState list = mapM (crawl nextState) list

233−

241+

234− prettyVarName point = do

242+instance (Crawl t, Crawl v) => Crawl (Scheme t v) where

235− state <- get

243+ crawl nextState (Scheme rqs fqs c headers) =

244+ let rnm = crawl nextState in

245+ Scheme <$> rnm rqs <*> rnm fqs <*> crawl nextState c <*> return headers

246+

247+instance Crawl t => Crawl (TermN t) where

248+ crawl nextState tipe =

249+ case tipe of

250+ VarN x -> VarN <$> crawl nextState x

251+ TermN term -> TermN <$> crawl nextState term

252+

253+instance Crawl t => Crawl (Term1 t) where

254+ crawl nextState term =

255+ let rnm = crawl nextState in

256+ case term of

257+ App1 a b -> App1 <$> rnm a <*> rnm b

258+ Fun1 a b -> Fun1 <$> rnm a <*> rnm b

259+ Var1 a -> Var1 <$> rnm a

260+ EmptyRecord1 -> return EmptyRecord1

261+ Record1 fields ext ->

262+ Record1 <$> traverse (mapM rnm) fields <*> rnm ext

263+

264+instance Crawl a => Crawl (UF.Point a) where

265+ crawl nextState point = do

236− put =<< do desc <- liftIO $ UF.descriptor point

266+ desc <- liftIO $ UF.descriptor point

237− let (name', state') = func (name desc) state

267+ desc' <- crawl nextState desc

238− liftIO $ UF.setDescriptor point (desc { name = name' })

268+ liftIO $ UF.setDescriptor point desc'

239− return state'

269+ return point

240− return point

270+

241−

271+instance Crawl Descriptor where

242− prettyTypeName tipe =

272+ crawl nextState desc = do

243− case tipe of

273+ state <- get

244− VarN x -> VarN <$> prettyVarName x

274+ let (name', state') = nextState (name desc) state

245− TermN term -> TermN <$> prettyTermName term

275+ structure' <- traverse (crawl nextState) (structure desc)

246−

276+ put state'

247− prettyTermName term =

277+ return $ desc { name = name', structure = structure' }

248− case term of

249− App1 a b -> App1 <$> prettyTypeName a <*> prettyTypeName b

250− Fun1 a b -> Fun1 <$> prettyTypeName a <*> prettyTypeName b

251− Var1 a -> Var1 <$> prettyTypeName a

252− EmptyRecord1 -> return EmptyRecord1

253− Record1 fields ext -> Record1 <$> fields' <*> prettyTypeName ext

254− where

255− fields' = traverse (mapM prettyTypeName) fields