Compare.hs

{-# LANGUAGE OverloadedStrings #-}
module Diff.Compare
  ( bumpBy
  , computeChanges
  , Changes(..)
  , PackageChanges(..), packageChangeMagnitude
  , ModuleChanges(..), moduleChangeMagnitude
  )
  where

import Control.Monad (zipWithM)
import Data.Function (on)
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as Text
import Data.Text (Text)

import qualified Catalog
import Diff.Magnitude (Magnitude(..))
import qualified Elm.Compiler.Module as Module
import qualified Elm.Compiler.Type as Type
import qualified Elm.Docs as Docs
import qualified Elm.Package as Package
import qualified Manager



computeChanges
    :: [Docs.Documentation]
    -> Package.Name
    -> Package.Version
    -> Manager.Manager PackageChanges
computeChanges newDocs name version =
  do  oldDocs <- Catalog.documentation name version
      return (diffPackages oldDocs newDocs)



-- CHANGE MAGNITUDE


bumpBy :: PackageChanges -> Package.Version -> Package.Version
bumpBy changes version =
  case packageChangeMagnitude changes of
    PATCH ->
        Package.bumpPatch version

    MINOR ->
        Package.bumpMinor version

    MAJOR ->
        Package.bumpMajor version


packageChangeMagnitude :: PackageChanges -> Magnitude
packageChangeMagnitude pkgChanges =
    maximum (added : removed : map moduleChangeMagnitude moduleChanges)
  where
    moduleChanges =
      Map.elems (modulesChanged pkgChanges)

    removed =
      if null (modulesRemoved pkgChanges) then
        PATCH
      else
        MAJOR

    added =
      if null (modulesAdded pkgChanges) then
        PATCH
      else
        MINOR


moduleChangeMagnitude :: ModuleChanges -> Magnitude
moduleChangeMagnitude moduleChanges =
  maximum
    [ changeMagnitude (adtChanges moduleChanges)
    , changeMagnitude (aliasChanges moduleChanges)
    , changeMagnitude (valueChanges moduleChanges)
    ]


changeMagnitude :: Changes k v -> Magnitude
changeMagnitude (Changes added changed removed)
    | Map.size removed > 0 = MAJOR
    | Map.size changed > 0 = MAJOR
    | Map.size added   > 0 = MINOR
    | otherwise            = PATCH



-- DETECT CHANGES


data PackageChanges =
  PackageChanges
    { modulesAdded :: [Text]
    , modulesChanged :: Map.Map Text ModuleChanges
    , modulesRemoved :: [Text]
    }


data ModuleChanges =
  ModuleChanges
    { adtChanges :: Changes Text ([Text], Map.Map Text [Type.Type])
    , aliasChanges :: Changes Text ([Text], Type.Type)
    , valueChanges :: Changes Text Type.Type
    }


data Changes k v =
  Changes
    { added :: Map.Map k v
    , changed :: Map.Map k (v,v)
    , removed :: Map.Map k v
    }


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

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



data Module = Module
    { adts :: Map.Map Text ([Text], Map.Map Text [Type.Type])
    , aliases :: Map.Map Text ([Text], Type.Type)
    , values :: Map.Map Text Type.Type
    , version :: Docs.Version
    }


docsToModules :: [Docs.Documentation] -> Map.Map Text Module
docsToModules docs =
  Map.fromList (map docToModule docs)


docToModule :: Docs.Documentation -> (Text, Module)
docToModule (Docs.Documentation name _ aliases' unions' values' generatedByVersion) =
  (,) (Text.pack (Module.nameToString name)) $ Module
    { adts =
        Map.fromList $ flip map unions' $ \union ->
            ( Docs.unionName union
            , (Docs.unionArgs union, Map.fromList (Docs.unionCases union))
            )

    , aliases =
        Map.fromList $ flip map aliases' $ \alias ->
            (Docs.aliasName alias, (Docs.aliasArgs alias, Docs.aliasType alias))

    , values =
        Map.fromList $ flip map values' $ \value ->
            (Docs.valueName value, Docs.valueType value)
    , version =
        generatedByVersion
    }


diffModule :: Module -> Module -> ModuleChanges
diffModule (Module adts aliases values version) (Module adts' aliases' values' version') =
  let
    ignoreOrigin =
      case (version, version') of
        (Docs.NonCanonicalTypes, _) -> True
        (_, Docs.NonCanonicalTypes) -> True
        (_, _) -> False
  in
    ModuleChanges
      (getChanges (isEquivalentAdt ignoreOrigin) adts adts')
      (getChanges (isEquivalentType ignoreOrigin) aliases aliases')
      (getChanges (\t t' -> isEquivalentType ignoreOrigin ([],t) ([],t')) values values')


getChanges :: (Ord k) => (v -> v -> Bool) -> Map.Map k v -> Map.Map k v -> Changes k v
getChanges isEquivalent old new =
  Changes
    { added =
        Map.difference new old
    , changed =
        Map.filter
            (not . uncurry isEquivalent)
            (Map.intersectionWith (,) old new)
    , removed =
        Map.difference old new
    }


isEquivalentAdt
    :: Bool
    -> ([Text], Map.Map Text [Type.Type])
    -> ([Text], Map.Map Text [Type.Type])
    -> Bool
isEquivalentAdt ignoreOrigin (oldVars, oldCtors) (newVars, newCtors) =
    Map.size oldCtors == Map.size newCtors
    && and (zipWith (==) (Map.keys oldCtors) (Map.keys newCtors))
    && and (Map.elems (Map.intersectionWith equiv oldCtors newCtors))
  where
    equiv :: [Type.Type] -> [Type.Type] -> Bool
    equiv oldTypes newTypes =
        let
          allEquivalent =
              zipWith
                (isEquivalentType ignoreOrigin)
                (map ((,) oldVars) oldTypes)
                (map ((,) newVars) newTypes)
        in
          length oldTypes == length newTypes
          && and allEquivalent


isEquivalentType :: Bool -> ([Text], Type.Type) -> ([Text], Type.Type) -> Bool
isEquivalentType ignoreOrigin (oldVars, oldType) (newVars, newType) =
  case diffType ignoreOrigin oldType newType of
    Nothing ->
        False

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



-- TYPES


diffType :: Bool -> Type.Type -> Type.Type -> Maybe [(Text,Text)]
diffType ignoreOrigin oldType newType =
  let
    go = diffType ignoreOrigin
  in
  case (oldType, newType) of
    (Type.Var oldName, Type.Var newName) ->
        Just [(oldName, newName)]

    (Type.Type oldName, Type.Type newName) ->
        let
          format =
            if ignoreOrigin then dropOrigin else id
        in
          if format oldName == format newName then
            Just []
          else
            Nothing

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

    (Type.App t ts, Type.App t' ts') ->
        if length ts /= length ts' then
          Nothing
        else
          (++)
            <$> go t t'
            <*> (concat <$> zipWithM go ts ts')

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

          (Just _, Nothing) ->
              Nothing

          (Nothing, Nothing) ->
              diffFields ignoreOrigin fields fields'

          (Just ext, Just ext') ->
              (++)
                <$> go ext ext'
                <*> diffFields ignoreOrigin fields fields'

    (_, _) ->
        Nothing


diffFields :: Bool -> [(Text, Type.Type)] -> [(Text, Type.Type)] -> Maybe [(Text,Text)]
diffFields ignoreOrigin rawFields rawFields'
    | length rawFields /= length rawFields' = Nothing
    | or (zipWith ((/=) `on` fst) fields fields') = Nothing
    | otherwise =
        concat <$> zipWithM (diffType ignoreOrigin `on` snd) fields fields'
    where
      fields  = sort rawFields
      fields' = sort rawFields'

      sort =
          List.sortBy (compare `on` fst)


dropOrigin :: Text -> Text
dropOrigin name =
    snd (Text.breakOnEnd "." name)



-- TYPE VARIABLES


isEquivalentRenaming :: [(Text,Text)] -> 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 compatableVars verifiedRenamings
        &&
        allUnique (map snd verifiedRenamings)


compatableVars :: (Text, Text) -> Bool
compatableVars (old, new) =
  case (categorizeVar old, categorizeVar new) of
    (CompAppend, CompAppend) -> True
    (Comparable, Comparable) -> True
    (Appendable, Appendable) -> True
    (Number    , Number    ) -> True

    (Comparable, CompAppend) -> True
    (Appendable, CompAppend) -> True
    (Number    , CompAppend) -> True
    (Number    , Comparable) -> True

    (_, Var) -> True

    (_, _) -> False


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


categorizeVar :: Text -> TypeVarCategory
categorizeVar name
    | Text.isPrefixOf "compappend" name = CompAppend
    | Text.isPrefixOf "comparable" name = Comparable
    | Text.isPrefixOf "appendable" name = Appendable
    | Text.isPrefixOf "number"     name = Number
    | otherwise                         = Var