{-# LANGUAGE TemplateHaskell   #-}

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

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

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

      -- * Custom migrations
    , CustomMigrations(..)
    , mkRecordMigration
    , mkRecordMigration'
    , mkRecordMigrationSchema
    , noDataChanges
    , noSchemaChanges
    , 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.Changes.Types
import           Data.API.Error
import           Data.API.JSON
import           Data.API.NormalForm
import           Data.API.TH.Compat
import           Data.API.Types
import           Data.API.Utils
import           Data.API.Value as Value
import           Data.Binary.Serialise.CBOR.Extra

import           Control.Applicative
import           Control.Monad (guard, foldM, void)
import qualified Data.Aeson as JS
import           Data.List
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.Time
import           Data.Version
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 JS.Object JS.Value 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 :: (API, Version)
-> (API, VersionExtra)
-> APIChangelog
-> CustomMigrations Object Value db rec fld
-> TypeName
-> DataChecks
-> Value
-> Either MigrateFailure (Value, [MigrateWarning])
migrateDataDump (API, Version)
startApi (API, VersionExtra)
endApi APIChangelog
changelog CustomMigrations Object Value db rec fld
custom TypeName
root DataChecks
chks Value
db = do
    let custom' :: CustomMigrationsTagged Object Value
custom' = CustomMigrations Object Value db rec fld
-> CustomMigrationsTagged Object Value
forall db ty fld o v.
(Read db, Read ty, Read fld) =>
CustomMigrations o v db ty fld -> CustomMigrationsTagged o v
readCustomMigrations CustomMigrations Object Value db rec fld
custom
    ([APITableChange]
changes, [MigrateWarning]
warnings) <- (API, Version)
-> (API, VersionExtra)
-> APIChangelog
-> CustomMigrationsTagged Object Value
-> TypeName
-> DataChecks
-> Either ValidateFailure ([APITableChange], [MigrateWarning])
forall o v.
(API, Version)
-> (API, VersionExtra)
-> APIChangelog
-> CustomMigrationsTagged o v
-> TypeName
-> DataChecks
-> Either ValidateFailure ([APITableChange], [MigrateWarning])
validateChanges' (API, Version)
startApi (API, VersionExtra)
endApi APIChangelog
changelog CustomMigrationsTagged Object Value
custom' TypeName
root DataChecks
chks
                                                           Either ValidateFailure ([APITableChange], [MigrateWarning])
-> (ValidateFailure -> MigrateFailure)
-> Either MigrateFailure ([APITableChange], [MigrateWarning])
forall e a e'. Either e a -> (e -> e') -> Either e' a
?!? ValidateFailure -> MigrateFailure
ValidateFailure
    Value
db' <- TypeName
-> CustomMigrationsTagged Object Value
-> Value
-> [APITableChange]
-> Either (ValueError, Position) Value
applyChangesToDatabase TypeName
root CustomMigrationsTagged Object Value
custom' Value
db [APITableChange]
changes  Either (ValueError, Position) Value
-> ((ValueError, Position) -> MigrateFailure)
-> Either MigrateFailure Value
forall e a e'. Either e a -> (e -> e') -> Either e' a
?!? (ValueError -> Position -> MigrateFailure)
-> (ValueError, Position) -> MigrateFailure
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ValueError -> Position -> MigrateFailure
ValueError
    (Value, [MigrateWarning])
-> Either MigrateFailure (Value, [MigrateWarning])
forall (m :: * -> *) a. Monad m => a -> m a
return (Value
db', [MigrateWarning]
warnings)

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 Record Value db rec fld  -- ^ Custom migration functions
                -> TypeName                     -- ^ Name of the dataset's type
                -> DataChecks                   -- ^ How thoroughly to validate changes
                -> Value.Value                  -- ^ Dataset to be migrated
                -> Either MigrateFailure (Value.Value, [MigrateWarning])
migrateDataDump' :: (API, Version)
-> (API, VersionExtra)
-> APIChangelog
-> CustomMigrations Record Value db rec fld
-> TypeName
-> DataChecks
-> Value
-> Either MigrateFailure (Value, [MigrateWarning])
migrateDataDump' (API, Version)
startApi (API, VersionExtra)
endApi APIChangelog
changelog CustomMigrations Record Value db rec fld
custom TypeName
root DataChecks
chks Value
db = do
    let custom' :: CustomMigrationsTagged Record Value
custom' = CustomMigrations Record Value db rec fld
-> CustomMigrationsTagged Record Value
forall db ty fld o v.
(Read db, Read ty, Read fld) =>
CustomMigrations o v db ty fld -> CustomMigrationsTagged o v
readCustomMigrations CustomMigrations Record Value db rec fld
custom
    ([APITableChange]
changes, [MigrateWarning]
warnings) <- (API, Version)
-> (API, VersionExtra)
-> APIChangelog
-> CustomMigrationsTagged Record Value
-> TypeName
-> DataChecks
-> Either ValidateFailure ([APITableChange], [MigrateWarning])
forall o v.
(API, Version)
-> (API, VersionExtra)
-> APIChangelog
-> CustomMigrationsTagged o v
-> TypeName
-> DataChecks
-> Either ValidateFailure ([APITableChange], [MigrateWarning])
validateChanges' (API, Version)
startApi (API, VersionExtra)
endApi APIChangelog
changelog CustomMigrationsTagged Record Value
custom' TypeName
root DataChecks
chks
                                                           Either ValidateFailure ([APITableChange], [MigrateWarning])
-> (ValidateFailure -> MigrateFailure)
-> Either MigrateFailure ([APITableChange], [MigrateWarning])
forall e a e'. Either e a -> (e -> e') -> Either e' a
?!? ValidateFailure -> MigrateFailure
ValidateFailure
    Value
db' <- TypeName
-> CustomMigrationsTagged Record Value
-> Value
-> [APITableChange]
-> Either (ValueError, Position) Value
applyChangesToDatabase' TypeName
root CustomMigrationsTagged Record Value
custom' Value
db [APITableChange]
changes  Either (ValueError, Position) Value
-> ((ValueError, Position) -> MigrateFailure)
-> Either MigrateFailure Value
forall e a e'. Either e a -> (e -> e') -> Either e' a
?!? (ValueError -> Position -> MigrateFailure)
-> (ValueError, Position) -> MigrateFailure
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ValueError -> Position -> MigrateFailure
ValueError
    (Value, [MigrateWarning])
-> Either MigrateFailure (Value, [MigrateWarning])
forall (m :: * -> *) a. Monad m => a -> m a
return (Value
db', [MigrateWarning]
warnings)



-- | 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;
--
-- * Type migrations, which may change the schema of a single type; and
--
-- * Single field migrations, which may change only the type of the
-- field (with the new type specified in the changelog).
--
-- For database and type migrations, if the schema is unchanged, the
-- corresponding function should return 'Nothing'.
--
-- The @db@, @ty@ 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 o v db ty fld = CustomMigrations
    { CustomMigrations o v db ty fld -> db -> o -> Either ValueError o
databaseMigration       :: db -> o -> Either ValueError o
    , CustomMigrations o v db ty fld
-> db -> NormAPI -> Either ApplyFailure (Maybe NormAPI)
databaseMigrationSchema :: db -> NormAPI -> Either ApplyFailure (Maybe NormAPI)
    , CustomMigrations o v db ty fld -> ty -> v -> Either ValueError v
typeMigration           :: ty -> v -> Either ValueError v
    , CustomMigrations o v db ty fld
-> ty -> NormTypeDecl -> Either ApplyFailure (Maybe NormTypeDecl)
typeMigrationSchema     :: ty -> NormTypeDecl -> Either ApplyFailure (Maybe NormTypeDecl)
    , CustomMigrations o v db ty fld -> fld -> v -> Either ValueError v
fieldMigration          :: fld -> v -> Either ValueError v }

type CustomMigrationsTagged o v = CustomMigrations o v MigrationTag MigrationTag MigrationTag

readCustomMigrations :: (Read db, Read ty, Read fld)
                     => CustomMigrations o v db ty fld -> CustomMigrationsTagged o v
readCustomMigrations :: CustomMigrations o v db ty fld -> CustomMigrationsTagged o v
readCustomMigrations (CustomMigrations db -> o -> Either ValueError o
db db -> NormAPI -> Either ApplyFailure (Maybe NormAPI)
dbs ty -> v -> Either ValueError v
r ty -> NormTypeDecl -> Either ApplyFailure (Maybe NormTypeDecl)
rs fld -> v -> Either ValueError v
f) =
    (String -> o -> Either ValueError o)
-> (String -> NormAPI -> Either ApplyFailure (Maybe NormAPI))
-> (String -> v -> Either ValueError v)
-> (String
    -> NormTypeDecl -> Either ApplyFailure (Maybe NormTypeDecl))
-> (String -> v -> Either ValueError v)
-> CustomMigrationsTagged o v
forall o v db ty fld.
(db -> o -> Either ValueError o)
-> (db -> NormAPI -> Either ApplyFailure (Maybe NormAPI))
-> (ty -> v -> Either ValueError v)
-> (ty -> NormTypeDecl -> Either ApplyFailure (Maybe NormTypeDecl))
-> (fld -> v -> Either ValueError v)
-> CustomMigrations o v db ty fld
CustomMigrations (db -> o -> Either ValueError o
db (db -> o -> Either ValueError o)
-> (String -> db) -> String -> o -> Either ValueError o
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> db
forall a. Read a => String -> a
read) (db -> NormAPI -> Either ApplyFailure (Maybe NormAPI)
dbs (db -> NormAPI -> Either ApplyFailure (Maybe NormAPI))
-> (String -> db)
-> String
-> NormAPI
-> Either ApplyFailure (Maybe NormAPI)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> db
forall a. Read a => String -> a
read) (ty -> v -> Either ValueError v
r (ty -> v -> Either ValueError v)
-> (String -> ty) -> String -> v -> Either ValueError v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ty
forall a. Read a => String -> a
read) (ty -> NormTypeDecl -> Either ApplyFailure (Maybe NormTypeDecl)
rs (ty -> NormTypeDecl -> Either ApplyFailure (Maybe NormTypeDecl))
-> (String -> ty)
-> String
-> NormTypeDecl
-> Either ApplyFailure (Maybe NormTypeDecl)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ty
forall a. Read a => String -> a
read) (fld -> v -> Either ValueError v
f (fld -> v -> Either ValueError v)
-> (String -> fld) -> String -> v -> Either ValueError v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> fld
forall a. Read a => String -> a
read)

-- | Lift a custom record migration to work on arbitrary values
mkRecordMigration :: (JS.Object -> Either ValueError JS.Object)
                  -> (JS.Value  -> Either ValueError JS.Value)
mkRecordMigration :: (Object -> Either ValueError Object)
-> Value -> Either ValueError Value
mkRecordMigration Object -> Either ValueError Object
f (JS.Object Object
o) = Object -> Value
JS.Object (Object -> Value)
-> Either ValueError Object -> Either ValueError Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Either ValueError Object
f Object
o
mkRecordMigration Object -> Either ValueError Object
_ Value
v             = ValueError -> Either ValueError Value
forall a b. a -> Either a b
Left (ValueError -> Either ValueError Value)
-> ValueError -> Either ValueError Value
forall a b. (a -> b) -> a -> b
$ JSONError -> ValueError
JSONError (JSONError -> ValueError) -> JSONError -> ValueError
forall a b. (a -> b) -> a -> b
$ Value -> JSONError
expectedObject Value
v

mkRecordMigration' :: (Record -> Either ValueError Record)
                   -> (Value  -> Either ValueError Value)
mkRecordMigration' :: (Record -> Either ValueError Record)
-> Value -> Either ValueError Value
mkRecordMigration' Record -> Either ValueError Record
f (Record Record
xs) = Record -> Value
Record (Record -> Value)
-> Either ValueError Record -> Either ValueError Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Record -> Either ValueError Record
f Record
xs
mkRecordMigration' Record -> Either ValueError Record
_ Value
v           = ValueError -> Either ValueError Value
forall a b. a -> Either a b
Left (ValueError -> Either ValueError Value)
-> ValueError -> Either ValueError Value
forall a b. (a -> b) -> a -> b
$ JSONError -> ValueError
JSONError (JSONError -> ValueError) -> JSONError -> ValueError
forall a b. (a -> b) -> a -> b
$ Value -> JSONError
expectedObject (Value -> Value
forall a. ToJSON a => a -> Value
JS.toJSON Value
v)

-- | Lift a schema change on record types to work on arbitrary type declarations
mkRecordMigrationSchema :: TypeName
                        -> (NormRecordType -> Either ApplyFailure (Maybe NormRecordType))
                        -> (NormTypeDecl   -> Either ApplyFailure (Maybe NormTypeDecl))
mkRecordMigrationSchema :: TypeName
-> (NormRecordType -> Either ApplyFailure (Maybe NormRecordType))
-> NormTypeDecl
-> Either ApplyFailure (Maybe NormTypeDecl)
mkRecordMigrationSchema TypeName
tname NormRecordType -> Either ApplyFailure (Maybe NormRecordType)
f NormTypeDecl
tinfo = do
  NormRecordType
recinfo <- NormTypeDecl -> Maybe NormRecordType
expectRecordType NormTypeDecl
tinfo Maybe NormRecordType
-> ApplyFailure -> Either ApplyFailure NormRecordType
forall a e. Maybe a -> e -> Either e a
?! TypeName -> TypeKind -> ApplyFailure
TypeWrongKind TypeName
tname TypeKind
TKRecord
  (NormRecordType -> NormTypeDecl)
-> Maybe NormRecordType -> Maybe NormTypeDecl
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NormRecordType -> NormTypeDecl
NRecordType (Maybe NormRecordType -> Maybe NormTypeDecl)
-> Either ApplyFailure (Maybe NormRecordType)
-> Either ApplyFailure (Maybe NormTypeDecl)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NormRecordType -> Either ApplyFailure (Maybe NormRecordType)
f NormRecordType
recinfo

-- | Use for 'databaseMigration', 'typeMigration' or 'fieldMigration'
-- to indicate that changes to the data are not required
noDataChanges :: a -> Either ValueError a
noDataChanges :: a -> Either ValueError a
noDataChanges = a -> Either ValueError a
forall (m :: * -> *) a. Monad m => a -> m a
return

-- | Use for 'databaseMigrationSchema' or 'typeMigrationSchema' to
-- indicate that the schema should not be changed
noSchemaChanges :: a -> Either ApplyFailure (Maybe a)
noSchemaChanges :: a -> Either ApplyFailure (Maybe a)
noSchemaChanges a
_ = Maybe a -> Either ApplyFailure (Maybe a)
forall a b. b -> Either a b
Right Maybe a
forall a. Maybe a
Nothing


-- | 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 (DataChecks -> DataChecks -> Bool
(DataChecks -> DataChecks -> Bool)
-> (DataChecks -> DataChecks -> Bool) -> Eq DataChecks
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DataChecks -> DataChecks -> Bool
$c/= :: DataChecks -> DataChecks -> Bool
== :: DataChecks -> DataChecks -> Bool
$c== :: DataChecks -> DataChecks -> Bool
Eq, Eq DataChecks
Eq DataChecks
-> (DataChecks -> DataChecks -> Ordering)
-> (DataChecks -> DataChecks -> Bool)
-> (DataChecks -> DataChecks -> Bool)
-> (DataChecks -> DataChecks -> Bool)
-> (DataChecks -> DataChecks -> Bool)
-> (DataChecks -> DataChecks -> DataChecks)
-> (DataChecks -> DataChecks -> DataChecks)
-> Ord DataChecks
DataChecks -> DataChecks -> Bool
DataChecks -> DataChecks -> Ordering
DataChecks -> DataChecks -> DataChecks
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: DataChecks -> DataChecks -> DataChecks
$cmin :: DataChecks -> DataChecks -> DataChecks
max :: DataChecks -> DataChecks -> DataChecks
$cmax :: DataChecks -> DataChecks -> DataChecks
>= :: DataChecks -> DataChecks -> Bool
$c>= :: DataChecks -> DataChecks -> Bool
> :: DataChecks -> DataChecks -> Bool
$c> :: DataChecks -> DataChecks -> Bool
<= :: DataChecks -> DataChecks -> Bool
$c<= :: DataChecks -> DataChecks -> Bool
< :: DataChecks -> DataChecks -> Bool
$c< :: DataChecks -> DataChecks -> Bool
compare :: DataChecks -> DataChecks -> Ordering
$ccompare :: DataChecks -> DataChecks -> Ordering
$cp1Ord :: Eq DataChecks
Ord)

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


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

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

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

-- | Changelog in order starting from oldest version up to newest.
-- Entries are @(from, to, changes-oldest-first)@.
viewChangelogReverse :: APIChangelog -> [(VersionExtra, VersionExtra, [APIChange])]
viewChangelogReverse :: APIChangelog -> [(VersionExtra, VersionExtra, [APIChange])]
viewChangelogReverse APIChangelog
clog =
  [(VersionExtra, VersionExtra, [APIChange])]
-> [(VersionExtra, VersionExtra, [APIChange])]
forall a. [a] -> [a]
reverse [ (VersionExtra
v,VersionExtra
v',[APIChange] -> [APIChange]
forall a. [a] -> [a]
reverse [APIChange]
cs) | (VersionExtra
v',VersionExtra
v,[APIChange]
cs) <- APIChangelog -> [(VersionExtra, VersionExtra, [APIChange])]
viewChangelog APIChangelog
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 :: APIChangelog -> [(VersionExtra, VersionExtra, [APIChange])]
viewChangelog (ChangesStart Version
_)          = []
viewChangelog (ChangesUpTo VersionExtra
v' [APIChange]
cs APIChangelog
older) = (VersionExtra
v', VersionExtra
v, [APIChange]
cs) (VersionExtra, VersionExtra, [APIChange])
-> [(VersionExtra, VersionExtra, [APIChange])]
-> [(VersionExtra, VersionExtra, [APIChange])]
forall a. a -> [a] -> [a]
: APIChangelog -> [(VersionExtra, VersionExtra, [APIChange])]
viewChangelog APIChangelog
older
                                           where v :: VersionExtra
v = APIChangelog -> VersionExtra
changelogVersion APIChangelog
older

-- | Is the changelog in the correct order? If not, return a pair of
-- out-of-order versions.
isChangelogOrdered :: APIChangelog -> Either (VersionExtra, VersionExtra) ()
isChangelogOrdered :: APIChangelog -> Either (VersionExtra, VersionExtra) ()
isChangelogOrdered APIChangelog
changelog =
    case ((VersionExtra, VersionExtra, [APIChange]) -> Bool)
-> [(VersionExtra, VersionExtra, [APIChange])]
-> Maybe (VersionExtra, VersionExtra, [APIChange])
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\ (VersionExtra
v', VersionExtra
v, [APIChange]
_) -> VersionExtra
v' VersionExtra -> VersionExtra -> Bool
forall a. Ord a => a -> a -> Bool
<= VersionExtra
v) (APIChangelog -> [(VersionExtra, VersionExtra, [APIChange])]
viewChangelog APIChangelog
changelog) of
      Maybe (VersionExtra, VersionExtra, [APIChange])
Nothing         -> () -> Either (VersionExtra, VersionExtra) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just (VersionExtra
v', VersionExtra
v, [APIChange]
_) -> (VersionExtra, VersionExtra)
-> Either (VersionExtra, VersionExtra) ()
forall a b. a -> Either a b
Left (VersionExtra
v', VersionExtra
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 :: APIChangelog -> (Set String, Set String, Set String)
changelogTags (ChangesStart Version
_) = (Set String
forall a. Set a
Set.empty, Set String
forall a. Set a
Set.empty, Set String
forall a. Set a
Set.empty)
changelogTags (ChangesUpTo VersionExtra
_ [APIChange]
cs APIChangelog
older) =
    [(Set String, Set String, Set String)]
-> (Set String, Set String, Set String)
forall a a a.
(Ord a, Ord a, Ord a) =>
[(Set a, Set a, Set a)] -> (Set a, Set a, Set a)
unions3 ((APIChange -> (Set String, Set String, Set String))
-> [APIChange] -> [(Set String, Set String, Set String)]
forall a b. (a -> b) -> [a] -> [b]
map APIChange -> (Set String, Set String, Set String)
changeTags [APIChange]
cs) (Set String, Set String, Set String)
-> (Set String, Set String, Set String)
-> (Set String, Set String, Set String)
forall a a a.
(Ord a, Ord a, Ord a) =>
(Set a, Set a, Set a)
-> (Set a, Set a, Set a) -> (Set a, Set a, Set a)
`union3` APIChangelog -> (Set String, Set String, Set String)
changelogTags APIChangelog
older
  where
    union3 :: (Set a, Set a, Set a)
-> (Set a, Set a, Set a) -> (Set a, Set a, Set a)
union3 (Set a
a, Set a
b, Set a
c) (Set a
x, Set a
y, Set a
z) = (Set a
a Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set a
x, Set a
b Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set a
y, Set a
c Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set a
z)
    unions3 :: [(Set a, Set a, Set a)] -> (Set a, Set a, Set a)
unions3 [(Set a, Set a, Set a)]
xyzs = ([Set a] -> Set a
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions [Set a]
xs, [Set a] -> Set a
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions [Set a]
ys, [Set a] -> Set a
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions [Set a]
zs)
      where ([Set a]
xs, [Set a]
ys, [Set a]
zs) = [(Set a, Set a, Set a)] -> ([Set a], [Set a], [Set a])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 [(Set a, Set a, Set a)]
xyzs

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


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

-- | 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 :: TypeName -> NormAPI -> Map TypeName UpdateDeclPos
findUpdatePos TypeName
tname NormAPI
api = (Maybe UpdateDeclPos -> Maybe UpdateDeclPos)
-> TypeName
-> Map TypeName UpdateDeclPos
-> Map TypeName UpdateDeclPos
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (UpdateDeclPos -> Maybe UpdateDeclPos
forall a. a -> Maybe a
Just (UpdateDeclPos -> Maybe UpdateDeclPos)
-> (Maybe UpdateDeclPos -> UpdateDeclPos)
-> Maybe UpdateDeclPos
-> Maybe UpdateDeclPos
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe UpdateDeclPos -> UpdateDeclPos
UpdateHere) TypeName
tname (Map TypeName UpdateDeclPos -> Map TypeName UpdateDeclPos)
-> Map TypeName UpdateDeclPos -> Map TypeName UpdateDeclPos
forall a b. (a -> b) -> a -> b
$
                          (TypeName -> UpdateDeclPos)
-> Set TypeName -> Map TypeName UpdateDeclPos
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet TypeName -> UpdateDeclPos
findDecl Set TypeName
deps
  where
    -- The set of types that depend on the type being updated
    deps :: Set TypeName
    deps :: Set TypeName
deps = NormAPI -> Set TypeName -> Set TypeName
transitiveReverseDeps NormAPI
api (TypeName -> Set TypeName
forall a. a -> Set a
Set.singleton TypeName
tname)

    findDecl :: TypeName -> UpdateDeclPos
    findDecl :: TypeName -> UpdateDeclPos
findDecl TypeName
tname' = NormTypeDecl -> UpdateDeclPos
findDecl' (NormTypeDecl -> UpdateDeclPos) -> NormTypeDecl -> UpdateDeclPos
forall a b. (a -> b) -> a -> b
$
                      NormTypeDecl -> Maybe NormTypeDecl -> NormTypeDecl
forall a. a -> Maybe a -> a
fromMaybe (String -> NormTypeDecl
forall a. HasCallStack => String -> a
error String
"findUpdatePos: missing type") (Maybe NormTypeDecl -> NormTypeDecl)
-> Maybe NormTypeDecl -> NormTypeDecl
forall a b. (a -> b) -> a -> b
$
                      TypeName -> NormAPI -> Maybe NormTypeDecl
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TypeName
tname' NormAPI
api

    findDecl' :: NormTypeDecl -> UpdateDeclPos
    findDecl' :: NormTypeDecl -> UpdateDeclPos
findDecl' (NRecordType NormRecordType
flds) = Map FieldName (Maybe UpdateTypePos) -> UpdateDeclPos
UpdateRecord (Map FieldName (Maybe UpdateTypePos) -> UpdateDeclPos)
-> Map FieldName (Maybe UpdateTypePos) -> UpdateDeclPos
forall a b. (a -> b) -> a -> b
$ (APIType -> Maybe UpdateTypePos)
-> NormRecordType -> Map FieldName (Maybe UpdateTypePos)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap APIType -> Maybe UpdateTypePos
findType NormRecordType
flds
    findDecl' (NUnionType NormRecordType
alts)  = Map FieldName (Maybe UpdateTypePos) -> UpdateDeclPos
UpdateUnion  (Map FieldName (Maybe UpdateTypePos) -> UpdateDeclPos)
-> Map FieldName (Maybe UpdateTypePos) -> UpdateDeclPos
forall a b. (a -> b) -> a -> b
$ (APIType -> Maybe UpdateTypePos)
-> NormRecordType -> Map FieldName (Maybe UpdateTypePos)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap APIType -> Maybe UpdateTypePos
findType NormRecordType
alts
    findDecl' (NEnumType NormEnumType
_)      = String -> UpdateDeclPos
forall a. HasCallStack => String -> a
error String
"findDecl': unexpected enum"
    findDecl' (NTypeSynonym APIType
ty)  = UpdateTypePos -> UpdateDeclPos
UpdateType (UpdateTypePos -> UpdateDeclPos) -> UpdateTypePos -> UpdateDeclPos
forall a b. (a -> b) -> a -> b
$ UpdateTypePos -> Maybe UpdateTypePos -> UpdateTypePos
forall a. a -> Maybe a -> a
fromMaybe (String -> UpdateTypePos
forall a. HasCallStack => String -> a
error String
"findDecl': missing") (Maybe UpdateTypePos -> UpdateTypePos)
-> Maybe UpdateTypePos -> UpdateTypePos
forall a b. (a -> b) -> a -> b
$
                                                APIType -> Maybe UpdateTypePos
findType APIType
ty
    findDecl' (NNewtype BasicType
_)       = String -> UpdateDeclPos
forall a. HasCallStack => String -> a
error String
"findDecl': unexpected newtype"

    findType :: APIType -> Maybe UpdateTypePos
    findType :: APIType -> Maybe UpdateTypePos
findType (TyList APIType
ty)      = UpdateTypePos -> UpdateTypePos
UpdateList (UpdateTypePos -> UpdateTypePos)
-> Maybe UpdateTypePos -> Maybe UpdateTypePos
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> APIType -> Maybe UpdateTypePos
findType APIType
ty
    findType (TyMaybe APIType
ty)     = UpdateTypePos -> UpdateTypePos
UpdateMaybe (UpdateTypePos -> UpdateTypePos)
-> Maybe UpdateTypePos -> Maybe UpdateTypePos
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> APIType -> Maybe UpdateTypePos
findType APIType
ty
    findType (TyName TypeName
tname')
        | TypeName
tname' TypeName -> TypeName -> Bool
forall a. Eq a => a -> a -> Bool
== TypeName
tname Bool -> Bool -> Bool
|| TypeName
tname' TypeName -> Set TypeName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set TypeName
deps = UpdateTypePos -> Maybe UpdateTypePos
forall a. a -> Maybe a
Just (UpdateTypePos -> Maybe UpdateTypePos)
-> UpdateTypePos -> Maybe UpdateTypePos
forall a b. (a -> b) -> a -> b
$ TypeName -> UpdateTypePos
UpdateNamed TypeName
tname'
        | Bool
otherwise                                   = Maybe UpdateTypePos
forall a. Maybe a
Nothing
    findType (TyBasic BasicType
_)      = Maybe UpdateTypePos
forall a. Maybe a
Nothing
    findType APIType
TyJSON           = Maybe UpdateTypePos
forall a. Maybe a
Nothing


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

-- | 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 o v db rec fld -- ^ Custom migration functions
                -> TypeName                    -- ^ Name of the dataset's type
                -> DataChecks                  -- ^ How thoroughly to validate changes
                -> Either ValidateFailure [ValidateWarning]
validateChanges :: (API, Version)
-> (API, VersionExtra)
-> APIChangelog
-> CustomMigrations o v db rec fld
-> TypeName
-> DataChecks
-> Either ValidateFailure [MigrateWarning]
validateChanges (API
api,Version
ver) (API
api',VersionExtra
ver') APIChangelog
clog CustomMigrations o v db rec fld
custom TypeName
root DataChecks
chks = ([APITableChange], [MigrateWarning]) -> [MigrateWarning]
forall a b. (a, b) -> b
snd (([APITableChange], [MigrateWarning]) -> [MigrateWarning])
-> Either ValidateFailure ([APITableChange], [MigrateWarning])
-> Either ValidateFailure [MigrateWarning]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
  (API, Version)
-> (API, VersionExtra)
-> APIChangelog
-> CustomMigrationsTagged o v
-> TypeName
-> DataChecks
-> Either ValidateFailure ([APITableChange], [MigrateWarning])
forall o v.
(API, Version)
-> (API, VersionExtra)
-> APIChangelog
-> CustomMigrationsTagged o v
-> TypeName
-> DataChecks
-> Either ValidateFailure ([APITableChange], [MigrateWarning])
validateChanges' (API
api,Version
ver) (API
api',VersionExtra
ver') APIChangelog
clog (CustomMigrations o v db rec fld -> CustomMigrationsTagged o v
forall db ty fld o v.
(Read db, Read ty, Read fld) =>
CustomMigrations o v db ty fld -> CustomMigrationsTagged o v
readCustomMigrations CustomMigrations o v db rec fld
custom) TypeName
root DataChecks
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 o v -- ^ Custom migration functions
                 -> TypeName               -- ^ Name of the dataset's type
                 -> DataChecks             -- ^ How thoroughly to validate changes
                 -> Either ValidateFailure ([APITableChange], [ValidateWarning])
validateChanges' :: (API, Version)
-> (API, VersionExtra)
-> APIChangelog
-> CustomMigrationsTagged o v
-> TypeName
-> DataChecks
-> Either ValidateFailure ([APITableChange], [MigrateWarning])
validateChanges' (API
api,Version
ver) (API
api',VersionExtra
ver') APIChangelog
clog CustomMigrationsTagged o v
custom TypeName
root DataChecks
chks = do
  -- select changes by version from log
  ([APIChange]
changes, VersionExtra
verEnd) <- APIChangelog
-> VersionExtra
-> VersionExtra
-> Either ValidateFailure ([APIChange], VersionExtra)
selectChanges APIChangelog
clog (Version -> VersionExtra
Release Version
ver) VersionExtra
ver'
  -- take norm of start and end api,
  let apiStart :: NormAPI
apiStart  = API -> NormAPI
apiNormalForm API
api
      apiTarget :: NormAPI
apiTarget = API -> NormAPI
apiNormalForm API
api'
  -- check start and end APIs are well formed.
  NormAPI -> Either (Set TypeName) ()
apiInvariant NormAPI
apiStart  Either (Set TypeName) ()
-> (Set TypeName -> ValidateFailure) -> Either ValidateFailure ()
forall e a e'. Either e a -> (e -> e') -> Either e' a
?!? VersionExtra -> Set TypeName -> ValidateFailure
ApiInvalid (Version -> VersionExtra
Release Version
ver)
  NormAPI -> Either (Set TypeName) ()
apiInvariant NormAPI
apiTarget Either (Set TypeName) ()
-> (Set TypeName -> ValidateFailure) -> Either ValidateFailure ()
forall e a e'. Either e a -> (e -> e') -> Either e' a
?!? VersionExtra -> Set TypeName -> ValidateFailure
ApiInvalid VersionExtra
ver'
   -- check expected end api
  (NormAPI
apiEnd, [APITableChange]
changes') <- TypeName
-> CustomMigrationsTagged o v
-> DataChecks
-> [APIChange]
-> NormAPI
-> Either ValidateFailure (NormAPI, [APITableChange])
forall o v.
TypeName
-> CustomMigrationsTagged o v
-> DataChecks
-> [APIChange]
-> NormAPI
-> Either ValidateFailure (NormAPI, [APITableChange])
applyAPIChangesToAPI TypeName
root CustomMigrationsTagged o v
custom DataChecks
chks [APIChange]
changes NormAPI
apiStart
  -- check expected end api
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (NormAPI
apiEnd NormAPI -> NormAPI -> Bool
forall a. Eq a => a -> a -> Bool
== NormAPI
apiTarget) Maybe () -> ValidateFailure -> Either ValidateFailure ()
forall a e. Maybe a -> e -> Either e a
?! VersionExtra
-> VersionExtra
-> Map TypeName (MergeResult NormTypeDecl NormTypeDecl)
-> ValidateFailure
ChangelogIncomplete VersionExtra
verEnd VersionExtra
ver' (NormAPI
-> NormAPI -> Map TypeName (MergeResult NormTypeDecl NormTypeDecl)
forall a k.
(Eq a, Ord k) =>
Map k a -> Map k a -> Map k (MergeResult a a)
diffMaps NormAPI
apiEnd NormAPI
apiTarget)
  ([APITableChange], [MigrateWarning])
-> Either ValidateFailure ([APITableChange], [MigrateWarning])
forall (m :: * -> *) a. Monad m => a -> m a
return ([APITableChange]
changes', [])

selectChanges :: APIChangelog -> VersionExtra -> VersionExtra
              -> Either ValidateFailure ([APIChange], VersionExtra)
selectChanges :: APIChangelog
-> VersionExtra
-> VersionExtra
-> Either ValidateFailure ([APIChange], VersionExtra)
selectChanges APIChangelog
clog VersionExtra
ver VersionExtra
ver'
  | VersionExtra
ver' VersionExtra -> VersionExtra -> Bool
forall a. Eq a => a -> a -> Bool
== VersionExtra
ver = ([APIChange], VersionExtra)
-> Either ValidateFailure ([APIChange], VersionExtra)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], VersionExtra
ver')
  | VersionExtra
ver' VersionExtra -> VersionExtra -> Bool
forall a. Ord a => a -> a -> Bool
>  VersionExtra
ver = do
      APIChangelog -> Either (VersionExtra, VersionExtra) ()
isChangelogOrdered APIChangelog
clog Either (VersionExtra, VersionExtra) ()
-> ((VersionExtra, VersionExtra) -> ValidateFailure)
-> Either ValidateFailure ()
forall e a e'. Either e a -> (e -> e') -> Either e' a
?!? (VersionExtra -> VersionExtra -> ValidateFailure)
-> (VersionExtra, VersionExtra) -> ValidateFailure
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry VersionExtra -> VersionExtra -> ValidateFailure
ChangelogOutOfOrder
      let withinRange :: [(VersionExtra, VersionExtra, [APIChange])]
withinRange = ((VersionExtra, VersionExtra, [APIChange]) -> Bool)
-> [(VersionExtra, VersionExtra, [APIChange])]
-> [(VersionExtra, VersionExtra, [APIChange])]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\ (VersionExtra
_, VersionExtra
v, [APIChange]
_) -> VersionExtra
v VersionExtra -> VersionExtra -> Bool
forall a. Ord a => a -> a -> Bool
<= VersionExtra
ver') ([(VersionExtra, VersionExtra, [APIChange])]
 -> [(VersionExtra, VersionExtra, [APIChange])])
-> [(VersionExtra, VersionExtra, [APIChange])]
-> [(VersionExtra, VersionExtra, [APIChange])]
forall a b. (a -> b) -> a -> b
$
                            ((VersionExtra, VersionExtra, [APIChange]) -> Bool)
-> [(VersionExtra, VersionExtra, [APIChange])]
-> [(VersionExtra, VersionExtra, [APIChange])]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (\ (VersionExtra
_, VersionExtra
v, [APIChange]
_) -> VersionExtra
v VersionExtra -> VersionExtra -> Bool
forall a. Ord a => a -> a -> Bool
<= VersionExtra
ver) ([(VersionExtra, VersionExtra, [APIChange])]
 -> [(VersionExtra, VersionExtra, [APIChange])])
-> [(VersionExtra, VersionExtra, [APIChange])]
-> [(VersionExtra, VersionExtra, [APIChange])]
forall a b. (a -> b) -> a -> b
$
                                APIChangelog -> [(VersionExtra, VersionExtra, [APIChange])]
viewChangelogReverse APIChangelog
clog
          endVer :: VersionExtra
endVer = case [(VersionExtra, VersionExtra, [APIChange])]
-> Maybe (VersionExtra, VersionExtra, [APIChange])
forall a. [a] -> Maybe a
lastMay [(VersionExtra, VersionExtra, [APIChange])]
withinRange of
                     Maybe (VersionExtra, VersionExtra, [APIChange])
Nothing        -> VersionExtra
ver
                     Just (VersionExtra
_, VersionExtra
v, [APIChange]
_) -> VersionExtra
v
      ([APIChange], VersionExtra)
-> Either ValidateFailure ([APIChange], VersionExtra)
forall (m :: * -> *) a. Monad m => a -> m a
return ([ APIChange
c | (VersionExtra
_,VersionExtra
_, [APIChange]
cs) <- [(VersionExtra, VersionExtra, [APIChange])]
withinRange, APIChange
c <- [APIChange]
cs ], VersionExtra
endVer)

  | Bool
otherwise = ValidateFailure
-> Either ValidateFailure ([APIChange], VersionExtra)
forall a b. a -> Either a b
Left (VersionExtra -> VersionExtra -> ValidateFailure
CannotDowngrade VersionExtra
ver VersionExtra
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 o v -> DataChecks
                     -> [APIChange] -> NormAPI
                     -> Either ValidateFailure (NormAPI, [APITableChange])
applyAPIChangesToAPI :: TypeName
-> CustomMigrationsTagged o v
-> DataChecks
-> [APIChange]
-> NormAPI
-> Either ValidateFailure (NormAPI, [APITableChange])
applyAPIChangesToAPI TypeName
root CustomMigrationsTagged o v
custom DataChecks
chks [APIChange]
changes NormAPI
api = do
    (NormAPI
api', [APITableChange]
changes') <- ((NormAPI, [APITableChange])
 -> APIChange -> Either ValidateFailure (NormAPI, [APITableChange]))
-> (NormAPI, [APITableChange])
-> [APIChange]
-> Either ValidateFailure (NormAPI, [APITableChange])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (TypeName
-> CustomMigrationsTagged o v
-> DataChecks
-> (NormAPI, [APITableChange])
-> APIChange
-> Either ValidateFailure (NormAPI, [APITableChange])
forall o v.
TypeName
-> CustomMigrationsTagged o v
-> DataChecks
-> (NormAPI, [APITableChange])
-> APIChange
-> Either ValidateFailure (NormAPI, [APITableChange])
doChangeAPI TypeName
root CustomMigrationsTagged o v
custom DataChecks
chks) (NormAPI
api, []) [APIChange]
changes
    let changes'' :: [APITableChange]
changes'' | DataChecks
chks DataChecks -> DataChecks -> Bool
forall a. Ord a => a -> a -> Bool
>= DataChecks
CheckStartAndEnd = NormAPI -> [APITableChange] -> [APITableChange]
addV NormAPI
api ([APITableChange] -> [APITableChange])
-> [APITableChange] -> [APITableChange]
forall a b. (a -> b) -> a -> b
$ [APITableChange] -> [APITableChange]
forall a. [a] -> [a]
reverse ([APITableChange] -> [APITableChange])
-> [APITableChange] -> [APITableChange]
forall a b. (a -> b) -> a -> b
$ NormAPI -> [APITableChange] -> [APITableChange]
addV NormAPI
api' [APITableChange]
changes'
                  | Bool
otherwise                = [APITableChange] -> [APITableChange]
forall a. [a] -> [a]
reverse [APITableChange]
changes'
    (NormAPI, [APITableChange])
-> Either ValidateFailure (NormAPI, [APITableChange])
forall (m :: * -> *) a. Monad m => a -> m a
return (NormAPI
api', [APITableChange]
changes'')
  where
    addV :: NormAPI -> [APITableChange] -> [APITableChange]
addV NormAPI
_ cs :: [APITableChange]
cs@(ValidateData NormAPI
_ : [APITableChange]
_) = [APITableChange]
cs
    addV NormAPI
a [APITableChange]
cs                      = NormAPI -> APITableChange
ValidateData NormAPI
a APITableChange -> [APITableChange] -> [APITableChange]
forall a. a -> [a] -> [a]
: [APITableChange]
cs

-- | Apply the API change
doChangeAPI :: TypeName -> CustomMigrationsTagged o v -> DataChecks
            -> (NormAPI, [APITableChange]) -> APIChange
            -> Either ValidateFailure (NormAPI, [APITableChange])
doChangeAPI :: TypeName
-> CustomMigrationsTagged o v
-> DataChecks
-> (NormAPI, [APITableChange])
-> APIChange
-> Either ValidateFailure (NormAPI, [APITableChange])
doChangeAPI TypeName
root CustomMigrationsTagged o v
custom DataChecks
chks (NormAPI
api, [APITableChange]
changes) APIChange
change = do
    (NormAPI
api', Map TypeName UpdateDeclPos
pos) <- TypeName
-> CustomMigrationsTagged o v
-> APIChange
-> NormAPI
-> Either ApplyFailure (NormAPI, Map TypeName UpdateDeclPos)
forall o v.
TypeName
-> CustomMigrationsTagged o v
-> APIChange
-> NormAPI
-> Either ApplyFailure (NormAPI, Map TypeName UpdateDeclPos)
applyAPIChangeToAPI TypeName
root CustomMigrationsTagged o v
custom APIChange
change NormAPI
api
                       Either ApplyFailure (NormAPI, Map TypeName UpdateDeclPos)
-> (ApplyFailure -> ValidateFailure)
-> Either ValidateFailure (NormAPI, Map TypeName UpdateDeclPos)
forall e a e'. Either e a -> (e -> e') -> Either e' a
?!? [APITableChange] -> APIChange -> ApplyFailure -> ValidateFailure
ChangelogEntryInvalid [APITableChange]
changes APIChange
change
    let changes' :: [APITableChange]
changes' = NormAPI
-> APIChange -> Map TypeName UpdateDeclPos -> APITableChange
APIChange NormAPI
api APIChange
change Map TypeName UpdateDeclPos
pos APITableChange -> [APITableChange] -> [APITableChange]
forall a. a -> [a] -> [a]
: [APITableChange]
changes
        changes'' :: [APITableChange]
changes'' | DataChecks -> APIChange -> Bool
validateAfter DataChecks
chks APIChange
change = NormAPI -> APITableChange
ValidateData NormAPI
api' APITableChange -> [APITableChange] -> [APITableChange]
forall a. a -> [a] -> [a]
: [APITableChange]
changes'
                  | Bool
otherwise                 = [APITableChange]
changes'
    (NormAPI, [APITableChange])
-> Either ValidateFailure (NormAPI, [APITableChange])
forall (m :: * -> *) a. Monad m => a -> m a
return (NormAPI
api', [APITableChange]
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 o v -> APIChange -> NormAPI
                    -> Either ApplyFailure (NormAPI, Map TypeName UpdateDeclPos)

applyAPIChangeToAPI :: TypeName
-> CustomMigrationsTagged o v
-> APIChange
-> NormAPI
-> Either ApplyFailure (NormAPI, Map TypeName UpdateDeclPos)
applyAPIChangeToAPI TypeName
_ CustomMigrationsTagged o v
_ (ChAddType TypeName
tname NormTypeDecl
tdecl) NormAPI
api = do
  -- to add a new type, that type must not yet exist
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (TypeName
tname TypeName -> NormAPI -> Bool
`typeDeclaredInApi` NormAPI
api))   Maybe () -> ApplyFailure -> Either ApplyFailure ()
forall a e. Maybe a -> e -> Either e a
?! TypeName -> ApplyFailure
TypeExists TypeName
tname
  NormTypeDecl -> NormAPI -> Either (Set TypeName) ()
declIsValid NormTypeDecl
tdecl NormAPI
api                         Either (Set TypeName) ()
-> (Set TypeName -> ApplyFailure) -> Either ApplyFailure ()
forall e a e'. Either e a -> (e -> e') -> Either e' a
?!? TypeName -> NormTypeDecl -> Set TypeName -> ApplyFailure
DeclMalformed TypeName
tname NormTypeDecl
tdecl
  (NormAPI, Map TypeName UpdateDeclPos)
-> Either ApplyFailure (NormAPI, Map TypeName UpdateDeclPos)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeName -> NormTypeDecl -> NormAPI -> NormAPI
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TypeName
tname NormTypeDecl
tdecl NormAPI
api, Map TypeName UpdateDeclPos
forall k a. Map k a
Map.empty)

applyAPIChangeToAPI TypeName
_ CustomMigrationsTagged o v
_ (ChDeleteType TypeName
tname) NormAPI
api = do
  -- to delete a type, that type must exist
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (TypeName
tname TypeName -> NormAPI -> Bool
`typeDeclaredInApi` NormAPI
api)         Maybe () -> ApplyFailure -> Either ApplyFailure ()
forall a e. Maybe a -> e -> Either e a
?! TypeName -> ApplyFailure
TypeDoesNotExist TypeName
tname
  -- it must also not be used anywhere else in the API
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (TypeName
tname TypeName -> NormAPI -> Bool
`typeUsedInApi` NormAPI
api))       Maybe () -> ApplyFailure -> Either ApplyFailure ()
forall a e. Maybe a -> e -> Either e a
?! TypeName -> ApplyFailure
TypeInUse TypeName
tname
  (NormAPI, Map TypeName UpdateDeclPos)
-> Either ApplyFailure (NormAPI, Map TypeName UpdateDeclPos)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeName -> NormAPI -> NormAPI
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete TypeName
tname NormAPI
api, Map TypeName UpdateDeclPos
forall k a. Map k a
Map.empty)

applyAPIChangeToAPI TypeName
_ CustomMigrationsTagged o v
_ (ChRenameType TypeName
tname TypeName
tname') NormAPI
api = do
  -- to rename a type, the original type name must exist
  -- and the new one must not yet exist
  NormTypeDecl
tinfo <- TypeName -> NormAPI -> Either ApplyFailure NormTypeDecl
lookupType TypeName
tname NormAPI
api
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (TypeName
tname' TypeName -> NormAPI -> Bool
`typeDeclaredInApi` NormAPI
api))  Maybe () -> ApplyFailure -> Either ApplyFailure ()
forall a e. Maybe a -> e -> Either e a
?! TypeName -> ApplyFailure
TypeExists TypeName
tname'
  (NormAPI, Map TypeName UpdateDeclPos)
-> Either ApplyFailure (NormAPI, Map TypeName UpdateDeclPos)
forall (m :: * -> *) a. Monad m => a -> m a
return ( (TypeName -> TypeName -> NormAPI -> NormAPI
renameTypeUses TypeName
tname TypeName
tname'
            (NormAPI -> NormAPI) -> (NormAPI -> NormAPI) -> NormAPI -> NormAPI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeName -> NormTypeDecl -> NormAPI -> NormAPI
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TypeName
tname' NormTypeDecl
tinfo (NormAPI -> NormAPI) -> (NormAPI -> NormAPI) -> NormAPI -> NormAPI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeName -> NormAPI -> NormAPI
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete TypeName
tname) NormAPI
api
         , Map TypeName UpdateDeclPos
forall k a. Map k a
Map.empty )

applyAPIChangeToAPI TypeName
_ CustomMigrationsTagged o v
custom (ChCustomType TypeName
tname String
tag) NormAPI
api = do
  -- to make some change to values of a type, the type name must exist
  NormTypeDecl
tinfo  <- TypeName -> NormAPI -> Either ApplyFailure NormTypeDecl
lookupType TypeName
tname NormAPI
api
  Maybe NormTypeDecl
mb_tinfo' <- CustomMigrationsTagged o v
-> String
-> NormTypeDecl
-> Either ApplyFailure (Maybe NormTypeDecl)
forall o v db ty fld.
CustomMigrations o v db ty fld
-> ty -> NormTypeDecl -> Either ApplyFailure (Maybe NormTypeDecl)
typeMigrationSchema CustomMigrationsTagged o v
custom String
tag NormTypeDecl
tinfo
  let api' :: NormAPI
api' = case Maybe NormTypeDecl
mb_tinfo' of
                 Just NormTypeDecl
tinfo' -> TypeName -> NormTypeDecl -> NormAPI -> NormAPI
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TypeName
tname NormTypeDecl
tinfo' NormAPI
api
                 Maybe NormTypeDecl
Nothing     -> NormAPI
api
  (NormAPI, Map TypeName UpdateDeclPos)
-> Either ApplyFailure (NormAPI, Map TypeName UpdateDeclPos)
forall (m :: * -> *) a. Monad m => a -> m a
return (NormAPI
api', TypeName -> NormAPI -> Map TypeName UpdateDeclPos
findUpdatePos TypeName
tname NormAPI
api)

applyAPIChangeToAPI TypeName
root CustomMigrationsTagged o v
_ (ChAddField TypeName
tname FieldName
fname APIType
ftype Maybe DefaultValue
mb_defval) NormAPI
api = do
  NormTypeDecl
tinfo   <- TypeName -> NormAPI -> Either ApplyFailure NormTypeDecl
lookupType TypeName
tname NormAPI
api
  NormRecordType
recinfo <- NormTypeDecl -> Maybe NormRecordType
expectRecordType NormTypeDecl
tinfo                Maybe NormRecordType
-> ApplyFailure -> Either ApplyFailure NormRecordType
forall a e. Maybe a -> e -> Either e a
?! TypeName -> TypeKind -> ApplyFailure
TypeWrongKind TypeName
tname TypeKind
TKRecord
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (FieldName -> NormRecordType -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member FieldName
fname NormRecordType
recinfo))           Maybe () -> ApplyFailure -> Either ApplyFailure ()
forall a e. Maybe a -> e -> Either e a
?! TypeName -> TypeKind -> FieldName -> ApplyFailure
FieldExists TypeName
tname TypeKind
TKRecord FieldName
fname
  APIType -> NormAPI -> Either (Set TypeName) ()
typeIsValid APIType
ftype NormAPI
api                            Either (Set TypeName) ()
-> (Set TypeName -> ApplyFailure) -> Either ApplyFailure ()
forall e a e'. Either e a -> (e -> e') -> Either e' a
?!? APIType -> Set TypeName -> ApplyFailure
TypeMalformed APIType
ftype
  case Maybe DefaultValue
mb_defval Maybe DefaultValue -> Maybe DefaultValue -> Maybe DefaultValue
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> APIType -> Maybe DefaultValue
defaultValueForType APIType
ftype of
    Just DefaultValue
defval -> Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (NormAPI -> APIType -> DefaultValue -> Bool
compatibleDefaultValue NormAPI
api APIType
ftype DefaultValue
defval)
                                                   Maybe () -> ApplyFailure -> Either ApplyFailure ()
forall a e. Maybe a -> e -> Either e a
?! TypeName -> FieldName -> APIType -> DefaultValue -> ApplyFailure
FieldBadDefaultValue TypeName
tname FieldName
fname APIType
ftype DefaultValue
defval
    Maybe DefaultValue
Nothing     -> Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (TypeName -> TypeName -> NormAPI -> Bool
typeUsedInTransitiveDep TypeName
root TypeName
tname NormAPI
api))
                                                   Maybe () -> ApplyFailure -> Either ApplyFailure ()
forall a e. Maybe a -> e -> Either e a
?! TypeName -> FieldName -> ApplyFailure
DefaultMissing TypeName
tname FieldName
fname
  let tinfo' :: NormTypeDecl
tinfo' = NormRecordType -> NormTypeDecl
NRecordType (FieldName -> APIType -> NormRecordType -> NormRecordType
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert FieldName
fname APIType
ftype NormRecordType
recinfo)
  (NormAPI, Map TypeName UpdateDeclPos)
-> Either ApplyFailure (NormAPI, Map TypeName UpdateDeclPos)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeName -> NormTypeDecl -> NormAPI -> NormAPI
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TypeName
tname NormTypeDecl
tinfo' NormAPI
api, TypeName -> NormAPI -> Map TypeName UpdateDeclPos
findUpdatePos TypeName
tname NormAPI
api)

applyAPIChangeToAPI TypeName
_ CustomMigrationsTagged o v
_ (ChDeleteField TypeName
tname FieldName
fname) NormAPI
api = do
  NormTypeDecl
tinfo   <- TypeName -> NormAPI -> Either ApplyFailure NormTypeDecl
lookupType TypeName
tname NormAPI
api
  NormRecordType
recinfo <- NormTypeDecl -> Maybe NormRecordType
expectRecordType NormTypeDecl
tinfo        Maybe NormRecordType
-> ApplyFailure -> Either ApplyFailure NormRecordType
forall a e. Maybe a -> e -> Either e a
?! TypeName -> TypeKind -> ApplyFailure
TypeWrongKind TypeName
tname TypeKind
TKRecord
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (FieldName -> NormRecordType -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member FieldName
fname NormRecordType
recinfo)         Maybe () -> ApplyFailure -> Either ApplyFailure ()
forall a e. Maybe a -> e -> Either e a
?! TypeName -> TypeKind -> FieldName -> ApplyFailure
FieldDoesNotExist TypeName
tname TypeKind
TKRecord FieldName
fname
  let tinfo' :: NormTypeDecl
tinfo' = NormRecordType -> NormTypeDecl
NRecordType (FieldName -> NormRecordType -> NormRecordType
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete FieldName
fname NormRecordType
recinfo)
  (NormAPI, Map TypeName UpdateDeclPos)
-> Either ApplyFailure (NormAPI, Map TypeName UpdateDeclPos)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeName -> NormTypeDecl -> NormAPI -> NormAPI
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TypeName
tname NormTypeDecl
tinfo' NormAPI
api, TypeName -> NormAPI -> Map TypeName UpdateDeclPos
findUpdatePos TypeName
tname NormAPI
api)

applyAPIChangeToAPI TypeName
_ CustomMigrationsTagged o v
_ (ChRenameField TypeName
tname FieldName
fname FieldName
fname') NormAPI
api = do
  NormTypeDecl
tinfo   <- TypeName -> NormAPI -> Either ApplyFailure NormTypeDecl
lookupType TypeName
tname NormAPI
api
  NormRecordType
recinfo <- NormTypeDecl -> Maybe NormRecordType
expectRecordType NormTypeDecl
tinfo        Maybe NormRecordType
-> ApplyFailure -> Either ApplyFailure NormRecordType
forall a e. Maybe a -> e -> Either e a
?! TypeName -> TypeKind -> ApplyFailure
TypeWrongKind TypeName
tname TypeKind
TKRecord
  APIType
ftype   <- FieldName -> NormRecordType -> Maybe APIType
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FieldName
fname NormRecordType
recinfo      Maybe APIType -> ApplyFailure -> Either ApplyFailure APIType
forall a e. Maybe a -> e -> Either e a
?! TypeName -> TypeKind -> FieldName -> ApplyFailure
FieldDoesNotExist TypeName
tname TypeKind
TKRecord FieldName
fname
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (FieldName -> NormRecordType -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member FieldName
fname' NormRecordType
recinfo))  Maybe () -> ApplyFailure -> Either ApplyFailure ()
forall a e. Maybe a -> e -> Either e a
?! TypeName -> TypeKind -> FieldName -> ApplyFailure
FieldExists TypeName
tname TypeKind
TKRecord FieldName
fname'
  let tinfo' :: NormTypeDecl
tinfo' = (NormRecordType -> NormTypeDecl
NRecordType (NormRecordType -> NormTypeDecl)
-> (NormRecordType -> NormRecordType)
-> NormRecordType
-> NormTypeDecl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> APIType -> NormRecordType -> NormRecordType
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert FieldName
fname' APIType
ftype
                            (NormRecordType -> NormRecordType)
-> (NormRecordType -> NormRecordType)
-> NormRecordType
-> NormRecordType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> NormRecordType -> NormRecordType
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete FieldName
fname) NormRecordType
recinfo
  (NormAPI, Map TypeName UpdateDeclPos)
-> Either ApplyFailure (NormAPI, Map TypeName UpdateDeclPos)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeName -> NormTypeDecl -> NormAPI -> NormAPI
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TypeName
tname NormTypeDecl
tinfo' NormAPI
api, TypeName -> NormAPI -> Map TypeName UpdateDeclPos
findUpdatePos TypeName
tname NormAPI
api)

applyAPIChangeToAPI TypeName
_ CustomMigrationsTagged o v
_ (ChChangeField TypeName
tname FieldName
fname APIType
ftype String
_) NormAPI
api = do
  NormTypeDecl
tinfo   <- TypeName -> NormAPI -> Either ApplyFailure NormTypeDecl
lookupType TypeName
tname NormAPI
api
  NormRecordType
recinfo <- NormTypeDecl -> Maybe NormRecordType
expectRecordType NormTypeDecl
tinfo        Maybe NormRecordType
-> ApplyFailure -> Either ApplyFailure NormRecordType
forall a e. Maybe a -> e -> Either e a
?! TypeName -> TypeKind -> ApplyFailure
TypeWrongKind TypeName
tname TypeKind
TKRecord
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (FieldName -> NormRecordType -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member FieldName
fname NormRecordType
recinfo)         Maybe () -> ApplyFailure -> Either ApplyFailure ()
forall a e. Maybe a -> e -> Either e a
?! TypeName -> TypeKind -> FieldName -> ApplyFailure
FieldDoesNotExist TypeName
tname TypeKind
TKRecord FieldName
fname
  let tinfo' :: NormTypeDecl
tinfo' = (NormRecordType -> NormTypeDecl
NRecordType (NormRecordType -> NormTypeDecl)
-> (NormRecordType -> NormRecordType)
-> NormRecordType
-> NormTypeDecl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> APIType -> NormRecordType -> NormRecordType
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert FieldName
fname APIType
ftype) NormRecordType
recinfo
  (NormAPI, Map TypeName UpdateDeclPos)
-> Either ApplyFailure (NormAPI, Map TypeName UpdateDeclPos)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeName -> NormTypeDecl -> NormAPI -> NormAPI
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TypeName
tname NormTypeDecl
tinfo' NormAPI
api, TypeName -> NormAPI -> Map TypeName UpdateDeclPos
findUpdatePos TypeName
tname NormAPI
api)

applyAPIChangeToAPI TypeName
_ CustomMigrationsTagged o v
_ (ChAddUnionAlt TypeName
tname FieldName
fname APIType
ftype) NormAPI
api = do
  NormTypeDecl
tinfo     <- TypeName -> NormAPI -> Either ApplyFailure NormTypeDecl
lookupType TypeName
tname NormAPI
api
  NormRecordType
unioninfo <- NormTypeDecl -> Maybe NormRecordType
expectUnionType NormTypeDecl
tinfo               Maybe NormRecordType
-> ApplyFailure -> Either ApplyFailure NormRecordType
forall a e. Maybe a -> e -> Either e a
?! TypeName -> TypeKind -> ApplyFailure
TypeWrongKind TypeName
tname TypeKind
TKUnion
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (FieldName -> NormRecordType -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member FieldName
fname NormRecordType
unioninfo))         Maybe () -> ApplyFailure -> Either ApplyFailure ()
forall a e. Maybe a -> e -> Either e a
?! TypeName -> TypeKind -> FieldName -> ApplyFailure
FieldExists TypeName
tname TypeKind
TKUnion FieldName
fname
  APIType -> NormAPI -> Either (Set TypeName) ()
typeIsValid APIType
ftype NormAPI
api                            Either (Set TypeName) ()
-> (Set TypeName -> ApplyFailure) -> Either ApplyFailure ()
forall e a e'. Either e a -> (e -> e') -> Either e' a
?!? APIType -> Set TypeName -> ApplyFailure
TypeMalformed APIType
ftype
  let tinfo' :: NormTypeDecl
tinfo' = NormRecordType -> NormTypeDecl
NUnionType (FieldName -> APIType -> NormRecordType -> NormRecordType
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert FieldName
fname APIType
ftype NormRecordType
unioninfo)
  (NormAPI, Map TypeName UpdateDeclPos)
-> Either ApplyFailure (NormAPI, Map TypeName UpdateDeclPos)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeName -> NormTypeDecl -> NormAPI -> NormAPI
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TypeName
tname NormTypeDecl
tinfo' NormAPI
api, Map TypeName UpdateDeclPos
forall k a. Map k a
Map.empty)

applyAPIChangeToAPI TypeName
root CustomMigrationsTagged o v
_ (ChDeleteUnionAlt TypeName
tname FieldName
fname) NormAPI
api = do
  NormTypeDecl
tinfo     <- TypeName -> NormAPI -> Either ApplyFailure NormTypeDecl
lookupType TypeName
tname NormAPI
api
  NormRecordType
unioninfo <- NormTypeDecl -> Maybe NormRecordType
expectUnionType NormTypeDecl
tinfo         Maybe NormRecordType
-> ApplyFailure -> Either ApplyFailure NormRecordType
forall a e. Maybe a -> e -> Either e a
?! TypeName -> TypeKind -> ApplyFailure
TypeWrongKind TypeName
tname TypeKind
TKUnion
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (TypeName -> TypeName -> NormAPI -> Bool
typeUsedInTransitiveDep TypeName
root TypeName
tname NormAPI
api)) Maybe () -> ApplyFailure -> Either ApplyFailure ()
forall a e. Maybe a -> e -> Either e a
?! TypeName -> ApplyFailure
TypeInUse TypeName
tname
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (FieldName -> NormRecordType -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member FieldName
fname NormRecordType
unioninfo)         Maybe () -> ApplyFailure -> Either ApplyFailure ()
forall a e. Maybe a -> e -> Either e a
?! TypeName -> TypeKind -> FieldName -> ApplyFailure
FieldDoesNotExist TypeName
tname TypeKind
TKUnion FieldName
fname
  let tinfo' :: NormTypeDecl
tinfo' = NormRecordType -> NormTypeDecl
NUnionType (FieldName -> NormRecordType -> NormRecordType
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete FieldName
fname NormRecordType
unioninfo)
  (NormAPI, Map TypeName UpdateDeclPos)
-> Either ApplyFailure (NormAPI, Map TypeName UpdateDeclPos)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeName -> NormTypeDecl -> NormAPI -> NormAPI
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TypeName
tname NormTypeDecl
tinfo' NormAPI
api, Map TypeName UpdateDeclPos
forall k a. Map k a
Map.empty)

applyAPIChangeToAPI TypeName
_ CustomMigrationsTagged o v
_ (ChRenameUnionAlt TypeName
tname FieldName
fname FieldName
fname') NormAPI
api = do
  NormTypeDecl
tinfo     <- TypeName -> NormAPI -> Either ApplyFailure NormTypeDecl
lookupType TypeName
tname NormAPI
api
  NormRecordType
unioninfo <- NormTypeDecl -> Maybe NormRecordType
expectUnionType NormTypeDecl
tinfo        Maybe NormRecordType
-> ApplyFailure -> Either ApplyFailure NormRecordType
forall a e. Maybe a -> e -> Either e a
?! TypeName -> TypeKind -> ApplyFailure
TypeWrongKind TypeName
tname TypeKind
TKUnion
  APIType
ftype     <- FieldName -> NormRecordType -> Maybe APIType
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FieldName
fname NormRecordType
unioninfo   Maybe APIType -> ApplyFailure -> Either ApplyFailure APIType
forall a e. Maybe a -> e -> Either e a
?! TypeName -> TypeKind -> FieldName -> ApplyFailure
FieldDoesNotExist TypeName
tname TypeKind
TKUnion FieldName
fname
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (FieldName -> NormRecordType -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member FieldName
fname' NormRecordType
unioninfo)) Maybe () -> ApplyFailure -> Either ApplyFailure ()
forall a e. Maybe a -> e -> Either e a
?! TypeName -> TypeKind -> FieldName -> ApplyFailure
FieldExists TypeName
tname TypeKind
TKUnion FieldName
fname'
  let tinfo' :: NormTypeDecl
tinfo' = (NormRecordType -> NormTypeDecl
NUnionType (NormRecordType -> NormTypeDecl)
-> (NormRecordType -> NormRecordType)
-> NormRecordType
-> NormTypeDecl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> APIType -> NormRecordType -> NormRecordType
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert FieldName
fname' APIType
ftype
                           (NormRecordType -> NormRecordType)
-> (NormRecordType -> NormRecordType)
-> NormRecordType
-> NormRecordType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> NormRecordType -> NormRecordType
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete FieldName
fname) NormRecordType
unioninfo
  (NormAPI, Map TypeName UpdateDeclPos)
-> Either ApplyFailure (NormAPI, Map TypeName UpdateDeclPos)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeName -> NormTypeDecl -> NormAPI -> NormAPI
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TypeName
tname NormTypeDecl
tinfo' NormAPI
api, TypeName -> NormAPI -> Map TypeName UpdateDeclPos
findUpdatePos TypeName
tname NormAPI
api)

applyAPIChangeToAPI TypeName
_ CustomMigrationsTagged o v
_ (ChAddEnumVal TypeName
tname FieldName
fname) NormAPI
api = do
  NormTypeDecl
tinfo    <- TypeName -> NormAPI -> Either ApplyFailure NormTypeDecl
lookupType TypeName
tname NormAPI
api
  NormEnumType
enuminfo <- NormTypeDecl -> Maybe NormEnumType
expectEnumType NormTypeDecl
tinfo                 Maybe NormEnumType
-> ApplyFailure -> Either ApplyFailure NormEnumType
forall a e. Maybe a -> e -> Either e a
?! TypeName -> TypeKind -> ApplyFailure
TypeWrongKind TypeName
tname TypeKind
TKEnum
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (FieldName -> NormEnumType -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member FieldName
fname NormEnumType
enuminfo))          Maybe () -> ApplyFailure -> Either ApplyFailure ()
forall a e. Maybe a -> e -> Either e a
?! TypeName -> TypeKind -> FieldName -> ApplyFailure
FieldExists TypeName
tname TypeKind
TKEnum FieldName
fname
  let tinfo' :: NormTypeDecl
tinfo' = NormEnumType -> NormTypeDecl
NEnumType (FieldName -> NormEnumType -> NormEnumType
forall a. Ord a => a -> Set a -> Set a
Set.insert FieldName
fname NormEnumType
enuminfo)
  (NormAPI, Map TypeName UpdateDeclPos)
-> Either ApplyFailure (NormAPI, Map TypeName UpdateDeclPos)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeName -> NormTypeDecl -> NormAPI -> NormAPI
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TypeName
tname NormTypeDecl
tinfo' NormAPI
api, Map TypeName UpdateDeclPos
forall k a. Map k a
Map.empty)

applyAPIChangeToAPI TypeName
root CustomMigrationsTagged o v
_ (ChDeleteEnumVal TypeName
tname FieldName
fname) NormAPI
api = do
  NormTypeDecl
tinfo    <- TypeName -> NormAPI -> Either ApplyFailure NormTypeDecl
lookupType TypeName
tname NormAPI
api
  NormEnumType
enuminfo <- NormTypeDecl -> Maybe NormEnumType
expectEnumType NormTypeDecl
tinfo          Maybe NormEnumType
-> ApplyFailure -> Either ApplyFailure NormEnumType
forall a e. Maybe a -> e -> Either e a
?! TypeName -> TypeKind -> ApplyFailure
TypeWrongKind TypeName
tname TypeKind
TKEnum
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (TypeName -> TypeName -> NormAPI -> Bool
typeUsedInTransitiveDep TypeName
root TypeName
tname NormAPI
api)) Maybe () -> ApplyFailure -> Either ApplyFailure ()
forall a e. Maybe a -> e -> Either e a
?! TypeName -> ApplyFailure
TypeInUse TypeName
tname
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (FieldName -> NormEnumType -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member FieldName
fname NormEnumType
enuminfo)         Maybe () -> ApplyFailure -> Either ApplyFailure ()
forall a e. Maybe a -> e -> Either e a
?! TypeName -> TypeKind -> FieldName -> ApplyFailure
FieldDoesNotExist TypeName
tname TypeKind
TKEnum FieldName
fname
  let tinfo' :: NormTypeDecl
tinfo' = NormEnumType -> NormTypeDecl
NEnumType (FieldName -> NormEnumType -> NormEnumType
forall a. Ord a => a -> Set a -> Set a
Set.delete FieldName
fname NormEnumType
enuminfo)
  (NormAPI, Map TypeName UpdateDeclPos)
-> Either ApplyFailure (NormAPI, Map TypeName UpdateDeclPos)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeName -> NormTypeDecl -> NormAPI -> NormAPI
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TypeName
tname NormTypeDecl
tinfo' NormAPI
api, Map TypeName UpdateDeclPos
forall k a. Map k a
Map.empty)

applyAPIChangeToAPI TypeName
_ CustomMigrationsTagged o v
_ (ChRenameEnumVal TypeName
tname FieldName
fname FieldName
fname') NormAPI
api = do
  NormTypeDecl
tinfo     <- TypeName -> NormAPI -> Either ApplyFailure NormTypeDecl
lookupType TypeName
tname NormAPI
api
  NormEnumType
enuminfo <- NormTypeDecl -> Maybe NormEnumType
expectEnumType NormTypeDecl
tinfo         Maybe NormEnumType
-> ApplyFailure -> Either ApplyFailure NormEnumType
forall a e. Maybe a -> e -> Either e a
?! TypeName -> TypeKind -> ApplyFailure
TypeWrongKind TypeName
tname TypeKind
TKEnum
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (FieldName -> NormEnumType -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member FieldName
fname NormEnumType
enuminfo)        Maybe () -> ApplyFailure -> Either ApplyFailure ()
forall a e. Maybe a -> e -> Either e a
?! TypeName -> TypeKind -> FieldName -> ApplyFailure
FieldDoesNotExist TypeName
tname TypeKind
TKEnum FieldName
fname
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (FieldName -> NormEnumType -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member FieldName
fname' NormEnumType
enuminfo)) Maybe () -> ApplyFailure -> Either ApplyFailure ()
forall a e. Maybe a -> e -> Either e a
?! TypeName -> TypeKind -> FieldName -> ApplyFailure
FieldExists TypeName
tname TypeKind
TKEnum FieldName
fname'
  let tinfo' :: NormTypeDecl
tinfo' = (NormEnumType -> NormTypeDecl
NEnumType (NormEnumType -> NormTypeDecl)
-> (NormEnumType -> NormEnumType) -> NormEnumType -> NormTypeDecl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> NormEnumType -> NormEnumType
forall a. Ord a => a -> Set a -> Set a
Set.insert FieldName
fname'
                          (NormEnumType -> NormEnumType)
-> (NormEnumType -> NormEnumType) -> NormEnumType -> NormEnumType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> NormEnumType -> NormEnumType
forall a. Ord a => a -> Set a -> Set a
Set.delete FieldName
fname) NormEnumType
enuminfo
  (NormAPI, Map TypeName UpdateDeclPos)
-> Either ApplyFailure (NormAPI, Map TypeName UpdateDeclPos)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeName -> NormTypeDecl -> NormAPI -> NormAPI
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TypeName
tname NormTypeDecl
tinfo' NormAPI
api, TypeName -> NormAPI -> Map TypeName UpdateDeclPos
findUpdatePos TypeName
tname NormAPI
api)

applyAPIChangeToAPI TypeName
root CustomMigrationsTagged o v
custom (ChCustomAll String
tag) NormAPI
api = do
  Maybe NormAPI
mb_api' <- CustomMigrationsTagged o v
-> String -> NormAPI -> Either ApplyFailure (Maybe NormAPI)
forall o v db ty fld.
CustomMigrations o v db ty fld
-> db -> NormAPI -> Either ApplyFailure (Maybe NormAPI)
databaseMigrationSchema CustomMigrationsTagged o v
custom String
tag NormAPI
api
  (NormAPI, Map TypeName UpdateDeclPos)
-> Either ApplyFailure (NormAPI, Map TypeName UpdateDeclPos)
forall (m :: * -> *) a. Monad m => a -> m a
return ( NormAPI -> Maybe NormAPI -> NormAPI
forall a. a -> Maybe a -> a
fromMaybe NormAPI
api Maybe NormAPI
mb_api'
         , TypeName -> UpdateDeclPos -> Map TypeName UpdateDeclPos
forall k a. k -> a -> Map k a
Map.singleton TypeName
root (Maybe UpdateDeclPos -> UpdateDeclPos
UpdateHere Maybe UpdateDeclPos
forall a. Maybe a
Nothing))


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

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

expectEnumType :: NormTypeDecl -> Maybe (Set FieldName)
expectEnumType :: NormTypeDecl -> Maybe NormEnumType
expectEnumType (NEnumType NormEnumType
rinfo) = NormEnumType -> Maybe NormEnumType
forall a. a -> Maybe a
Just NormEnumType
rinfo
expectEnumType NormTypeDecl
_                 = Maybe NormEnumType
forall a. Maybe a
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.Object JS.Value
                       -> JS.Value -> [APITableChange]
                       -> Either (ValueError, Position) JS.Value
applyChangesToDatabase :: TypeName
-> CustomMigrationsTagged Object Value
-> Value
-> [APITableChange]
-> Either (ValueError, Position) Value
applyChangesToDatabase TypeName
root CustomMigrationsTagged Object Value
custom = (Value -> APITableChange -> Either (ValueError, Position) Value)
-> Value -> [APITableChange] -> Either (ValueError, Position) Value
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (TypeName
-> CustomMigrationsTagged Object Value
-> Value
-> APITableChange
-> Either (ValueError, Position) Value
applyChangeToDatabase TypeName
root CustomMigrationsTagged Object Value
custom)
  -- just apply each of the individual changes in sequence to the whole dataset

applyChangeToDatabase :: TypeName -> CustomMigrationsTagged JS.Object JS.Value
                      -> JS.Value -> APITableChange
                      -> Either (ValueError, Position) JS.Value
applyChangeToDatabase :: TypeName
-> CustomMigrationsTagged Object Value
-> Value
-> APITableChange
-> Either (ValueError, Position) Value
applyChangeToDatabase TypeName
root CustomMigrationsTagged Object Value
custom Value
v (APIChange NormAPI
_ APIChange
c Map TypeName UpdateDeclPos
upds) =
    Map TypeName UpdateDeclPos
-> (Value -> Position -> Either (ValueError, Position) Value)
-> UpdateTypePos
-> Value
-> Position
-> Either (ValueError, Position) Value
updateTypeAt Map TypeName UpdateDeclPos
upds (APIChange
-> CustomMigrationsTagged Object Value
-> Value
-> Position
-> Either (ValueError, Position) Value
applyChangeToData APIChange
c CustomMigrationsTagged Object Value
custom) (TypeName -> UpdateTypePos
UpdateNamed TypeName
root) Value
v []
applyChangeToDatabase TypeName
root CustomMigrationsTagged Object Value
_      Value
v (ValidateData NormAPI
api) = do
    TypeName -> NormAPI -> Value -> Either (ValueError, Position) ()
dataMatchesNormAPI TypeName
root NormAPI
api Value
v
    Value -> Either (ValueError, Position) Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
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 :: Map TypeName UpdateDeclPos
-> (Value -> Position -> Either (ValueError, Position) Value)
-> UpdateDeclPos
-> Value
-> Position
-> Either (ValueError, Position) Value
updateDeclAt Map TypeName UpdateDeclPos
_    Value -> Position -> Either (ValueError, Position) Value
alter (UpdateHere Maybe UpdateDeclPos
Nothing)    Value
v Position
p = Value -> Position -> Either (ValueError, Position) Value
alter Value
v Position
p
updateDeclAt Map TypeName UpdateDeclPos
upds Value -> Position -> Either (ValueError, Position) Value
alter (UpdateHere (Just UpdateDeclPos
upd)) Value
v Position
p = (Value -> Position -> Either (ValueError, Position) Value)
-> Position -> Value -> Either (ValueError, Position) Value
forall a b c. (a -> b -> c) -> b -> a -> c
flip Value -> Position -> Either (ValueError, Position) Value
alter Position
p (Value -> Either (ValueError, Position) Value)
-> Either (ValueError, Position) Value
-> Either (ValueError, Position) Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Map TypeName UpdateDeclPos
-> (Value -> Position -> Either (ValueError, Position) Value)
-> UpdateDeclPos
-> Value
-> Position
-> Either (ValueError, Position) Value
updateDeclAt Map TypeName UpdateDeclPos
upds Value -> Position -> Either (ValueError, Position) Value
alter UpdateDeclPos
upd Value
v Position
p
updateDeclAt Map TypeName UpdateDeclPos
upds Value -> Position -> Either (ValueError, Position) Value
alter (UpdateRecord Map FieldName (Maybe UpdateTypePos)
upd_flds) Value
v Position
p = Map FieldName (Maybe UpdateTypePos)
-> (Maybe UpdateTypePos
    -> Value -> Position -> Either (ValueError, Position) Value)
-> Value
-> Position
-> Either (ValueError, Position) Value
forall a.
Map FieldName a
-> (a -> Value -> Position -> Either (ValueError, Position) Value)
-> Value
-> Position
-> Either (ValueError, Position) Value
withObjectMatchingFields Map FieldName (Maybe UpdateTypePos)
upd_flds
                                                        ((Value -> Position -> Either (ValueError, Position) Value)
-> (UpdateTypePos
    -> Value -> Position -> Either (ValueError, Position) Value)
-> Maybe UpdateTypePos
-> Value
-> Position
-> Either (ValueError, Position) Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Either (ValueError, Position) Value
-> Position -> Either (ValueError, Position) Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (ValueError, Position) Value
 -> Position -> Either (ValueError, Position) Value)
-> (Value -> Either (ValueError, Position) Value)
-> Value
-> Position
-> Either (ValueError, Position) Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Either (ValueError, Position) Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure) (Map TypeName UpdateDeclPos
-> (Value -> Position -> Either (ValueError, Position) Value)
-> UpdateTypePos
-> Value
-> Position
-> Either (ValueError, Position) Value
updateTypeAt Map TypeName UpdateDeclPos
upds Value -> Position -> Either (ValueError, Position) Value
alter)) Value
v Position
p
updateDeclAt Map TypeName UpdateDeclPos
upds Value -> Position -> Either (ValueError, Position) Value
alter (UpdateUnion Map FieldName (Maybe UpdateTypePos)
upd_alts)  Value
v Position
p = Map FieldName (Maybe UpdateTypePos)
-> (Maybe UpdateTypePos
    -> Value -> Position -> Either (ValueError, Position) Value)
-> Value
-> Position
-> Either (ValueError, Position) Value
forall a.
Map FieldName a
-> (a -> Value -> Position -> Either (ValueError, Position) Value)
-> Value
-> Position
-> Either (ValueError, Position) Value
withObjectMatchingUnion Map FieldName (Maybe UpdateTypePos)
upd_alts
                                                        ((Value -> Position -> Either (ValueError, Position) Value)
-> (UpdateTypePos
    -> Value -> Position -> Either (ValueError, Position) Value)
-> Maybe UpdateTypePos
-> Value
-> Position
-> Either (ValueError, Position) Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Either (ValueError, Position) Value
-> Position -> Either (ValueError, Position) Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (ValueError, Position) Value
 -> Position -> Either (ValueError, Position) Value)
-> (Value -> Either (ValueError, Position) Value)
-> Value
-> Position
-> Either (ValueError, Position) Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Either (ValueError, Position) Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure) (Map TypeName UpdateDeclPos
-> (Value -> Position -> Either (ValueError, Position) Value)
-> UpdateTypePos
-> Value
-> Position
-> Either (ValueError, Position) Value
updateTypeAt Map TypeName UpdateDeclPos
upds Value -> Position -> Either (ValueError, Position) Value
alter)) Value
v Position
p
updateDeclAt Map TypeName UpdateDeclPos
upds Value -> Position -> Either (ValueError, Position) Value
alter (UpdateType UpdateTypePos
upd)        Value
v Position
p = Map TypeName UpdateDeclPos
-> (Value -> Position -> Either (ValueError, Position) Value)
-> UpdateTypePos
-> Value
-> Position
-> Either (ValueError, Position) Value
updateTypeAt Map TypeName UpdateDeclPos
upds Value -> Position -> Either (ValueError, Position) Value
alter UpdateTypePos
upd Value
v Position
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 :: Map TypeName UpdateDeclPos
-> (Value -> Position -> Either (ValueError, Position) Value)
-> UpdateTypePos
-> Value
-> Position
-> Either (ValueError, Position) Value
updateTypeAt Map TypeName UpdateDeclPos
upds Value -> Position -> Either (ValueError, Position) Value
alter (UpdateList UpdateTypePos
upd)    Value
v Position
p = (Value -> Position -> Either (ValueError, Position) Value)
-> Value -> Position -> Either (ValueError, Position) Value
withArrayElems (Map TypeName UpdateDeclPos
-> (Value -> Position -> Either (ValueError, Position) Value)
-> UpdateTypePos
-> Value
-> Position
-> Either (ValueError, Position) Value
updateTypeAt Map TypeName UpdateDeclPos
upds Value -> Position -> Either (ValueError, Position) Value
alter UpdateTypePos
upd) Value
v Position
p
updateTypeAt Map TypeName UpdateDeclPos
upds Value -> Position -> Either (ValueError, Position) Value
alter (UpdateMaybe UpdateTypePos
upd)   Value
v Position
p = (Value -> Position -> Either (ValueError, Position) Value)
-> Value -> Position -> Either (ValueError, Position) Value
withMaybe (Map TypeName UpdateDeclPos
-> (Value -> Position -> Either (ValueError, Position) Value)
-> UpdateTypePos
-> Value
-> Position
-> Either (ValueError, Position) Value
updateTypeAt Map TypeName UpdateDeclPos
upds Value -> Position -> Either (ValueError, Position) Value
alter UpdateTypePos
upd) Value
v Position
p
updateTypeAt Map TypeName UpdateDeclPos
upds Value -> Position -> Either (ValueError, Position) Value
alter (UpdateNamed TypeName
tname) Value
v Position
p = case TypeName -> Map TypeName UpdateDeclPos -> Maybe UpdateDeclPos
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TypeName
tname Map TypeName UpdateDeclPos
upds of
    Just UpdateDeclPos
upd -> Map TypeName UpdateDeclPos
-> (Value -> Position -> Either (ValueError, Position) Value)
-> UpdateDeclPos
-> Value
-> Position
-> Either (ValueError, Position) Value
updateDeclAt Map TypeName UpdateDeclPos
upds Value -> Position -> Either (ValueError, Position) Value
alter UpdateDeclPos
upd Value
v Position
p
    Maybe UpdateDeclPos
Nothing  -> Value -> Either (ValueError, Position) Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v


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

applyChangeToData :: APIChange
-> CustomMigrationsTagged Object Value
-> Value
-> Position
-> Either (ValueError, Position) Value
applyChangeToData (ChAddField TypeName
tname FieldName
fname APIType
ftype Maybe DefaultValue
mb_defval) CustomMigrationsTagged Object Value
_ =
  case Maybe DefaultValue
mb_defval Maybe DefaultValue -> Maybe DefaultValue -> Maybe DefaultValue
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> APIType -> Maybe DefaultValue
defaultValueForType APIType
ftype of
    Just DefaultValue
defval -> let newFieldValue :: Value
newFieldValue = DefaultValue -> Value
defaultValueAsJsValue DefaultValue
defval
                   in (Object -> Position -> Either (ValueError, Position) Object)
-> Value -> Position -> Either (ValueError, Position) Value
withObject (\ Object
v Position
_ -> Object -> Either (ValueError, Position) Object
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Object -> Either (ValueError, Position) Object)
-> Object -> Either (ValueError, Position) Object
forall a b. (a -> b) -> a -> b
$ Text -> Value -> Object -> Object
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HMap.insert (FieldName -> Text
_FieldName FieldName
fname) Value
newFieldValue Object
v)
    Maybe DefaultValue
Nothing     -> \ Value
_ Position
p -> (ValueError, Position) -> Either (ValueError, Position) Value
forall a b. a -> Either a b
Left (ApplyFailure -> ValueError
InvalidAPI (TypeName -> FieldName -> ApplyFailure
DefaultMissing TypeName
tname FieldName
fname), Position
p)

applyChangeToData (ChDeleteField TypeName
_ FieldName
fname) CustomMigrationsTagged Object Value
_ =
    (Object -> Position -> Either (ValueError, Position) Object)
-> Value -> Position -> Either (ValueError, Position) Value
withObject (\ Object
v Position
_ -> Object -> Either (ValueError, Position) Object
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Object -> Either (ValueError, Position) Object)
-> Object -> Either (ValueError, Position) Object
forall a b. (a -> b) -> a -> b
$ Text -> Object -> Object
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
HMap.delete (FieldName -> Text
_FieldName FieldName
fname) Object
v)

applyChangeToData (ChRenameField TypeName
_ FieldName
fname FieldName
fname') CustomMigrationsTagged Object Value
_ =
    (Object -> Position -> Either (ValueError, Position) Object)
-> Value -> Position -> Either (ValueError, Position) Value
withObject ((Object -> Position -> Either (ValueError, Position) Object)
 -> Value -> Position -> Either (ValueError, Position) Value)
-> (Object -> Position -> Either (ValueError, Position) Object)
-> Value
-> Position
-> Either (ValueError, Position) Value
forall a b. (a -> b) -> a -> b
$ \Object
rec Position
p -> case Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMap.lookup (FieldName -> Text
_FieldName FieldName
fname) Object
rec of
                           Just Value
field -> Value -> Object -> Either (ValueError, Position) Object
forall (f :: * -> *) v.
Applicative f =>
v -> HashMap Text v -> f (HashMap Text v)
rename Value
field Object
rec
                           Maybe Value
Nothing    -> (ValueError, Position) -> Either (ValueError, Position) Object
forall a b. a -> Either a b
Left (JSONError -> ValueError
JSONError JSONError
MissingField, FieldName -> Step
inField FieldName
fname Step -> Position -> Position
forall a. a -> [a] -> [a]
: Position
p)
  where
    rename :: v -> HashMap Text v -> f (HashMap Text v)
rename v
x = HashMap Text v -> f (HashMap Text v)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashMap Text v -> f (HashMap Text v))
-> (HashMap Text v -> HashMap Text v)
-> HashMap Text v
-> f (HashMap Text v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> v -> HashMap Text v -> HashMap Text v
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HMap.insert (FieldName -> Text
_FieldName FieldName
fname') v
x (HashMap Text v -> HashMap Text v)
-> (HashMap Text v -> HashMap Text v)
-> HashMap Text v
-> HashMap Text v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> HashMap Text v -> HashMap Text v
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
HMap.delete (FieldName -> Text
_FieldName FieldName
fname)

applyChangeToData (ChChangeField TypeName
_ FieldName
fname APIType
_ftype String
tag) CustomMigrationsTagged Object Value
custom =
    Text
-> (Value -> Position -> Either (ValueError, Position) Value)
-> Value
-> Position
-> Either (ValueError, Position) Value
withObjectField (FieldName -> Text
_FieldName FieldName
fname) ((Value -> Either ValueError Value)
-> Value -> Position -> Either (ValueError, Position) Value
forall a b.
(a -> Either ValueError b)
-> a -> Position -> Either (ValueError, Position) b
liftMigration ((Value -> Either ValueError Value)
 -> Value -> Position -> Either (ValueError, Position) Value)
-> (Value -> Either ValueError Value)
-> Value
-> Position
-> Either (ValueError, Position) Value
forall a b. (a -> b) -> a -> b
$ CustomMigrationsTagged Object Value
-> String -> Value -> Either ValueError Value
forall o v db ty fld.
CustomMigrations o v db ty fld -> fld -> v -> Either ValueError v
fieldMigration CustomMigrationsTagged Object Value
custom String
tag)

applyChangeToData (ChRenameUnionAlt TypeName
_ FieldName
fname FieldName
fname') CustomMigrationsTagged Object Value
_ = (Object -> Position -> Either (ValueError, Position) Object)
-> Value -> Position -> Either (ValueError, Position) Value
withObject ((Object -> Position -> Either (ValueError, Position) Object)
 -> Value -> Position -> Either (ValueError, Position) Value)
-> (Object -> Position -> Either (ValueError, Position) Object)
-> Value
-> Position
-> Either (ValueError, Position) Value
forall a b. (a -> b) -> a -> b
$ \Object
un Position
p ->
    case Object -> [(Text, Value)]
forall k v. HashMap k v -> [(k, v)]
HMap.toList Object
un of
        [(Text
k, Value
r)] | Text
k Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== FieldName -> Text
_FieldName FieldName
fname -> Object -> Either (ValueError, Position) Object
forall (m :: * -> *) a. Monad m => a -> m a
return (Object -> Either (ValueError, Position) Object)
-> Object -> Either (ValueError, Position) Object
forall a b. (a -> b) -> a -> b
$ Text -> Value -> Object
forall k v. Hashable k => k -> v -> HashMap k v
HMap.singleton (FieldName -> Text
_FieldName FieldName
fname') Value
r
                 | Bool
otherwise             -> Object -> Either (ValueError, Position) Object
forall (m :: * -> *) a. Monad m => a -> m a
return Object
un
        [(Text, Value)]
_ -> (ValueError, Position) -> Either (ValueError, Position) Object
forall a b. a -> Either a b
Left (JSONError -> ValueError
JSONError (JSONError -> ValueError) -> JSONError -> ValueError
forall a b. (a -> b) -> a -> b
$ String -> JSONError
SyntaxError String
"Not singleton", Position
p)

applyChangeToData (ChRenameEnumVal TypeName
_ FieldName
fname FieldName
fname') CustomMigrationsTagged Object Value
_ = (Text -> Position -> Either (ValueError, Position) Text)
-> Value -> Position -> Either (ValueError, Position) Value
withString ((Text -> Position -> Either (ValueError, Position) Text)
 -> Value -> Position -> Either (ValueError, Position) Value)
-> (Text -> Position -> Either (ValueError, Position) Text)
-> Value
-> Position
-> Either (ValueError, Position) Value
forall a b. (a -> b) -> a -> b
$ \Text
s Position
_ ->
    if Text
s Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== FieldName -> Text
_FieldName FieldName
fname then Text -> Either (ValueError, Position) Text
forall (m :: * -> *) a. Monad m => a -> m a
return (FieldName -> Text
_FieldName FieldName
fname')
                           else Text -> Either (ValueError, Position) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
s

applyChangeToData (ChCustomType TypeName
_ String
tag)   CustomMigrationsTagged Object Value
custom = (Value -> Either ValueError Value)
-> Value -> Position -> Either (ValueError, Position) Value
forall a b.
(a -> Either ValueError b)
-> a -> Position -> Either (ValueError, Position) b
liftMigration ((Value -> Either ValueError Value)
 -> Value -> Position -> Either (ValueError, Position) Value)
-> (Value -> Either ValueError Value)
-> Value
-> Position
-> Either (ValueError, Position) Value
forall a b. (a -> b) -> a -> b
$ CustomMigrationsTagged Object Value
-> String -> Value -> Either ValueError Value
forall o v db ty fld.
CustomMigrations o v db ty fld -> ty -> v -> Either ValueError v
typeMigration CustomMigrationsTagged Object Value
custom String
tag
applyChangeToData (ChCustomAll String
tag)      CustomMigrationsTagged Object Value
custom = (Object -> Position -> Either (ValueError, Position) Object)
-> Value -> Position -> Either (ValueError, Position) Value
withObject ((Object -> Either ValueError Object)
-> Object -> Position -> Either (ValueError, Position) Object
forall a b.
(a -> Either ValueError b)
-> a -> Position -> Either (ValueError, Position) b
liftMigration ((Object -> Either ValueError Object)
 -> Object -> Position -> Either (ValueError, Position) Object)
-> (Object -> Either ValueError Object)
-> Object
-> Position
-> Either (ValueError, Position) Object
forall a b. (a -> b) -> a -> b
$ CustomMigrationsTagged Object Value
-> String -> Object -> Either ValueError Object
forall o v db ty fld.
CustomMigrations o v db ty fld -> db -> o -> Either ValueError o
databaseMigration CustomMigrationsTagged Object Value
custom String
tag)

applyChangeToData (ChAddType TypeName
_ NormTypeDecl
_)        CustomMigrationsTagged Object Value
_ = Either (ValueError, Position) Value
-> Position -> Either (ValueError, Position) Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (ValueError, Position) Value
 -> Position -> Either (ValueError, Position) Value)
-> (Value -> Either (ValueError, Position) Value)
-> Value
-> Position
-> Either (ValueError, Position) Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Either (ValueError, Position) Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure
applyChangeToData (ChDeleteType TypeName
_)       CustomMigrationsTagged Object Value
_ = Either (ValueError, Position) Value
-> Position -> Either (ValueError, Position) Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (ValueError, Position) Value
 -> Position -> Either (ValueError, Position) Value)
-> (Value -> Either (ValueError, Position) Value)
-> Value
-> Position
-> Either (ValueError, Position) Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Either (ValueError, Position) Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure
applyChangeToData (ChRenameType TypeName
_ TypeName
_)     CustomMigrationsTagged Object Value
_ = Either (ValueError, Position) Value
-> Position -> Either (ValueError, Position) Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (ValueError, Position) Value
 -> Position -> Either (ValueError, Position) Value)
-> (Value -> Either (ValueError, Position) Value)
-> Value
-> Position
-> Either (ValueError, Position) Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Either (ValueError, Position) Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure
applyChangeToData (ChAddUnionAlt TypeName
_ FieldName
_ APIType
_)  CustomMigrationsTagged Object Value
_ = Either (ValueError, Position) Value
-> Position -> Either (ValueError, Position) Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (ValueError, Position) Value
 -> Position -> Either (ValueError, Position) Value)
-> (Value -> Either (ValueError, Position) Value)
-> Value
-> Position
-> Either (ValueError, Position) Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Either (ValueError, Position) Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure
applyChangeToData (ChDeleteUnionAlt TypeName
_ FieldName
_) CustomMigrationsTagged Object Value
_ = Either (ValueError, Position) Value
-> Position -> Either (ValueError, Position) Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (ValueError, Position) Value
 -> Position -> Either (ValueError, Position) Value)
-> (Value -> Either (ValueError, Position) Value)
-> Value
-> Position
-> Either (ValueError, Position) Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Either (ValueError, Position) Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure
applyChangeToData (ChAddEnumVal TypeName
_ FieldName
_)     CustomMigrationsTagged Object Value
_ = Either (ValueError, Position) Value
-> Position -> Either (ValueError, Position) Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (ValueError, Position) Value
 -> Position -> Either (ValueError, Position) Value)
-> (Value -> Either (ValueError, Position) Value)
-> Value
-> Position
-> Either (ValueError, Position) Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Either (ValueError, Position) Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure
applyChangeToData (ChDeleteEnumVal TypeName
_ FieldName
_)  CustomMigrationsTagged Object Value
_ = Either (ValueError, Position) Value
-> Position -> Either (ValueError, Position) Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (ValueError, Position) Value
 -> Position -> Either (ValueError, Position) Value)
-> (Value -> Either (ValueError, Position) Value)
-> Value
-> Position
-> Either (ValueError, Position) Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Either (ValueError, Position) Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure


liftMigration :: (a -> Either ValueError b)
                 -> (a -> Position -> Either (ValueError, Position) b)
liftMigration :: (a -> Either ValueError b)
-> a -> Position -> Either (ValueError, Position) b
liftMigration a -> Either ValueError b
f a
v Position
p = a -> Either ValueError b
f a
v Either ValueError b
-> (ValueError -> (ValueError, Position))
-> Either (ValueError, Position) b
forall e a e'. Either e a -> (e -> e') -> Either e' a
?!? (ValueError -> Position -> (ValueError, Position))
-> Position -> ValueError -> (ValueError, Position)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) Position
p


---------------------------------------------------------------------
-- Performing data transformation (new generic value representation)
--

applyChangesToDatabase' :: TypeName -> CustomMigrationsTagged Record Value
                        -> Value.Value -> [APITableChange]
                        -> Either (ValueError, Position) Value.Value
applyChangesToDatabase' :: TypeName
-> CustomMigrationsTagged Record Value
-> Value
-> [APITableChange]
-> Either (ValueError, Position) Value
applyChangesToDatabase' TypeName
root CustomMigrationsTagged Record Value
custom = (Value -> APITableChange -> Either (ValueError, Position) Value)
-> Value -> [APITableChange] -> Either (ValueError, Position) Value
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (TypeName
-> CustomMigrationsTagged Record Value
-> Value
-> APITableChange
-> Either (ValueError, Position) Value
applyChangeToDatabase' TypeName
root CustomMigrationsTagged Record Value
custom)
  -- just apply each of the individual changes in sequence to the whole dataset

applyChangeToDatabase' :: TypeName -> CustomMigrationsTagged Record Value
                       -> Value.Value -> APITableChange
                       -> Either (ValueError, Position) Value.Value
applyChangeToDatabase' :: TypeName
-> CustomMigrationsTagged Record Value
-> Value
-> APITableChange
-> Either (ValueError, Position) Value
applyChangeToDatabase' TypeName
root CustomMigrationsTagged Record Value
custom Value
v (APIChange NormAPI
api APIChange
c Map TypeName UpdateDeclPos
upds) =
    Map TypeName UpdateDeclPos
-> (Value -> Position -> Either (ValueError, Position) Value)
-> UpdateTypePos
-> Value
-> Position
-> Either (ValueError, Position) Value
updateTypeAt' Map TypeName UpdateDeclPos
upds (NormAPI
-> APIChange
-> CustomMigrationsTagged Record Value
-> Value
-> Position
-> Either (ValueError, Position) Value
applyChangeToData' NormAPI
api APIChange
c CustomMigrationsTagged Record Value
custom) (TypeName -> UpdateTypePos
UpdateNamed TypeName
root) Value
v []
applyChangeToDatabase' TypeName
root CustomMigrationsTagged Record Value
_      Value
v (ValidateData NormAPI
api) = do
    NormAPI
-> APIType -> Value -> Position -> Either (ValueError, Position) ()
matchesNormAPI NormAPI
api (TypeName -> APIType
TyName TypeName
root) Value
v []
    Value -> Either (ValueError, Position) Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
v


-- | Apply an update at the given position in a declaration's value
updateDeclAt' :: Map TypeName UpdateDeclPos
              -> (Value.Value -> Position -> Either (ValueError, Position) Value.Value)
              -> UpdateDeclPos
              -> Value.Value -> Position -> Either (ValueError, Position) Value.Value
updateDeclAt' :: Map TypeName UpdateDeclPos
-> (Value -> Position -> Either (ValueError, Position) Value)
-> UpdateDeclPos
-> Value
-> Position
-> Either (ValueError, Position) Value
updateDeclAt' Map TypeName UpdateDeclPos
_    Value -> Position -> Either (ValueError, Position) Value
alter (UpdateHere Maybe UpdateDeclPos
Nothing)    Value
v Position
p = Value -> Position -> Either (ValueError, Position) Value
alter Value
v Position
p
updateDeclAt' Map TypeName UpdateDeclPos
upds Value -> Position -> Either (ValueError, Position) Value
alter (UpdateHere (Just UpdateDeclPos
upd)) Value
v Position
p = (Value -> Position -> Either (ValueError, Position) Value)
-> Position -> Value -> Either (ValueError, Position) Value
forall a b c. (a -> b -> c) -> b -> a -> c
flip Value -> Position -> Either (ValueError, Position) Value
alter Position
p (Value -> Either (ValueError, Position) Value)
-> Either (ValueError, Position) Value
-> Either (ValueError, Position) Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Map TypeName UpdateDeclPos
-> (Value -> Position -> Either (ValueError, Position) Value)
-> UpdateDeclPos
-> Value
-> Position
-> Either (ValueError, Position) Value
updateDeclAt' Map TypeName UpdateDeclPos
upds Value -> Position -> Either (ValueError, Position) Value
alter UpdateDeclPos
upd Value
v Position
p
updateDeclAt' Map TypeName UpdateDeclPos
upds Value -> Position -> Either (ValueError, Position) Value
alter (UpdateRecord Map FieldName (Maybe UpdateTypePos)
upd_flds) Value
v Position
p = do
    Record
xs <- Value -> Position -> Either (ValueError, Position) Record
expectRecord Value
v Position
p
    Record -> Value
Record (Record -> Value)
-> Either (ValueError, Position) Record
-> Either (ValueError, Position) Value
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> (Field -> Either (ValueError, Position) Field)
-> Record -> Either (ValueError, Position) Record
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Field -> Either (ValueError, Position) Field
update Record
xs
  where
    update :: Field -> Either (ValueError, Position) Field
update x :: Field
x@(Field FieldName
fn Value
v') = case FieldName
-> Map FieldName (Maybe UpdateTypePos)
-> Maybe (Maybe UpdateTypePos)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FieldName
fn Map FieldName (Maybe UpdateTypePos)
upd_flds of
        Just Maybe UpdateTypePos
Nothing    -> Field -> Either (ValueError, Position) Field
forall (f :: * -> *) a. Applicative f => a -> f a
pure Field
x
        Just (Just UpdateTypePos
utp) -> FieldName -> Value -> Field
Field FieldName
fn (Value -> Field)
-> Either (ValueError, Position) Value
-> Either (ValueError, Position) Field
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Map TypeName UpdateDeclPos
-> (Value -> Position -> Either (ValueError, Position) Value)
-> UpdateTypePos
-> Value
-> Position
-> Either (ValueError, Position) Value
updateTypeAt' Map TypeName UpdateDeclPos
upds Value -> Position -> Either (ValueError, Position) Value
alter UpdateTypePos
utp Value
v' (FieldName -> Step
inField FieldName
fn Step -> Position -> Position
forall a. a -> [a] -> [a]
: Position
p)
        Maybe (Maybe UpdateTypePos)
Nothing         -> (ValueError, Position) -> Either (ValueError, Position) Field
forall a b. a -> Either a b
Left (JSONError -> ValueError
JSONError JSONError
UnexpectedField, FieldName -> Step
inField FieldName
fn Step -> Position -> Position
forall a. a -> [a] -> [a]
: Position
p)
updateDeclAt' Map TypeName UpdateDeclPos
upds Value -> Position -> Either (ValueError, Position) Value
alter (UpdateUnion Map FieldName (Maybe UpdateTypePos)
upd_alts)  Value
v Position
p = do
    (FieldName
fn, Value
v') <- Value
-> Position -> Either (ValueError, Position) (FieldName, Value)
expectUnion Value
v Position
p
    case FieldName
-> Map FieldName (Maybe UpdateTypePos)
-> Maybe (Maybe UpdateTypePos)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FieldName
fn Map FieldName (Maybe UpdateTypePos)
upd_alts of
        Just Maybe UpdateTypePos
Nothing    -> Value -> Either (ValueError, Position) Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v
        Just (Just UpdateTypePos
utp) -> FieldName -> Value -> Value
Union FieldName
fn (Value -> Value)
-> Either (ValueError, Position) Value
-> Either (ValueError, Position) Value
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Map TypeName UpdateDeclPos
-> (Value -> Position -> Either (ValueError, Position) Value)
-> UpdateTypePos
-> Value
-> Position
-> Either (ValueError, Position) Value
updateTypeAt' Map TypeName UpdateDeclPos
upds Value -> Position -> Either (ValueError, Position) Value
alter UpdateTypePos
utp Value
v' (FieldName -> Step
inField FieldName
fn Step -> Position -> Position
forall a. a -> [a] -> [a]
: Position
p)
        Maybe (Maybe UpdateTypePos)
Nothing         -> (ValueError, Position) -> Either (ValueError, Position) Value
forall a b. a -> Either a b
Left (JSONError -> ValueError
JSONError JSONError
UnexpectedField, FieldName -> Step
inField FieldName
fn Step -> Position -> Position
forall a. a -> [a] -> [a]
: Position
p)
updateDeclAt' Map TypeName UpdateDeclPos
upds Value -> Position -> Either (ValueError, Position) Value
alter (UpdateType UpdateTypePos
upd)        Value
v Position
p = Map TypeName UpdateDeclPos
-> (Value -> Position -> Either (ValueError, Position) Value)
-> UpdateTypePos
-> Value
-> Position
-> Either (ValueError, Position) Value
updateTypeAt' Map TypeName UpdateDeclPos
upds Value -> Position -> Either (ValueError, Position) Value
alter UpdateTypePos
upd Value
v Position
p

-- | Apply an update at the given position in a type's value
updateTypeAt' :: Map TypeName UpdateDeclPos
             -> (Value.Value -> Position -> Either (ValueError, Position) Value.Value)
             -> UpdateTypePos
             -> Value.Value -> Position -> Either (ValueError, Position) Value.Value
updateTypeAt' :: Map TypeName UpdateDeclPos
-> (Value -> Position -> Either (ValueError, Position) Value)
-> UpdateTypePos
-> Value
-> Position
-> Either (ValueError, Position) Value
updateTypeAt' Map TypeName UpdateDeclPos
upds Value -> Position -> Either (ValueError, Position) Value
alter (UpdateList UpdateTypePos
upd)    Value
v Position
p = do
    [Value]
xs <- Value -> Position -> Either (ValueError, Position) [Value]
expectList Value
v Position
p
    [Value] -> Value
List ([Value] -> Value)
-> Either (ValueError, Position) [Value]
-> Either (ValueError, Position) Value
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> ((Int, Value) -> Either (ValueError, Position) Value)
-> [(Int, Value)] -> Either (ValueError, Position) [Value]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ (Int
i, Value
v') -> Map TypeName UpdateDeclPos
-> (Value -> Position -> Either (ValueError, Position) Value)
-> UpdateTypePos
-> Value
-> Position
-> Either (ValueError, Position) Value
updateTypeAt' Map TypeName UpdateDeclPos
upds Value -> Position -> Either (ValueError, Position) Value
alter UpdateTypePos
upd Value
v' (Int -> Step
InElem Int
i Step -> Position -> Position
forall a. a -> [a] -> [a]
: Position
p)) ([Int] -> [Value] -> [(Int, Value)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [Value]
xs)
updateTypeAt' Map TypeName UpdateDeclPos
upds Value -> Position -> Either (ValueError, Position) Value
alter (UpdateMaybe UpdateTypePos
upd)   Value
v Position
p = do
    Maybe Value
mb <- Value -> Position -> Either (ValueError, Position) (Maybe Value)
expectMaybe Value
v Position
p
    case Maybe Value
mb of
      Maybe Value
Nothing -> Value -> Either (ValueError, Position) Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v
      Just Value
v' -> Maybe Value -> Value
Maybe (Maybe Value -> Value) -> (Value -> Maybe Value) -> Value -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Value)
-> Either (ValueError, Position) Value
-> Either (ValueError, Position) Value
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Map TypeName UpdateDeclPos
-> (Value -> Position -> Either (ValueError, Position) Value)
-> UpdateTypePos
-> Value
-> Position
-> Either (ValueError, Position) Value
updateTypeAt' Map TypeName UpdateDeclPos
upds Value -> Position -> Either (ValueError, Position) Value
alter UpdateTypePos
upd Value
v' Position
p
updateTypeAt' Map TypeName UpdateDeclPos
upds Value -> Position -> Either (ValueError, Position) Value
alter (UpdateNamed TypeName
tname) Value
v Position
p = case TypeName -> Map TypeName UpdateDeclPos -> Maybe UpdateDeclPos
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TypeName
tname Map TypeName UpdateDeclPos
upds of
    Just UpdateDeclPos
upd -> Map TypeName UpdateDeclPos
-> (Value -> Position -> Either (ValueError, Position) Value)
-> UpdateDeclPos
-> Value
-> Position
-> Either (ValueError, Position) Value
updateDeclAt' Map TypeName UpdateDeclPos
upds Value -> Position -> Either (ValueError, Position) Value
alter UpdateDeclPos
upd Value
v Position
p
    Maybe UpdateDeclPos
Nothing  -> Value -> Either (ValueError, Position) Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v


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

applyChangeToData' :: NormAPI
-> APIChange
-> CustomMigrationsTagged Record Value
-> Value
-> Position
-> Either (ValueError, Position) Value
applyChangeToData' NormAPI
api (ChAddField TypeName
tname FieldName
fname APIType
ftype Maybe DefaultValue
mb_defval) CustomMigrationsTagged Record Value
_ Value
v Position
p =
  case Maybe DefaultValue
mb_defval Maybe DefaultValue -> Maybe DefaultValue -> Maybe DefaultValue
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> APIType -> Maybe DefaultValue
defaultValueForType APIType
ftype of
    Just DefaultValue
defval -> case NormAPI -> APIType -> DefaultValue -> Maybe Value
fromDefaultValue NormAPI
api APIType
ftype DefaultValue
defval of
                     Just Value
v' -> Record -> Value
Record (Record -> Value) -> (Record -> Record) -> Record -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> Value -> Record -> Record
insertField FieldName
fname Value
v' (Record -> Value)
-> Either (ValueError, Position) Record
-> Either (ValueError, Position) Value
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Value -> Position -> Either (ValueError, Position) Record
expectRecord Value
v Position
p
                     Maybe Value
Nothing -> (ValueError, Position) -> Either (ValueError, Position) Value
forall a b. a -> Either a b
Left (ApplyFailure -> ValueError
InvalidAPI (TypeName -> FieldName -> APIType -> DefaultValue -> ApplyFailure
FieldBadDefaultValue TypeName
tname FieldName
fname APIType
ftype DefaultValue
defval), Position
p)
    Maybe DefaultValue
Nothing -> (ValueError, Position) -> Either (ValueError, Position) Value
forall a b. a -> Either a b
Left (ApplyFailure -> ValueError
InvalidAPI (TypeName -> FieldName -> ApplyFailure
DefaultMissing TypeName
tname FieldName
fname), Position
p)

applyChangeToData' NormAPI
_ (ChDeleteField TypeName
_ FieldName
fname) CustomMigrationsTagged Record Value
_ Value
v Position
p =
    Record -> Value
Record (Record -> Value) -> (Record -> Record) -> Record -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> Record -> Record
deleteField FieldName
fname (Record -> Value)
-> Either (ValueError, Position) Record
-> Either (ValueError, Position) Value
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Value -> Position -> Either (ValueError, Position) Record
expectRecord Value
v Position
p

applyChangeToData' NormAPI
_ (ChRenameField TypeName
_ FieldName
fname FieldName
fname') CustomMigrationsTagged Record Value
_ Value
v Position
p =
    Record -> Value
Record (Record -> Value) -> (Record -> Record) -> Record -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> FieldName -> Record -> Record
renameField FieldName
fname FieldName
fname' (Record -> Value)
-> Either (ValueError, Position) Record
-> Either (ValueError, Position) Value
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Value -> Position -> Either (ValueError, Position) Record
expectRecord Value
v Position
p

applyChangeToData' NormAPI
_ (ChChangeField TypeName
_ FieldName
fname APIType
_ftype String
tag) CustomMigrationsTagged Record Value
custom Value
v Position
p = do
    Record
xs <- Value -> Position -> Either (ValueError, Position) Record
expectRecord Value
v Position
p
    case FieldName -> Record -> Maybe (Record, Value, Record)
findField FieldName
fname Record
xs of
        Just (Record
ys, Value
v', Record
zs)  -> do Value
v'' <- (Value -> Either ValueError Value)
-> Value -> Position -> Either (ValueError, Position) Value
forall a b.
(a -> Either ValueError b)
-> a -> Position -> Either (ValueError, Position) b
liftMigration (CustomMigrationsTagged Record Value
-> String -> Value -> Either ValueError Value
forall o v db ty fld.
CustomMigrations o v db ty fld -> fld -> v -> Either ValueError v
fieldMigration CustomMigrationsTagged Record Value
custom String
tag) Value
v' (FieldName -> Step
inField FieldName
fnameStep -> Position -> Position
forall a. a -> [a] -> [a]
:Position
p)
                                 Value -> Either (ValueError, Position) Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Record -> Value
Record (Record -> FieldName -> Value -> Record -> Record
joinRecords Record
ys FieldName
fname Value
v'' Record
zs))
        Maybe (Record, Value, Record)
Nothing            -> (ValueError, Position) -> Either (ValueError, Position) Value
forall a b. a -> Either a b
Left (JSONError -> ValueError
JSONError JSONError
MissingField, FieldName -> Step
inField FieldName
fname Step -> Position -> Position
forall a. a -> [a] -> [a]
: Position
p)

applyChangeToData' NormAPI
_ (ChRenameUnionAlt TypeName
_ FieldName
fname FieldName
fname') CustomMigrationsTagged Record Value
_ Value
v Position
p = do
    (FieldName
fn, Value
v') <- Value
-> Position -> Either (ValueError, Position) (FieldName, Value)
expectUnion Value
v Position
p
    Value -> Either (ValueError, Position) Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either (ValueError, Position) Value)
-> Value -> Either (ValueError, Position) Value
forall a b. (a -> b) -> a -> b
$! if FieldName
fn FieldName -> FieldName -> Bool
forall a. Eq a => a -> a -> Bool
== FieldName
fname then FieldName -> Value -> Value
Union FieldName
fname' Value
v' else Value
v

applyChangeToData' NormAPI
_ (ChRenameEnumVal TypeName
_ FieldName
fname FieldName
fname') CustomMigrationsTagged Record Value
_ Value
v Position
p = do
    FieldName
fn <- Value -> Position -> Either (ValueError, Position) FieldName
expectEnum Value
v Position
p
    Value -> Either (ValueError, Position) Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either (ValueError, Position) Value)
-> Value -> Either (ValueError, Position) Value
forall a b. (a -> b) -> a -> b
$! if FieldName
fn FieldName -> FieldName -> Bool
forall a. Eq a => a -> a -> Bool
== FieldName
fname then FieldName -> Value
Enum FieldName
fname' else Value
v

applyChangeToData' NormAPI
_ (ChCustomType TypeName
_ String
tag)   CustomMigrationsTagged Record Value
custom Value
v Position
p = (Value -> Either ValueError Value)
-> Value -> Position -> Either (ValueError, Position) Value
forall a b.
(a -> Either ValueError b)
-> a -> Position -> Either (ValueError, Position) b
liftMigration (CustomMigrationsTagged Record Value
-> String -> Value -> Either ValueError Value
forall o v db ty fld.
CustomMigrations o v db ty fld -> ty -> v -> Either ValueError v
typeMigration CustomMigrationsTagged Record Value
custom String
tag) Value
v Position
p
applyChangeToData' NormAPI
_ (ChCustomAll String
tag)      CustomMigrationsTagged Record Value
custom Value
v Position
p = do
    Record
xs <- Value -> Position -> Either (ValueError, Position) Record
expectRecord Value
v Position
p
    Record -> Value
Record (Record -> Value)
-> Either (ValueError, Position) Record
-> Either (ValueError, Position) Value
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> (Record -> Either ValueError Record)
-> Record -> Position -> Either (ValueError, Position) Record
forall a b.
(a -> Either ValueError b)
-> a -> Position -> Either (ValueError, Position) b
liftMigration (CustomMigrationsTagged Record Value
-> String -> Record -> Either ValueError Record
forall o v db ty fld.
CustomMigrations o v db ty fld -> db -> o -> Either ValueError o
databaseMigration CustomMigrationsTagged Record Value
custom String
tag) Record
xs Position
p

applyChangeToData' NormAPI
_ (ChAddType TypeName
_ NormTypeDecl
_)        CustomMigrationsTagged Record Value
_ Value
v Position
_ = Value -> Either (ValueError, Position) Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v
applyChangeToData' NormAPI
_ (ChDeleteType TypeName
_)       CustomMigrationsTagged Record Value
_ Value
v Position
_ = Value -> Either (ValueError, Position) Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v
applyChangeToData' NormAPI
_ (ChRenameType TypeName
_ TypeName
_)     CustomMigrationsTagged Record Value
_ Value
v Position
_ = Value -> Either (ValueError, Position) Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v
applyChangeToData' NormAPI
_ (ChAddUnionAlt TypeName
_ FieldName
_ APIType
_)  CustomMigrationsTagged Record Value
_ Value
v Position
_ = Value -> Either (ValueError, Position) Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v
applyChangeToData' NormAPI
_ (ChDeleteUnionAlt TypeName
_ FieldName
_) CustomMigrationsTagged Record Value
_ Value
v Position
_ = Value -> Either (ValueError, Position) Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v
applyChangeToData' NormAPI
_ (ChAddEnumVal TypeName
_ FieldName
_)     CustomMigrationsTagged Record Value
_ Value
v Position
_ = Value -> Either (ValueError, Position) Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v
applyChangeToData' NormAPI
_ (ChDeleteEnumVal TypeName
_ FieldName
_)  CustomMigrationsTagged Record Value
_ Value
v Position
_ = Value -> Either (ValueError, Position) Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v


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

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

withObjectField :: T.Text -> (JS.Value -> Position -> Either (ValueError, Position) JS.Value)
                -> JS.Value -> Position -> Either (ValueError, Position) JS.Value
withObjectField :: Text
-> (Value -> Position -> Either (ValueError, Position) Value)
-> Value
-> Position
-> Either (ValueError, Position) Value
withObjectField Text
field Value -> Position -> Either (ValueError, Position) Value
alter (JS.Object Object
obj) Position
p =
    case Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMap.lookup Text
field Object
obj of
      Maybe Value
Nothing     -> (ValueError, Position) -> Either (ValueError, Position) Value
forall a b. a -> Either a b
Left (JSONError -> ValueError
JSONError JSONError
MissingField, Text -> Step
InField Text
field Step -> Position -> Position
forall a. a -> [a] -> [a]
: Position
p)
      Just Value
fvalue -> Object -> Value
JS.Object (Object -> Value)
-> Either (ValueError, Position) Object
-> Either (ValueError, Position) Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Value -> Object -> Object
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HMap.insert Text
field
                                       (Value -> Object -> Object)
-> Either (ValueError, Position) Value
-> Either (ValueError, Position) (Object -> Object)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> Position -> Either (ValueError, Position) Value
alter Value
fvalue (Text -> Step
InField Text
field Step -> Position -> Position
forall a. a -> [a] -> [a]
: Position
p))
                                       Either (ValueError, Position) (Object -> Object)
-> Either (ValueError, Position) Object
-> Either (ValueError, Position) Object
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Either (ValueError, Position) Object
forall (f :: * -> *) a. Applicative f => a -> f a
pure Object
obj)
withObjectField Text
_ Value -> Position -> Either (ValueError, Position) Value
_ Value
v Position
p = (ValueError, Position) -> Either (ValueError, Position) Value
forall a b. a -> Either a b
Left (JSONError -> ValueError
JSONError (JSONError -> ValueError) -> JSONError -> ValueError
forall a b. (a -> b) -> a -> b
$ Value -> JSONError
expectedObject Value
v, Position
p)

withObjectMatchingFields :: Map FieldName a
                         -> (a -> JS.Value -> Position -> Either (ValueError, Position) JS.Value)
                         -> JS.Value -> Position -> Either (ValueError, Position) JS.Value
withObjectMatchingFields :: Map FieldName a
-> (a -> Value -> Position -> Either (ValueError, Position) Value)
-> Value
-> Position
-> Either (ValueError, Position) Value
withObjectMatchingFields Map FieldName a
m a -> Value -> Position -> Either (ValueError, Position) Value
f (JS.Object Object
obj) Position
p = do
    Map Text (a, Value)
zs <- Map Text a
-> Map Text Value
-> Either (Text, Either a Value) (Map Text (a, Value))
forall k a b.
Ord k =>
Map k a -> Map k b -> Either (k, Either a b) (Map k (a, b))
matchMaps ((FieldName -> Text) -> Map FieldName a -> Map Text a
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys FieldName -> Text
_FieldName Map FieldName a
m) (Object -> Map Text Value
forall a. HashMap Text a -> Map Text a
hmapToMap Object
obj) Either (Text, Either a Value) (Map Text (a, Value))
-> ((Text, Either a Value) -> (ValueError, Position))
-> Either (ValueError, Position) (Map Text (a, Value))
forall e a e'. Either e a -> (e -> e') -> Either e' a
?!? (Text, Either a Value) -> (ValueError, Position)
forall a b. (Text, Either a b) -> (ValueError, Position)
toErr
    Map Text Value
obj' <- (Text -> (a, Value) -> Either (ValueError, Position) Value)
-> Map Text (a, Value)
-> Either (ValueError, Position) (Map Text Value)
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey (\ Text
k (a
ty, Value
val) -> (a -> Value -> Position -> Either (ValueError, Position) Value
f a
ty Value
val (Text -> Step
InField Text
k Step -> Position -> Position
forall a. a -> [a] -> [a]
: Position
p))) Map Text (a, Value)
zs
    Value -> Either (ValueError, Position) Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Either (ValueError, Position) Value)
-> Value -> Either (ValueError, Position) Value
forall a b. (a -> b) -> a -> b
$ Object -> Value
JS.Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Map Text Value -> Object
forall v. Map Text v -> HashMap Text v
mapToHMap Map Text Value
obj'
  where
    toErr :: (Text, Either a b) -> (ValueError, Position)
toErr (Text
k, Left a
_)  = (JSONError -> ValueError
JSONError JSONError
MissingField, Text -> Step
InField Text
k Step -> Position -> Position
forall a. a -> [a] -> [a]
: Position
p)
    toErr (Text
k, Right b
_) = (JSONError -> ValueError
JSONError JSONError
UnexpectedField, Text -> Step
InField Text
k Step -> Position -> Position
forall a. a -> [a] -> [a]
: Position
p)

    hmapToMap :: HashMap Text a -> Map Text a
hmapToMap = [(Text, a)] -> Map Text a
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Text, a)] -> Map Text a)
-> (HashMap Text a -> [(Text, a)]) -> HashMap Text a -> Map Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap Text a -> [(Text, a)]
forall k v. HashMap k v -> [(k, v)]
HMap.toList

    mapToHMap :: Map Text v -> HashMap Text v
mapToHMap = [(Text, v)] -> HashMap Text v
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HMap.fromList ([(Text, v)] -> HashMap Text v)
-> (Map Text v -> [(Text, v)]) -> Map Text v -> HashMap Text v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text v -> [(Text, v)]
forall k a. Map k a -> [(k, a)]
Map.toList

withObjectMatchingFields Map FieldName a
_ a -> Value -> Position -> Either (ValueError, Position) Value
_ Value
v Position
p = (ValueError, Position) -> Either (ValueError, Position) Value
forall a b. a -> Either a b
Left (JSONError -> ValueError
JSONError (JSONError -> ValueError) -> JSONError -> ValueError
forall a b. (a -> b) -> a -> b
$ Value -> JSONError
expectedObject Value
v, Position
p)

withObjectMatchingUnion :: Map FieldName a
                         -> (a -> JS.Value -> Position -> Either (ValueError, Position) JS.Value)
                         -> JS.Value -> Position -> Either (ValueError, Position) JS.Value
withObjectMatchingUnion :: Map FieldName a
-> (a -> Value -> Position -> Either (ValueError, Position) Value)
-> Value
-> Position
-> Either (ValueError, Position) Value
withObjectMatchingUnion Map FieldName a
m a -> Value -> Position -> Either (ValueError, Position) Value
f (JS.Object Object
obj) Position
p
  | [(Text
k, Value
r)] <- Object -> [(Text, Value)]
forall k v. HashMap k v -> [(k, v)]
HMap.toList Object
obj
  = do a
x  <- FieldName -> Map FieldName a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Text -> FieldName
FieldName Text
k) Map FieldName a
m Maybe a
-> (ValueError, Position) -> Either (ValueError, Position) a
forall a e. Maybe a -> e -> Either e a
?! (JSONError -> ValueError
JSONError JSONError
UnexpectedField, Text -> Step
InField Text
k Step -> Position -> Position
forall a. a -> [a] -> [a]
: Position
p)
       Value
r' <- a -> Value -> Position -> Either (ValueError, Position) Value
f a
x Value
r (Text -> Step
InField Text
k Step -> Position -> Position
forall a. a -> [a] -> [a]
: Position
p)
       Value -> Either (ValueError, Position) Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Either (ValueError, Position) Value)
-> Value -> Either (ValueError, Position) Value
forall a b. (a -> b) -> a -> b
$ Object -> Value
JS.Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Text -> Value -> Object
forall k v. Hashable k => k -> v -> HashMap k v
HMap.singleton Text
k Value
r'
withObjectMatchingUnion Map FieldName a
_ a -> Value -> Position -> Either (ValueError, Position) Value
_ Value
_ Position
p = (ValueError, Position) -> Either (ValueError, Position) Value
forall a b. a -> Either a b
Left (JSONError -> ValueError
JSONError (JSONError -> ValueError) -> JSONError -> ValueError
forall a b. (a -> b) -> a -> b
$ String -> JSONError
SyntaxError String
"Not singleton", Position
p)

withArrayElems :: (JS.Value -> Position -> Either (ValueError, Position) JS.Value)
               -> JS.Value -> Position -> Either (ValueError, Position) JS.Value
withArrayElems :: (Value -> Position -> Either (ValueError, Position) Value)
-> Value -> Position -> Either (ValueError, Position) Value
withArrayElems Value -> Position -> Either (ValueError, Position) Value
alter (JS.Array Array
arr) Position
p = Array -> Value
JS.Array (Array -> Value)
-> Either (ValueError, Position) Array
-> Either (ValueError, Position) Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Int, Value) -> Either (ValueError, Position) Value)
-> Vector (Int, Value) -> Either (ValueError, Position) Array
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Vector a -> m (Vector b)
V.mapM (Int, Value) -> Either (ValueError, Position) Value
alterAt (Array -> Vector (Int, Value)
forall a. Vector a -> Vector (Int, a)
V.indexed Array
arr)
  where
    alterAt :: (Int, Value) -> Either (ValueError, Position) Value
alterAt (Int
i, Value
v) = Value -> Position -> Either (ValueError, Position) Value
alter Value
v (Int -> Step
InElem Int
i Step -> Position -> Position
forall a. a -> [a] -> [a]
: Position
p)
withArrayElems Value -> Position -> Either (ValueError, Position) Value
_     Value
v              Position
p = (ValueError, Position) -> Either (ValueError, Position) Value
forall a b. a -> Either a b
Left (JSONError -> ValueError
JSONError (JSONError -> ValueError) -> JSONError -> ValueError
forall a b. (a -> b) -> a -> b
$ Value -> JSONError
expectedArray Value
v, Position
p)

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

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


compatibleDefaultValue :: NormAPI -> APIType -> DefaultValue -> Bool
compatibleDefaultValue :: NormAPI -> APIType -> DefaultValue -> Bool
compatibleDefaultValue NormAPI
api APIType
ty DefaultValue
dv = Maybe Value -> Bool
forall a. Maybe a -> Bool
isJust (NormAPI -> APIType -> DefaultValue -> Maybe Value
fromDefaultValue NormAPI
api APIType
ty DefaultValue
dv)

-- | 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 :: APIType -> Maybe DefaultValue
defaultValueForType (TyList  APIType
_) = DefaultValue -> Maybe DefaultValue
forall a. a -> Maybe a
Just DefaultValue
DefValList
defaultValueForType (TyMaybe APIType
_) = DefaultValue -> Maybe DefaultValue
forall a. a -> Maybe a
Just DefaultValue
DefValMaybe
defaultValueForType APIType
_           = Maybe DefaultValue
forall a. Maybe a
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 :: TypeName -> API -> Value -> Either (ValueError, Position) ()
dataMatchesAPI TypeName
root = TypeName -> NormAPI -> Value -> Either (ValueError, Position) ()
dataMatchesNormAPI TypeName
root (NormAPI -> Value -> Either (ValueError, Position) ())
-> (API -> NormAPI)
-> API
-> Value
-> Either (ValueError, Position) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. API -> NormAPI
apiNormalForm

dataMatchesNormAPI :: TypeName -> NormAPI -> JS.Value -> Either (ValueError, Position) ()
dataMatchesNormAPI :: TypeName -> NormAPI -> Value -> Either (ValueError, Position) ()
dataMatchesNormAPI TypeName
root NormAPI
api Value
db = Either (ValueError, Position) Value
-> Either (ValueError, Position) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Either (ValueError, Position) Value
 -> Either (ValueError, Position) ())
-> Either (ValueError, Position) Value
-> Either (ValueError, Position) ()
forall a b. (a -> b) -> a -> b
$ APIType -> Value -> Position -> Either (ValueError, Position) Value
valueMatches (TypeName -> APIType
TyName TypeName
root) Value
db []
  where
    declMatches :: NormTypeDecl -> JS.Value -> Position -> Either (ValueError, Position) JS.Value
    declMatches :: NormTypeDecl
-> Value -> Position -> Either (ValueError, Position) Value
declMatches (NRecordType NormRecordType
flds) = NormRecordType
-> (APIType
    -> Value -> Position -> Either (ValueError, Position) Value)
-> Value
-> Position
-> Either (ValueError, Position) Value
forall a.
Map FieldName a
-> (a -> Value -> Position -> Either (ValueError, Position) Value)
-> Value
-> Position
-> Either (ValueError, Position) Value
withObjectMatchingFields NormRecordType
flds APIType -> Value -> Position -> Either (ValueError, Position) Value
valueMatches
    declMatches (NUnionType NormRecordType
alts)  = NormRecordType
-> (APIType
    -> Value -> Position -> Either (ValueError, Position) Value)
-> Value
-> Position
-> Either (ValueError, Position) Value
forall a.
Map FieldName a
-> (a -> Value -> Position -> Either (ValueError, Position) Value)
-> Value
-> Position
-> Either (ValueError, Position) Value
withObjectMatchingUnion  NormRecordType
alts APIType -> Value -> Position -> Either (ValueError, Position) Value
valueMatches
    declMatches (NEnumType NormEnumType
vals)   = (Text -> Position -> Either (ValueError, Position) Text)
-> Value -> Position -> Either (ValueError, Position) Value
withString ((Text -> Position -> Either (ValueError, Position) Text)
 -> Value -> Position -> Either (ValueError, Position) Value)
-> (Text -> Position -> Either (ValueError, Position) Text)
-> Value
-> Position
-> Either (ValueError, Position) Value
forall a b. (a -> b) -> a -> b
$ \ Text
s Position
p ->
        if Text -> FieldName
FieldName Text
s FieldName -> NormEnumType -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` NormEnumType
vals
           then Text -> Either (ValueError, Position) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
s
           else (ValueError, Position) -> Either (ValueError, Position) Text
forall a b. a -> Either a b
Left (JSONError -> ValueError
JSONError JSONError
UnexpectedField, Text -> Step
InField Text
s Step -> Position -> Position
forall a. a -> [a] -> [a]
: Position
p)
    declMatches (NTypeSynonym APIType
t)   = APIType -> Value -> Position -> Either (ValueError, Position) Value
valueMatches APIType
t
    declMatches (NNewtype BasicType
bt)      = BasicType
-> Value -> Position -> Either (ValueError, Position) Value
valueMatchesBasic BasicType
bt

    valueMatches :: APIType -> JS.Value -> Position -> Either (ValueError, Position) JS.Value
    valueMatches :: APIType -> Value -> Position -> Either (ValueError, Position) Value
valueMatches (TyList APIType
t)      = (Value -> Position -> Either (ValueError, Position) Value)
-> Value -> Position -> Either (ValueError, Position) Value
withArrayElems (APIType -> Value -> Position -> Either (ValueError, Position) Value
valueMatches APIType
t)
    valueMatches (TyMaybe APIType
t)     = (Value -> Position -> Either (ValueError, Position) Value)
-> Value -> Position -> Either (ValueError, Position) Value
withMaybe (APIType -> Value -> Position -> Either (ValueError, Position) Value
valueMatches APIType
t)
    valueMatches (TyName TypeName
tname)  = \ Value
v Position
p -> do
        NormTypeDecl
d <- TypeName -> NormAPI -> Either ApplyFailure NormTypeDecl
lookupType TypeName
tname NormAPI
api Either ApplyFailure NormTypeDecl
-> (ApplyFailure -> (ValueError, Position))
-> Either (ValueError, Position) NormTypeDecl
forall e a e'. Either e a -> (e -> e') -> Either e' a
?!? (\ ApplyFailure
f -> (ApplyFailure -> ValueError
InvalidAPI ApplyFailure
f, Position
p))
        NormTypeDecl
-> Value -> Position -> Either (ValueError, Position) Value
declMatches NormTypeDecl
d Value
v Position
p
    valueMatches (TyBasic BasicType
bt)    = BasicType
-> Value -> Position -> Either (ValueError, Position) Value
valueMatchesBasic BasicType
bt
    valueMatches APIType
TyJSON          = \ Value
v Position
_ -> Value -> Either (ValueError, Position) Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
v

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

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

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


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

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

    [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [ Cxt -> Name -> [TyVarBndr] -> [Con] -> [Name] -> Dec
mkDataD [] (String -> Name
mkName String
all_nm) [] (String -> Set String -> [Con]
cons String
all_nm Set String
all_tags) [Name]
derivs
           , Cxt -> Name -> [TyVarBndr] -> [Con] -> [Name] -> Dec
mkDataD [] (String -> Name
mkName String
rec_nm) [] (String -> Set String -> [Con]
cons String
rec_nm Set String
rec_tags) [Name]
derivs
           , Cxt -> Name -> [TyVarBndr] -> [Con] -> [Name] -> Dec
mkDataD [] (String -> Name
mkName String
fld_nm) [] (String -> Set String -> [Con]
cons String
fld_nm Set String
fld_tags) [Name]
derivs ]
  where
    (Set String
all_tags, Set String
rec_tags, Set String
fld_tags) = APIChangelog -> (Set String, Set String, Set String)
changelogTags APIChangelog
changes

    guardNoDups :: Set a -> m ()
guardNoDups Set a
xs
      | Set a -> Bool
forall a. Set a -> Bool
Set.null Set a
xs = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      | Bool
otherwise   = String -> m ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"generateMigrationKinds: duplicate custom migrations in changelog: "
                             String -> String -> String
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => a -> String
show (Set a -> [a]
forall a. Set a -> [a]
Set.toList Set a
xs)

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

    derivs :: [Name]
derivs = [''Read, ''Show]