git.iko.soy/elk
on 2ec15df help sign in
elk/builder/src/Elm/Diff.hs
274 lines 7.5 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 Deps.Diff (PackageChanges(..), ModuleChanges(..), Changes(..), Magnitude(..))
16import qualified Deps.Diff as Diff
17import qualified Deps.Get as Get
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.Task as Task
35-- DIFF
38data Args
39 = CodeVsLatest
40 | CodeVsExactly Pkg.Version
41 | LocalInquiry Pkg.Version Pkg.Version
42 | GlobalInquiry Pkg.Name Pkg.Version Pkg.Version
45diff :: Args -> Task.Task ()
46diff args =
47 case args of
48 GlobalInquiry name v1 v2 ->
49 do pkgs <- Get.all Get.RequireLatest
50 case Get.versions name pkgs of
51 Left suggestions ->
52 throw $ E.UnknownPackage name suggestions
54 Right vsns ->
55 do oldDocs <- getDocs name vsns (min v1 v2)
56 newDocs <- getDocs name vsns (max v1 v2)
57 writeDoc (toDoc (Diff.diff oldDocs newDocs))
59 LocalInquiry v1 v2 ->
60 do (_, name, vsns) <- getPackageInfo
61 oldDocs <- getDocs name vsns (min v1 v2)
62 newDocs <- getDocs name vsns (max v1 v2)
63 writeDoc (toDoc (Diff.diff oldDocs newDocs))
65 CodeVsLatest ->
66 do (summary, name, vsns) <- getPackageInfo
67 oldDocs <- getDocs name vsns (maximum vsns)
68 newDocs <- Task.silently (Project.generateDocs summary)
69 writeDoc (toDoc (Diff.diff oldDocs newDocs))
71 CodeVsExactly version ->
72 do (summary, name, vsns) <- getPackageInfo
73 oldDocs <- getDocs name vsns version
74 newDocs <- Task.silently (Project.generateDocs summary)
75 writeDoc (toDoc (Diff.diff oldDocs newDocs))
78throw :: E.Exit -> Task.Task a
79throw exit =
80 Task.throw $ Exit.Diff exit
84-- DIFF HELPERS
87getDocs :: Pkg.Name -> [Pkg.Version] -> Pkg.Version -> Task.Task Docs.Documentation
88getDocs name allVersions version =
89 if elem version allVersions then
90 Get.docs name version
91 else
92 throw $ E.UnknownVersion name version allVersions
95getPackageInfo :: Task.Task (Summary.Summary, Pkg.Name, [Pkg.Version])
96getPackageInfo =
97 do summary <- Project.getRoot
98 case Summary._project summary of
99 Project.App _ ->
100 throw $ E.Application
102 Project.Pkg (Project.PkgInfo name _ _ _ _ _ _ _) ->
103 do pkgs <- Get.all Get.RequireLatest
104 let vsns = either (const []) id (Get.versions name pkgs)
105 return ( summary, name, vsns )
109-- WRITE DOC
112writeDoc :: D.Doc -> Task.Task ()
113writeDoc doc =
114 liftIO $ Help.toStdout (doc <> "\n")
118-- TO DOC
121toDoc :: PackageChanges -> D.Doc
122toDoc changes@(PackageChanges added changed removed) =
123 if null added && Map.null changed && null removed then
124 "No API changes detected, so this is a" <+> D.green "PATCH" <+> "change."
125 else
126 let
127 magDoc =
128 D.fromString (Diff.magnitudeToString (Diff.toMagnitude changes))
130 header =
131 "This is a" <+> D.green magDoc <+> "change."
133 addedChunk =
134 if null added then [] else
135 [ Chunk "ADDED MODULES" MINOR $
136 D.vcat $ map (D.fromString . Module.nameToString) added
137 ]
139 removedChunk =
140 if null removed then [] else
141 [ Chunk "REMOVED MODULES" MAJOR $
142 D.vcat $ map (D.fromString . Module.nameToString) removed
143 ]
145 chunks =
146 addedChunk ++ removedChunk ++ map changesToChunk (Map.toList changed)
147 in
148 D.vcat (header : "" : map chunkToDoc chunks)
151data Chunk =
152 Chunk
153 { _title :: String
154 , _magnitude :: Magnitude
155 , _details :: D.Doc
156 }
159chunkToDoc :: Chunk -> D.Doc
160chunkToDoc (Chunk title magnitude details) =
161 let
162 magDoc =
163 Diff.magnitudeToString magnitude
165 header =
166 "----" <+> D.fromString title <+> "-" <+> D.fromString magDoc <+> "----"
167 in
168 D.vcat
169 [ D.dullcyan header
170 , ""
171 , D.indent 4 details
172 , ""
173 , ""
174 ]
177changesToChunk :: (N.Name, ModuleChanges) -> Chunk
178changesToChunk (name, changes@(ModuleChanges unions aliases values binops)) =
179 let
180 magnitude =
181 Diff.moduleChangeMagnitude changes
183 (unionAdd, unionChange, unionRemove) =
184 changesToDocTriple unionToDoc unions
186 (aliasAdd, aliasChange, aliasRemove) =
187 changesToDocTriple aliasToDoc aliases
189 (valueAdd, valueChange, valueRemove) =
190 changesToDocTriple valueToDoc values
192 (binopAdd, binopChange, binopRemove) =
193 changesToDocTriple binopToDoc binops
194 in
195 Chunk (N.toString name) magnitude $
196 D.vcat $ List.intersperse "" $ Maybe.catMaybes $
197 [ changesToDoc "Added" unionAdd aliasAdd valueAdd binopAdd
198 , changesToDoc "Removed" unionRemove aliasRemove valueRemove binopRemove
199 , changesToDoc "Changed" unionChange aliasChange valueChange binopChange
200 ]
203changesToDocTriple :: (k -> v -> D.Doc) -> Changes k v -> ([D.Doc], [D.Doc], [D.Doc])
204changesToDocTriple entryToDoc (Changes added changed removed) =
205 let
206 indented (name, value) =
207 D.indent 4 (entryToDoc name value)
209 diffed (name, (oldValue, newValue)) =
210 D.vcat
211 [ " - " <> entryToDoc name oldValue
212 , " + " <> entryToDoc name newValue
213 , ""
214 ]
215 in
216 ( map indented (Map.toList added)
217 , map diffed (Map.toList changed)
218 , map indented (Map.toList removed)
219 )
222changesToDoc :: String -> [D.Doc] -> [D.Doc] -> [D.Doc] -> [D.Doc] -> Maybe D.Doc
223changesToDoc categoryName unions aliases values binops =
224 if null unions && null aliases && null values && null binops then
225 Nothing
227 else
228 Just $ D.vcat $
229 D.fromString categoryName <> ":" : unions ++ aliases ++ binops ++ values
232unionToDoc :: N.Name -> Docs.Union -> D.Doc
233unionToDoc name (Docs.Union _ tvars ctors) =
234 let
235 setup =
236 "type" <+> D.fromName name <+> D.hsep (map D.fromName tvars)
238 ctorDoc (ctor, tipes) =
239 typeDoc (Type.Type ctor tipes)
240 in
241 D.hang 4 (D.sep (setup : zipWith (<+>) ("=" : repeat "|") (map ctorDoc ctors)))
244aliasToDoc :: N.Name -> Docs.Alias -> D.Doc
245aliasToDoc name (Docs.Alias _ tvars tipe) =
246 let
247 declaration =
248 "type" <+> "alias" <+> D.hsep (map D.fromName (name:tvars)) <+> "="
249 in
250 D.hang 4 (D.sep [ declaration, typeDoc tipe ])
253valueToDoc :: N.Name -> Docs.Value -> D.Doc
254valueToDoc name (Docs.Value _ tipe) =
255 D.hang 4 $ D.sep [ D.fromName name <+> ":", typeDoc tipe ]
258binopToDoc :: N.Name -> Docs.Binop -> D.Doc
259binopToDoc name (Docs.Binop _ tipe associativity (Docs.Precedence n)) =
260 "(" <> D.fromName name <> ")" <+> ":" <+> typeDoc tipe <> D.black details
261 where
262 details =
263 " (" <> D.fromName assoc <> "/" <> D.fromInt n <> ")"
265 assoc =
266 case associativity of
267 Docs.Left -> "left"
268 Docs.Non -> "non"
269 Docs.Right -> "right"
272typeDoc :: Type.Type -> D.Doc
273typeDoc tipe =
274 Type.toDoc Type.None tipe