git.iko.soy/elk
on 2edbe13 help sign in
elk/terminal/src/Diff.hs
359 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 BackgroundWriter as BW
17import qualified Build
18import Deps.Diff (PackageChanges(..), ModuleChanges(..), Changes(..))
19import qualified Deps.Diff as DD
20import qualified Deps.Registry as Registry
21import qualified Elm.Compiler.Type as Type
22import qualified Elm.Details as Details
23import qualified Elm.Docs as Docs
24import qualified Elm.Magnitude as M
25import qualified Elm.Outline as Outline
26import qualified Elm.Package as Pkg
27import qualified Elm.Version as V
28import qualified Http
29import qualified Reporting
30import Reporting.Doc ((<>), (<+>))
31import qualified Reporting.Doc as D
32import qualified Reporting.Exit as Exit
33import qualified Reporting.Exit.Help as Help
34import qualified Reporting.Render.Type.Localizer as L
35import qualified Reporting.Task as Task
36import qualified Stuff
40-- RUN
43data Args
44 = CodeVsLatest
45 | CodeVsExactly V.Version
46 | LocalInquiry V.Version V.Version
47 | GlobalInquiry Pkg.Name V.Version V.Version
50run :: Args -> () -> IO ()
51run args () =
52 Reporting.attempt Exit.diffToReport $
53 Task.run $
54 do env <- getEnv
55 diff env args
59-- ENVIRONMENT
62data Env =
63 Env
64 { _maybeRoot :: Maybe FilePath
65 , _cache :: Stuff.PackageCache
66 , _manager :: Http.Manager
67 , _registry :: Registry.Registry
68 }
71getEnv :: Task Env
72getEnv =
73 do maybeRoot <- Task.io $ Stuff.findRoot
74 cache <- Task.io $ Stuff.getPackageCache
75 manager <- Task.io $ Http.getManager
76 registry <- Task.eio Exit.DiffMustHaveLatestRegistry $ Registry.latest manager cache
77 return (Env maybeRoot cache manager registry)
81-- DIFF
84type Task a =
85 Task.Task Exit.Diff a
88diff :: Env -> Args -> Task ()
89diff env@(Env _ _ _ registry) args =
90 case args of
91 GlobalInquiry name v1 v2 ->
92 case Registry.getVersions' name registry of
93 Right vsns ->
94 do oldDocs <- getDocs env name vsns (min v1 v2)
95 newDocs <- getDocs env name vsns (max v1 v2)
96 writeDiff oldDocs newDocs
98 Left suggestions ->
99 Task.throw $ Exit.DiffUnknownPackage name suggestions
101 LocalInquiry v1 v2 ->
102 do (name, vsns) <- readOutline env
103 oldDocs <- getDocs env name vsns (min v1 v2)
104 newDocs <- getDocs env name vsns (max v1 v2)
105 writeDiff oldDocs newDocs
107 CodeVsLatest ->
108 do (name, vsns) <- readOutline env
109 oldDocs <- getLatestDocs env name vsns
110 newDocs <- generateDocs env
111 writeDiff oldDocs newDocs
113 CodeVsExactly version ->
114 do (name, vsns) <- readOutline env
115 oldDocs <- getDocs env name vsns version
116 newDocs <- generateDocs env
117 writeDiff oldDocs newDocs
121-- GET DOCS
124getDocs :: Env -> Pkg.Name -> Registry.KnownVersions -> V.Version -> Task Docs.Documentation
125getDocs (Env _ cache manager _) name (Registry.KnownVersions latest previous) version =
126 if latest == version || elem version previous
127 then Task.eio (Exit.DiffDocsProblem version) $ DD.getDocs cache manager name version
128 else Task.throw $ Exit.DiffUnknownVersion name version (latest:previous)
131getLatestDocs :: Env -> Pkg.Name -> Registry.KnownVersions -> Task Docs.Documentation
132getLatestDocs (Env _ cache manager _) name (Registry.KnownVersions latest _) =
133 Task.eio (Exit.DiffDocsProblem latest) $ DD.getDocs cache manager name latest
137-- READ OUTLINE
140readOutline :: Env -> Task (Pkg.Name, Registry.KnownVersions)
141readOutline (Env maybeRoot _ _ registry) =
142 case maybeRoot of
143 Nothing ->
144 Task.throw $ Exit.DiffNoOutline
146 Just root ->
147 do result <- Task.io $ Outline.read root
148 case result of
149 Left err ->
150 Task.throw $ Exit.DiffBadOutline err
152 Right outline ->
153 case outline of
154 Outline.App _ ->
155 Task.throw $ Exit.DiffApplication
157 Outline.Pkg (Outline.PkgOutline pkg _ _ _ _ _ _ _) ->
158 case Registry.getVersions pkg registry of
159 Just vsns -> return (pkg, vsns)
160 Nothing -> Task.throw Exit.DiffUnpublished
164-- GENERATE DOCS
167generateDocs :: Env -> Task Docs.Documentation
168generateDocs (Env maybeRoot _ _ _) =
169 case maybeRoot of
170 Nothing ->
171 Task.throw $ Exit.DiffNoOutline
173 Just root ->
174 do details <-
175 Task.eio Exit.DiffBadDetails $ BW.withScope $ \scope ->
176 Details.load Reporting.silent scope root
178 case Details._outline details of
179 Details.ValidApp _ ->
180 Task.throw $ Exit.DiffApplication
182 Details.ValidPkg _ exposed _ ->
183 case exposed of
184 [] ->
185 Task.throw $ Exit.DiffNoExposed
187 e:es ->
188 Task.eio Exit.DiffBadBuild $
189 Build.fromExposed Reporting.silent root details Build.KeepDocs (NE.List e es)
193-- WRITE DIFF
196writeDiff :: Docs.Documentation -> Docs.Documentation -> Task ()
197writeDiff oldDocs newDocs =
198 let
199 changes = DD.diff oldDocs newDocs
200 localizer = L.fromNames (Map.union oldDocs newDocs)
201 in
202 Task.io $ Help.toStdout $ toDoc localizer changes <> "\n"
206-- TO DOC
209toDoc :: L.Localizer -> PackageChanges -> D.Doc
210toDoc localizer changes@(PackageChanges added changed removed) =
211 if null added && Map.null changed && null removed then
212 "No API changes detected, so this is a" <+> D.green "PATCH" <+> "change."
213 else
214 let
215 magDoc =
216 D.fromChars (M.toChars (DD.toMagnitude changes))
218 header =
219 "This is a" <+> D.green magDoc <+> "change."
221 addedChunk =
222 if null added then [] else
223 [ Chunk "ADDED MODULES" M.MINOR $
224 D.vcat $ map D.fromName added
225 ]
227 removedChunk =
228 if null removed then [] else
229 [ Chunk "REMOVED MODULES" M.MAJOR $
230 D.vcat $ map D.fromName removed
231 ]
233 chunks =
234 addedChunk ++ removedChunk ++ map (changesToChunk localizer) (Map.toList changed)
235 in
236 D.vcat (header : "" : map chunkToDoc chunks)
239data Chunk =
240 Chunk
241 { _title :: String
242 , _magnitude :: M.Magnitude
243 , _details :: D.Doc
244 }
247chunkToDoc :: Chunk -> D.Doc
248chunkToDoc (Chunk title magnitude details) =
249 let
250 header =
251 "----" <+> D.fromChars title <+> "-" <+> D.fromChars (M.toChars magnitude) <+> "----"
252 in
253 D.vcat
254 [ D.dullcyan header
255 , ""
256 , D.indent 4 details
257 , ""
258 , ""
259 ]
262changesToChunk :: L.Localizer -> (Name.Name, ModuleChanges) -> Chunk
263changesToChunk localizer (name, changes@(ModuleChanges unions aliases values binops)) =
264 let
265 magnitude =
266 DD.moduleChangeMagnitude changes
268 (unionAdd, unionChange, unionRemove) =
269 changesToDocTriple (unionToDoc localizer) unions
271 (aliasAdd, aliasChange, aliasRemove) =
272 changesToDocTriple (aliasToDoc localizer) aliases
274 (valueAdd, valueChange, valueRemove) =
275 changesToDocTriple (valueToDoc localizer) values
277 (binopAdd, binopChange, binopRemove) =
278 changesToDocTriple (binopToDoc localizer) binops
279 in
280 Chunk (Name.toChars name) magnitude $
281 D.vcat $ List.intersperse "" $ Maybe.catMaybes $
282 [ changesToDoc "Added" unionAdd aliasAdd valueAdd binopAdd
283 , changesToDoc "Removed" unionRemove aliasRemove valueRemove binopRemove
284 , changesToDoc "Changed" unionChange aliasChange valueChange binopChange
285 ]
288changesToDocTriple :: (k -> v -> D.Doc) -> Changes k v -> ([D.Doc], [D.Doc], [D.Doc])
289changesToDocTriple entryToDoc (Changes added changed removed) =
290 let
291 indented (name, value) =
292 D.indent 4 (entryToDoc name value)
294 diffed (name, (oldValue, newValue)) =
295 D.vcat
296 [ " - " <> entryToDoc name oldValue
297 , " + " <> entryToDoc name newValue
298 , ""
299 ]
300 in
301 ( map indented (Map.toList added)
302 , map diffed (Map.toList changed)
303 , map indented (Map.toList removed)
304 )
307changesToDoc :: String -> [D.Doc] -> [D.Doc] -> [D.Doc] -> [D.Doc] -> Maybe D.Doc
308changesToDoc categoryName unions aliases values binops =
309 if null unions && null aliases && null values && null binops then
310 Nothing
312 else
313 Just $ D.vcat $
314 D.fromChars categoryName <> ":" : unions ++ aliases ++ binops ++ values
317unionToDoc :: L.Localizer -> Name.Name -> Docs.Union -> D.Doc
318unionToDoc localizer name (Docs.Union _ tvars ctors) =
319 let
320 setup =
321 "type" <+> D.fromName name <+> D.hsep (map D.fromName tvars)
323 ctorDoc (ctor, tipes) =
324 typeDoc localizer (Type.Type ctor tipes)
325 in
326 D.hang 4 (D.sep (setup : zipWith (<+>) ("=" : repeat "|") (map ctorDoc ctors)))
329aliasToDoc :: L.Localizer -> Name.Name -> Docs.Alias -> D.Doc
330aliasToDoc localizer name (Docs.Alias _ tvars tipe) =
331 let
332 declaration =
333 "type" <+> "alias" <+> D.hsep (map D.fromName (name:tvars)) <+> "="
334 in
335 D.hang 4 (D.sep [ declaration, typeDoc localizer tipe ])
338valueToDoc :: L.Localizer -> Name.Name -> Docs.Value -> D.Doc
339valueToDoc localizer name (Docs.Value _ tipe) =
340 D.hang 4 $ D.sep [ D.fromName name <+> ":", typeDoc localizer tipe ]
343binopToDoc :: L.Localizer -> Name.Name -> Docs.Binop -> D.Doc
344binopToDoc localizer name (Docs.Binop _ tipe associativity (Docs.Precedence n)) =
345 "(" <> D.fromName name <> ")" <+> ":" <+> typeDoc localizer tipe <> D.black details
346 where
347 details =
348 " (" <> D.fromName assoc <> "/" <> D.fromInt n <> ")"
350 assoc =
351 case associativity of
352 Docs.Left -> "left"
353 Docs.Non -> "non"
354 Docs.Right -> "right"
357typeDoc :: L.Localizer -> Type.Type -> D.Doc
358typeDoc localizer tipe =
359 Type.toDoc localizer Type.None tipe