git.iko.soy/elk
on 1c91efd help sign in
elk/builder/src/Deps/Diff.hs
363 lines 8.6 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2module Deps.Diff
3 ( diff
4 , PackageChanges(..)
5 , ModuleChanges(..)
6 , Changes(..)
7 , Magnitude(..)
8 , moduleChangeMagnitude
9 , magnitudeToString
10 , toMagnitude
11 , bump
12 )
13 where
16import Control.Monad (zipWithM)
17import Data.Function (on)
18import qualified Data.List as List
19import qualified Data.Map as Map
20import qualified Data.Set as Set
21import qualified Data.Text as Text
23import qualified Elm.Compiler.Module as Module
24import qualified Elm.Compiler.Type as Type
25import qualified Elm.Docs as Docs
26import qualified Elm.Name as N
27import qualified Elm.Package as Pkg
31-- CHANGES
34data PackageChanges =
35 PackageChanges
36 { _modules_added :: [Module.Raw]
37 , _modules_changed :: Map.Map Module.Raw ModuleChanges
38 , _modules_removed :: [Module.Raw]
39 }
42data ModuleChanges =
43 ModuleChanges
44 { _unions :: Changes N.Name Docs.Union
45 , _aliases :: Changes N.Name Docs.Alias
46 , _values :: Changes N.Name Docs.Value
47 , _binops :: Changes N.Name Docs.Binop
48 }
51data Changes k v =
52 Changes
53 { _added :: Map.Map k v
54 , _changed :: Map.Map k (v,v)
55 , _removed :: Map.Map k v
56 }
59getChanges :: (Ord k) => (v -> v -> Bool) -> Map.Map k v -> Map.Map k v -> Changes k v
60getChanges isEquivalent old new =
61 let
62 overlap = Map.intersectionWith (,) old new
63 changed = Map.filter (not . uncurry isEquivalent) overlap
64 in
65 Changes (Map.difference new old) changed (Map.difference old new)
69-- DIFF
72diff :: Docs.Documentation -> Docs.Documentation -> PackageChanges
73diff oldDocs newDocs =
74 let
75 filterOutPatches chngs =
76 Map.filter (\chng -> moduleChangeMagnitude chng /= PATCH) chngs
78 (Changes added changed removed) =
79 getChanges (\_ _ -> False) oldDocs newDocs
80 in
81 PackageChanges
82 (Map.keys added)
83 (filterOutPatches (Map.map diffModule changed))
84 (Map.keys removed)
88diffModule :: (Docs.Module, Docs.Module) -> ModuleChanges
89diffModule (Docs.Module _ _ u1 a1 v1 b1, Docs.Module _ _ u2 a2 v2 b2) =
90 ModuleChanges
91 (getChanges isEquivalentUnion u1 u2)
92 (getChanges isEquivalentAlias a1 a2)
93 (getChanges isEquivalentValue v1 v2)
94 (getChanges isEquivalentBinop b1 b2)
98-- EQUIVALENCE
101isEquivalentUnion :: Docs.Union -> Docs.Union -> Bool
102isEquivalentUnion (Docs.Union oldComment oldVars oldCtors) (Docs.Union newComment newVars newCtors) =
103 length oldCtors == length newCtors
104 && and (zipWith (==) (map fst oldCtors) (map fst newCtors))
105 && and (Map.elems (Map.intersectionWith equiv (Map.fromList oldCtors) (Map.fromList newCtors)))
106 where
107 equiv :: [Type.Type] -> [Type.Type] -> Bool
108 equiv oldTypes newTypes =
109 let
110 allEquivalent =
111 zipWith
112 isEquivalentAlias
113 (map (Docs.Alias oldComment oldVars) oldTypes)
114 (map (Docs.Alias newComment newVars) newTypes)
115 in
116 length oldTypes == length newTypes
117 && and allEquivalent
120isEquivalentAlias :: Docs.Alias -> Docs.Alias -> Bool
121isEquivalentAlias (Docs.Alias _ oldVars oldType) (Docs.Alias _ newVars newType) =
122 case diffType oldType newType of
123 Nothing ->
124 False
126 Just renamings ->
127 length oldVars == length newVars
128 && isEquivalentRenaming (zip oldVars newVars ++ renamings)
131isEquivalentValue :: Docs.Value -> Docs.Value -> Bool
132isEquivalentValue (Docs.Value c1 t1) (Docs.Value c2 t2) =
133 isEquivalentAlias (Docs.Alias c1 [] t1) (Docs.Alias c2 [] t2)
136isEquivalentBinop :: Docs.Binop -> Docs.Binop -> Bool
137isEquivalentBinop (Docs.Binop c1 t1 a1 p1) (Docs.Binop c2 t2 a2 p2) =
138 isEquivalentAlias (Docs.Alias c1 [] t1) (Docs.Alias c2 [] t2)
139 && a1 == a2
140 && p1 == p2
144-- DIFF TYPES
147diffType :: Type.Type -> Type.Type -> Maybe [(N.Name,N.Name)]
148diffType oldType newType =
149 case (oldType, newType) of
150 (Type.Var oldName, Type.Var newName) ->
151 Just [(oldName, newName)]
153 (Type.Lambda a b, Type.Lambda a' b') ->
154 (++)
155 <$> diffType a a'
156 <*> diffType b b'
158 (Type.Type oldName oldArgs, Type.Type newName newArgs) ->
159 if not (isSameName oldName newName) || length oldArgs /= length newArgs then
160 Nothing
161 else
162 concat <$> zipWithM diffType oldArgs newArgs
164 (Type.Record fields maybeExt, Type.Record fields' maybeExt') ->
165 case (maybeExt, maybeExt') of
166 (Nothing, Just _) ->
167 Nothing
169 (Just _, Nothing) ->
170 Nothing
172 (Nothing, Nothing) ->
173 diffFields fields fields'
175 (Just oldExt, Just newExt) ->
176 (:) (oldExt, newExt) <$> diffFields fields fields'
178 (Type.Unit, Type.Unit) ->
179 Just []
181 (Type.Tuple a b cs, Type.Tuple x y zs) ->
182 if length cs /= length zs then
183 Nothing
184 else
185 do aVars <- diffType a x
186 bVars <- diffType b y
187 cVars <- concat <$> zipWithM diffType cs zs
188 return (aVars ++ bVars ++ cVars)
190 (_, _) ->
191 Nothing
194-- handle very old docs that do not use qualified names
195isSameName :: N.Name -> N.Name -> Bool
196isSameName oldFullName newFullName =
197 let
198 dedot name =
199 reverse (Text.splitOn "." (N.toText name))
200 in
201 case ( dedot oldFullName, dedot newFullName ) of
202 (oldName:[], newName:_) ->
203 oldName == newName
205 (oldName:_, newName:[]) ->
206 oldName == newName
208 _ ->
209 oldFullName == newFullName
212diffFields :: [(N.Name, Type.Type)] -> [(N.Name, Type.Type)] -> Maybe [(N.Name,N.Name)]
213diffFields oldRawFields newRawFields =
214 let
215 sort = List.sortBy (compare `on` fst)
216 oldFields = sort oldRawFields
217 newFields = sort newRawFields
218 in
219 if length oldRawFields /= length newRawFields then
220 Nothing
222 else if or (zipWith ((/=) `on` fst) oldFields newFields) then
223 Nothing
225 else
226 concat <$> zipWithM (diffType `on` snd) oldFields newFields
230-- TYPE VARIABLES
233isEquivalentRenaming :: [(N.Name,N.Name)] -> Bool
234isEquivalentRenaming varPairs =
235 let
236 renamings =
237 Map.toList (foldr insert Map.empty varPairs)
239 insert (old,new) dict =
240 Map.insertWith (++) old [new] dict
242 verify (old, news) =
243 case news of
244 [] ->
245 Nothing
247 new : rest ->
248 if all (new ==) rest then
249 Just (old, new)
250 else
251 Nothing
253 allUnique list =
254 length list == Set.size (Set.fromList list)
255 in
256 case mapM verify renamings of
257 Nothing ->
258 False
260 Just verifiedRenamings ->
261 all compatibleVars verifiedRenamings
262 &&
263 allUnique (map snd verifiedRenamings)
266compatibleVars :: (N.Name, N.Name) -> Bool
267compatibleVars (old, new) =
268 case (categorizeVar old, categorizeVar new) of
269 (CompAppend, CompAppend) -> True
270 (Comparable, Comparable) -> True
271 (Appendable, Appendable) -> True
272 (Number , Number ) -> True
273 (Number , Comparable) -> True
275 (_, Var) -> True
277 (_, _) -> False
280data TypeVarCategory
281 = CompAppend
282 | Comparable
283 | Appendable
284 | Number
285 | Var
288categorizeVar :: N.Name -> TypeVarCategory
289categorizeVar name
290 | N.startsWith "compappend" name = CompAppend
291 | N.startsWith "comparable" name = Comparable
292 | N.startsWith "appendable" name = Appendable
293 | N.startsWith "number" name = Number
294 | otherwise = Var
298-- MAGNITUDE
301data Magnitude
302 = PATCH
303 | MINOR
304 | MAJOR
305 deriving (Eq, Ord)
308magnitudeToString :: Magnitude -> String
309magnitudeToString magnitude =
310 case magnitude of
311 PATCH ->
312 "PATCH"
314 MINOR ->
315 "MINOR"
317 MAJOR ->
318 "MAJOR"
321bump :: PackageChanges -> Pkg.Version -> Pkg.Version
322bump changes version =
323 case toMagnitude changes of
324 PATCH ->
325 Pkg.bumpPatch version
327 MINOR ->
328 Pkg.bumpMinor version
330 MAJOR ->
331 Pkg.bumpMajor version
334toMagnitude :: PackageChanges -> Magnitude
335toMagnitude (PackageChanges added changed removed) =
336 let
337 addMag = if null added then PATCH else MINOR
338 removeMag = if null removed then PATCH else MAJOR
339 changeMags = map moduleChangeMagnitude (Map.elems changed)
340 in
341 maximum (addMag : removeMag : changeMags)
344moduleChangeMagnitude :: ModuleChanges -> Magnitude
345moduleChangeMagnitude (ModuleChanges unions aliases values binops) =
346 maximum
347 [ changeMagnitude unions
348 , changeMagnitude aliases
349 , changeMagnitude values
350 , changeMagnitude binops
351 ]
354changeMagnitude :: Changes k v -> Magnitude
355changeMagnitude (Changes added changed removed) =
356 if Map.size removed > 0 || Map.size changed > 0 then
357 MAJOR
359 else if Map.size added > 0 then
360 MINOR
362 else
363 PATCH