git.iko.soy/elk
on afa4f13 help sign in
elk/terminal/src/Diff.hs
358 lines 9.9 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Diff
4 ( Args(..)
5 , run
6 )
7 where
10import qualified Data.List as List
11import qualified Data.Map as Map
12import qualified Data.Maybe as Maybe
13import qualified Data.Name as Name
14import qualified Data.NonEmptyList as NE
16import qualified Build
17import Deps.Diff (PackageChanges(..), ModuleChanges(..), Changes(..))
18import qualified Deps.Diff as DD
19import qualified Deps.Registry as Registry
20import qualified Elm.Compiler.Type as Type
21import qualified Elm.Details as Details
22import qualified Elm.Docs as Docs
23import qualified Elm.Magnitude as M
24import qualified Elm.Outline as Outline
25import qualified Elm.Package as Pkg
26import qualified Elm.Version as V
27import qualified Http
28import qualified Reporting
29import Reporting.Doc ((<>), (<+>))
30import qualified Reporting.Doc as D
31import qualified Reporting.Exit as Exit
32import qualified Reporting.Exit.Help as Help
33import qualified Reporting.Render.Type.Localizer as L
34import qualified Reporting.Task as Task
35import qualified Stuff
39-- RUN
42data Args
43 = CodeVsLatest
44 | CodeVsExactly V.Version
45 | LocalInquiry V.Version V.Version
46 | GlobalInquiry Pkg.Name V.Version V.Version
49run :: Args -> () -> IO ()
50run args () =
51 Reporting.attempt Exit.diffToReport $
52 Task.run $
53 do env <- getEnv
54 diff env args
58-- ENVIRONMENT
61data Env =
62 Env
63 { _maybeRoot :: Maybe FilePath
64 , _cache :: Stuff.PackageCache
65 , _manager :: Http.Manager
66 , _registry :: Registry.Registry
67 }
70getEnv :: Task Env
71getEnv =
72 do maybeRoot <- Task.io $ Stuff.findRoot
73 cache <- Task.io $ Stuff.getPackageCache
74 manager <- Task.io $ Http.getManager
75 registry <- Task.eio Exit.DiffMustHaveLatestRegistry $ Registry.latest manager cache
76 return (Env maybeRoot cache manager registry)
80-- DIFF
83type Task a =
84 Task.Task Exit.Diff a
87diff :: Env -> Args -> Task ()
88diff env@(Env _ _ _ registry) args =
89 case args of
90 GlobalInquiry name v1 v2 ->
91 case Registry.getVersions' name registry of
92 Right vsns ->
93 do oldDocs <- getDocs env name vsns (min v1 v2)
94 newDocs <- getDocs env name vsns (max v1 v2)
95 writeDiff oldDocs newDocs
97 Left suggestions ->
98 Task.throw $ Exit.DiffUnknownPackage name suggestions
100 LocalInquiry v1 v2 ->
101 do (name, vsns) <- readOutline env
102 oldDocs <- getDocs env name vsns (min v1 v2)
103 newDocs <- getDocs env name vsns (max v1 v2)
104 writeDiff oldDocs newDocs
106 CodeVsLatest ->
107 do (name, vsns) <- readOutline env
108 oldDocs <- getLatestDocs env name vsns
109 newDocs <- generateDocs env
110 writeDiff oldDocs newDocs
112 CodeVsExactly version ->
113 do (name, vsns) <- readOutline env
114 oldDocs <- getDocs env name vsns version
115 newDocs <- generateDocs env
116 writeDiff oldDocs newDocs
120-- GET DOCS
123getDocs :: Env -> Pkg.Name -> Registry.KnownVersions -> V.Version -> Task Docs.Documentation
124getDocs (Env _ cache manager _) name (Registry.KnownVersions latest previous) version =
125 if latest == version || elem version previous
126 then Task.eio (Exit.DiffDocsProblem version) $ DD.getDocs cache manager name version
127 else Task.throw $ Exit.DiffUnknownVersion name version (latest:previous)
130getLatestDocs :: Env -> Pkg.Name -> Registry.KnownVersions -> Task Docs.Documentation
131getLatestDocs (Env _ cache manager _) name (Registry.KnownVersions latest _) =
132 Task.eio (Exit.DiffDocsProblem latest) $ DD.getDocs cache manager name latest
136-- READ OUTLINE
139readOutline :: Env -> Task (Pkg.Name, Registry.KnownVersions)
140readOutline (Env maybeRoot _ _ registry) =
141 case maybeRoot of
142 Nothing ->
143 Task.throw $ Exit.DiffNoOutline
145 Just root ->
146 do result <- Task.io $ Outline.read root
147 case result of
148 Left err ->
149 Task.throw $ Exit.DiffBadOutline err
151 Right outline ->
152 case outline of
153 Outline.App _ ->
154 Task.throw $ Exit.DiffApplication
156 Outline.Pkg (Outline.PkgOutline pkg _ _ _ _ _ _ _) ->
157 case Registry.getVersions pkg registry of
158 Just vsns -> return (pkg, vsns)
159 Nothing -> Task.throw Exit.DiffUnpublished
163-- GENERATE DOCS
166generateDocs :: Env -> Task Docs.Documentation
167generateDocs (Env maybeRoot _ _ _) =
168 case maybeRoot of
169 Nothing ->
170 Task.throw $ Exit.DiffNoOutline
172 Just root ->
173 do details <-
174 Task.eio Exit.DiffBadDetails $
175 Details.load Reporting.silent root
177 case Details._outline details of
178 Details.ValidApp _ ->
179 Task.throw $ Exit.DiffApplication
181 Details.ValidPkg _ exposed ->
182 case exposed of
183 [] ->
184 Task.throw $ Exit.DiffNoExposed
186 e:es ->
187 Task.eio Exit.DiffBadBuild $
188 Build.fromExposed Reporting.silent root details Build.KeepDocs (NE.List e es)
192-- WRITE DIFF
195writeDiff :: Docs.Documentation -> Docs.Documentation -> Task ()
196writeDiff oldDocs newDocs =
197 let
198 changes = DD.diff oldDocs newDocs
199 localizer = L.fromNames (Map.union oldDocs newDocs)
200 in
201 Task.io $ Help.toStdout $ toDoc localizer changes <> "\n"
205-- TO DOC
208toDoc :: L.Localizer -> PackageChanges -> D.Doc
209toDoc localizer changes@(PackageChanges added changed removed) =
210 if null added && Map.null changed && null removed then
211 "No API changes detected, so this is a" <+> D.green "PATCH" <+> "change."
212 else
213 let
214 magDoc =
215 D.fromChars (M.toChars (DD.toMagnitude changes))
217 header =
218 "This is a" <+> D.green magDoc <+> "change."
220 addedChunk =
221 if null added then [] else
222 [ Chunk "ADDED MODULES" M.MINOR $
223 D.vcat $ map D.fromName added
224 ]
226 removedChunk =
227 if null removed then [] else
228 [ Chunk "REMOVED MODULES" M.MAJOR $
229 D.vcat $ map D.fromName removed
230 ]
232 chunks =
233 addedChunk ++ removedChunk ++ map (changesToChunk localizer) (Map.toList changed)
234 in
235 D.vcat (header : "" : map chunkToDoc chunks)
238data Chunk =
239 Chunk
240 { _title :: String
241 , _magnitude :: M.Magnitude
242 , _details :: D.Doc
243 }
246chunkToDoc :: Chunk -> D.Doc
247chunkToDoc (Chunk title magnitude details) =
248 let
249 header =
250 "----" <+> D.fromChars title <+> "-" <+> D.fromChars (M.toChars magnitude) <+> "----"
251 in
252 D.vcat
253 [ D.dullcyan header
254 , ""
255 , D.indent 4 details
256 , ""
257 , ""
258 ]
261changesToChunk :: L.Localizer -> (Name.Name, ModuleChanges) -> Chunk
262changesToChunk localizer (name, changes@(ModuleChanges unions aliases values binops)) =
263 let
264 magnitude =
265 DD.moduleChangeMagnitude changes
267 (unionAdd, unionChange, unionRemove) =
268 changesToDocTriple (unionToDoc localizer) unions
270 (aliasAdd, aliasChange, aliasRemove) =
271 changesToDocTriple (aliasToDoc localizer) aliases
273 (valueAdd, valueChange, valueRemove) =
274 changesToDocTriple (valueToDoc localizer) values
276 (binopAdd, binopChange, binopRemove) =
277 changesToDocTriple (binopToDoc localizer) binops
278 in
279 Chunk (Name.toChars name) magnitude $
280 D.vcat $ List.intersperse "" $ Maybe.catMaybes $
281 [ changesToDoc "Added" unionAdd aliasAdd valueAdd binopAdd
282 , changesToDoc "Removed" unionRemove aliasRemove valueRemove binopRemove
283 , changesToDoc "Changed" unionChange aliasChange valueChange binopChange
284 ]
287changesToDocTriple :: (k -> v -> D.Doc) -> Changes k v -> ([D.Doc], [D.Doc], [D.Doc])
288changesToDocTriple entryToDoc (Changes added changed removed) =
289 let
290 indented (name, value) =
291 D.indent 4 (entryToDoc name value)
293 diffed (name, (oldValue, newValue)) =
294 D.vcat
295 [ " - " <> entryToDoc name oldValue
296 , " + " <> entryToDoc name newValue
297 , ""
298 ]
299 in
300 ( map indented (Map.toList added)
301 , map diffed (Map.toList changed)
302 , map indented (Map.toList removed)
303 )
306changesToDoc :: String -> [D.Doc] -> [D.Doc] -> [D.Doc] -> [D.Doc] -> Maybe D.Doc
307changesToDoc categoryName unions aliases values binops =
308 if null unions && null aliases && null values && null binops then
309 Nothing
311 else
312 Just $ D.vcat $
313 D.fromChars categoryName <> ":" : unions ++ aliases ++ binops ++ values
316unionToDoc :: L.Localizer -> Name.Name -> Docs.Union -> D.Doc
317unionToDoc localizer name (Docs.Union _ tvars ctors) =
318 let
319 setup =
320 "type" <+> D.fromName name <+> D.hsep (map D.fromName tvars)
322 ctorDoc (ctor, tipes) =
323 typeDoc localizer (Type.Type ctor tipes)
324 in
325 D.hang 4 (D.sep (setup : zipWith (<+>) ("=" : repeat "|") (map ctorDoc ctors)))
328aliasToDoc :: L.Localizer -> Name.Name -> Docs.Alias -> D.Doc
329aliasToDoc localizer name (Docs.Alias _ tvars tipe) =
330 let
331 declaration =
332 "type" <+> "alias" <+> D.hsep (map D.fromName (name:tvars)) <+> "="
333 in
334 D.hang 4 (D.sep [ declaration, typeDoc localizer tipe ])
337valueToDoc :: L.Localizer -> Name.Name -> Docs.Value -> D.Doc
338valueToDoc localizer name (Docs.Value _ tipe) =
339 D.hang 4 $ D.sep [ D.fromName name <+> ":", typeDoc localizer tipe ]
342binopToDoc :: L.Localizer -> Name.Name -> Docs.Binop -> D.Doc
343binopToDoc localizer name (Docs.Binop _ tipe associativity (Docs.Precedence n)) =
344 "(" <> D.fromName name <> ")" <+> ":" <+> typeDoc localizer tipe <> D.black details
345 where
346 details =
347 " (" <> D.fromName assoc <> "/" <> D.fromInt n <> ")"
349 assoc =
350 case associativity of
351 Docs.Left -> "left"
352 Docs.Non -> "non"
353 Docs.Right -> "right"
356typeDoc :: L.Localizer -> Type.Type -> D.Doc
357typeDoc localizer tipe =
358 Type.toDoc localizer Type.None tipe