git.iko.soy/elk
on 2ea433c help sign in
elk/builder/src/Deps/Diff.hs
364 lines 8.6 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 (Type.Unit, Type.Unit) ->
180 Just []
182 (Type.Tuple a b cs, Type.Tuple x y zs) ->
183 if length cs /= length zs then
184 Nothing
185 else
186 do aVars <- diffType a x
187 bVars <- diffType b y
188 cVars <- concat <$> zipWithM diffType cs zs
189 return (aVars ++ bVars ++ cVars)
191 (_, _) ->
192 Nothing
195-- handle very old docs that do not use qualified names
196isSameName :: N.Name -> N.Name -> Bool
197isSameName oldFullName newFullName =
198 let
199 dedot name =
200 reverse (Text.splitOn "." (N.toText name))
201 in
202 case ( dedot oldFullName, dedot newFullName ) of
203 (oldName:[], newName:_) ->
204 oldName == newName
206 (oldName:_, newName:[]) ->
207 oldName == newName
209 _ ->
210 oldFullName == newFullName
213diffFields :: [(N.Name, Type.Type)] -> [(N.Name, Type.Type)] -> Maybe [(N.Name,N.Name)]
214diffFields oldRawFields newRawFields =
215 let
216 sort = List.sortBy (compare `on` fst)
217 oldFields = sort oldRawFields
218 newFields = sort newRawFields
219 in
220 if length oldRawFields /= length newRawFields then
221 Nothing
223 else if or (zipWith ((/=) `on` fst) oldFields newFields) then
224 Nothing
226 else
227 concat <$> zipWithM (diffType `on` snd) oldFields newFields
231-- TYPE VARIABLES
234isEquivalentRenaming :: [(N.Name,N.Name)] -> Bool
235isEquivalentRenaming varPairs =
236 let
237 renamings =
238 Map.toList (foldr insert Map.empty varPairs)
240 insert (old,new) dict =
241 Map.insertWith (++) old [new] dict
243 verify (old, news) =
244 case news of
245 [] ->
246 Nothing
248 new : rest ->
249 if all (new ==) rest then
250 Just (old, new)
251 else
252 Nothing
254 allUnique list =
255 length list == Set.size (Set.fromList list)
256 in
257 case mapM verify renamings of
258 Nothing ->
259 False
261 Just verifiedRenamings ->
262 all compatibleVars verifiedRenamings
263 &&
264 allUnique (map snd verifiedRenamings)
267compatibleVars :: (N.Name, N.Name) -> Bool
268compatibleVars (old, new) =
269 case (categorizeVar old, categorizeVar new) of
270 (CompAppend, CompAppend) -> True
271 (Comparable, Comparable) -> True
272 (Appendable, Appendable) -> True
273 (Number , Number ) -> True
274 (Number , Comparable) -> True
276 (_, Var) -> True
278 (_, _) -> False
281data TypeVarCategory
282 = CompAppend
283 | Comparable
284 | Appendable
285 | Number
286 | Var
289categorizeVar :: N.Name -> TypeVarCategory
290categorizeVar name
291 | N.startsWith "compappend" name = CompAppend
292 | N.startsWith "comparable" name = Comparable
293 | N.startsWith "appendable" name = Appendable
294 | N.startsWith "number" name = Number
295 | otherwise = Var
299-- MAGNITUDE
302data Magnitude
303 = PATCH
304 | MINOR
305 | MAJOR
306 deriving (Eq, Ord)
309magnitudeToString :: Magnitude -> String
310magnitudeToString magnitude =
311 case magnitude of
312 PATCH ->
313 "PATCH"
315 MINOR ->
316 "MINOR"
318 MAJOR ->
319 "MAJOR"
322bump :: PackageChanges -> Pkg.Version -> Pkg.Version
323bump changes version =
324 case toMagnitude changes of
325 PATCH ->
326 Pkg.bumpPatch version
328 MINOR ->
329 Pkg.bumpMinor version
331 MAJOR ->
332 Pkg.bumpMajor version
335toMagnitude :: PackageChanges -> Magnitude
336toMagnitude (PackageChanges added changed removed) =
337 let
338 addMag = if null added then PATCH else MINOR
339 removeMag = if null removed then PATCH else MAJOR
340 changeMags = map moduleChangeMagnitude (Map.elems changed)
341 in
342 maximum (addMag : removeMag : changeMags)
345moduleChangeMagnitude :: ModuleChanges -> Magnitude
346moduleChangeMagnitude (ModuleChanges unions aliases values binops) =
347 maximum
348 [ changeMagnitude unions
349 , changeMagnitude aliases
350 , changeMagnitude values
351 , changeMagnitude binops
352 ]
355changeMagnitude :: Changes k v -> Magnitude
356changeMagnitude (Changes added changed removed) =
357 if Map.size removed > 0 || Map.size changed > 0 then
358 MAJOR
360 else if Map.size added > 0 then
361 MINOR
363 else
364 PATCH