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
13
14
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 ((</>))
23
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
36
37
38
39-- CHANGES
40
41
42data PackageChanges =
43  PackageChanges
44    { _modules_added :: [ModuleName.Raw]
45    , _modules_changed :: Map.Map ModuleName.Raw ModuleChanges
46    , _modules_removed :: [ModuleName.Raw]
47    }
48
49
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    }
57
58
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    }
65
66
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)
74
75
76
77-- DIFF
78
79
80diff :: Docs.Documentation -> Docs.Documentation -> PackageChanges
81diff oldDocs newDocs =
82  let
83    filterOutPatches chngs =
84      Map.filter (\chng -> moduleChangeMagnitude chng /= M.PATCH) chngs
85
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)
93
94
95
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)
103
104
105
106-- EQUIVALENCE
107
108
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
126
127
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
133
134    Just renamings ->
135      length oldVars == length newVars
136      && isEquivalentRenaming (zip oldVars newVars ++ renamings)
137
138
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)
142
143
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
149
150
151
152-- DIFF TYPES
153
154
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)]
160
161    (Type.Lambda a b, Type.Lambda a' b') ->
162      (++)
163        <$> diffType a a'
164        <*> diffType b b'
165
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
171
172    (Type.Record fields maybeExt, Type.Record fields' maybeExt') ->
173      case (maybeExt, maybeExt') of
174        (Nothing, Just _) ->
175          Nothing
176
177        (Just _, Nothing) ->
178          Nothing
179
180        (Nothing, Nothing) ->
181          diffFields fields fields'
182
183        (Just oldExt, Just newExt) ->
184          (:) (oldExt, newExt) <$> diffFields fields fields'
185
186    (Type.Unit, Type.Unit) ->
187      Just []
188
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)
197
198    (_, _) ->
199      Nothing
200
201
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
212
213      (oldName:_, newName:[]) ->
214        oldName == newName
215
216      _ ->
217        oldFullName == newFullName
218
219
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
229
230    else if or (zipWith ((/=) `on` fst) oldFields newFields) then
231      Nothing
232
233    else
234      concat <$> zipWithM (diffType `on` snd) oldFields newFields
235
236
237
238-- TYPE VARIABLES
239
240
241isEquivalentRenaming :: [(Name.Name,Name.Name)] -> Bool
242isEquivalentRenaming varPairs =
243  let
244    renamings =
245      Map.toList (foldr insert Map.empty varPairs)
246
247    insert (old,new) dict =
248      Map.insertWith (++) old [new] dict
249
250    verify (old, news) =
251      case news of
252        [] ->
253          Nothing
254
255        new : rest ->
256          if all (new ==) rest then
257            Just (old, new)
258          else
259            Nothing
260
261    allUnique list =
262      length list == Set.size (Set.fromList list)
263  in
264    case mapM verify renamings of
265      Nothing ->
266        False
267
268      Just verifiedRenamings ->
269        all compatibleVars verifiedRenamings
270        &&
271        allUnique (map snd verifiedRenamings)
272
273
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
282
283    (_, Var) -> True
284
285    (_, _) -> False
286
287
288data TypeVarCategory
289  = CompAppend
290  | Comparable
291  | Appendable
292  | Number
293  | Var
294
295
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
303
304
305
306-- MAGNITUDE
307
308
309bump :: PackageChanges -> V.Version -> V.Version
310bump changes version =
311  case toMagnitude changes of
312    M.PATCH ->
313      V.bumpPatch version
314
315    M.MINOR ->
316      V.bumpMinor version
317
318    M.MAJOR ->
319      V.bumpMajor version
320
321
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)
330
331
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    ]
340
341
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
346
347  else if Map.size added > 0 then
348    M.MINOR
349
350  else
351    M.PATCH
352
353
354
355-- GET DOCS
356
357
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
369
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
381
382                  Left _ ->
383                    return $ Left $ Exit.DP_Data url body
384