git.iko.soy/elk
on d4e9599 help sign in
elk/builder/src/Elm/Diff.hs
279 lines 7.6 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
14import Text.PrettyPrint.ANSI.Leijen ((<>), (<+>))
15import qualified Text.PrettyPrint.ANSI.Leijen as P
17import Deps.Diff (PackageChanges(..), ModuleChanges(..), Changes(..), Magnitude(..))
18import qualified Deps.Diff as Diff
19import qualified Deps.Get as Get
20import qualified Elm.Compiler.Module as Module
21import qualified Elm.Compiler.Type as Type
22import qualified Elm.Docs as Docs
23import qualified Elm.Name as N
24import qualified Elm.Package as Pkg
25import qualified Elm.Project as Project
26import qualified Elm.Project.Json as Project
27import qualified Elm.Project.Summary as Summary
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 :: P.Doc -> Task.Task ()
113writeDoc doc =
114 liftIO $ Help.toStdout (doc <> "\n")
118-- TO DOC
121toDoc :: PackageChanges -> P.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" <+> P.green "PATCH" <+> "change."
125 else
126 let
127 magDoc =
128 P.text (Diff.magnitudeToString (Diff.toMagnitude changes))
130 header =
131 "This is a" <+> P.green magDoc <+> "change."
133 addedChunk =
134 if null added then [] else
135 [ Chunk "ADDED MODULES" MINOR $
136 P.vcat $ map (P.text . Module.nameToString) added
137 ]
139 removedChunk =
140 if null removed then [] else
141 [ Chunk "REMOVED MODULES" MAJOR $
142 P.vcat $ map (P.text . Module.nameToString) removed
143 ]
145 chunks =
146 addedChunk ++ removedChunk ++ map changesToChunk (Map.toList changed)
147 in
148 P.vcat (header : "" : map chunkToDoc chunks)
151data Chunk =
152 Chunk
153 { _title :: String
154 , _magnitude :: Magnitude
155 , _details :: P.Doc
156 }
159chunkToDoc :: Chunk -> P.Doc
160chunkToDoc (Chunk title magnitude details) =
161 let
162 magDoc =
163 Diff.magnitudeToString magnitude
165 header =
166 "----" <+> P.text title <+> "-" <+> P.text magDoc <+> "----"
167 in
168 P.vcat
169 [ P.dullcyan header
170 , ""
171 , P.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 P.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 -> P.Doc) -> Changes k v -> ([P.Doc], [P.Doc], [P.Doc])
204changesToDocTriple entryToDoc (Changes added changed removed) =
205 let
206 indented (name, value) =
207 P.indent 4 (entryToDoc name value)
209 diffed (name, (oldValue, newValue)) =
210 P.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 -> [P.Doc] -> [P.Doc] -> [P.Doc] -> [P.Doc] -> Maybe P.Doc
223changesToDoc categoryName unions aliases values binops =
224 if null unions && null aliases && null values && null binops then
225 Nothing
227 else
228 Just $ P.vcat $
229 P.text categoryName <> ":" : unions ++ aliases ++ binops ++ values
232unionToDoc :: N.Name -> Docs.Union -> P.Doc
233unionToDoc name (Docs.Union _ tvars ctors) =
234 let
235 setup =
236 "type" <+> nameToDoc name <+> P.hsep (map nameToDoc tvars)
238 ctorDoc (ctor, tipes) =
239 typeDoc (Type.Type ctor tipes)
240 in
241 P.hang 4 (P.sep (setup : zipWith (<+>) ("=" : repeat "|") (map ctorDoc ctors)))
244aliasToDoc :: N.Name -> Docs.Alias -> P.Doc
245aliasToDoc name (Docs.Alias _ tvars tipe) =
246 let
247 declaration =
248 "type" <+> "alias" <+> P.hsep (map nameToDoc (name:tvars)) <+> "="
249 in
250 P.hang 4 (P.sep [ declaration, typeDoc tipe ])
253valueToDoc :: N.Name -> Docs.Value -> P.Doc
254valueToDoc name (Docs.Value _ tipe) =
255 P.hang 4 $ P.sep [ nameToDoc name <+> P.colon, typeDoc tipe ]
258binopToDoc :: N.Name -> Docs.Binop -> P.Doc
259binopToDoc name (Docs.Binop _ tipe associativity (Docs.Precedence n)) =
260 "(" <> nameToDoc name <> ")" <+> P.colon <+> typeDoc tipe <> P.black details
261 where
262 details =
263 " (" <> nameToDoc assoc <> "/" <> P.int n <> ")"
265 assoc =
266 case associativity of
267 Docs.Left -> "left"
268 Docs.Non -> "non"
269 Docs.Right -> "right"
272typeDoc :: Type.Type -> P.Doc
273typeDoc tipe =
274 Type.toDoc Type.None tipe
277nameToDoc :: N.Name -> P.Doc
278nameToDoc name =
279 P.text (N.toString name)