git.iko.soy/elk
on master help sign in
elk/builder/src/Deps/Diff.hs
383 lines 9.8 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 System.Directory as Dir
22import System.FilePath ((</>))
24import qualified Deps.Website as Website
25import qualified Elm.Compiler.Type as Type
26import qualified Elm.Docs as Docs
27import qualified Elm.Magnitude as M
28import qualified Elm.ModuleName as ModuleName
29import qualified Elm.Package as Pkg
30import qualified Elm.Version as V
31import qualified File
32import qualified Http
33import qualified Json.Decode as D
34import qualified Reporting.Exit as Exit
35import qualified Stuff
39-- CHANGES
42data PackageChanges =
43 PackageChanges
44 { _modules_added :: [ModuleName.Raw]
45 , _modules_changed :: Map.Map ModuleName.Raw ModuleChanges
46 , _modules_removed :: [ModuleName.Raw]
47 }
50data ModuleChanges =
51 ModuleChanges
52 { _unions :: Changes Name.Name Docs.Union
53 , _aliases :: Changes Name.Name Docs.Alias
54 , _values :: Changes Name.Name Docs.Value
55 , _binops :: Changes Name.Name Docs.Binop
56 }
59data Changes k v =
60 Changes
61 { _added :: Map.Map k v
62 , _changed :: Map.Map k (v,v)
63 , _removed :: Map.Map k v
64 }
67getChanges :: (Ord k) => (v -> v -> Bool) -> Map.Map k v -> Map.Map k v -> Changes k v
68getChanges isEquivalent old new =
69 let
70 overlap = Map.intersectionWith (,) old new
71 changed = Map.filter (not . uncurry isEquivalent) overlap
72 in
73 Changes (Map.difference new old) changed (Map.difference old new)
77-- DIFF
80diff :: Docs.Documentation -> Docs.Documentation -> PackageChanges
81diff oldDocs newDocs =
82 let
83 filterOutPatches chngs =
84 Map.filter (\chng -> moduleChangeMagnitude chng /= M.PATCH) chngs
86 (Changes added changed removed) =
87 getChanges (\_ _ -> False) oldDocs newDocs
88 in
89 PackageChanges
90 (Map.keys added)
91 (filterOutPatches (Map.map diffModule changed))
92 (Map.keys removed)
96diffModule :: (Docs.Module, Docs.Module) -> ModuleChanges
97diffModule (Docs.Module _ _ u1 a1 v1 b1, Docs.Module _ _ u2 a2 v2 b2) =
98 ModuleChanges
99 (getChanges isEquivalentUnion u1 u2)
100 (getChanges isEquivalentAlias a1 a2)
101 (getChanges isEquivalentValue v1 v2)
102 (getChanges isEquivalentBinop b1 b2)
106-- EQUIVALENCE
109isEquivalentUnion :: Docs.Union -> Docs.Union -> Bool
110isEquivalentUnion (Docs.Union oldComment oldVars oldCtors) (Docs.Union newComment newVars newCtors) =
111 length oldCtors == length newCtors
112 && and (zipWith (==) (map fst oldCtors) (map fst newCtors))
113 && and (Map.elems (Map.intersectionWith equiv (Map.fromList oldCtors) (Map.fromList newCtors)))
114 where
115 equiv :: [Type.Type] -> [Type.Type] -> Bool
116 equiv oldTypes newTypes =
117 let
118 allEquivalent =
119 zipWith
120 isEquivalentAlias
121 (map (Docs.Alias oldComment oldVars) oldTypes)
122 (map (Docs.Alias newComment newVars) newTypes)
123 in
124 length oldTypes == length newTypes
125 && and allEquivalent
128isEquivalentAlias :: Docs.Alias -> Docs.Alias -> Bool
129isEquivalentAlias (Docs.Alias _ oldVars oldType) (Docs.Alias _ newVars newType) =
130 case diffType oldType newType of
131 Nothing ->
132 False
134 Just renamings ->
135 length oldVars == length newVars
136 && isEquivalentRenaming (zip oldVars newVars ++ renamings)
139isEquivalentValue :: Docs.Value -> Docs.Value -> Bool
140isEquivalentValue (Docs.Value c1 t1) (Docs.Value c2 t2) =
141 isEquivalentAlias (Docs.Alias c1 [] t1) (Docs.Alias c2 [] t2)
144isEquivalentBinop :: Docs.Binop -> Docs.Binop -> Bool
145isEquivalentBinop (Docs.Binop c1 t1 a1 p1) (Docs.Binop c2 t2 a2 p2) =
146 isEquivalentAlias (Docs.Alias c1 [] t1) (Docs.Alias c2 [] t2)
147 && a1 == a2
148 && p1 == p2
152-- DIFF TYPES
155diffType :: Type.Type -> Type.Type -> Maybe [(Name.Name,Name.Name)]
156diffType oldType newType =
157 case (oldType, newType) of
158 (Type.Var oldName, Type.Var newName) ->
159 Just [(oldName, newName)]
161 (Type.Lambda a b, Type.Lambda a' b') ->
162 (++)
163 <$> diffType a a'
164 <*> diffType b b'
166 (Type.Type oldName oldArgs, Type.Type newName newArgs) ->
167 if not (isSameName oldName newName) || length oldArgs /= length newArgs then
168 Nothing
169 else
170 concat <$> zipWithM diffType oldArgs newArgs
172 (Type.Record fields maybeExt, Type.Record fields' maybeExt') ->
173 case (maybeExt, maybeExt') of
174 (Nothing, Just _) ->
175 Nothing
177 (Just _, Nothing) ->
178 Nothing
180 (Nothing, Nothing) ->
181 diffFields fields fields'
183 (Just oldExt, Just newExt) ->
184 (:) (oldExt, newExt) <$> diffFields fields fields'
186 (Type.Unit, Type.Unit) ->
187 Just []
189 (Type.Tuple a b cs, Type.Tuple x y zs) ->
190 if length cs /= length zs then
191 Nothing
192 else
193 do aVars <- diffType a x
194 bVars <- diffType b y
195 cVars <- concat <$> zipWithM diffType cs zs
196 return (aVars ++ bVars ++ cVars)
198 (_, _) ->
199 Nothing
202-- handle very old docs that do not use qualified names
203isSameName :: Name.Name -> Name.Name -> Bool
204isSameName oldFullName newFullName =
205 let
206 dedot name =
207 reverse (Name.splitDots name)
208 in
209 case ( dedot oldFullName, dedot newFullName ) of
210 (oldName:[], newName:_) ->
211 oldName == newName
213 (oldName:_, newName:[]) ->
214 oldName == newName
216 _ ->
217 oldFullName == newFullName
220diffFields :: [(Name.Name, Type.Type)] -> [(Name.Name, Type.Type)] -> Maybe [(Name.Name,Name.Name)]
221diffFields oldRawFields newRawFields =
222 let
223 sort = List.sortBy (compare `on` fst)
224 oldFields = sort oldRawFields
225 newFields = sort newRawFields
226 in
227 if length oldRawFields /= length newRawFields then
228 Nothing
230 else if or (zipWith ((/=) `on` fst) oldFields newFields) then
231 Nothing
233 else
234 concat <$> zipWithM (diffType `on` snd) oldFields newFields
238-- TYPE VARIABLES
241isEquivalentRenaming :: [(Name.Name,Name.Name)] -> Bool
242isEquivalentRenaming varPairs =
243 let
244 renamings =
245 Map.toList (foldr insert Map.empty varPairs)
247 insert (old,new) dict =
248 Map.insertWith (++) old [new] dict
250 verify (old, news) =
251 case news of
252 [] ->
253 Nothing
255 new : rest ->
256 if all (new ==) rest then
257 Just (old, new)
258 else
259 Nothing
261 allUnique list =
262 length list == Set.size (Set.fromList list)
263 in
264 case mapM verify renamings of
265 Nothing ->
266 False
268 Just verifiedRenamings ->
269 all compatibleVars verifiedRenamings
270 &&
271 allUnique (map snd verifiedRenamings)
274compatibleVars :: (Name.Name, Name.Name) -> Bool
275compatibleVars (old, new) =
276 case (categorizeVar old, categorizeVar new) of
277 (CompAppend, CompAppend) -> True
278 (Comparable, Comparable) -> True
279 (Appendable, Appendable) -> True
280 (Number , Number ) -> True
281 (Number , Comparable) -> True
283 (_, Var) -> True
285 (_, _) -> False
288data TypeVarCategory
289 = CompAppend
290 | Comparable
291 | Appendable
292 | Number
293 | Var
296categorizeVar :: Name.Name -> TypeVarCategory
297categorizeVar name
298 | Name.isCompappendType name = CompAppend
299 | Name.isComparableType name = Comparable
300 | Name.isAppendableType name = Appendable
301 | Name.isNumberType name = Number
302 | otherwise = Var
306-- MAGNITUDE
309bump :: PackageChanges -> V.Version -> V.Version
310bump changes version =
311 case toMagnitude changes of
312 M.PATCH ->
313 V.bumpPatch version
315 M.MINOR ->
316 V.bumpMinor version
318 M.MAJOR ->
319 V.bumpMajor version
322toMagnitude :: PackageChanges -> M.Magnitude
323toMagnitude (PackageChanges added changed removed) =
324 let
325 addMag = if null added then M.PATCH else M.MINOR
326 removeMag = if null removed then M.PATCH else M.MAJOR
327 changeMags = map moduleChangeMagnitude (Map.elems changed)
328 in
329 maximum (addMag : removeMag : changeMags)
332moduleChangeMagnitude :: ModuleChanges -> M.Magnitude
333moduleChangeMagnitude (ModuleChanges unions aliases values binops) =
334 maximum
335 [ changeMagnitude unions
336 , changeMagnitude aliases
337 , changeMagnitude values
338 , changeMagnitude binops
339 ]
342changeMagnitude :: Changes k v -> M.Magnitude
343changeMagnitude (Changes added changed removed) =
344 if Map.size removed > 0 || Map.size changed > 0 then
345 M.MAJOR
347 else if Map.size added > 0 then
348 M.MINOR
350 else
351 M.PATCH
355-- GET DOCS
358getDocs :: Stuff.PackageCache -> Http.Manager -> Pkg.Name -> V.Version -> IO (Either Exit.DocsProblem Docs.Documentation)
359getDocs cache manager name version =
360 do let home = Stuff.package cache name version
361 let path = home </> "docs.json"
362 exists <- File.exists path
363 if exists
364 then
365 do bytes <- File.readUtf8 path
366 case D.fromByteString Docs.decoder bytes of
367 Right docs ->
368 return $ Right docs
370 Left _ ->
371 do File.remove path
372 return $ Left Exit.DP_Cache
373 else
374 do let url = Website.metadata name version "docs.json"
375 Http.get manager url [] Exit.DP_Http $ \body ->
376 case D.fromByteString Docs.decoder body of
377 Right docs ->
378 do Dir.createDirectoryIfMissing True home
379 File.writeUtf8 path body
380 return $ Right docs
382 Left _ ->
383 return $ Left $ Exit.DP_Data url body