git.iko.soy/elk
on efe80bc help sign in
elk/builder/src/Deps/Diff.hs
380 lines 9.6 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2module Deps.Diff
3 ( diff
4 , PackageChanges(..)
5 , ModuleChanges(..)
6 , Changes(..)
7 , moduleChangeMagnitude
8 , toMagnitude
9 , bump
10 , getDocs
11 )
12 where
15import Control.Monad (zipWithM)
16import Data.Function (on)
17import qualified Data.List as List
18import qualified Data.Map as Map
19import qualified Data.Name as Name
20import qualified Data.Set as Set
21import qualified Data.Utf8 as Utf8
23import qualified Deps.Website as Website
24import qualified Elm.Compiler.Type as Type
25import qualified Elm.Docs as Docs
26import qualified Elm.Magnitude as M
27import qualified Elm.ModuleName as ModuleName
28import qualified Elm.Package as Pkg
29import qualified Elm.Version as V
30import qualified File
31import qualified Http
32import qualified Json.Decode as D
33import qualified Reporting.Exit as Exit
34import qualified Stuff
38-- CHANGES
41data PackageChanges =
42 PackageChanges
43 { _modules_added :: [ModuleName.Raw]
44 , _modules_changed :: Map.Map ModuleName.Raw ModuleChanges
45 , _modules_removed :: [ModuleName.Raw]
46 }
49data ModuleChanges =
50 ModuleChanges
51 { _unions :: Changes Name.Name Docs.Union
52 , _aliases :: Changes Name.Name Docs.Alias
53 , _values :: Changes Name.Name Docs.Value
54 , _binops :: Changes Name.Name Docs.Binop
55 }
58data Changes k v =
59 Changes
60 { _added :: Map.Map k v
61 , _changed :: Map.Map k (v,v)
62 , _removed :: Map.Map k v
63 }
66getChanges :: (Ord k) => (v -> v -> Bool) -> Map.Map k v -> Map.Map k v -> Changes k v
67getChanges isEquivalent old new =
68 let
69 overlap = Map.intersectionWith (,) old new
70 changed = Map.filter (not . uncurry isEquivalent) overlap
71 in
72 Changes (Map.difference new old) changed (Map.difference old new)
76-- DIFF
79diff :: Docs.Documentation -> Docs.Documentation -> PackageChanges
80diff oldDocs newDocs =
81 let
82 filterOutPatches chngs =
83 Map.filter (\chng -> moduleChangeMagnitude chng /= M.PATCH) chngs
85 (Changes added changed removed) =
86 getChanges (\_ _ -> False) oldDocs newDocs
87 in
88 PackageChanges
89 (Map.keys added)
90 (filterOutPatches (Map.map diffModule changed))
91 (Map.keys removed)
95diffModule :: (Docs.Module, Docs.Module) -> ModuleChanges
96diffModule (Docs.Module _ _ u1 a1 v1 b1, Docs.Module _ _ u2 a2 v2 b2) =
97 ModuleChanges
98 (getChanges isEquivalentUnion u1 u2)
99 (getChanges isEquivalentAlias a1 a2)
100 (getChanges isEquivalentValue v1 v2)
101 (getChanges isEquivalentBinop b1 b2)
105-- EQUIVALENCE
108isEquivalentUnion :: Docs.Union -> Docs.Union -> Bool
109isEquivalentUnion (Docs.Union oldComment oldVars oldCtors) (Docs.Union newComment newVars newCtors) =
110 length oldCtors == length newCtors
111 && and (zipWith (==) (map fst oldCtors) (map fst newCtors))
112 && and (Map.elems (Map.intersectionWith equiv (Map.fromList oldCtors) (Map.fromList newCtors)))
113 where
114 equiv :: [Type.Type] -> [Type.Type] -> Bool
115 equiv oldTypes newTypes =
116 let
117 allEquivalent =
118 zipWith
119 isEquivalentAlias
120 (map (Docs.Alias oldComment oldVars) oldTypes)
121 (map (Docs.Alias newComment newVars) newTypes)
122 in
123 length oldTypes == length newTypes
124 && and allEquivalent
127isEquivalentAlias :: Docs.Alias -> Docs.Alias -> Bool
128isEquivalentAlias (Docs.Alias _ oldVars oldType) (Docs.Alias _ newVars newType) =
129 case diffType oldType newType of
130 Nothing ->
131 False
133 Just renamings ->
134 length oldVars == length newVars
135 && isEquivalentRenaming (zip oldVars newVars ++ renamings)
138isEquivalentValue :: Docs.Value -> Docs.Value -> Bool
139isEquivalentValue (Docs.Value c1 t1) (Docs.Value c2 t2) =
140 isEquivalentAlias (Docs.Alias c1 [] t1) (Docs.Alias c2 [] t2)
143isEquivalentBinop :: Docs.Binop -> Docs.Binop -> Bool
144isEquivalentBinop (Docs.Binop c1 t1 a1 p1) (Docs.Binop c2 t2 a2 p2) =
145 isEquivalentAlias (Docs.Alias c1 [] t1) (Docs.Alias c2 [] t2)
146 && a1 == a2
147 && p1 == p2
151-- DIFF TYPES
154diffType :: Type.Type -> Type.Type -> Maybe [(Name.Name,Name.Name)]
155diffType oldType newType =
156 case (oldType, newType) of
157 (Type.Var oldName, Type.Var newName) ->
158 Just [(oldName, newName)]
160 (Type.Lambda a b, Type.Lambda a' b') ->
161 (++)
162 <$> diffType a a'
163 <*> diffType b b'
165 (Type.Type oldName oldArgs, Type.Type newName newArgs) ->
166 if not (isSameName oldName newName) || length oldArgs /= length newArgs then
167 Nothing
168 else
169 concat <$> zipWithM diffType oldArgs newArgs
171 (Type.Record fields maybeExt, Type.Record fields' maybeExt') ->
172 case (maybeExt, maybeExt') of
173 (Nothing, Just _) ->
174 Nothing
176 (Just _, Nothing) ->
177 Nothing
179 (Nothing, Nothing) ->
180 diffFields fields fields'
182 (Just oldExt, Just newExt) ->
183 (:) (oldExt, newExt) <$> diffFields fields fields'
185 (Type.Unit, Type.Unit) ->
186 Just []
188 (Type.Tuple a b cs, Type.Tuple x y zs) ->
189 if length cs /= length zs then
190 Nothing
191 else
192 do aVars <- diffType a x
193 bVars <- diffType b y
194 cVars <- concat <$> zipWithM diffType cs zs
195 return (aVars ++ bVars ++ cVars)
197 (_, _) ->
198 Nothing
201-- handle very old docs that do not use qualified names
202isSameName :: Name.Name -> Name.Name -> Bool
203isSameName oldFullName newFullName =
204 let
205 dedot name =
206 reverse (Utf8.split 0x2E {-.-} (Name.toUtf8 name))
207 in
208 case ( dedot oldFullName, dedot newFullName ) of
209 (oldName:[], newName:_) ->
210 oldName == newName
212 (oldName:_, newName:[]) ->
213 oldName == newName
215 _ ->
216 oldFullName == newFullName
219diffFields :: [(Name.Name, Type.Type)] -> [(Name.Name, Type.Type)] -> Maybe [(Name.Name,Name.Name)]
220diffFields oldRawFields newRawFields =
221 let
222 sort = List.sortBy (compare `on` fst)
223 oldFields = sort oldRawFields
224 newFields = sort newRawFields
225 in
226 if length oldRawFields /= length newRawFields then
227 Nothing
229 else if or (zipWith ((/=) `on` fst) oldFields newFields) then
230 Nothing
232 else
233 concat <$> zipWithM (diffType `on` snd) oldFields newFields
237-- TYPE VARIABLES
240isEquivalentRenaming :: [(Name.Name,Name.Name)] -> Bool
241isEquivalentRenaming varPairs =
242 let
243 renamings =
244 Map.toList (foldr insert Map.empty varPairs)
246 insert (old,new) dict =
247 Map.insertWith (++) old [new] dict
249 verify (old, news) =
250 case news of
251 [] ->
252 Nothing
254 new : rest ->
255 if all (new ==) rest then
256 Just (old, new)
257 else
258 Nothing
260 allUnique list =
261 length list == Set.size (Set.fromList list)
262 in
263 case mapM verify renamings of
264 Nothing ->
265 False
267 Just verifiedRenamings ->
268 all compatibleVars verifiedRenamings
269 &&
270 allUnique (map snd verifiedRenamings)
273compatibleVars :: (Name.Name, Name.Name) -> Bool
274compatibleVars (old, new) =
275 case (categorizeVar old, categorizeVar new) of
276 (CompAppend, CompAppend) -> True
277 (Comparable, Comparable) -> True
278 (Appendable, Appendable) -> True
279 (Number , Number ) -> True
280 (Number , Comparable) -> True
282 (_, Var) -> True
284 (_, _) -> False
287data TypeVarCategory
288 = CompAppend
289 | Comparable
290 | Appendable
291 | Number
292 | Var
295categorizeVar :: Name.Name -> TypeVarCategory
296categorizeVar name
297 | Name.isCompappendType name = CompAppend
298 | Name.isComparableType name = Comparable
299 | Name.isAppendableType name = Appendable
300 | Name.isNumberType name = Number
301 | otherwise = Var
305-- MAGNITUDE
308bump :: PackageChanges -> V.Version -> V.Version
309bump changes version =
310 case toMagnitude changes of
311 M.PATCH ->
312 V.bumpPatch version
314 M.MINOR ->
315 V.bumpMinor version
317 M.MAJOR ->
318 V.bumpMajor version
321toMagnitude :: PackageChanges -> M.Magnitude
322toMagnitude (PackageChanges added changed removed) =
323 let
324 addMag = if null added then M.PATCH else M.MINOR
325 removeMag = if null removed then M.PATCH else M.MAJOR
326 changeMags = map moduleChangeMagnitude (Map.elems changed)
327 in
328 maximum (addMag : removeMag : changeMags)
331moduleChangeMagnitude :: ModuleChanges -> M.Magnitude
332moduleChangeMagnitude (ModuleChanges unions aliases values binops) =
333 maximum
334 [ changeMagnitude unions
335 , changeMagnitude aliases
336 , changeMagnitude values
337 , changeMagnitude binops
338 ]
341changeMagnitude :: Changes k v -> M.Magnitude
342changeMagnitude (Changes added changed removed) =
343 if Map.size removed > 0 || Map.size changed > 0 then
344 M.MAJOR
346 else if Map.size added > 0 then
347 M.MINOR
349 else
350 M.PATCH
354-- GET DOCS
357getDocs :: Stuff.PackageCache -> Http.Manager -> Pkg.Name -> V.Version -> IO (Either Exit.DocsProblem Docs.Documentation)
358getDocs cache manager name version =
359 do let path = Stuff.metadata cache name version "docs.json"
360 exists <- File.exists path
361 if exists
362 then
363 do result <- D.fromFile Docs.decoder path
364 case result of
365 Right docs ->
366 return $ Right docs
368 Left _ ->
369 do File.remove path
370 return $ Left Exit.DP_Cache
371 else
372 do let url = Website.metadata name version "docs.json"
373 Http.post manager url [] Exit.DP_Http $ \body ->
374 case D.fromByteString Docs.decoder body of
375 Right docs ->
376 do File.writeUtf8 path body
377 return $ Right docs
379 Left _ ->
380 return $ Left Exit.DP_Data