git.iko.soy/elk
on d78293c help sign in
elk/builder/src/Deps/Diff.hs
356 lines 8.4 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Deps.Diff
4 ( diff
5 , PackageChanges(..)
6 , ModuleChanges(..)
7 , Changes(..)
8 , Magnitude(..)
9 , moduleChangeMagnitude
10 , magnitudeToString
11 , toMagnitude
12 , bump
13 )
14 where
17import Control.Monad (zipWithM)
18import Data.Function (on)
19import qualified Data.List as List
20import qualified Data.Map as Map
21import qualified Data.Set as Set
22import qualified Data.Text as Text
24import qualified Elm.Compiler.Module as Module
25import qualified Elm.Compiler.Type as Type
26import qualified Elm.Docs as Docs
27import qualified Elm.Name as N
28import qualified Elm.Package as Pkg
32-- CHANGES
35data PackageChanges =
36 PackageChanges
37 { _modules_added :: [Module.Raw]
38 , _modules_changed :: Map.Map Module.Raw ModuleChanges
39 , _modules_removed :: [Module.Raw]
40 }
43data ModuleChanges =
44 ModuleChanges
45 { _unions :: Changes N.Name Docs.Union
46 , _aliases :: Changes N.Name Docs.Alias
47 , _values :: Changes N.Name Docs.Value
48 , _binops :: Changes N.Name Docs.Binop
49 }
52data Changes k v =
53 Changes
54 { _added :: Map.Map k v
55 , _changed :: Map.Map k (v,v)
56 , _removed :: Map.Map k v
57 }
60getChanges :: (Ord k) => (v -> v -> Bool) -> Map.Map k v -> Map.Map k v -> Changes k v
61getChanges isEquivalent old new =
62 let
63 overlap = Map.intersectionWith (,) old new
64 changed = Map.filter (not . uncurry isEquivalent) overlap
65 in
66 Changes (Map.difference new old) changed (Map.difference old new)
70-- DIFF
73diff :: Docs.Documentation -> Docs.Documentation -> PackageChanges
74diff oldDocs newDocs =
75 let
76 filterOutPatches chngs =
77 Map.filter (\chng -> moduleChangeMagnitude chng /= PATCH) chngs
79 (Changes added changed removed) =
80 getChanges (\_ _ -> False) oldDocs newDocs
81 in
82 PackageChanges
83 (Map.keys added)
84 (filterOutPatches (Map.map diffModule changed))
85 (Map.keys removed)
89diffModule :: (Docs.Module, Docs.Module) -> ModuleChanges
90diffModule (Docs.Module _ _ u1 a1 v1 b1, Docs.Module _ _ u2 a2 v2 b2) =
91 ModuleChanges
92 (getChanges isEquivalentUnion u1 u2)
93 (getChanges isEquivalentAlias a1 a2)
94 (getChanges isEquivalentValue v1 v2)
95 (getChanges isEquivalentBinop b1 b2)
99-- EQUIVALENCE
102isEquivalentUnion :: Docs.Union -> Docs.Union -> Bool
103isEquivalentUnion (Docs.Union oldComment oldVars oldCtors) (Docs.Union newComment newVars newCtors) =
104 length oldCtors == length newCtors
105 && and (zipWith (==) (map fst oldCtors) (map fst newCtors))
106 && and (Map.elems (Map.intersectionWith equiv (Map.fromList oldCtors) (Map.fromList newCtors)))
107 where
108 equiv :: [Type.Type] -> [Type.Type] -> Bool
109 equiv oldTypes newTypes =
110 let
111 allEquivalent =
112 zipWith
113 isEquivalentAlias
114 (map (Docs.Alias oldComment oldVars) oldTypes)
115 (map (Docs.Alias newComment newVars) newTypes)
116 in
117 length oldTypes == length newTypes
118 && and allEquivalent
121isEquivalentAlias :: Docs.Alias -> Docs.Alias -> Bool
122isEquivalentAlias (Docs.Alias _ oldVars oldType) (Docs.Alias _ newVars newType) =
123 case diffType oldType newType of
124 Nothing ->
125 False
127 Just renamings ->
128 length oldVars == length newVars
129 && isEquivalentRenaming (zip oldVars newVars ++ renamings)
132isEquivalentValue :: Docs.Value -> Docs.Value -> Bool
133isEquivalentValue (Docs.Value c1 t1) (Docs.Value c2 t2) =
134 isEquivalentAlias (Docs.Alias c1 [] t1) (Docs.Alias c2 [] t2)
137isEquivalentBinop :: Docs.Binop -> Docs.Binop -> Bool
138isEquivalentBinop (Docs.Binop c1 t1 a1 p1) (Docs.Binop c2 t2 a2 p2) =
139 isEquivalentAlias (Docs.Alias c1 [] t1) (Docs.Alias c2 [] t2)
140 && a1 == a2
141 && p1 == p2
145-- DIFF TYPES
148diffType :: Type.Type -> Type.Type -> Maybe [(N.Name,N.Name)]
149diffType oldType newType =
150 case (oldType, newType) of
151 (Type.Var oldName, Type.Var newName) ->
152 Just [(oldName, newName)]
154 (Type.Lambda a b, Type.Lambda a' b') ->
155 (++)
156 <$> diffType a a'
157 <*> diffType b b'
159 (Type.Type oldName oldArgs, Type.Type newName newArgs) ->
160 if not (isSameName oldName newName) || length oldArgs /= length newArgs then
161 Nothing
162 else
163 concat <$> zipWithM diffType oldArgs newArgs
165 (Type.Record fields maybeExt, Type.Record fields' maybeExt') ->
166 case (maybeExt, maybeExt') of
167 (Nothing, Just _) ->
168 Nothing
170 (Just _, Nothing) ->
171 Nothing
173 (Nothing, Nothing) ->
174 diffFields fields fields'
176 (Just oldExt, Just newExt) ->
177 (:) (oldExt, newExt) <$> diffFields fields fields'
179 (_, _) ->
180 Nothing
183-- handle very old docs that do not use qualified names
184isSameName :: N.Name -> N.Name -> Bool
185isSameName oldFullName newFullName =
186 let
187 dedot name =
188 reverse (Text.splitOn "." (N.toText name))
189 in
190 case ( dedot oldFullName, dedot newFullName ) of
191 (oldName:[], newName:_) ->
192 oldName == newName
194 (oldName:_, newName:[]) ->
195 oldName == newName
197 _ ->
198 oldFullName == newFullName
201diffFields :: [(N.Name, Type.Type)] -> [(N.Name, Type.Type)] -> Maybe [(N.Name,N.Name)]
202diffFields oldRawFields newRawFields =
203 let
204 sort = List.sortBy (compare `on` fst)
205 oldFields = sort oldRawFields
206 newFields = sort newRawFields
207 in
208 if length oldRawFields /= length newRawFields then
209 Nothing
211 else if or (zipWith ((/=) `on` fst) oldFields newFields) then
212 Nothing
214 else
215 concat <$> zipWithM (diffType `on` snd) oldFields newFields
219-- TYPE VARIABLES
222isEquivalentRenaming :: [(N.Name,N.Name)] -> Bool
223isEquivalentRenaming varPairs =
224 let
225 renamings =
226 Map.toList (foldr insert Map.empty varPairs)
228 insert (old,new) dict =
229 Map.insertWith (++) old [new] dict
231 verify (old, news) =
232 case news of
233 [] ->
234 Nothing
236 new : rest ->
237 if all (new ==) rest then
238 Just (old, new)
239 else
240 Nothing
242 allUnique list =
243 length list == Set.size (Set.fromList list)
244 in
245 case mapM verify renamings of
246 Nothing ->
247 False
249 Just verifiedRenamings ->
250 all compatableVars verifiedRenamings
251 &&
252 allUnique (map snd verifiedRenamings)
255compatableVars :: (N.Name, N.Name) -> Bool
256compatableVars (old, new) =
257 case (categorizeVar old, categorizeVar new) of
258 (CompAppend, CompAppend) -> True
259 (Comparable, Comparable) -> True
260 (Appendable, Appendable) -> True
261 (Number , Number ) -> True
263 (Comparable, CompAppend) -> True
264 (Appendable, CompAppend) -> True
265 (Number , CompAppend) -> True
266 (Number , Comparable) -> True
268 (_, Var) -> True
270 (_, _) -> False
273data TypeVarCategory
274 = CompAppend
275 | Comparable
276 | Appendable
277 | Number
278 | Var
281categorizeVar :: N.Name -> TypeVarCategory
282categorizeVar name
283 | N.startsWith "compappend" name = CompAppend
284 | N.startsWith "comparable" name = Comparable
285 | N.startsWith "appendable" name = Appendable
286 | N.startsWith "number" name = Number
287 | otherwise = Var
291-- MAGNITUDE
294data Magnitude
295 = PATCH
296 | MINOR
297 | MAJOR
298 deriving (Eq, Ord)
301magnitudeToString :: Magnitude -> String
302magnitudeToString magnitude =
303 case magnitude of
304 PATCH ->
305 "PATCH"
307 MINOR ->
308 "MINOR"
310 MAJOR ->
311 "MAJOR"
314bump :: PackageChanges -> Pkg.Version -> Pkg.Version
315bump changes version =
316 case toMagnitude changes of
317 PATCH ->
318 Pkg.bumpPatch version
320 MINOR ->
321 Pkg.bumpMinor version
323 MAJOR ->
324 Pkg.bumpMajor version
327toMagnitude :: PackageChanges -> Magnitude
328toMagnitude (PackageChanges added changed removed) =
329 let
330 addMag = if null added then PATCH else MINOR
331 removeMag = if null removed then PATCH else MAJOR
332 changeMags = map moduleChangeMagnitude (Map.elems changed)
333 in
334 maximum (addMag : removeMag : changeMags)
337moduleChangeMagnitude :: ModuleChanges -> Magnitude
338moduleChangeMagnitude (ModuleChanges unions aliases values binops) =
339 maximum
340 [ changeMagnitude unions
341 , changeMagnitude aliases
342 , changeMagnitude values
343 , changeMagnitude binops
344 ]
347changeMagnitude :: Changes k v -> Magnitude
348changeMagnitude (Changes added changed removed) =
349 if Map.size removed > 0 || Map.size changed > 0 then
350 MAJOR
352 else if Map.size added > 0 then
353 MINOR
355 else
356 PATCH