git.iko.soy/elk
on 3973751 help sign in
elk/terminal/src/Diff.hs
325 lines 9.0 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
15import qualified Build
16import Deps.Diff (PackageChanges(..), ModuleChanges(..), Changes(..))
17import qualified Deps.Diff as DD
18import qualified Deps.Registry as Registry
19import qualified Elm.Compiler.Type as Type
20import qualified Elm.Details as Details
21import qualified Elm.Docs as Docs
22import qualified Elm.Magnitude as M
23import qualified Elm.Package as Pkg
24import qualified Elm.Version as V
25import qualified Http
26import qualified Reporting
27import Reporting.Doc ((<>), (<+>))
28import qualified Reporting.Doc as D
29import qualified Reporting.Exit as Exit
30import qualified Reporting.Exit.Help as Help
31import qualified Reporting.Render.Type.Localizer as L
32import qualified Reporting.Task as Task
33import qualified Stuff
37-- RUN
40data Args
41 = CodeVsLatest
42 | CodeVsExactly V.Version
43 | LocalInquiry V.Version V.Version
44 | GlobalInquiry Pkg.Name V.Version V.Version
47run :: Args -> () -> IO ()
48run args () =
49 Reporting.attempt Exit.diffToReport $
50 Task.run $
51 do env <- getEnv
52 diff env args
56-- ENVIRONMENT
59data Env =
60 Env
61 { _root :: Maybe FilePath
62 , _cache :: Stuff.PackageCache
63 , _manager :: Http.Manager
64 , _registry :: Registry.Registry
65 }
68getEnv :: Task Env
69getEnv =
70 do root <- Task.io $ Stuff.findRoot
71 cache <- Task.io $ Stuff.getPackageCache
72 manager <- Task.io $ Http.getManager
73 registry <- Task.eio Exit.DiffBadRegistry $ Registry.latest manager cache
74 return (Env root cache manager registry)
78-- DIFF
81type Task a =
82 Task.Task Exit.Diff a
85diff :: Env -> Args -> Task ()
86diff env@(Env _ _ _ registry) args =
87 case args of
88 GlobalInquiry name v1 v2 ->
89 case Registry.getVersions' name registry of
90 Right vsns ->
91 do oldDocs <- getDocs env name vsns (min v1 v2)
92 newDocs <- getDocs env name vsns (max v1 v2)
93 writeDiff oldDocs newDocs
95 Left suggestions ->
96 Task.throw $ Exit.DiffUnknownPackage name suggestions
98 LocalInquiry v1 v2 ->
99 do (_, name, vsns) <- getDetails env
100 oldDocs <- getDocs env name vsns (min v1 v2)
101 newDocs <- getDocs env name vsns (max v1 v2)
102 writeDiff oldDocs newDocs
104 CodeVsLatest ->
105 do (details, name, vsns) <- getDetails env
106 oldDocs <- getLatestDocs env name vsns
107 newDocs <- Build.generateDocs details
108 writeDiff oldDocs newDocs
110 CodeVsExactly version ->
111 do (details, name, vsns) <- getDetails env
112 oldDocs <- getDocs env name vsns version
113 newDocs <- Build.generateDocs details
114 writeDiff oldDocs newDocs
118-- GET DOCS
121getDocs :: Env -> Pkg.Name -> Registry.KnownVersions -> V.Version -> Task Docs.Documentation
122getDocs (Env _ cache manager _) name (Registry.KnownVersions latest previous) version =
123 if latest == version || elem version previous
124 then Task.eio Exit.DiffDocsProblem $ DD.getDocs cache manager name version
125 else Task.throw $ Exit.DiffUnknownVersion name version (latest:previous)
128getLatestDocs :: Env -> Pkg.Name -> Registry.KnownVersions -> Task Docs.Documentation
129getLatestDocs (Env _ cache manager _) name (Registry.KnownVersions latest _) =
130 Task.eio Exit.DiffDocsProblem $ DD.getDocs cache manager name latest
134-- GET DETAILS
137getDetails :: Env -> Task (Details.Details, Pkg.Name, Registry.KnownVersions)
138getDetails (Env maybeRoot _ _ registry) =
139 case maybeRoot of
140 Nothing ->
141 Task.throw $ Exit.DiffNoOutline
143 Just root ->
144 do details <- Task.eio Exit.DiffBadDetails $ Details.load Reporting.silent root
145 case Details._outline details of
146 Details.ValidApp _ ->
147 Task.throw $ Exit.DiffApplication
149 Details.ValidPkg pkg _ ->
150 case Registry.getVersions pkg registry of
151 Just vsns ->
152 return (details, pkg, vsns)
154 Nothing ->
155 Task.throw Exit.DiffUnpublished
159-- WRITE DOC
162writeDiff :: Docs.Documentation -> Docs.Documentation -> Task ()
163writeDiff oldDocs newDocs =
164 let
165 changes = DD.diff oldDocs newDocs
166 localizer = L.fromNames (Map.union oldDocs newDocs)
167 in
168 Task.io $ Help.toStdout $ toDoc localizer changes <> "\n"
172-- TO DOC
175toDoc :: L.Localizer -> PackageChanges -> D.Doc
176toDoc localizer changes@(PackageChanges added changed removed) =
177 if null added && Map.null changed && null removed then
178 "No API changes detected, so this is a" <+> D.green "PATCH" <+> "change."
179 else
180 let
181 magDoc =
182 D.fromChars (M.toChars (DD.toMagnitude changes))
184 header =
185 "This is a" <+> D.green magDoc <+> "change."
187 addedChunk =
188 if null added then [] else
189 [ Chunk "ADDED MODULES" M.MINOR $
190 D.vcat $ map D.fromName added
191 ]
193 removedChunk =
194 if null removed then [] else
195 [ Chunk "REMOVED MODULES" M.MAJOR $
196 D.vcat $ map D.fromName removed
197 ]
199 chunks =
200 addedChunk ++ removedChunk ++ map (changesToChunk localizer) (Map.toList changed)
201 in
202 D.vcat (header : "" : map chunkToDoc chunks)
205data Chunk =
206 Chunk
207 { _title :: String
208 , _magnitude :: M.Magnitude
209 , _details :: D.Doc
210 }
213chunkToDoc :: Chunk -> D.Doc
214chunkToDoc (Chunk title magnitude details) =
215 let
216 header =
217 "----" <+> D.fromChars title <+> "-" <+> D.fromChars (M.toChars magnitude) <+> "----"
218 in
219 D.vcat
220 [ D.dullcyan header
221 , ""
222 , D.indent 4 details
223 , ""
224 , ""
225 ]
228changesToChunk :: L.Localizer -> (Name.Name, ModuleChanges) -> Chunk
229changesToChunk localizer (name, changes@(ModuleChanges unions aliases values binops)) =
230 let
231 magnitude =
232 DD.moduleChangeMagnitude changes
234 (unionAdd, unionChange, unionRemove) =
235 changesToDocTriple (unionToDoc localizer) unions
237 (aliasAdd, aliasChange, aliasRemove) =
238 changesToDocTriple (aliasToDoc localizer) aliases
240 (valueAdd, valueChange, valueRemove) =
241 changesToDocTriple (valueToDoc localizer) values
243 (binopAdd, binopChange, binopRemove) =
244 changesToDocTriple (binopToDoc localizer) binops
245 in
246 Chunk (Name.toChars name) magnitude $
247 D.vcat $ List.intersperse "" $ Maybe.catMaybes $
248 [ changesToDoc "Added" unionAdd aliasAdd valueAdd binopAdd
249 , changesToDoc "Removed" unionRemove aliasRemove valueRemove binopRemove
250 , changesToDoc "Changed" unionChange aliasChange valueChange binopChange
251 ]
254changesToDocTriple :: (k -> v -> D.Doc) -> Changes k v -> ([D.Doc], [D.Doc], [D.Doc])
255changesToDocTriple entryToDoc (Changes added changed removed) =
256 let
257 indented (name, value) =
258 D.indent 4 (entryToDoc name value)
260 diffed (name, (oldValue, newValue)) =
261 D.vcat
262 [ " - " <> entryToDoc name oldValue
263 , " + " <> entryToDoc name newValue
264 , ""
265 ]
266 in
267 ( map indented (Map.toList added)
268 , map diffed (Map.toList changed)
269 , map indented (Map.toList removed)
270 )
273changesToDoc :: String -> [D.Doc] -> [D.Doc] -> [D.Doc] -> [D.Doc] -> Maybe D.Doc
274changesToDoc categoryName unions aliases values binops =
275 if null unions && null aliases && null values && null binops then
276 Nothing
278 else
279 Just $ D.vcat $
280 D.fromChars categoryName <> ":" : unions ++ aliases ++ binops ++ values
283unionToDoc :: L.Localizer -> Name.Name -> Docs.Union -> D.Doc
284unionToDoc localizer name (Docs.Union _ tvars ctors) =
285 let
286 setup =
287 "type" <+> D.fromName name <+> D.hsep (map D.fromName tvars)
289 ctorDoc (ctor, tipes) =
290 typeDoc localizer (Type.Type ctor tipes)
291 in
292 D.hang 4 (D.sep (setup : zipWith (<+>) ("=" : repeat "|") (map ctorDoc ctors)))
295aliasToDoc :: L.Localizer -> Name.Name -> Docs.Alias -> D.Doc
296aliasToDoc localizer name (Docs.Alias _ tvars tipe) =
297 let
298 declaration =
299 "type" <+> "alias" <+> D.hsep (map D.fromName (name:tvars)) <+> "="
300 in
301 D.hang 4 (D.sep [ declaration, typeDoc localizer tipe ])
304valueToDoc :: L.Localizer -> Name.Name -> Docs.Value -> D.Doc
305valueToDoc localizer name (Docs.Value _ tipe) =
306 D.hang 4 $ D.sep [ D.fromName name <+> ":", typeDoc localizer tipe ]
309binopToDoc :: L.Localizer -> Name.Name -> Docs.Binop -> D.Doc
310binopToDoc localizer name (Docs.Binop _ tipe associativity (Docs.Precedence n)) =
311 "(" <> D.fromName name <> ")" <+> ":" <+> typeDoc localizer tipe <> D.black details
312 where
313 details =
314 " (" <> D.fromName assoc <> "/" <> D.fromInt n <> ")"
316 assoc =
317 case associativity of
318 Docs.Left -> "left"
319 Docs.Non -> "non"
320 Docs.Right -> "right"
323typeDoc :: L.Localizer -> Type.Type -> D.Doc
324typeDoc localizer tipe =
325 Type.toDoc localizer Type.None tipe