git.iko.soy/elk
on dd2feec help sign in
elk/src/Reporting/Helpers.hs
235 lines 5.3 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, reflowLink, makeLink
9 , stack, reflow
10 , commaSep, capitalize, ordinalize, drawCycle
11 , findPotentialTypos, findTypoPairs, vetTypos
12 , nearbyNames, distance
13 -- re-exports
14 , Doc, (<+>), (<>), black, 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 Data.Monoid ((<>))
25import qualified Data.Set as Set
26import qualified Data.Text as Text
27import Data.Text (Text)
28import qualified Elm.Name as N
29import qualified Text.EditDistance as Dist
30import qualified Text.PrettyPrint.ANSI.Leijen as P
31import Text.PrettyPrint.ANSI.Leijen hiding ((<>))
33import qualified Elm.Compiler.Version as Compiler
34import qualified Elm.Package as Pkg
38-- DOC HELPERS
41textToDoc :: Text -> Doc
42textToDoc msg =
43 text (Text.unpack msg)
46nameToDoc :: N.Name -> Doc
47nameToDoc name =
48 text (N.toString name)
51args :: Int -> String
52args n =
53 show n <> if n == 1 then " argument" else " arguments"
56moreArgs :: Int -> String
57moreArgs n =
58 show n <> " more" <> if n == 1 then " argument" else " arguments"
62-- HINTS
65toSimpleNote :: String -> Doc
66toSimpleNote message =
67 fillSep ((underline (text "Note") <> ":") : map text (words message))
70toSimpleHint :: String -> Doc
71toSimpleHint message =
72 toFancyHint (map text (words message))
75toFancyHint :: [Doc] -> Doc
76toFancyHint chunks =
77 fillSep (underline (text "Hint") <> ":" : chunks)
80link :: Doc -> String -> String -> String -> Doc
81link word before fileName after =
82 fillSep $
83 (underline word <> ":")
84 : map text (words before)
85 ++ P.text (makeLink fileName)
86 : map text (words after)
89makeLink :: String -> String
90makeLink fileName =
91 "<https://elm-lang.org/hints/" <> Pkg.versionToString Compiler.version <> "/" <> fileName <> ">"
94reflowLink :: String -> String -> String -> Doc
95reflowLink before fileName after =
96 fillSep $
97 map text (words before)
98 ++ P.text (makeLink fileName)
99 : map text (words after)
102stack :: [Doc] -> Doc
103stack chunks =
104 case chunks of
105 [] ->
106 error "function `stack` requires a non-empty list of docs"
108 doc : docs ->
109 List.foldl' (\a b -> a <> hardline <> hardline <> b) doc docs
112reflow :: String -> Doc
113reflow paragraph =
114 fillSep (map text (words paragraph))
117commaSep :: Doc -> (Doc -> Doc) -> [Doc] -> [Doc]
118commaSep conjunction addStyle names =
119 case names of
120 [name] ->
121 [ addStyle name ]
123 [name1,name2] ->
124 [ addStyle name1, conjunction, addStyle name2 ]
126 _ ->
127 map (\name -> addStyle name <> ",") (init names)
128 ++
129 [ conjunction
130 , addStyle (last names)
131 ]
134capitalize :: Text -> Text
135capitalize txt =
136 case Text.uncons txt of
137 Nothing ->
138 txt
140 Just (c, rest) ->
141 Text.cons (Char.toUpper c) rest
144ordinalize :: Int -> String
145ordinalize number =
146 let
147 remainder10 =
148 number `mod` 10
150 remainder100 =
151 number `mod` 100
153 ending
154 | remainder100 `elem` [11..13] = "th"
155 | remainder10 == 1 = "st"
156 | remainder10 == 2 = "nd"
157 | remainder10 == 3 = "rd"
158 | otherwise = "th"
159 in
160 show number <> ending
164drawCycle :: [N.Name] -> Doc
165drawCycle names =
166 let
167 topLine = "┌─────┐"
168 nameLine name = "│ " <> dullyellow (nameToDoc name)
169 midLine = "│ ↓"
170 bottomLine = "└─────┘"
171 in
172 vcat (topLine : List.intersperse midLine (map nameLine names) ++ [ bottomLine ])
176-- FIND TYPOS
179findPotentialTypos :: [String] -> String -> [String]
180findPotentialTypos knownNames badName =
181 filter (\name -> distance badName name == 1) knownNames
184findTypoPairs :: [String] -> [String] -> [(String, String)]
185findTypoPairs leftOnly rightOnly =
186 let
187 veryNear leftName =
188 map ((,) leftName) (findPotentialTypos rightOnly leftName)
189 in
190 concatMap veryNear leftOnly
193vetTypos :: [(String, String)] -> Maybe (Set.Set String, Set.Set String)
194vetTypos potentialTypos =
195 let
196 tallyNames (ln, rn) (lc, rc) =
197 ( Map.insertWith (+) ln 1 lc
198 , Map.insertWith (+) rn 1 rc
199 )
201 (leftCounts, rightCounts) =
202 foldr tallyNames (Map.empty, Map.empty) potentialTypos
204 acceptable :: Map.Map String Int -> Bool
205 acceptable counts =
206 not (Map.null counts)
207 &&
208 Map.foldr (\n unique -> n < 2 && unique) True counts
209 in
210 if acceptable leftCounts && acceptable rightCounts then
211 Just (Map.keysSet leftCounts, Map.keysSet rightCounts)
213 else
214 Nothing
218-- NEARBY NAMES
221nearbyNames :: String -> [String] -> [String]
222nearbyNames name names =
223 let
224 editDistance =
225 if length name < 3 then 1 else 2
226 in
227 map snd $
228 filter ( (<= editDistance) . abs . fst ) $
229 List.sortBy (compare `on` fst) $
230 map (\x -> (distance name x, x)) names
233distance :: String -> String -> Int
234distance x y =
235 Dist.restrictedDamerauLevenshteinDistance Dist.defaultEditCosts x y