8759d16 · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Move typo-finders & add parens in rendered types

8759d16Evan Czaplicki11 years ago

src/Reporting/Error/Helpers.hs+38

compare with master

unifiedsplit

@@ -3,6 +3,7 @@ module Reporting.Error.Helpers

3 ( (|>)

4 , functionName, hintLink, stack, reflowParagraph

5 , commaSep, capitalize, ordinalize, drawCycle

6+ , findPotentialTypos, vetTypos

6 , nearbyNames, distance, maybeYouWant

7 , nearbyNames, distance, maybeYouWant

7 )

8 )

8 where

9 where

@@ -10,6 +11,8 @@ module Reporting.Error.Helpers

10import Data.Function (on)

11import Data.Function (on)

11import qualified Data.Char as Char

12import qualified Data.Char as Char

12import qualified Data.List as List

13import qualified Data.List as List

14+import qualified Data.Map as Map

15+import qualified Data.Set as Set

13import qualified Text.EditDistance as Dist

16import qualified Text.EditDistance as Dist

14import Text.PrettyPrint.ANSI.Leijen

17import Text.PrettyPrint.ANSI.Leijen

15 ( Doc, (<>), dullyellow, fillSep, hardline, text, vcat )

18 ( Doc, (<>), dullyellow, fillSep, hardline, text, vcat )

@@ -126,6 +129,41 @@ drawCycle strings =

126

129

127

130

128

131

132+-- FIND TYPOS

133+

134+

135+findPotentialTypos :: [String] -> [String] -> [(String, String)]

136+findPotentialTypos leftOnly rightOnly =

137+ let

138+ veryNear leftName =

139+ map ((,) leftName) (filter ((==1) . distance leftName) rightOnly)

140+ in

141+ concatMap veryNear leftOnly

142+

143+

144+vetTypos :: [(String, String)] -> Maybe (Set.Set String, Set.Set String)

145+vetTypos potentialTypos =

146+ let

147+ tallyNames (ln, rn) (lc, rc) =

148+ ( Map.insertWith (+) ln 1 lc

149+ , Map.insertWith (+) rn 1 rc

150+ )

151+

152+ (leftCounts, rightCounts) =

153+ foldr tallyNames (Map.empty, Map.empty) potentialTypos

154+

155+ allUnique :: Map.Map String Int -> Bool

156+ allUnique counts =

157+ Map.foldr (\n unique -> n < 2 && unique) True counts

158+ in

159+ if allUnique leftCounts && allUnique rightCounts then

160+ Just (Map.keysSet leftCounts, Map.keysSet rightCounts)

161+

162+ else

163+ Nothing

164+

165+

166+

129-- NEARBY NAMES

167-- NEARBY NAMES

130

168

131

169

src/Reporting/Error/Type.hs+2−2

@@ -453,8 +453,8 @@ reasonToString reason =

453 in

454 case reason of

455 MessyFields leftOnly rightOnly ->

456− do let typos = RenderType.findPotentialTypos leftOnly rightOnly

456+ do let typos = Help.findPotentialTypos leftOnly rightOnly

457− _ <- RenderType.vetTypos typos

457+ _ <- Help.vetTypos typos

458 misspellingMessage typos

459

460 NotNumber ->

src/Reporting/Render/Type.hs+65−75

@@ -5,8 +5,6 @@ module Reporting.Render.Type

5 , toDoc

6 , diffToDocs

7 , Style(..)

8− , findPotentialTypos

9− , vetTypos

10 )

8 )

11 where

9 where

@@ -14,14 +12,14 @@ import Control.Arrow ((***), first)

14import qualified Data.Map as Map

12import qualified Data.Map as Map

15import qualified Data.Set as Set

13import qualified Data.Set as Set

16import Text.PrettyPrint.ANSI.Leijen

14import Text.PrettyPrint.ANSI.Leijen

17− ( Doc, (<>), (<+>), cat, colon, comma, dullyellow, equals, hang, hsep

15+ ( Doc, (<+>), cat, colon, comma, dullyellow, equals, hang, hsep

18− , lbrace, lparen, parens, rbrace, rparen, sep, space, text, vcat

16+ , lbrace, lparen, parens, rbrace, rparen, sep, text, vcat

19 )

17 )

21import qualified AST.Helpers as Help

19import qualified AST.Helpers as Help

22import qualified AST.Type as Type

20import qualified AST.Type as Type

23import qualified AST.Variable as Var

21import qualified AST.Variable as Var

24−import Reporting.Error.Helpers as Help

22+import qualified Reporting.Error.Helpers as Help

@@ -30,12 +28,12 @@ import Reporting.Error.Helpers as Help

31toDoc :: Localizer -> Type.Canonical -> Doc

29toDoc :: Localizer -> Type.Canonical -> Doc

32toDoc localizer tipe =

30toDoc localizer tipe =

33− docType localizer tipe

31+ docType localizer None tipe

36diffToDocs :: Localizer -> Type.Canonical -> Type.Canonical -> (Doc,Doc)

34diffToDocs :: Localizer -> Type.Canonical -> Type.Canonical -> (Doc,Doc)

37diffToDocs localizer leftType rightType =

35diffToDocs localizer leftType rightType =

38− case diff localizer leftType rightType of

36+ case diff localizer None leftType rightType of

39 Same doc ->

37 Same doc ->

40 (doc, doc)

38 (doc, doc)

@@ -47,7 +45,7 @@ decl :: Localizer -> String -> [String] -> [(String, [Type.Canonical])] -> Doc

47decl localizer name vars tags =

45decl localizer name vars tags =

48 let

46 let

49 docTag (tag, args) =

47 docTag (tag, args) =

50− hang 2 (sep (text tag : map (docType localizer) args))

48+ hang 2 (sep (text tag : map (docType localizer App) args))

51 in

49 in

52 hang 4 $ vcat $

50 hang 4 $ vcat $

53 (hsep (map text ("type" : name : vars)))

51 (hsep (map text ("type" : name : vars)))

@@ -68,13 +66,13 @@ annotation localizer name tipe =

68 hang 4 $ sep $

66 hang 4 $ sep $

69 docName

67 docName

70 : zipWith (<+>)

68 : zipWith (<+>)

71− ((colon <> space) : repeat (text "->"))

69+ (colon : repeat (text "->"))

72− (map (docType localizer) parts)

70+ (map (docType localizer Func) parts)

74 _ ->

72 _ ->

75 hang 4 $ sep $

73 hang 4 $ sep $

76 [ docName <+> colon

74 [ docName <+> colon

77− , docType localizer tipe

75+ , docType localizer None tipe

78 ]

76 ]

@@ -158,8 +156,14 @@ partitionDiffs dict =

158-- DOC DIFF

156-- DOC DIFF

159

157

160

158

159+data Context

160+ = None

161+ | Func

162+ | App

163+

164+

161−diff :: Localizer -> Type.Canonical -> Type.Canonical -> Diff Doc

165+diff :: Localizer -> Context -> Type.Canonical -> Type.Canonical -> Diff Doc

162−diff localizer leftType rightType =

166+diff localizer context leftType rightType =

163 let

167 let

164 go = diff localizer

168 go = diff localizer

165 in

169 in

@@ -169,13 +173,14 @@ diff localizer leftType rightType =

169 leftParts = Type.collectLambdas leftType

173 leftParts = Type.collectLambdas leftType

170 rightParts = Type.collectLambdas rightType

174 rightParts = Type.collectLambdas rightType

171 in

175 in

176+

172 if length leftParts /= length rightParts then

177 if length leftParts /= length rightParts then

173 difference

178 difference

174− (docLambda (map (docType localizer) leftParts))

179+ (docLambda context (map (docType localizer Func) leftParts))

175− (docLambda (map (docType localizer) rightParts))

180+ (docLambda context (map (docType localizer Func) rightParts))

176

181

177 else

182 else

178− docLambda <$> sequenceA (zipWith go leftParts rightParts)

183+ docLambda context <$> sequenceA (zipWith (go Func) leftParts rightParts)

179

184

180 (Type.Var x, Type.Var y) | x == y ->

185 (Type.Var x, Type.Var y) | x == y ->

181 pure (text x)

186 pure (text x)

@@ -186,12 +191,12 @@ diff localizer leftType rightType =

186 (Type.App (Type.Type leftName) leftArgs, Type.App (Type.Type rightName) rightArgs) ->

191 (Type.App (Type.Type leftName) leftArgs, Type.App (Type.Type rightName) rightArgs) ->

187 if leftName /= rightName || length leftArgs /= length rightArgs then

192 if leftName /= rightName || length leftArgs /= length rightArgs then

188 difference

193 difference

189− (docApp localizer leftName (map (docType localizer) leftArgs))

194+ (docApp localizer context leftName (map (docType localizer App) leftArgs))

190− (docApp localizer rightName (map (docType localizer) rightArgs))

195+ (docApp localizer context rightName (map (docType localizer App) rightArgs))

191

196

192 else

197 else

193− docApp localizer leftName

198+ docApp localizer context leftName

194− <$> sequenceA (zipWith go leftArgs rightArgs)

199+ <$> sequenceA (zipWith (go App) leftArgs rightArgs)

195

200

196 (Type.App _ _, Type.App _ _) ->

201 (Type.App _ _, Type.App _ _) ->

197 error "Type applications without concrete names should not get here."

202 error "Type applications without concrete names should not get here."

@@ -207,19 +212,19 @@ diff localizer leftType rightType =

207 diffRecord localizer leftFields leftExt rightFields rightExt

212 diffRecord localizer leftFields leftExt rightFields rightExt

208

213

209 (Type.Aliased leftName leftArgs _, Type.Aliased rightName rightArgs _) | leftName == rightName ->

214 (Type.Aliased leftName leftArgs _, Type.Aliased rightName rightArgs _) | leftName == rightName ->

210− docApp localizer leftName

215+ docApp localizer context leftName

211− <$> sequenceA (zipWith go (map snd leftArgs) (map snd rightArgs))

216+ <$> sequenceA (zipWith (go App) (map snd leftArgs) (map snd rightArgs))

212

217

213 (Type.Aliased _ args real, _) ->

218 (Type.Aliased _ args real, _) ->

214− go (Type.dealias args real) rightType

219+ go context (Type.dealias args real) rightType

215

220

216 (_, Type.Aliased _ args real) ->

221 (_, Type.Aliased _ args real) ->

217− go leftType (Type.dealias args real)

222+ go context leftType (Type.dealias args real)

218

223

219 (_, _) ->

224 (_, _) ->

220 difference

225 difference

221− (docType localizer leftType)

226+ (docType localizer context leftType)

222− (docType localizer rightType)

227+ (docType localizer context rightType)

223

228

224

229

225difference :: Doc -> Doc -> Diff Doc

230difference :: Doc -> Doc -> Diff Doc

@@ -240,7 +245,7 @@ diffRecord localizer leftFields leftExt rightFields rightExt =

240 if Map.null leftOnly && Map.null rightOnly then

245 if Map.null leftOnly && Map.null rightOnly then

241 let

246 let

242 fieldDiffs =

247 fieldDiffs =

243− Map.map (uncurry (diff localizer)) both

248+ Map.map (uncurry (diff localizer None)) both

244 in

249 in

245 case partitionDiffs fieldDiffs of

250 case partitionDiffs fieldDiffs of

246 ([], sames) ->

251 ([], sames) ->

@@ -288,14 +293,14 @@ unzipDiffs diffPairs =

288

293

289

294

290

295

291−-- ANALYZE FIELD NAMES FOR SIMILAR NAMES

296+-- RECORD DIFFS HELPERS

292

297

293

298

294analyzeFields :: [String] -> [String] -> ( [(Doc, Doc)], [(Doc, Doc)] )

299analyzeFields :: [String] -> [String] -> ( [(Doc, Doc)], [(Doc, Doc)] )

295analyzeFields leftOnly rightOnly =

300analyzeFields leftOnly rightOnly =

296 let

301 let

297 potentialTypos =

302 potentialTypos =

298− findPotentialTypos leftOnly rightOnly

303+ Help.findPotentialTypos leftOnly rightOnly

299

304

300 mkField func name =

305 mkField func name =

301 ( func (text name), text "…" )

306 ( func (text name), text "…" )

@@ -303,7 +308,7 @@ analyzeFields leftOnly rightOnly =

303 mkFieldWith counts name =

308 mkFieldWith counts name =

304 mkField (if Set.member name counts then dullyellow else id) name

309 mkField (if Set.member name counts then dullyellow else id) name

305 in

310 in

306− case vetTypos potentialTypos of

311+ case Help.vetTypos potentialTypos of

307 Just (leftTypos, rightTypos) ->

312 Just (leftTypos, rightTypos) ->

308 ( map (mkFieldWith leftTypos) leftOnly

313 ( map (mkFieldWith leftTypos) leftOnly

309 , map (mkFieldWith rightTypos) rightOnly

314 , map (mkFieldWith rightTypos) rightOnly

@@ -315,39 +320,6 @@ analyzeFields leftOnly rightOnly =

315 )

320 )

316

321

317

322

318−findPotentialTypos :: [String] -> [String] -> [(String, String)]

319−findPotentialTypos leftOnly rightOnly =

320− let

321− veryNear leftName =

322− map ((,) leftName) (filter ((==1) . Help.distance leftName) rightOnly)

323− in

324− concatMap veryNear leftOnly

325−

326−

327−vetTypos :: [(String, String)] -> Maybe (Set.Set String, Set.Set String)

328−vetTypos potentialTypos =

329− let

330− tallyNames (ln, rn) (lc, rc) =

331− ( Map.insertWith (+) ln 1 lc

332− , Map.insertWith (+) rn 1 rc

333− )

334−

335− (leftCounts, rightCounts) =

336− foldr tallyNames (Map.empty, Map.empty) potentialTypos

337−

338− allUnique counts =

339− Map.foldr (\n unique -> n < 2 && unique) True counts

340− in

341− if allUnique leftCounts && allUnique rightCounts then

342− Just (Map.keysSet leftCounts, Map.keysSet rightCounts)

343−

344− else

345− Nothing

346−

347−

348−-- RECORD DIFFS HELPERS

349−

350−

351type Fields =

323type Fields =

352 Map.Map String Type.Canonical

324 Map.Map String Type.Canonical

353

325

@@ -398,11 +370,11 @@ flattenRecordHelp fields ext =

398-- TYPES TO DOCS

370-- TYPES TO DOCS

399

371

400

372

401−docType :: Localizer -> Type.Canonical -> Doc

373+docType :: Localizer -> Context -> Type.Canonical -> Doc

402−docType localizer tipe =

374+docType localizer context tipe =

403 case tipe of

375 case tipe of

404 Type.Lambda _ _ ->

376 Type.Lambda _ _ ->

405− docLambda (map (docType localizer) (Type.collectLambdas tipe))

377+ docLambda context (map (docType localizer Func) (Type.collectLambdas tipe))

406

378

407 Type.Var x ->

379 Type.Var x ->

408 text x

380 text x

@@ -411,7 +383,7 @@ docType localizer tipe =

411 varToDoc localizer name

383 varToDoc localizer name

412

384

413 Type.App (Type.Type name) args ->

385 Type.App (Type.Type name) args ->

414− docApp localizer name (map (docType localizer) args)

386+ docApp localizer context name (map (docType localizer App) args)

415

387

416 Type.App _ _ ->

388 Type.App _ _ ->

417 error "type applications should start with a type atom"

389 error "type applications should start with a type atom"

@@ -422,27 +394,36 @@ docType localizer tipe =

422 flattenRecordHelp outerFields outerExt

394 flattenRecordHelp outerFields outerExt

423 in

395 in

424 docRecord Full

396 docRecord Full

425− (map (text *** docType localizer) fields)

397+ (map (text *** docType localizer None) fields)

426 (fmap text ext)

398 (fmap text ext)

427

399

428 Type.Aliased name args _ ->

400 Type.Aliased name args _ ->

429− docApp localizer name (map (docType localizer . snd) args)

401+ docApp localizer context name (map (docType localizer App . snd) args)

430

402

431

403

432

404

433−docLambda :: [Doc] -> Doc

405+docLambda :: Context -> [Doc] -> Doc

434−docLambda docs =

406+docLambda context docs =

435 case docs of

407 case docs of

436 [] ->

408 [] ->

437 error "cannot call docLambda with an empty list"

409 error "cannot call docLambda with an empty list"

438

410

439 arg:rest ->

411 arg:rest ->

412+ case context of

413+ None ->

440− sep (arg : map (text "->" <+>) rest)

414+ sep (arg : map (text "->" <+>) rest)

415+

416+ _ ->

417+ cat

418+ [ lparen

419+ , sep (arg : map (text "->" <+>) rest)

420+ , rparen

421+ ]

441

422

442

423

443

424

444−docApp :: Localizer -> Var.Canonical -> [Doc] -> Doc

425+docApp :: Localizer -> Context -> Var.Canonical -> [Doc] -> Doc

445−docApp localizer name args =

426+docApp localizer context name args =

446 if Var.isTuple name then

427 if Var.isTuple name then

447 sep

428 sep

448 [ cat (zipWith (<+>) (lparen : repeat comma) args)

429 [ cat (zipWith (<+>) (lparen : repeat comma) args)

@@ -453,7 +434,16 @@ docApp localizer name args =

453 varToDoc localizer name

434 varToDoc localizer name

454

435

455 else

436 else

437+ case context of

438+ App ->

439+ cat

440+ [ lparen

441+ , hang 4 (sep (varToDoc localizer name : args))

442+ , rparen

443+ ]

444+

445+ _ ->

456− hang 4 (sep (varToDoc localizer name : args))

446+ hang 4 (sep (varToDoc localizer name : args))

457

447

458

448

459

449