{-# OPTIONS_GHC -fno-warn-deprecations #-}
{-# LANGUAGE TemplateHaskell   #-}

-- | This module deals with validating API changelogs and migrating
-- JSON data between different versions of a schema.
module Data.API.Changes
    ( migrateDataDump

      -- * Validating changelogs
    , validateChanges
    , dataMatchesAPI
    , DataChecks(..)

      -- * Changelog representation
    , APIChangelog(..)
    , APIWithChangelog
    , APIChange(..)
    , VersionExtra(..)
    , showVersionExtra
    , changelogStartVersion
    , changelogVersion

      -- * Custom migrations
    , CustomMigrations(..)
    , generateMigrationKinds
    , MigrationTag

      -- * API normal forms
    , NormAPI
    , NormTypeDecl(..)
    , NormRecordType
    , NormUnionType
    , NormEnumType
    , apiNormalForm
    , declNF

      -- * Migration errors
    , MigrateFailure(..)
    , MigrateWarning
    , ValidateFailure(..)
    , ValidateWarning
    , ApplyFailure(..)
    , TypeKind(..)
    , MergeResult(..)
    , ValueError(..)
    , prettyMigrateFailure
    , prettyValidateFailure
    , prettyValueError
    , prettyValueErrorPosition
    ) where

import           Data.API.JSON
import           Data.API.PP
import           Data.API.Types
import           Data.API.Utils

import           Control.Applicative
import           Control.Monad
import qualified Data.Aeson as JS
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Base64 as B64
import           Data.Map (Map)
import qualified Data.Map as Map
import           Data.Maybe
import           Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.HashMap.Strict as HMap
import qualified Data.Vector as V
import qualified Data.Text as T
import           Data.Version
import           Data.Time
import           Data.List
import           Language.Haskell.TH
import           Safe


-------------------------
-- Top level: do it all
--

-- | Migrate a dataset from one version of an API schema to another.
-- The data must be described by a named type, the name of which is
-- assumed not to change.
--
-- The @db@, @rec@ and @fld@ types must be enumerations of all the
-- custom migration tags in the changelog, as generated by
-- 'generateMigrationKind'.

migrateDataDump :: (Read db, Read rec, Read fld)
                => (API, Version)               -- ^ Starting schema and version
                -> (API, VersionExtra)          -- ^ Ending schema and version
                -> APIChangelog                 -- ^ Log of changes, containing both versions
                -> CustomMigrations db rec fld  -- ^ Custom migration functions
                -> TypeName                     -- ^ Name of the dataset's type
                -> DataChecks                   -- ^ How thoroughly to validate changes
                -> JS.Value                     -- ^ Dataset to be migrated
                -> Either MigrateFailure (JS.Value, [MigrateWarning])
migrateDataDump startApi endApi changelog custom root chks db = do
    let custom' = readCustomMigrations custom
    (changes, warnings) <- validateChanges' startApi endApi changelog custom' root chks
                                                           ?!? ValidateFailure
    db' <- applyChangesToDatabase root custom' db changes  ?!? uncurry ValueError
    return (db', warnings)

data MigrateFailure
    = ValidateFailure ValidateFailure
    | ValueError ValueError Position
    deriving (Eq, Show)

type MigrateWarning = ValidateWarning

------------------
-- The key types
--

type APIWithChangelog = (API, APIChangelog)

-- | An API changelog, consisting of a list of versions with the
-- changes from one version to the next.  The versions must be in
-- descending order (according to the 'Ord' 'Version' instance).
data APIChangelog =
     -- | The changes from the previous version up to this version.
     ChangesUpTo VersionExtra [APIChange] APIChangelog
     -- | The initial version
   | ChangesStart Version
    deriving (Eq, Show)

-- | A single change within a changelog
data APIChange
    = ChAddType       TypeName NormTypeDecl
    | ChDeleteType    TypeName
    | ChRenameType    TypeName TypeName

      -- Specific changes for record types
    | ChAddField      TypeName FieldName APIType (Maybe DefaultValue)
    | ChDeleteField   TypeName FieldName
    | ChRenameField   TypeName FieldName FieldName
    | ChChangeField   TypeName FieldName APIType MigrationTag

      -- Changes for union types
    | ChAddUnionAlt    TypeName FieldName APIType
    | ChDeleteUnionAlt TypeName FieldName
    | ChRenameUnionAlt TypeName FieldName FieldName

      -- Changes for enum types
    | ChAddEnumVal    TypeName FieldName
    | ChDeleteEnumVal TypeName FieldName
    | ChRenameEnumVal TypeName FieldName FieldName

      -- Custom value (not type) changes
    | ChCustomRecord  TypeName MigrationTag
    | ChCustomAll     MigrationTag
    deriving (Eq, Show)

-- | Within the changelog, custom migrations are represented as
-- strings, so we have less type-safety.
type MigrationTag = String

-- | Custom migrations used in the changelog must be implemented in
-- Haskell, and supplied in this record.  There are three kinds:
--
-- * Whole-database migrations, which may arbitrarily change the API
-- schema and the data to match;
--
-- * Record migrations, which may change the schema of a single
-- record; and
--
-- * Single field migrations, which may change only the type of the
-- field (with the new type specified in the changelog).
--
-- For database and record migrations, if the schema is unchanged, the
-- corresponding function should return 'Nothing'.
--
-- The @db@, @rec@ and @fld@ parameters should be instantiated with
-- the enumeration types generated by 'generateMigrationKinds', which
-- correspond to the exact set of custom migration tags used in the
-- changelog.
data CustomMigrations db rec fld = CustomMigrations
    { databaseMigration       :: db -> JS.Object -> Either ValueError JS.Object
    , databaseMigrationSchema :: db -> NormAPI -> Maybe NormAPI
    , recordMigration         :: rec -> JS.Object -> Either ValueError JS.Object
    , recordMigrationSchema   :: rec -> NormRecordType -> Maybe NormRecordType
    , fieldMigration          :: fld -> JS.Value -> Either ValueError JS.Value }

type CustomMigrationsTagged = CustomMigrations MigrationTag MigrationTag MigrationTag

readCustomMigrations :: (Read db, Read rec, Read fld)
                     => CustomMigrations db rec fld -> CustomMigrationsTagged
readCustomMigrations (CustomMigrations db dbs r rs f) =
    CustomMigrations (db . read) (dbs . read) (r . read) (rs . read) (f . read)


-- | When to validate the data against the schema (each level implies
-- the preceding levels):
data DataChecks = NoChecks         -- ^ Not at all
                | CheckStartAndEnd -- ^ At start and end of the migration
                | CheckCustom      -- ^ After custom migrations
                | CheckAll         -- ^ After every change
  deriving (Eq, Ord)

-- | Whether to validate the dataset after this change
validateAfter :: DataChecks -> APIChange -> Bool
validateAfter chks (ChChangeField{})  = chks >= CheckCustom
validateAfter chks (ChCustomRecord{}) = chks >= CheckCustom
validateAfter chks (ChCustomAll{})    = chks >= CheckCustom
validateAfter chks _                  = chks >= CheckAll


--------------------
-- Changelog utils
--

-- | Represents either a released version (with a version number) or
-- the version under development, which is newer than any release
data VersionExtra = Release Version
                  | DevVersion
  deriving (Eq, Ord, Show)

showVersionExtra :: VersionExtra -> String
showVersionExtra (Release v) = showVersion v
showVersionExtra DevVersion  = "development"

instance PP VersionExtra where
  pp = showVersionExtra


-- | The earliest version in the changelog
changelogStartVersion :: APIChangelog -> Version
changelogStartVersion (ChangesStart v) = v
changelogStartVersion (ChangesUpTo _ _ clog) = changelogStartVersion clog

-- | The latest version in the changelog
changelogVersion :: APIChangelog -> VersionExtra
changelogVersion (ChangesStart v)     = Release v
changelogVersion (ChangesUpTo  v _ _) = v

-- | Changelog in order starting from oldest version up to newest.
-- Entries are @(from, to, changes-oldest-first)@.
viewChangelogReverse :: APIChangelog -> [(VersionExtra, VersionExtra, [APIChange])]
viewChangelogReverse clog =
  reverse [ (v,v',reverse cs) | (v',v,cs) <- viewChangelog clog ]

-- | Changelog in order as written, with latest version at the beginning, going
-- back to older versions. Entries are @(to, from, changes-latest-first)@.
viewChangelog :: APIChangelog -> [(VersionExtra, VersionExtra, [APIChange])]
viewChangelog (ChangesStart _)          = []
viewChangelog (ChangesUpTo v' cs older) = (v', v, cs) : viewChangelog older
                                           where v = changelogVersion older

-- | Is the changelog in the correct order? If not, return a pair of
-- out-of-order versions.
isChangelogOrdered :: APIChangelog -> Either (VersionExtra, VersionExtra) ()
isChangelogOrdered changelog =
    case find (\ (v', v, _) -> v' <= v) (viewChangelog changelog) of
      Nothing         -> return ()
      Just (v', v, _) -> Left (v', v)


-- | Sets of custom migration tags in the changelog for
-- whole-database, single-record and single-field migrations
changelogTags :: APIChangelog -> (Set MigrationTag, Set MigrationTag, Set MigrationTag)
changelogTags (ChangesStart _) = (Set.empty, Set.empty, Set.empty)
changelogTags (ChangesUpTo _ cs older) =
    unions3 (map changeTags cs) `union3` changelogTags older
  where
    union3 (a, b, c) (x, y, z) = (a `Set.union` x, b `Set.union` y, c `Set.union` z)
    unions3 xyzs = (Set.unions xs, Set.unions ys, Set.unions zs)
      where (xs, ys, zs) = unzip3 xyzs

-- | Sets of custom migration tags in a single change
changeTags :: APIChange -> (Set MigrationTag, Set MigrationTag, Set MigrationTag)
changeTags (ChChangeField _ _ _ t) = (Set.empty, Set.empty, Set.singleton t)
changeTags (ChCustomRecord _ t)    = (Set.empty, Set.singleton t, Set.empty)
changeTags (ChCustomAll t)         = (Set.singleton t, Set.empty, Set.empty)
changeTags _                       = (Set.empty, Set.empty, Set.empty)


------------------------------------------
-- Comparing APIs: canonical/normal form
--

-- | The API type has too much extra info for us to be able to simply compare
-- them with @(==)@. Our strategy is to strip out ancillary information and
-- normalise into a canonical form, and then we can use a simple @(==)@ compare.
--
-- Our normalised API discards most of the details of each type, keeping
-- just essential information about each type. We discard order of types and
-- fields, so we can use just associative maps.
--
type NormAPI = Map TypeName NormTypeDecl

-- | The normal or canonical form for a type declaration, an 'APINode'.
-- Equality of the normal form indicates equivalence of APIs.
--
-- We track all types.
--
data NormTypeDecl
    = NRecordType  NormRecordType
    | NUnionType   NormUnionType
    | NEnumType    NormEnumType
    | NTypeSynonym APIType
    | NNewtype     BasicType
  deriving (Eq, Show)

-- | The canonical form of a record type is a map from fields to
-- values; similarly a union is a map from fields to alternatives and
-- an enum is a set of values.
type NormRecordType = Map FieldName APIType
type NormUnionType  = Map FieldName APIType
type NormEnumType   = Set FieldName


-- | Compute the normal form of an API, discarding extraneous information.
apiNormalForm :: API -> NormAPI
apiNormalForm api =
    Map.fromList
      [ (name, declNF spec)
      | ThNode (APINode {anName = name, anSpec = spec}) <- api ]

-- | Compute the normal form of a single type declaration.
declNF :: Spec -> NormTypeDecl
declNF (SpRecord (SpecRecord fields)) = NRecordType $ Map.fromList
                                          [ (fname, ftType ftype)
                                          | (fname, ftype) <- fields ]
declNF (SpUnion (SpecUnion alts))     = NUnionType $ Map.fromList
                                          [ (fname, ftype)
                                          | (fname, (ftype, _)) <- alts ]
declNF (SpEnum (SpecEnum elems))      = NEnumType $ Set.fromList
                                          [ fname | (fname, _) <- elems ]
declNF (SpSynonym t)                  = NTypeSynonym t
declNF (SpNewtype (SpecNewtype bt _)) = NNewtype bt


-------------------------
-- Type decl/expr utils
--

typeDelcsFreeVars :: NormAPI -> Set TypeName
typeDelcsFreeVars = Set.unions . map typeDelcFreeVars . Map.elems

typeDelcFreeVars :: NormTypeDecl -> Set TypeName
typeDelcFreeVars (NRecordType fields) = Set.unions . map typeFreeVars
                                                   . Map.elems $ fields
typeDelcFreeVars (NUnionType  alts)   = Set.unions . map typeFreeVars
                                                   . Map.elems $ alts
typeDelcFreeVars (NEnumType _)        = Set.empty
typeDelcFreeVars (NTypeSynonym t)     = typeFreeVars t
typeDelcFreeVars (NNewtype _)         = Set.empty

typeFreeVars :: APIType -> Set TypeName
typeFreeVars (TyList  t) = typeFreeVars t
typeFreeVars (TyMaybe t) = typeFreeVars t
typeFreeVars (TyName  n) = Set.singleton n
typeFreeVars (TyBasic _) = Set.empty
typeFreeVars  TyJSON     = Set.empty

mapTypeDeclFreeVars :: (TypeName -> APIType) -> NormTypeDecl -> NormTypeDecl
mapTypeDeclFreeVars f   (NRecordType fields) = NRecordType (Map.map (mapTypeFreeVars f) fields)
mapTypeDeclFreeVars f   (NUnionType  alts)   = NUnionType (Map.map (mapTypeFreeVars f) alts)
mapTypeDeclFreeVars _ d@(NEnumType _)        = d
mapTypeDeclFreeVars f   (NTypeSynonym t)     = NTypeSynonym (mapTypeFreeVars f t)
mapTypeDeclFreeVars _ d@(NNewtype _)         = d

mapTypeFreeVars :: (TypeName -> APIType) -> APIType -> APIType
mapTypeFreeVars f (TyList  t)   = TyList (mapTypeFreeVars f t)
mapTypeFreeVars f (TyMaybe t)   = TyMaybe (mapTypeFreeVars f t)
mapTypeFreeVars f (TyName  n)   = f n
mapTypeFreeVars _ t@(TyBasic _) = t
mapTypeFreeVars _ t@TyJSON      = t


typeDeclaredInApi :: TypeName -> NormAPI -> Bool
typeDeclaredInApi tname api = Map.member tname api

-- | Check if a type is used anywhere in the API
typeUsedInApi :: TypeName -> NormAPI -> Bool
typeUsedInApi tname api = tname `Set.member` typeDelcsFreeVars api

-- | Check if a type is used anywhere in the database (possibly in a
-- transitive dependency of the root).
typeUsedInApiTable :: TypeName -> TypeName -> NormAPI -> Bool
typeUsedInApiTable root tname api =
    tname == root || tname `Set.member` transitiveDeps api (Set.singleton root)

-- | Compute the transitive dependencies of a set of types
transitiveDeps :: NormAPI -> Set TypeName -> Set TypeName
transitiveDeps api = transitiveClosure $ \ s ->
                         typeDelcsFreeVars $
                         Map.filterWithKey (\ x _ -> x `Set.member` s) api

-- | Compute the set of types that depend (transitively) on the given types
transitiveSped :: NormAPI -> Set TypeName -> Set TypeName
transitiveSped api = transitiveClosure $ \ s ->
                         Map.keysSet $
                         Map.filter (intersects s . typeDelcFreeVars) api
  where
    intersects s1 s2 = not $ Set.null $ s1 `Set.intersection` s2

-- | Compute the transitive closure of a relation.  Relations are
-- represented as functions that takes a set of elements to the set of
-- related elements.
transitiveClosure :: Ord a => (Set a -> Set a) -> Set a -> Set a
transitiveClosure rel x = findUsed x0 x0
  where
    x0 = rel x

    findUsed seen old
      | Set.null new = seen
      | otherwise    = findUsed (seen `Set.union` new) new
      where
        new = rel old `Set.difference` seen

renameTypeUses :: TypeName -> TypeName -> NormAPI -> NormAPI
renameTypeUses tname tname' = Map.map (mapTypeDeclFreeVars rename)
  where
    rename tn | tn == tname = TyName tname'
              | otherwise   = TyName tn

typeIsValid :: APIType -> NormAPI -> Either (Set TypeName) ()
typeIsValid t api
    | typeVars `Set.isSubsetOf` declaredTypes = return ()
    | otherwise = Left (typeVars Set.\\ declaredTypes)
  where
    typeVars      = typeFreeVars t
    declaredTypes = Map.keysSet api

declIsValid :: NormTypeDecl -> NormAPI -> Either (Set TypeName) ()
declIsValid decl api
    | declVars `Set.isSubsetOf` declaredTypes = return ()
    | otherwise = Left (declVars Set.\\ declaredTypes)
  where
    declVars      = typeDelcFreeVars decl
    declaredTypes = Map.keysSet api

apiInvariant :: NormAPI -> Either (Set TypeName) ()
apiInvariant api
  | usedTypes `Set.isSubsetOf` declaredTypes = return ()
  | otherwise = Left (usedTypes Set.\\ declaredTypes)
  where
    usedTypes     = typeDelcsFreeVars api
    declaredTypes = Map.keysSet api


--------------------------------
-- Representing update positions
--

-- | Represents the positions in a declaration to apply an update
data UpdateDeclPos
    = UpdateHere   (Maybe UpdateDeclPos)
    | UpdateRecord (Map FieldName (Maybe UpdateTypePos))
    | UpdateUnion  (Map FieldName (Maybe UpdateTypePos))
    | UpdateType   UpdateTypePos
    deriving (Eq, Show)

-- | Represents the positions in a type to apply an update
data UpdateTypePos
    = UpdateList UpdateTypePos
    | UpdateMaybe UpdateTypePos
    | UpdateNamed TypeName
    deriving (Eq, Show)

data APITableChange
      -- | The pair of an APIChange and the positions in which to apply it
    = APIChange APIChange (Map TypeName UpdateDeclPos)
      -- | Request to validate the dataset against the given API
    | ValidateData NormAPI
    deriving (Eq, Show)

-- | Given a type to be modified, find the positions in which each
-- type in the API must be updated
findUpdatePos :: TypeName -> NormAPI -> Map TypeName UpdateDeclPos
findUpdatePos tname api = Map.alter (Just . UpdateHere) tname $
                          Map.fromSet findDecl deps
  where
    -- The set of types that depend on the type being updated
    deps :: Set TypeName
    deps = transitiveSped api (Set.singleton tname)

    findDecl :: TypeName -> UpdateDeclPos
    findDecl tname' = findDecl' $
                      fromMaybe (error "findUpdatePos: missing type") $
                      Map.lookup tname' api

    findDecl' :: NormTypeDecl -> UpdateDeclPos
    findDecl' (NRecordType flds) = UpdateRecord $ fmap findType flds
    findDecl' (NUnionType alts)  = UpdateUnion  $ fmap findType alts
    findDecl' (NEnumType _)      = error "findDecl': unexpected enum"
    findDecl' (NTypeSynonym ty)  = UpdateType $ fromMaybe (error "findDecl': missing") $
                                                findType ty
    findDecl' (NNewtype _)       = error "findDecl': unexpected newtype"

    findType :: APIType -> Maybe UpdateTypePos
    findType (TyList ty)      = UpdateList <$> findType ty
    findType (TyMaybe ty)     = UpdateMaybe <$> findType ty
    findType (TyName tname')
        | tname' == tname || tname' `Set.member` deps = Just $ UpdateNamed tname'
        | otherwise                                   = Nothing
    findType (TyBasic _)      = Nothing
    findType TyJSON           = Nothing


---------------------------
-- Validating API changes
--

-- | Errors that may be discovered when validating a changelog
data ValidateFailure
        -- | the changelog must be in descending order of versions
    = ChangelogOutOfOrder { vfLaterVersion   :: VersionExtra
                          , vfEarlierVersion :: VersionExtra }
        -- | forbid migrating from one version to an earlier version
    | CannotDowngrade { vfFromVersion :: VersionExtra
                      , vfToVersion   :: VersionExtra }
        -- | an API uses types that are not declared
    | ApiInvalid { vfInvalidVersion      :: VersionExtra
                 , vfMissingDeclarations :: Set TypeName }
        -- | changelog entry does not apply
    | ChangelogEntryInvalid { vfSuccessfullyApplied :: [APITableChange]
                            , vfFailedToApply       :: APIChange
                            , vfApplyFailure        :: ApplyFailure }
        -- | changelog is incomplete
        --   (ie all entries apply ok but result isn't the target api)
    | ChangelogIncomplete { vfChangelogVersion :: VersionExtra
                          , vfTargetVersion    :: VersionExtra
                          , vfDifferences      :: Map TypeName (MergeResult NormTypeDecl NormTypeDecl) }
  deriving (Eq, Show)

data ValidateWarning = ValidateWarning -- add warnings about bits we cannot check (opaque custom)
  deriving Show

-- | Errors that may occur applying a single API change
data ApplyFailure
    = TypeExists           { afExistingType  :: TypeName }     -- ^ for adding or renaming type
    | TypeDoesNotExist     { afMissingType   :: TypeName }     -- ^ for deleting or renaming a type
    | TypeWrongKind        { afTypeName      :: TypeName
                           , afExpectedKind  :: TypeKind }     -- ^ e.g. it's not a record type
    | TypeInUse            { afTypeName      :: TypeName }     -- ^ cannot delete/modify types that are still used
    | TypeMalformed        { afType          :: APIType
                           , afMissingTypes  :: Set TypeName } -- ^ type refers to a non-existent type
    | DeclMalformed        { afTypeName      :: TypeName
                           , afDecl          :: NormTypeDecl
                           , afMissingTypes  :: Set TypeName } -- ^ decl refers to a non-existent type
    | FieldExists          { afTypeName      :: TypeName
                           , afTypeKind      :: TypeKind
                           , afExistingField :: FieldName }    -- ^ for adding or renaming a field
    | FieldDoesNotExist    { afTypeName      :: TypeName
                           , afTypeKind      :: TypeKind
                           , afMissingField  :: FieldName }    -- ^ for deleting or renaming a field
    | FieldBadDefaultValue { afTypeName      :: TypeName
                           , afFieldName     :: FieldName
                           , afFieldType     :: APIType
                           , afBadDefault    :: DefaultValue } -- ^ for adding a field, must be a default
                                                               --   value compatible with the type
    | DefaultMissing       { afTypeName      :: TypeName
                           , afFieldName     :: FieldName }    -- ^ for adding a field to a table
    | TableChangeError     { afCustomMessage :: String }       -- ^ custom error in tableChange
  deriving (Eq, Show)

data TypeKind = TKRecord | TKUnion | TKEnum
  deriving (Eq, Show)


-- | Check that a changelog adequately describes how to migrate from
-- one version to another.
validateChanges :: (Read db, Read rec, Read fld)
                => (API, Version)              -- ^ Starting schema and version
                -> (API, VersionExtra)         -- ^ Ending schema and version
                -> APIChangelog                -- ^ Changelog to be validated
                -> CustomMigrations db rec fld -- ^ Custom migration functions
                -> TypeName                    -- ^ Name of the dataset's type
                -> DataChecks                  -- ^ How thoroughly to validate changes
                -> Either ValidateFailure [ValidateWarning]
validateChanges (api,ver) (api',ver') clog custom root chks = snd <$>
  validateChanges' (api,ver) (api',ver') clog (readCustomMigrations custom) root chks

-- | Internal version of 'validateChanges', which works on unsafe
-- migration tags and returns the list of 'APITableChange's to apply
-- to the dataset.
validateChanges' :: (API, Version)         -- ^ Starting schema and version
                 -> (API, VersionExtra)    -- ^ Ending schema and version
                 -> APIChangelog           -- ^ Changelog to be validated
                 -> CustomMigrationsTagged -- ^ Custom migration functions
                 -> TypeName               -- ^ Name of the dataset's type
                 -> DataChecks             -- ^ How thoroughly to validate changes
                 -> Either ValidateFailure ([APITableChange], [ValidateWarning])
validateChanges' (api,ver) (api',ver') clog custom root chks = do
  -- select changes by version from log
  (changes, verEnd) <- selectChanges clog (Release ver) ver'
  -- take norm of start and end api,
  let apiStart  = apiNormalForm api
      apiTarget = apiNormalForm api'
  -- check start and end APIs are well formed.
  apiInvariant apiStart  ?!? ApiInvalid (Release ver)
  apiInvariant apiTarget ?!? ApiInvalid ver'
   -- check expected end api
  (apiEnd, changes') <- applyAPIChangesToAPI root custom chks changes apiStart
  -- check expected end api
  guard (apiEnd == apiTarget) ?! ChangelogIncomplete verEnd ver' (diffMaps apiEnd apiTarget)
  return (changes', [])

selectChanges :: APIChangelog -> VersionExtra -> VersionExtra
              -> Either ValidateFailure ([APIChange], VersionExtra)
selectChanges clog ver ver'
  | ver' == ver = return ([], ver')
  | ver' >  ver = do
      isChangelogOrdered clog ?!? uncurry ChangelogOutOfOrder
      let withinRange = takeWhile (\ (_, v, _) -> v <= ver') $
                            dropWhile (\ (_, v, _) -> v <= ver) $
                                viewChangelogReverse clog
          endVer = case lastMay withinRange of
                     Nothing        -> ver
                     Just (_, v, _) -> v
      return ([ c | (_,_, cs) <- withinRange, c <- cs ], endVer)

  | otherwise = Left (CannotDowngrade ver ver')

-- | Apply a list of changes to an API, returning the updated API and
-- a list of the changes with appropriate TableChanges interspersed.
-- On failure, return the list of successfully applied changes, the
-- change that failed and the reason for the failure.
applyAPIChangesToAPI :: TypeName -> CustomMigrationsTagged -> DataChecks
                     -> [APIChange] -> NormAPI
                     -> Either ValidateFailure (NormAPI, [APITableChange])
applyAPIChangesToAPI root custom chks changes api = do
    (api', changes') <- foldM (doChangeAPI root custom chks) (api, []) changes
    let changes'' | chks >= CheckStartAndEnd = addV api $ reverse $ addV api' changes'
                  | otherwise                = reverse changes'
    return (api', changes'')
  where
    addV _ cs@(ValidateData _ : _) = cs
    addV a cs                      = ValidateData a : cs

-- | Apply the API change
doChangeAPI :: TypeName -> CustomMigrationsTagged -> DataChecks
            -> (NormAPI, [APITableChange]) -> APIChange
            -> Either ValidateFailure (NormAPI, [APITableChange])
doChangeAPI root custom chks (api, changes) change = do
    (api', pos) <- applyAPIChangeToAPI root custom change api
                       ?!? ChangelogEntryInvalid changes change
    let changes' = APIChange change pos : changes
        changes'' | validateAfter chks change = ValidateData api' : changes'
                  | otherwise                 = changes'
    return (api', changes'')

-- Checks and and performs an API change. If it works then we get back the new
-- overall api. This is used for two purposes, (1) validating that we can apply
-- each change in that context, and that we end up with the API we expect
-- and (2) getting the intermediate APIs during data migration, because we need
-- the schema of the intermediate data as part of applying the migration.
applyAPIChangeToAPI :: TypeName -> CustomMigrationsTagged -> APIChange -> NormAPI
                    -> Either ApplyFailure (NormAPI, Map TypeName UpdateDeclPos)

applyAPIChangeToAPI _ _ (ChAddType tname tdecl) api = do
  -- to add a new type, that type must not yet exist
  guard (not (tname `typeDeclaredInApi` api))   ?! TypeExists tname
  declIsValid tdecl api                         ?!? DeclMalformed tname tdecl
  return (Map.insert tname tdecl api, Map.empty)

applyAPIChangeToAPI _ _ (ChDeleteType tname) api = do
  -- to delete a type, that type must exist
  guard (tname `typeDeclaredInApi` api)         ?! TypeDoesNotExist tname
  -- it must also not be used anywhere else in the API
  guard (not (tname `typeUsedInApi` api))       ?! TypeInUse tname
  return (Map.delete tname api, Map.empty)

applyAPIChangeToAPI _ _ (ChRenameType tname tname') api = do
  -- to rename a type, the original type name must exist
  -- and the new one must not yet exist
  tinfo <- lookupType tname api
  guard (not (tname' `typeDeclaredInApi` api))  ?! TypeExists tname'
  return ( (renameTypeUses tname tname'
            . Map.insert tname' tinfo . Map.delete tname) api
         , Map.empty )

applyAPIChangeToAPI _ custom (ChCustomRecord tname tag) api = do
  -- to make some change to values of a type, the type name must exist
  tinfo   <- lookupType tname api
  recinfo <- expectRecordType tinfo               ?! TypeWrongKind tname TKRecord
  let api' = case recordMigrationSchema custom tag recinfo of
                 Just recinfo' -> Map.insert tname (NRecordType recinfo') api
                 Nothing       -> api
  return (api', findUpdatePos tname api)

applyAPIChangeToAPI root _ (ChAddField tname fname ftype mb_defval) api = do
  tinfo   <- lookupType tname api
  recinfo <- expectRecordType tinfo                ?! TypeWrongKind tname TKRecord
  guard (not (Map.member fname recinfo))           ?! FieldExists tname TKRecord fname
  typeIsValid ftype api                            ?!? TypeMalformed ftype
  case mb_defval <|> defaultValueForType ftype of
    Just defval -> guard (compatibleDefaultValue api ftype defval)
                                                   ?! FieldBadDefaultValue tname fname ftype defval
    Nothing     -> guard (not (typeUsedInApiTable root tname api))
                                                   ?! DefaultMissing tname fname
  let tinfo' = NRecordType (Map.insert fname ftype recinfo)
  return (Map.insert tname tinfo' api, findUpdatePos tname api)

applyAPIChangeToAPI _ _ (ChDeleteField tname fname) api = do
  tinfo   <- lookupType tname api
  recinfo <- expectRecordType tinfo        ?! TypeWrongKind tname TKRecord
  guard (Map.member fname recinfo)         ?! FieldDoesNotExist tname TKRecord fname
  let tinfo' = NRecordType (Map.delete fname recinfo)
  return (Map.insert tname tinfo' api, findUpdatePos tname api)

applyAPIChangeToAPI _ _ (ChRenameField tname fname fname') api = do
  tinfo   <- lookupType tname api
  recinfo <- expectRecordType tinfo        ?! TypeWrongKind tname TKRecord
  ftype   <- Map.lookup fname recinfo      ?! FieldDoesNotExist tname TKRecord fname
  guard (not (Map.member fname' recinfo))  ?! FieldExists tname TKRecord fname'
  let tinfo' = (NRecordType . Map.insert fname' ftype
                            . Map.delete fname) recinfo
  return (Map.insert tname tinfo' api, findUpdatePos tname api)

applyAPIChangeToAPI _ _ (ChChangeField tname fname ftype _) api = do
  tinfo   <- lookupType tname api
  recinfo <- expectRecordType tinfo        ?! TypeWrongKind tname TKRecord
  guard (Map.member fname recinfo)         ?! FieldDoesNotExist tname TKRecord fname
  let tinfo' = (NRecordType . Map.insert fname ftype) recinfo
  return (Map.insert tname tinfo' api, findUpdatePos tname api)

applyAPIChangeToAPI _ _ (ChAddUnionAlt tname fname ftype) api = do
  tinfo     <- lookupType tname api
  unioninfo <- expectUnionType tinfo               ?! TypeWrongKind tname TKUnion
  guard (not (Map.member fname unioninfo))         ?! FieldExists tname TKUnion fname
  typeIsValid ftype api                            ?!? TypeMalformed ftype
  let tinfo' = NUnionType (Map.insert fname ftype unioninfo)
  return (Map.insert tname tinfo' api, Map.empty)

applyAPIChangeToAPI root _ (ChDeleteUnionAlt tname fname) api = do
  tinfo     <- lookupType tname api
  unioninfo <- expectUnionType tinfo         ?! TypeWrongKind tname TKUnion
  guard (not (typeUsedInApiTable root tname api)) ?! TypeInUse tname
  guard (Map.member fname unioninfo)         ?! FieldDoesNotExist tname TKUnion fname
  let tinfo' = NUnionType (Map.delete fname unioninfo)
  return (Map.insert tname tinfo' api, Map.empty)

applyAPIChangeToAPI _ _ (ChRenameUnionAlt tname fname fname') api = do
  tinfo     <- lookupType tname api
  unioninfo <- expectUnionType tinfo        ?! TypeWrongKind tname TKUnion
  ftype     <- Map.lookup fname unioninfo   ?! FieldDoesNotExist tname TKUnion fname
  guard (not (Map.member fname' unioninfo)) ?! FieldExists tname TKUnion fname'
  let tinfo' = (NUnionType . Map.insert fname' ftype
                           . Map.delete fname) unioninfo
  return (Map.insert tname tinfo' api, findUpdatePos tname api)

applyAPIChangeToAPI _ _ (ChAddEnumVal tname fname) api = do
  tinfo    <- lookupType tname api
  enuminfo <- expectEnumType tinfo                 ?! TypeWrongKind tname TKEnum
  guard (not (Set.member fname enuminfo))          ?! FieldExists tname TKEnum fname
  let tinfo' = NEnumType (Set.insert fname enuminfo)
  return (Map.insert tname tinfo' api, Map.empty)

applyAPIChangeToAPI root _ (ChDeleteEnumVal tname fname) api = do
  tinfo    <- lookupType tname api
  enuminfo <- expectEnumType tinfo          ?! TypeWrongKind tname TKEnum
  guard (not (typeUsedInApiTable root tname api)) ?! TypeInUse tname
  guard (Set.member fname enuminfo)         ?! FieldDoesNotExist tname TKEnum fname
  let tinfo' = NEnumType (Set.delete fname enuminfo)
  return (Map.insert tname tinfo' api, Map.empty)

applyAPIChangeToAPI _ _ (ChRenameEnumVal tname fname fname') api = do
  tinfo     <- lookupType tname api
  enuminfo <- expectEnumType tinfo         ?! TypeWrongKind tname TKEnum
  guard (Set.member fname enuminfo)        ?! FieldDoesNotExist tname TKEnum fname
  guard (not (Set.member fname' enuminfo)) ?! FieldExists tname TKEnum fname'
  let tinfo' = (NEnumType . Set.insert fname'
                          . Set.delete fname) enuminfo
  return (Map.insert tname tinfo' api, findUpdatePos tname api)

applyAPIChangeToAPI root custom (ChCustomAll tag) api =
  return ( fromMaybe api (databaseMigrationSchema custom tag api)
         , Map.singleton root (UpdateHere Nothing))


lookupType :: TypeName -> NormAPI -> Either ApplyFailure NormTypeDecl
lookupType tname api = Map.lookup tname api ?! TypeDoesNotExist tname

expectRecordType :: NormTypeDecl -> Maybe (Map FieldName APIType)
expectRecordType (NRecordType rinfo) = Just rinfo
expectRecordType _                   = Nothing

expectUnionType :: NormTypeDecl -> Maybe (Map FieldName APIType)
expectUnionType (NUnionType rinfo) = Just rinfo
expectUnionType _                  = Nothing

expectEnumType :: NormTypeDecl -> Maybe (Set FieldName)
expectEnumType (NEnumType rinfo) = Just rinfo
expectEnumType _                 = Nothing


-----------------------------------
-- Performing data transformation
--

-- | This is the low level one that just does the changes.
--
-- We assume the changes have already been validated, and that the data
-- matches the API.
--
applyChangesToDatabase :: TypeName -> CustomMigrationsTagged
                       -> JS.Value -> [APITableChange]
                       -> Either (ValueError, Position) JS.Value
applyChangesToDatabase root custom = foldM (applyChangeToDatabase root custom)
  -- just apply each of the individual changes in sequence to the whole dataset

applyChangeToDatabase :: TypeName -> CustomMigrationsTagged
                      -> JS.Value -> APITableChange
                      -> Either (ValueError, Position) JS.Value
applyChangeToDatabase root custom v (APIChange c upds) =
    updateTypeAt upds (applyChangeToData c custom) (UpdateNamed root) v []
applyChangeToDatabase root _      v (ValidateData api) = do
    dataMatchesNormAPI root api v
    return v


-- | Apply an update at the given position in a declaration's value
updateDeclAt :: Map TypeName UpdateDeclPos
             -> (JS.Value -> Position -> Either (ValueError, Position) JS.Value)
             -> UpdateDeclPos
             -> JS.Value -> Position -> Either (ValueError, Position) JS.Value
updateDeclAt _    alter (UpdateHere Nothing)    v p = alter v p
updateDeclAt upds alter (UpdateHere (Just upd)) v p = flip alter p =<< updateDeclAt upds alter upd v p
updateDeclAt upds alter (UpdateRecord upd_flds) v p = withObjectMatchingFields upd_flds
                                                        (maybe (pure . pure) (updateTypeAt upds alter)) v p
updateDeclAt upds alter (UpdateUnion upd_alts)  v p = withObjectMatchingUnion upd_alts
                                                        (maybe (pure . pure) (updateTypeAt upds alter)) v p
updateDeclAt upds alter (UpdateType upd)        v p = updateTypeAt upds alter upd v p

-- | Apply an upate at the given position in a type's value
updateTypeAt :: Map TypeName UpdateDeclPos
             -> (JS.Value -> Position -> Either (ValueError, Position) JS.Value)
             -> UpdateTypePos
             -> JS.Value -> Position -> Either (ValueError, Position) JS.Value
updateTypeAt upds alter (UpdateList upd)    v p = withArrayElems (updateTypeAt upds alter upd) v p
updateTypeAt upds alter (UpdateMaybe upd)   v p = withMaybe (updateTypeAt upds alter upd) v p
updateTypeAt upds alter (UpdateNamed tname) v p = case Map.lookup tname upds of
    Just upd -> updateDeclAt upds alter upd v p
    Nothing  -> pure v


-- | This actually applies the change to the data value, assuming it
-- is already in the correct place
applyChangeToData :: APIChange -> CustomMigrationsTagged
                  -> JS.Value -> Position -> Either (ValueError, Position) JS.Value

applyChangeToData (ChAddField tname fname ftype mb_defval) _ =
  case mb_defval <|> defaultValueForType ftype of
    Just defval -> let newFieldValue = defaultValueAsJsValue defval
                   in withObject (\ v _ -> pure $ HMap.insert (fieldKey fname) newFieldValue v)
    Nothing     -> \ _ p -> Left (InvalidAPI (DefaultMissing tname fname), p)

applyChangeToData (ChDeleteField _ fname) _ =
    withObject (\ v _ -> pure $ HMap.delete (fieldKey fname) v)

applyChangeToData (ChRenameField _ fname fname') _ =
    withObject $ \rec p -> case HMap.lookup k_fname rec of
                           Just field -> renameField field rec
                           Nothing    -> Left (JSONError MissingField, InField k_fname : p)
  where
    k_fname       = fieldKey fname
    k_fname'      = fieldKey fname'
    renameField x = pure . HMap.insert k_fname' x . HMap.delete k_fname

applyChangeToData (ChChangeField _ fname _ftype tag) custom =
    withObjectField (fieldKey fname) (liftMigration $ fieldMigration custom tag)

applyChangeToData (ChRenameUnionAlt _ fname fname') _ = withObject $ \un p ->
    case HMap.toList un of
        [(k, r)] | k == fieldKey fname -> return $ HMap.singleton (fieldKey fname') r
                 | otherwise           -> return un
        _ -> Left (JSONError $ SyntaxError "Not singleton", p)

applyChangeToData (ChRenameEnumVal _ fname fname') _ = withString $ \s _ ->
    if s == fieldKey fname then return (fieldKey fname')
                           else return s

applyChangeToData (ChCustomRecord _ tag) custom = withObject (liftMigration $ recordMigration custom tag)
applyChangeToData (ChCustomAll tag)      custom = withObject (liftMigration $ databaseMigration custom tag)

applyChangeToData (ChAddType _ _)        _ = pure . pure
applyChangeToData (ChDeleteType _)       _ = pure . pure
applyChangeToData (ChRenameType _ _)     _ = pure . pure
applyChangeToData (ChAddUnionAlt _ _ _)  _ = pure . pure
applyChangeToData (ChDeleteUnionAlt _ _) _ = pure . pure
applyChangeToData (ChAddEnumVal _ _)     _ = pure . pure
applyChangeToData (ChDeleteEnumVal _ _)  _ = pure . pure


liftMigration :: (a -> Either ValueError b)
                 -> (a -> Position -> Either (ValueError, Position) b)
liftMigration f v p = f v ?!? flip (,) p

-------------------------------------
-- Utils for manipulating JS.Values
--

-- | Errors that can be discovered when migrating data values
data ValueError
    = JSONError JSONError                  -- ^ Data doesn't match schema
    | CustomMigrationError String JS.Value -- ^ Error generated during custom migration
    | InvalidAPI ApplyFailure              -- ^ An API change was invalid
    deriving (Eq, Show)

withObject :: (JS.Object -> Position -> Either (ValueError, Position) JS.Object)
           -> JS.Value -> Position -> Either (ValueError, Position) JS.Value
withObject alter (JS.Object obj) p = JS.Object <$> alter obj p
withObject _     v               p = Left (JSONError $ expectedObject v, p)

withObjectField :: T.Text -> (JS.Value -> Position -> Either (ValueError, Position) JS.Value)
                -> JS.Value -> Position -> Either (ValueError, Position) JS.Value
withObjectField field alter (JS.Object obj) p =
    case HMap.lookup field obj of
      Nothing     -> Left (JSONError MissingField, InField field : p)
      Just fvalue -> JS.Object <$> (HMap.insert field
                                       <$> (alter fvalue (InField field : p))
                                       <*> pure obj)
withObjectField _ _ v p = Left (JSONError $ expectedObject v, p)

withObjectMatchingFields :: Map FieldName a
                         -> (a -> JS.Value -> Position -> Either (ValueError, Position) JS.Value)
                         -> JS.Value -> Position -> Either (ValueError, Position) JS.Value
withObjectMatchingFields m f (JS.Object obj) p = do
    zs <- matchMaps (Map.mapKeys fieldKey m) (hmapToMap obj) ?!? toErr
    obj' <- Map.traverseWithKey (\ k (ty, val) -> (f ty val (InField k : p))) zs
    return $ JS.Object $ mapToHMap obj'
  where
    toErr (k, Left _)  = (JSONError MissingField, InField k : p)
    toErr (k, Right _) = (JSONError UnexpectedField, InField k : p)

    hmapToMap = Map.fromList . HMap.toList

    mapToHMap = HMap.fromList . Map.toList

withObjectMatchingFields _ _ v p = Left (JSONError $ expectedObject v, p)

withObjectMatchingUnion :: Map FieldName a
                         -> (a -> JS.Value -> Position -> Either (ValueError, Position) JS.Value)
                         -> JS.Value -> Position -> Either (ValueError, Position) JS.Value
withObjectMatchingUnion m f (JS.Object obj) p
  | [(k, r)] <- HMap.toList obj
  = do x  <- Map.lookup (fromFieldKey k) m ?! (JSONError UnexpectedField, InField k : p)
       r' <- f x r (InField k : p)
       return $ JS.Object $ HMap.singleton k r'
withObjectMatchingUnion _ _ _ p = Left (JSONError $ SyntaxError "Not singleton", p)

withArrayElems :: (JS.Value -> Position -> Either (ValueError, Position) JS.Value)
               -> JS.Value -> Position -> Either (ValueError, Position) JS.Value
withArrayElems alter (JS.Array arr) p = JS.Array <$> V.mapM alterAt (V.indexed arr)
  where
    alterAt (i, v) = alter v (InElem i : p)
withArrayElems _     v              p = Left (JSONError $ expectedArray v, p)

withMaybe :: (JS.Value -> Position -> Either (ValueError, Position) JS.Value)
          -> JS.Value -> Position -> Either (ValueError, Position) JS.Value
withMaybe _ JS.Null _ = return JS.Null
withMaybe f v       p = f v p

withString :: (T.Text -> Position -> Either (ValueError, Position) T.Text)
           -> JS.Value -> Position -> Either (ValueError, Position) JS.Value
withString alter (JS.String s) p = JS.String <$> alter s p
withString _     v             p = Left (JSONError $ expectedString v, p)

fieldKey :: FieldName -> T.Text
fieldKey (FieldName fname) = T.pack fname

fromFieldKey :: T.Text -> FieldName
fromFieldKey = FieldName . T.unpack

compatibleDefaultValue :: NormAPI -> APIType -> DefaultValue -> Bool
compatibleDefaultValue _   (TyList  _) DefValList  = True
compatibleDefaultValue _   (TyMaybe _) DefValMaybe = True
compatibleDefaultValue api (TyMaybe ty)    defval  = compatibleDefaultValue api ty defval
compatibleDefaultValue _   (TyBasic bt)    defval  =
    compatibleBasicDefaultValue bt defval
compatibleDefaultValue _   TyJSON          _       = True
compatibleDefaultValue env (TyName tname)  defval  =
    case Map.lookup tname env of
      Just (NTypeSynonym t) -> compatibleDefaultValue env t defval
      Just (NNewtype    bt) -> compatibleBasicDefaultValue bt defval
      Just (NEnumType vals) -> case defval of
                                 DefValString s -> fromFieldKey s `Set.member` vals
                                 _              -> False
      _                     -> False
compatibleDefaultValue _ _ _ = False

compatibleBasicDefaultValue :: BasicType -> DefaultValue -> Bool
compatibleBasicDefaultValue BTstring (DefValString _) = True
compatibleBasicDefaultValue BTbinary (DefValString v) = case B64.decode (B.pack (T.unpack v)) of
                                                           Left _  -> False
                                                           Right _ -> True
compatibleBasicDefaultValue BTbool   (DefValBool _)   = True
compatibleBasicDefaultValue BTint    (DefValInt _)    = True
compatibleBasicDefaultValue BTutc    (DefValUtc _)    = True
compatibleBasicDefaultValue _         _                = False

-- | Check if there is a "default" default value for a field of the
-- given type: list and maybe have @[]@ and @nothing@ respectively.
-- Note that type synonyms do not preserve defaults, since we do not
-- have access to the entire API.
defaultValueForType :: APIType -> Maybe DefaultValue
defaultValueForType (TyList  _) = Just DefValList
defaultValueForType (TyMaybe _) = Just DefValMaybe
defaultValueForType _           = Nothing


-------------------------------------------
-- Validation that a dataset matches an API
--

-- | Check that a dataset matches an API, which is necessary for
-- succesful migration.  The name of the dataset's type must be
-- specified.
dataMatchesAPI :: TypeName -> API -> JS.Value -> Either (ValueError, Position) ()
dataMatchesAPI root = dataMatchesNormAPI root . apiNormalForm

dataMatchesNormAPI :: TypeName -> NormAPI -> JS.Value -> Either (ValueError, Position) ()
dataMatchesNormAPI root api db = void $ valueMatches (TyName root) db []
  where
    declMatches :: NormTypeDecl -> JS.Value -> Position -> Either (ValueError, Position) JS.Value
    declMatches (NRecordType flds) = withObjectMatchingFields flds valueMatches
    declMatches (NUnionType alts)  = withObjectMatchingUnion  alts valueMatches
    declMatches (NEnumType vals)   = withString $ \ s p ->
        if fromFieldKey s `Set.member` vals
           then return s
           else Left (JSONError UnexpectedField, InField s : p)
    declMatches (NTypeSynonym t)   = valueMatches t
    declMatches (NNewtype bt)      = valueMatchesBasic bt

    valueMatches :: APIType -> JS.Value -> Position -> Either (ValueError, Position) JS.Value
    valueMatches (TyList t)      = withArrayElems (valueMatches t)
    valueMatches (TyMaybe t)     = withMaybe (valueMatches t)
    valueMatches (TyName tname)  = \ v p -> do
        d <- lookupType tname api ?!? (\ f -> (InvalidAPI f, p))
        declMatches d v p
    valueMatches (TyBasic bt)    = valueMatchesBasic bt
    valueMatches TyJSON          = \ v _ -> return v

    valueMatchesBasic :: BasicType -> JS.Value -> Position -> Either (ValueError, Position) JS.Value
    valueMatchesBasic BTstring = expectDecodes (fromJSONWithErrs :: Decode T.Text)
    valueMatchesBasic BTbinary = expectDecodes (fromJSONWithErrs :: Decode Binary)
    valueMatchesBasic BTbool   = expectDecodes (fromJSONWithErrs :: Decode Bool)
    valueMatchesBasic BTint    = expectDecodes (fromJSONWithErrs :: Decode Int)
    valueMatchesBasic BTutc    = expectDecodes (fromJSONWithErrs :: Decode UTCTime)

    expectDecodes :: Decode t -> JS.Value -> Position -> Either (ValueError, Position) JS.Value
    expectDecodes f v p = case f v of
                            Right _          -> return v
                            Left ((je, _):_) -> Left (JSONError je, p)
                            Left []          -> Left (JSONError $ SyntaxError "expectDecodes", p)

type Decode t = JS.Value -> Either [(JSONError, Position)] t

-------------------------------------
-- Utils for merging and diffing maps
--

data MergeResult a b = OnlyInLeft a | InBoth a b | OnlyInRight b
  deriving (Eq, Show)

mergeMaps :: Ord k => Map k a -> Map k b -> Map k (MergeResult a b)
mergeMaps m1 m2 = Map.unionWith (\(OnlyInLeft a) (OnlyInRight b) -> InBoth a b)
                      (fmap OnlyInLeft m1) (fmap OnlyInRight m2)

diffMaps :: (Eq a, Ord k) => Map k a -> Map k a -> Map k (MergeResult a a)
diffMaps m1 m2 = Map.filter different $ mergeMaps m1 m2
  where
    different (InBoth a b) = a /= b
    different _            = True

-- Attempts to match the keys of the maps to produce a map from keys
-- to pairs.
matchMaps :: Ord k => Map k a -> Map k b -> Either (k, Either a b) (Map k (a, b))
matchMaps m1 m2 = Map.traverseWithKey win $ mergeMaps m1 m2
  where
    win _ (InBoth x y)    = return (x, y)
    win k (OnlyInLeft x)  = Left (k, Left x)
    win k (OnlyInRight x) = Left (k, Right x)


-------------------------------------
-- Pretty-printing
--

prettyMigrateFailure :: MigrateFailure -> String
prettyMigrateFailure = unlines . ppLines

prettyValidateFailure :: ValidateFailure -> String
prettyValidateFailure = unlines . ppLines

prettyValueError :: ValueError -> String
prettyValueError = unlines . ppLines

prettyValueErrorPosition :: (ValueError, Position) -> String
prettyValueErrorPosition = unlines . ppLines


instance PP TypeKind where
  pp TKRecord = "record"
  pp TKUnion  = "union"
  pp TKEnum   = "enum"

ppATypeKind :: TypeKind -> String
ppATypeKind TKRecord = "a record"
ppATypeKind TKUnion  = "a union"
ppATypeKind TKEnum   = "an enum"

ppMemberWord :: TypeKind -> String
ppMemberWord TKRecord = "field"
ppMemberWord TKUnion  = "alternative"
ppMemberWord TKEnum   = "value"


instance PPLines APIChange where
  ppLines (ChAddType t d)           = ("added " ++ pp t ++ " ") `inFrontOf` ppLines d
  ppLines (ChDeleteType t)          = ["removed " ++ pp t]
  ppLines (ChRenameType t t')       = ["renamed " ++ pp t ++ " to " ++ pp t']
  ppLines (ChAddField t f ty mb_v)  = [ "changed record " ++ pp t
                                      , "  field added " ++ pp f ++ " :: " ++ pp ty
                                        ++ maybe "" (\ v -> " default " ++ pp v) mb_v]
  ppLines (ChDeleteField t f)       = ["changed record " ++ pp t, "  field removed " ++ pp f]
  ppLines (ChRenameField t f f')    = [ "changed record " ++ pp t
                                      , "  field renamed " ++ pp f ++ " to " ++ pp f']
  ppLines (ChChangeField t f ty c)  = [ "changed record " ++ pp t
                                      , "  field changed " ++ pp f ++ " :: " ++ pp ty
                                        ++ " migration " ++ pp c]
  ppLines (ChAddUnionAlt t f ty)    = [ "changed union " ++ pp t
                                      , "  alternative added " ++ pp f ++ " :: " ++ pp ty]
  ppLines (ChDeleteUnionAlt t f)    = [ "changed union " ++ pp t
                                      , "  alternative removed " ++ pp f]
  ppLines (ChRenameUnionAlt t f f') = [ "changed union " ++ pp t
                                      , "  alternative renamed " ++ pp f ++ " to " ++ pp f']
  ppLines (ChAddEnumVal t f)        = [ "changed enum " ++ pp t
                                      , "  alternative added " ++ pp f]
  ppLines (ChDeleteEnumVal t f)     = [ "changed enum " ++ pp t
                                      , "  alternative removed " ++ pp f]
  ppLines (ChRenameEnumVal t f f')  = [ "changed enum " ++ pp t
                                      , "  alternative renamed " ++ pp f ++ " to " ++ pp f']
  ppLines (ChCustomRecord t c)      = ["changed record " ++ pp t ++ " migration " ++ pp c]
  ppLines (ChCustomAll c)           = ["migration " ++ pp c]

instance PPLines NormTypeDecl where
  ppLines (NRecordType flds) = "record" : map (\ (f, ty) -> "  " ++ pp f
                                                            ++ " :: " ++ pp ty)
                                              (Map.toList flds)
  ppLines (NUnionType alts)  = "union"  : map (\ (f, ty) -> "  " ++ pp f
                                                            ++ " :: " ++ pp ty)
                                              (Map.toList alts)
  ppLines (NEnumType vals)   = "enum"   : map (\ v -> "  " ++ pp v)
                                              (Set.toList vals)
  ppLines (NTypeSynonym t)   = [pp t]
  ppLines (NNewtype b)       = ["basic " ++ pp b]

instance PPLines MigrateFailure where
  ppLines (ValidateFailure x) = ppLines x
  ppLines (ValueError x ps)   = ppLines x ++ map prettyStep ps

instance PPLines ValidateFailure where
  ppLines (ChangelogOutOfOrder later earlier) =
      ["Changelog out of order: version " ++ pp later
           ++ " appears after version " ++ pp earlier]
  ppLines (CannotDowngrade from to) =
      ["Cannot downgrade from version " ++ pp from
           ++ " to version " ++ pp to]
  ppLines (ApiInvalid ver missing) =
      ["Missing declarations in API version " ++ pp ver ++ ": " ++ pp missing]
  ppLines (ChangelogEntryInvalid succs change af) =
      ppLines af ++ ("when applying the change" : indent (ppLines change))
          ++ if not (null succs)
             then "after successfully applying the changes:"
                  : indent (ppLines succs)
             else []
  ppLines (ChangelogIncomplete ver ver' diffs) =
      ("Changelog incomplete! Differences between log version ("
           ++ showVersionExtra ver ++ ") and latest version (" ++ showVersionExtra ver' ++ "):")
      : indent (concatMap (uncurry ppDiff) $ Map.toList diffs)

instance PPLines APITableChange where
  ppLines (APIChange c _)  = ppLines c
  ppLines (ValidateData _) = []

ppDiff :: TypeName -> MergeResult NormTypeDecl NormTypeDecl -> [String]
ppDiff t (OnlyInLeft _)  = ["removed " ++ pp t]
ppDiff t (OnlyInRight d) = ("added " ++ pp t ++ " ") `inFrontOf` ppLines d
ppDiff t (InBoth (NRecordType flds) (NRecordType flds')) =
    ("changed record " ++ pp t)
    : (concatMap (uncurry (ppDiffFields "field")) $ Map.toList $ diffMaps flds flds')
ppDiff t (InBoth (NUnionType alts) (NUnionType alts')) =
    ("changed union " ++ pp t)
    : (concatMap (uncurry (ppDiffFields "alternative")) $ Map.toList $ diffMaps alts alts')
ppDiff t (InBoth (NEnumType vals) (NEnumType vals')) =
    ("changed enum " ++ pp t)
    :  (map (\ x -> "  alternative removed " ++ pp x) $ Set.toList $ vals  Set.\\ vals')
    ++ (map (\ x -> "  alternative added " ++ pp x)   $ Set.toList $ vals' Set.\\ vals)
ppDiff t (InBoth _ _) = ["incompatible definitions of " ++ pp t]

ppDiffFields :: String -> FieldName -> MergeResult APIType APIType -> [String]
ppDiffFields s f (OnlyInLeft _)   = ["  " ++ s ++ " removed " ++ pp f]
ppDiffFields s f (OnlyInRight ty) = ["  " ++ s ++ " added " ++ pp f ++ " :: " ++ pp ty]
ppDiffFields s f (InBoth ty ty')   = [ "  incompatible types for " ++ s ++ " " ++ pp f
                                     , "    changelog type:      " ++ pp ty
                                     , "    latest version type: " ++ pp ty' ]


instance PPLines ApplyFailure where
  ppLines (TypeExists t)                  = ["Type " ++ pp t ++ " already exists"]
  ppLines (TypeDoesNotExist t)            = ["Type " ++ pp t ++ " does not exist"]
  ppLines (TypeWrongKind t k)             = ["Type " ++ pp t ++ " is not " ++ ppATypeKind k]
  ppLines (TypeInUse t)                   = ["Type " ++ pp t ++ " is in use, so it cannot be modified"]
  ppLines (TypeMalformed ty xs)           = ["Type " ++ pp ty
                                             ++ " is malformed, missing declarations:"
                                            , "  " ++ pp xs]
  ppLines (DeclMalformed t _ xs)          = [ "Declaration of " ++ pp t
                                              ++ " is malformed, missing declarations:"
                                            , "  " ++ pp xs]
  ppLines (FieldExists t k f)             = ["Type " ++ pp t ++ " already has the "
                                             ++ ppMemberWord k ++ " " ++ pp f]
  ppLines (FieldDoesNotExist t k f)       = ["Type " ++ pp t ++ " does not have the "
                                             ++ ppMemberWord k ++ " " ++ pp f]
  ppLines (FieldBadDefaultValue _ _ ty v) = ["Default value " ++ pp v
                                             ++ " is not compatible with the type " ++ pp ty]
  ppLines (DefaultMissing t f)            = ["Field " ++ pp f ++ " does not have a default value, but "
                                             ++ pp t ++ " occurs in the database"]
  ppLines (TableChangeError s)            = ["Error when detecting changed tables:", "  " ++ s]


instance PPLines ValueError where
  ppLines (JSONError e)              = [prettyJSONError e]
  ppLines (CustomMigrationError e v) = [ "Custom migration error:", "  " ++ e
                                       , "when migrating value"] ++ indent (ppLines v)
  ppLines (InvalidAPI af)            = "Invalid API detected during value migration:"
                                       : indent (ppLines af)


-------------------------------------
-- Template Haskell
--

-- | Generate enumeration datatypes corresponding to the custom
-- migrations used in an API migration changelog.
generateMigrationKinds :: APIChangelog -> String -> String -> String -> Q [Dec]
generateMigrationKinds changes all_nm rec_nm fld_nm = do
    guardNoDups (all_tags `Set.intersection` rec_tags)
    guardNoDups (all_tags `Set.intersection` fld_tags)
    guardNoDups (rec_tags `Set.intersection` fld_tags)

    return [ DataD [] (mkName all_nm) [] (cons all_nm all_tags) derivs
           , DataD [] (mkName rec_nm) [] (cons rec_nm rec_tags) derivs
           , DataD [] (mkName fld_nm) [] (cons fld_nm fld_tags) derivs ]
  where
    (all_tags, rec_tags, fld_tags) = changelogTags changes

    guardNoDups xs
      | Set.null xs = return ()
      | otherwise   = fail $ "generateMigrationKinds: duplicate custom migrations in changelog: "
                             ++ show (Set.toList xs)

    -- List of constructors must not be empty, otherwise GHC can't
    -- derive Read/Show instances (see GHC Trac #7401)
    cons s xs | not (Set.null xs) = map (\ x -> NormalC (mkName x) []) (Set.toList xs)
              | otherwise         = [NormalC (mkName $ "No" ++ s) []]

    derivs = [''Read, ''Show]