git.iko.soy/elk
on 0bdfd73 help sign in
elk/src/Reporting/Helpers.hs
250 lines 5.7 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Reporting.Helpers
4 ( textToDoc
5 , nameToDoc
6 , args, moreArgs
7 , toSimpleNote, toSimpleHint, toFancyHint
8 , link, fancyLink, reflowLink, makeLink
9 , stack, reflow
10 , commaSep, capitalize, ordinalize, drawCycle
11 , findPotentialTypos, findTypoPairs, vetTypos
12 , nearbyNames, distance
13 -- re-exports
14 , Doc, (<+>), (<>), black, blue, cat, dullyellow, fillSep, green, hang, hardline
15 , hcat, hsep, indent, magenta, parens, sep, text, underline, vcat
16 )
17 where
20import Data.Function (on)
21import qualified Data.Char as Char
22import qualified Data.List as List
23import qualified Data.Map as Map
24import qualified Data.Maybe as Maybe
25import qualified Data.Set as Set
26import Data.Monoid ((<>))
27import qualified Data.Text as Text
28import Data.Text (Text)
29import qualified Elm.Name as N
30import qualified Text.EditDistance as Dist
31import qualified Text.PrettyPrint.ANSI.Leijen as P
32import Text.PrettyPrint.ANSI.Leijen hiding ((<>))
34import qualified Elm.Compiler.Version as Compiler
35import qualified Elm.Package as Pkg
39-- DOC HELPERS
42textToDoc :: Text -> Doc
43textToDoc msg =
44 text (Text.unpack msg)
47nameToDoc :: N.Name -> Doc
48nameToDoc name =
49 text (N.toString name)
52args :: Int -> String
53args n =
54 show n <> if n == 1 then " argument" else " arguments"
57moreArgs :: Int -> String
58moreArgs n =
59 show n <> " more" <> if n == 1 then " argument" else " arguments"
63-- HINTS
66toSimpleNote :: String -> Doc
67toSimpleNote message =
68 fillSep ((underline (text "Note") <> ":") : map text (words message))
71toSimpleHint :: String -> Doc
72toSimpleHint message =
73 toFancyHint (map text (words message))
76toFancyHint :: [Doc] -> Doc
77toFancyHint chunks =
78 fillSep (underline (text "Hint") <> ":" : chunks)
81link :: Doc -> String -> String -> String -> Doc
82link word before fileName after =
83 fillSep $
84 (underline word <> ":")
85 : map text (words before)
86 ++ P.text (makeLink fileName)
87 : map text (words after)
90fancyLink :: Doc -> [Doc] -> String -> [Doc] -> Doc
91fancyLink word before fileName after =
92 fillSep $
93 (underline word <> ":") : before ++ P.text (makeLink fileName) : after
96makeLink :: String -> String
97makeLink fileName =
98 "<https://elm-lang.org/hints/" <> Pkg.versionToString Compiler.version <> "/" <> fileName <> ">"
101reflowLink :: String -> String -> String -> Doc
102reflowLink before fileName after =
103 fillSep $
104 map text (words before)
105 ++ P.text (makeLink fileName)
106 : map text (words after)
109stack :: [Doc] -> Doc
110stack chunks =
111 case chunks of
112 [] ->
113 error "function `stack` requires a non-empty list of docs"
115 doc : docs ->
116 List.foldl' (\a b -> a <> hardline <> hardline <> b) doc docs
119reflow :: String -> Doc
120reflow paragraph =
121 fillSep (map text (words paragraph))
124commaSep :: Doc -> (Doc -> Doc) -> [Doc] -> [Doc]
125commaSep conjunction addStyle names =
126 case names of
127 [name] ->
128 [ addStyle name ]
130 [name1,name2] ->
131 [ addStyle name1, conjunction, addStyle name2 ]
133 _ ->
134 map (\name -> addStyle name <> ",") (init names)
135 ++
136 [ conjunction
137 , addStyle (last names)
138 ]
141capitalize :: Text -> Text
142capitalize txt =
143 case Text.uncons txt of
144 Nothing ->
145 txt
147 Just (c, rest) ->
148 Text.cons (Char.toUpper c) rest
151ordinalize :: Int -> String
152ordinalize number =
153 let
154 remainder10 =
155 number `mod` 10
157 remainder100 =
158 number `mod` 100
160 ending
161 | remainder100 `elem` [11..13] = "th"
162 | remainder10 == 1 = "st"
163 | remainder10 == 2 = "nd"
164 | remainder10 == 3 = "rd"
165 | otherwise = "th"
166 in
167 show number <> ending
171drawCycle :: [N.Name] -> Doc
172drawCycle names =
173 let
174 topLine = "┌─────┐"
175 nameLine name = "│ " <> dullyellow (nameToDoc name)
176 midLine = "│ ↓"
177 bottomLine = "└─────┘"
178 in
179 vcat (topLine : List.intersperse midLine (map nameLine names) ++ [ bottomLine ])
183-- FIND TYPOS
186findPotentialTypos :: [String] -> String -> [String]
187findPotentialTypos knownNames badName =
188 filter (\name -> distance badName name == 1) knownNames
191findTypoPairs :: [String] -> [String] -> [(String, String)]
192findTypoPairs leftOnly rightOnly =
193 let
194 veryNear leftName =
195 map ((,) leftName) (findPotentialTypos rightOnly leftName)
196 in
197 concatMap veryNear leftOnly
200vetTypos :: [(String, String)] -> Maybe (Set.Set String, Set.Set String)
201vetTypos potentialTypos =
202 let
203 tallyNames (ln, rn) (lc, rc) =
204 ( Map.insertWith (+) ln 1 lc
205 , Map.insertWith (+) rn 1 rc
206 )
208 (leftCounts, rightCounts) =
209 foldr tallyNames (Map.empty, Map.empty) potentialTypos
211 acceptable :: Map.Map String Int -> Bool
212 acceptable counts =
213 not (Map.null counts)
214 &&
215 Map.foldr (\n unique -> n < 2 && unique) True counts
216 in
217 if acceptable leftCounts && acceptable rightCounts then
218 Just (Map.keysSet leftCounts, Map.keysSet rightCounts)
220 else
221 Nothing
225-- NEARBY NAMES
228nearbyNames :: (a -> String) -> a -> [a] -> [a]
229nearbyNames toString value possibleValues =
230 let
231 name =
232 toString value
234 editDistance =
235 if length name < 3 then 1 else 2
237 getDistance pValue =
238 let
239 dist = abs (distance name (toString pValue))
240 in
241 if dist <= editDistance then Just (dist, pValue) else Nothing
242 in
243 map snd $
244 List.sortBy (compare `on` fst) $
245 Maybe.mapMaybe getDistance possibleValues
248distance :: String -> String -> Int
249distance x y =
250 Dist.restrictedDamerauLevenshteinDistance Dist.defaultEditCosts x y