git.iko.soy/elk
on df7839b 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 System.FilePath ((</>))
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 (Name.splitDots 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.package cache name version </> "docs.json"
360 exists <- File.exists path
361 if exists
362 then
363 do bytes <- File.readUtf8 path
364 case D.fromByteString Docs.decoder bytes 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.get 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