git.iko.soy/elk
on eb236ca help sign in
elk/builder/src/Elm/Diff.hs
283 lines 8.1 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Elm.Diff
4 ( Args(..)
5 , diff
6 )
7 where
10import Control.Monad.Except (liftIO)
11import qualified Data.List as List
12import qualified Data.Map as Map
13import qualified Data.Maybe as Maybe
15import qualified Deps.Cache as Cache
16import Deps.Diff (PackageChanges(..), ModuleChanges(..), Changes(..), Magnitude(..))
17import qualified Deps.Diff as Diff
18import qualified Elm.Compiler.Module as Module
19import qualified Elm.Compiler.Type as Type
20import qualified Elm.Docs as Docs
21import qualified Elm.Name as N
22import qualified Elm.Package as Pkg
23import qualified Elm.Project as Project
24import qualified Elm.Project.Json as Project
25import qualified Elm.Project.Summary as Summary
26import Reporting.Doc ((<>), (<+>))
27import qualified Reporting.Doc as D
28import qualified Reporting.Exit as Exit
29import qualified Reporting.Exit.Diff as E
30import qualified Reporting.Exit.Help as Help
31import qualified Reporting.Render.Type.Localizer as L
32import qualified Reporting.Task as Task
36-- DIFF
39data Args
40 = CodeVsLatest
41 | CodeVsExactly Pkg.Version
42 | LocalInquiry Pkg.Version Pkg.Version
43 | GlobalInquiry Pkg.Name Pkg.Version Pkg.Version
46diff :: Args -> Task.Task ()
47diff args =
48 case args of
49 GlobalInquiry name v1 v2 ->
50 do registry <- Cache.mandatoryUpdate
51 case Cache.getVersions name registry of
52 Left suggestions ->
53 throw $ E.UnknownPackage name suggestions
55 Right vsns ->
56 do oldDocs <- getDocs name vsns (min v1 v2)
57 newDocs <- getDocs name vsns (max v1 v2)
58 writeDiff oldDocs newDocs
60 LocalInquiry v1 v2 ->
61 do (_, name, vsns) <- getPackageInfo
62 oldDocs <- getDocs name vsns (min v1 v2)
63 newDocs <- getDocs name vsns (max v1 v2)
64 writeDiff oldDocs newDocs
66 CodeVsLatest ->
67 do (summary, name, vsns) <- getPackageInfo
68 oldDocs <- getDocs name vsns (maximum vsns)
69 newDocs <- Task.silently (Project.generateDocs summary)
70 writeDiff oldDocs newDocs
72 CodeVsExactly version ->
73 do (summary, name, vsns) <- getPackageInfo
74 oldDocs <- getDocs name vsns version
75 newDocs <- Task.silently (Project.generateDocs summary)
76 writeDiff oldDocs newDocs
79throw :: E.Exit -> Task.Task a
80throw exit =
81 Task.throw $ Exit.Diff exit
85-- DIFF HELPERS
88getDocs :: Pkg.Name -> [Pkg.Version] -> Pkg.Version -> Task.Task Docs.Documentation
89getDocs name allVersions version =
90 if elem version allVersions then
91 Cache.getDocs name version
92 else
93 throw $ E.UnknownVersion name version allVersions
96getPackageInfo :: Task.Task (Summary.Summary, Pkg.Name, [Pkg.Version])
97getPackageInfo =
98 do summary <- Project.getRoot
99 case Summary._project summary of
100 Project.App _ ->
101 throw $ E.Application
103 Project.Pkg (Project.PkgInfo name _ _ _ _ _ _ _) ->
104 do registry <- Cache.mandatoryUpdate
105 case Cache.getVersions name registry of
106 Right vsns ->
107 return ( summary, name, vsns )
109 Left _ ->
110 throw E.Unpublished
114-- WRITE DOC
117writeDiff :: Docs.Documentation -> Docs.Documentation -> Task.Task ()
118writeDiff oldDocs newDocs =
119 let
120 changes = Diff.diff oldDocs newDocs
121 localizer = L.fromNames (Map.union oldDocs newDocs)
122 in
123 liftIO $ Help.toStdout (toDoc localizer changes <> "\n")
127-- TO DOC
130toDoc :: L.Localizer -> PackageChanges -> D.Doc
131toDoc localizer changes@(PackageChanges added changed removed) =
132 if null added && Map.null changed && null removed then
133 "No API changes detected, so this is a" <+> D.green "PATCH" <+> "change."
134 else
135 let
136 magDoc =
137 D.fromString (Diff.magnitudeToString (Diff.toMagnitude changes))
139 header =
140 "This is a" <+> D.green magDoc <+> "change."
142 addedChunk =
143 if null added then [] else
144 [ Chunk "ADDED MODULES" MINOR $
145 D.vcat $ map (D.fromString . Module.nameToString) added
146 ]
148 removedChunk =
149 if null removed then [] else
150 [ Chunk "REMOVED MODULES" MAJOR $
151 D.vcat $ map (D.fromString . Module.nameToString) removed
152 ]
154 chunks =
155 addedChunk ++ removedChunk ++ map (changesToChunk localizer) (Map.toList changed)
156 in
157 D.vcat (header : "" : map chunkToDoc chunks)
160data Chunk =
161 Chunk
162 { _title :: String
163 , _magnitude :: Magnitude
164 , _details :: D.Doc
165 }
168chunkToDoc :: Chunk -> D.Doc
169chunkToDoc (Chunk title magnitude details) =
170 let
171 magDoc =
172 Diff.magnitudeToString magnitude
174 header =
175 "----" <+> D.fromString title <+> "-" <+> D.fromString magDoc <+> "----"
176 in
177 D.vcat
178 [ D.dullcyan header
179 , ""
180 , D.indent 4 details
181 , ""
182 , ""
183 ]
186changesToChunk :: L.Localizer -> (N.Name, ModuleChanges) -> Chunk
187changesToChunk localizer (name, changes@(ModuleChanges unions aliases values binops)) =
188 let
189 magnitude =
190 Diff.moduleChangeMagnitude changes
192 (unionAdd, unionChange, unionRemove) =
193 changesToDocTriple (unionToDoc localizer) unions
195 (aliasAdd, aliasChange, aliasRemove) =
196 changesToDocTriple (aliasToDoc localizer) aliases
198 (valueAdd, valueChange, valueRemove) =
199 changesToDocTriple (valueToDoc localizer) values
201 (binopAdd, binopChange, binopRemove) =
202 changesToDocTriple (binopToDoc localizer) binops
203 in
204 Chunk (N.toString name) magnitude $
205 D.vcat $ List.intersperse "" $ Maybe.catMaybes $
206 [ changesToDoc "Added" unionAdd aliasAdd valueAdd binopAdd
207 , changesToDoc "Removed" unionRemove aliasRemove valueRemove binopRemove
208 , changesToDoc "Changed" unionChange aliasChange valueChange binopChange
209 ]
212changesToDocTriple :: (k -> v -> D.Doc) -> Changes k v -> ([D.Doc], [D.Doc], [D.Doc])
213changesToDocTriple entryToDoc (Changes added changed removed) =
214 let
215 indented (name, value) =
216 D.indent 4 (entryToDoc name value)
218 diffed (name, (oldValue, newValue)) =
219 D.vcat
220 [ " - " <> entryToDoc name oldValue
221 , " + " <> entryToDoc name newValue
222 , ""
223 ]
224 in
225 ( map indented (Map.toList added)
226 , map diffed (Map.toList changed)
227 , map indented (Map.toList removed)
228 )
231changesToDoc :: String -> [D.Doc] -> [D.Doc] -> [D.Doc] -> [D.Doc] -> Maybe D.Doc
232changesToDoc categoryName unions aliases values binops =
233 if null unions && null aliases && null values && null binops then
234 Nothing
236 else
237 Just $ D.vcat $
238 D.fromString categoryName <> ":" : unions ++ aliases ++ binops ++ values
241unionToDoc :: L.Localizer -> N.Name -> Docs.Union -> D.Doc
242unionToDoc localizer name (Docs.Union _ tvars ctors) =
243 let
244 setup =
245 "type" <+> D.fromName name <+> D.hsep (map D.fromName tvars)
247 ctorDoc (ctor, tipes) =
248 typeDoc localizer (Type.Type ctor tipes)
249 in
250 D.hang 4 (D.sep (setup : zipWith (<+>) ("=" : repeat "|") (map ctorDoc ctors)))
253aliasToDoc :: L.Localizer -> N.Name -> Docs.Alias -> D.Doc
254aliasToDoc localizer name (Docs.Alias _ tvars tipe) =
255 let
256 declaration =
257 "type" <+> "alias" <+> D.hsep (map D.fromName (name:tvars)) <+> "="
258 in
259 D.hang 4 (D.sep [ declaration, typeDoc localizer tipe ])
262valueToDoc :: L.Localizer -> N.Name -> Docs.Value -> D.Doc
263valueToDoc localizer name (Docs.Value _ tipe) =
264 D.hang 4 $ D.sep [ D.fromName name <+> ":", typeDoc localizer tipe ]
267binopToDoc :: L.Localizer -> N.Name -> Docs.Binop -> D.Doc
268binopToDoc localizer name (Docs.Binop _ tipe associativity (Docs.Precedence n)) =
269 "(" <> D.fromName name <> ")" <+> ":" <+> typeDoc localizer tipe <> D.black details
270 where
271 details =
272 " (" <> D.fromName assoc <> "/" <> D.fromInt n <> ")"
274 assoc =
275 case associativity of
276 Docs.Left -> "left"
277 Docs.Non -> "non"
278 Docs.Right -> "right"
281typeDoc :: L.Localizer -> Type.Type -> D.Doc
282typeDoc localizer tipe =
283 Type.toDoc localizer Type.None tipe