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