Diff.hs

{-# LANGUAGE OverloadedStrings #-}
module Deps.Diff
  ( diff
  , PackageChanges(..)
  , ModuleChanges(..)
  , Changes(..)
  , moduleChangeMagnitude
  , toMagnitude
  , bump
  , getDocs
  )
  where


import Control.Monad (zipWithM)
import Data.Function (on)
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Name as Name
import qualified Data.Set as Set
import qualified System.Directory as Dir
import System.FilePath ((</>))

import qualified Deps.Website as Website
import qualified Elm.Compiler.Type as Type
import qualified Elm.Docs as Docs
import qualified Elm.Magnitude as M
import qualified Elm.ModuleName as ModuleName
import qualified Elm.Package as Pkg
import qualified Elm.Version as V
import qualified File
import qualified Http
import qualified Json.Decode as D
import qualified Reporting.Exit as Exit
import qualified Stuff



-- CHANGES


data PackageChanges =
  PackageChanges
    { _modules_added :: [ModuleName.Raw]
    , _modules_changed :: Map.Map ModuleName.Raw ModuleChanges
    , _modules_removed :: [ModuleName.Raw]
    }


data ModuleChanges =
  ModuleChanges
    { _unions :: Changes Name.Name Docs.Union
    , _aliases :: Changes Name.Name Docs.Alias
    , _values :: Changes Name.Name Docs.Value
    , _binops :: Changes Name.Name Docs.Binop
    }


data Changes k v =
  Changes
    { _added :: Map.Map k v
    , _changed :: Map.Map k (v,v)
    , _removed :: Map.Map k v
    }


getChanges :: (Ord k) => (v -> v -> Bool) -> Map.Map k v -> Map.Map k v -> Changes k v
getChanges isEquivalent old new =
  let
    overlap = Map.intersectionWith (,) old new
    changed = Map.filter (not . uncurry isEquivalent) overlap
  in
    Changes (Map.difference new old) changed (Map.difference old new)



-- DIFF


diff :: Docs.Documentation -> Docs.Documentation -> PackageChanges
diff oldDocs newDocs =
  let
    filterOutPatches chngs =
      Map.filter (\chng -> moduleChangeMagnitude chng /= M.PATCH) chngs

    (Changes added changed removed) =
      getChanges (\_ _ -> False) oldDocs newDocs
  in
    PackageChanges
      (Map.keys added)
      (filterOutPatches (Map.map diffModule changed))
      (Map.keys removed)



diffModule :: (Docs.Module, Docs.Module) -> ModuleChanges
diffModule (Docs.Module _ _ u1 a1 v1 b1, Docs.Module _ _ u2 a2 v2 b2) =
  ModuleChanges
    (getChanges isEquivalentUnion u1 u2)
    (getChanges isEquivalentAlias a1 a2)
    (getChanges isEquivalentValue v1 v2)
    (getChanges isEquivalentBinop b1 b2)



-- EQUIVALENCE


isEquivalentUnion :: Docs.Union -> Docs.Union -> Bool
isEquivalentUnion (Docs.Union oldComment oldVars oldCtors) (Docs.Union newComment newVars newCtors) =
    length oldCtors == length newCtors
    && and (zipWith (==) (map fst oldCtors) (map fst newCtors))
    && and (Map.elems (Map.intersectionWith equiv (Map.fromList oldCtors) (Map.fromList newCtors)))
  where
    equiv :: [Type.Type] -> [Type.Type] -> Bool
    equiv oldTypes newTypes =
      let
        allEquivalent =
          zipWith
            isEquivalentAlias
            (map (Docs.Alias oldComment oldVars) oldTypes)
            (map (Docs.Alias newComment newVars) newTypes)
      in
        length oldTypes == length newTypes
        && and allEquivalent


isEquivalentAlias :: Docs.Alias -> Docs.Alias -> Bool
isEquivalentAlias (Docs.Alias _ oldVars oldType) (Docs.Alias _ newVars newType) =
  case diffType oldType newType of
    Nothing ->
      False

    Just renamings ->
      length oldVars == length newVars
      && isEquivalentRenaming (zip oldVars newVars ++ renamings)


isEquivalentValue :: Docs.Value -> Docs.Value -> Bool
isEquivalentValue (Docs.Value c1 t1) (Docs.Value c2 t2) =
  isEquivalentAlias (Docs.Alias c1 [] t1) (Docs.Alias c2 [] t2)


isEquivalentBinop :: Docs.Binop -> Docs.Binop -> Bool
isEquivalentBinop (Docs.Binop c1 t1 a1 p1) (Docs.Binop c2 t2 a2 p2) =
  isEquivalentAlias (Docs.Alias c1 [] t1) (Docs.Alias c2 [] t2)
  && a1 == a2
  && p1 == p2



-- DIFF TYPES


diffType :: Type.Type -> Type.Type -> Maybe [(Name.Name,Name.Name)]
diffType oldType newType =
  case (oldType, newType) of
    (Type.Var oldName, Type.Var newName) ->
      Just [(oldName, newName)]

    (Type.Lambda a b, Type.Lambda a' b') ->
      (++)
        <$> diffType a a'
        <*> diffType b b'

    (Type.Type oldName oldArgs, Type.Type newName newArgs) ->
      if not (isSameName oldName newName) || length oldArgs /= length newArgs then
        Nothing
      else
        concat <$> zipWithM diffType oldArgs newArgs

    (Type.Record fields maybeExt, Type.Record fields' maybeExt') ->
      case (maybeExt, maybeExt') of
        (Nothing, Just _) ->
          Nothing

        (Just _, Nothing) ->
          Nothing

        (Nothing, Nothing) ->
          diffFields fields fields'

        (Just oldExt, Just newExt) ->
          (:) (oldExt, newExt) <$> diffFields fields fields'

    (Type.Unit, Type.Unit) ->
      Just []

    (Type.Tuple a b cs, Type.Tuple x y zs) ->
      if length cs /= length zs then
        Nothing
      else
        do  aVars <- diffType a x
            bVars <- diffType b y
            cVars <- concat <$> zipWithM diffType cs zs
            return (aVars ++ bVars ++ cVars)

    (_, _) ->
      Nothing


-- handle very old docs that do not use qualified names
isSameName :: Name.Name -> Name.Name -> Bool
isSameName oldFullName newFullName =
  let
    dedot name =
      reverse (Name.splitDots name)
  in
    case ( dedot oldFullName, dedot newFullName ) of
      (oldName:[], newName:_) ->
        oldName == newName

      (oldName:_, newName:[]) ->
        oldName == newName

      _ ->
        oldFullName == newFullName


diffFields :: [(Name.Name, Type.Type)] -> [(Name.Name, Type.Type)] -> Maybe [(Name.Name,Name.Name)]
diffFields oldRawFields newRawFields =
  let
    sort = List.sortBy (compare `on` fst)
    oldFields = sort oldRawFields
    newFields = sort newRawFields
  in
    if length oldRawFields /= length newRawFields then
      Nothing

    else if or (zipWith ((/=) `on` fst) oldFields newFields) then
      Nothing

    else
      concat <$> zipWithM (diffType `on` snd) oldFields newFields



-- TYPE VARIABLES


isEquivalentRenaming :: [(Name.Name,Name.Name)] -> Bool
isEquivalentRenaming varPairs =
  let
    renamings =
      Map.toList (foldr insert Map.empty varPairs)

    insert (old,new) dict =
      Map.insertWith (++) old [new] dict

    verify (old, news) =
      case news of
        [] ->
          Nothing

        new : rest ->
          if all (new ==) rest then
            Just (old, new)
          else
            Nothing

    allUnique list =
      length list == Set.size (Set.fromList list)
  in
    case mapM verify renamings of
      Nothing ->
        False

      Just verifiedRenamings ->
        all compatibleVars verifiedRenamings
        &&
        allUnique (map snd verifiedRenamings)


compatibleVars :: (Name.Name, Name.Name) -> Bool
compatibleVars (old, new) =
  case (categorizeVar old, categorizeVar new) of
    (CompAppend, CompAppend) -> True
    (Comparable, Comparable) -> True
    (Appendable, Appendable) -> True
    (Number    , Number    ) -> True
    (Number    , Comparable) -> True

    (_, Var) -> True

    (_, _) -> False


data TypeVarCategory
  = CompAppend
  | Comparable
  | Appendable
  | Number
  | Var


categorizeVar :: Name.Name -> TypeVarCategory
categorizeVar name
  | Name.isCompappendType name = CompAppend
  | Name.isComparableType name = Comparable
  | Name.isAppendableType name = Appendable
  | Name.isNumberType     name = Number
  | otherwise                  = Var



-- MAGNITUDE


bump :: PackageChanges -> V.Version -> V.Version
bump changes version =
  case toMagnitude changes of
    M.PATCH ->
      V.bumpPatch version

    M.MINOR ->
      V.bumpMinor version

    M.MAJOR ->
      V.bumpMajor version


toMagnitude :: PackageChanges -> M.Magnitude
toMagnitude (PackageChanges added changed removed) =
  let
    addMag = if null added then M.PATCH else M.MINOR
    removeMag = if null removed then M.PATCH else M.MAJOR
    changeMags = map moduleChangeMagnitude (Map.elems changed)
  in
    maximum (addMag : removeMag : changeMags)


moduleChangeMagnitude :: ModuleChanges -> M.Magnitude
moduleChangeMagnitude (ModuleChanges unions aliases values binops) =
  maximum
    [ changeMagnitude unions
    , changeMagnitude aliases
    , changeMagnitude values
    , changeMagnitude binops
    ]


changeMagnitude :: Changes k v -> M.Magnitude
changeMagnitude (Changes added changed removed) =
  if Map.size removed > 0 || Map.size changed > 0 then
    M.MAJOR

  else if Map.size added > 0 then
    M.MINOR

  else
    M.PATCH



-- GET DOCS


getDocs :: Stuff.PackageCache -> Http.Manager -> Pkg.Name -> V.Version -> IO (Either Exit.DocsProblem Docs.Documentation)
getDocs cache manager name version =
  do  let home = Stuff.package cache name version
      let path = home </> "docs.json"
      exists <- File.exists path
      if exists
        then
          do  bytes <- File.readUtf8 path
              case D.fromByteString Docs.decoder bytes of
                Right docs ->
                  return $ Right docs

                Left _ ->
                  do  File.remove path
                      return $ Left Exit.DP_Cache
        else
          do  let url = Website.metadata name version "docs.json"
              Http.get manager url [] Exit.DP_Http $ \body ->
                case D.fromByteString Docs.decoder body of
                  Right docs ->
                    do  Dir.createDirectoryIfMissing True home
                        File.writeUtf8 path body
                        return $ Right docs

                  Left _ ->
                    return $ Left $ Exit.DP_Data url body