git.iko.soy/elk
on 63fa090 help sign in
elk/builder/src/Deps/Diff.hs
368 lines 8.7 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 compatableVars verifiedRenamings
263 &&
264 allUnique (map snd verifiedRenamings)
267compatableVars :: (N.Name, N.Name) -> Bool
268compatableVars (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
275 (Comparable, CompAppend) -> True
276 (Appendable, CompAppend) -> True
277 (Number , CompAppend) -> True
278 (Number , Comparable) -> True
280 (_, Var) -> True
282 (_, _) -> False
285data TypeVarCategory
286 = CompAppend
287 | Comparable
288 | Appendable
289 | Number
290 | Var
293categorizeVar :: N.Name -> TypeVarCategory
294categorizeVar name
295 | N.startsWith "compappend" name = CompAppend
296 | N.startsWith "comparable" name = Comparable
297 | N.startsWith "appendable" name = Appendable
298 | N.startsWith "number" name = Number
299 | otherwise = Var
303-- MAGNITUDE
306data Magnitude
307 = PATCH
308 | MINOR
309 | MAJOR
310 deriving (Eq, Ord)
313magnitudeToString :: Magnitude -> String
314magnitudeToString magnitude =
315 case magnitude of
316 PATCH ->
317 "PATCH"
319 MINOR ->
320 "MINOR"
322 MAJOR ->
323 "MAJOR"
326bump :: PackageChanges -> Pkg.Version -> Pkg.Version
327bump changes version =
328 case toMagnitude changes of
329 PATCH ->
330 Pkg.bumpPatch version
332 MINOR ->
333 Pkg.bumpMinor version
335 MAJOR ->
336 Pkg.bumpMajor version
339toMagnitude :: PackageChanges -> Magnitude
340toMagnitude (PackageChanges added changed removed) =
341 let
342 addMag = if null added then PATCH else MINOR
343 removeMag = if null removed then PATCH else MAJOR
344 changeMags = map moduleChangeMagnitude (Map.elems changed)
345 in
346 maximum (addMag : removeMag : changeMags)
349moduleChangeMagnitude :: ModuleChanges -> Magnitude
350moduleChangeMagnitude (ModuleChanges unions aliases values binops) =
351 maximum
352 [ changeMagnitude unions
353 , changeMagnitude aliases
354 , changeMagnitude values
355 , changeMagnitude binops
356 ]
359changeMagnitude :: Changes k v -> Magnitude
360changeMagnitude (Changes added changed removed) =
361 if Map.size removed > 0 || Map.size changed > 0 then
362 MAJOR
364 else if Map.size added > 0 then
365 MINOR
367 else
368 PATCH