{-# 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.JSON.Compat
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.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 :: forall db rec fld.
(Read db, Read rec, Read fld) =>
(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' = 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) <- 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
                                                           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  forall e a e'. Either e a -> (e -> e') -> Either e' a
?!? forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ValueError -> Position -> MigrateFailure
ValueError
    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' :: forall db rec fld.
(Read db, Read rec, Read fld) =>
(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' = 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) <- 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
                                                           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  forall e a e'. Either e a -> (e -> e') -> Either e' a
?!? forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ValueError -> Position -> MigrateFailure
ValueError
    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
    { forall o v db ty fld.
CustomMigrations o v db ty fld -> db -> o -> Either ValueError o
databaseMigration       :: db -> o -> Either ValueError o
    , forall o v db ty fld.
CustomMigrations o v db ty fld
-> db -> NormAPI -> Either ApplyFailure (Maybe NormAPI)
databaseMigrationSchema :: db -> NormAPI -> Either ApplyFailure (Maybe NormAPI)
    , forall o v db ty fld.
CustomMigrations o v db ty fld -> ty -> v -> Either ValueError v
typeMigration           :: ty -> v -> Either ValueError v
    , forall o v db ty fld.
CustomMigrations o v db ty fld
-> ty -> NormTypeDecl -> Either ApplyFailure (Maybe NormTypeDecl)
typeMigrationSchema     :: ty -> NormTypeDecl -> Either ApplyFailure (Maybe NormTypeDecl)
    , forall o v db ty fld.
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 :: forall db ty fld o v.
(Read db, Read ty, Read fld) =>
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) =
    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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => MigrationTag -> a
read) (db -> NormAPI -> Either ApplyFailure (Maybe NormAPI)
dbs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => MigrationTag -> a
read) (ty -> v -> Either ValueError v
r forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => MigrationTag -> a
read) (ty -> NormTypeDecl -> Either ApplyFailure (Maybe NormTypeDecl)
rs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => MigrationTag -> a
read) (fld -> v -> Either ValueError v
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => MigrationTag -> 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 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             = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ JSONError -> ValueError
JSONError 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 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           = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ JSONError -> ValueError
JSONError forall a b. (a -> b) -> a -> b
$ Value -> JSONError
expectedObject (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 forall a e. Maybe a -> e -> Either e a
?! TypeName -> TypeKind -> ApplyFailure
TypeWrongKind TypeName
tname TypeKind
TKRecord
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NormRecordType -> NormTypeDecl
NRecordType 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 :: forall a. a -> Either ValueError a
noDataChanges = 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 :: forall a. a -> Either ApplyFailure (Maybe a)
noSchemaChanges a
_ = forall a b. b -> Either a b
Right 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
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
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
Ord)

-- | Whether to validate the dataset after this change
validateAfter :: DataChecks -> APIChange -> Bool
validateAfter :: DataChecks -> APIChange -> Bool
validateAfter DataChecks
chks (ChChangeField{})  = DataChecks
chks forall a. Ord a => a -> a -> Bool
>= DataChecks
CheckCustom
validateAfter DataChecks
chks (ChCustomType{})   = DataChecks
chks forall a. Ord a => a -> a -> Bool
>= DataChecks
CheckCustom
validateAfter DataChecks
chks (ChCustomAll{})    = DataChecks
chks forall a. Ord a => a -> a -> Bool
>= DataChecks
CheckCustom
validateAfter DataChecks
chks APIChange
_                  = DataChecks
chks 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 =
  forall a. [a] -> [a]
reverse [ (VersionExtra
v,VersionExtra
v',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) 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 forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\ (VersionExtra
v', VersionExtra
v, [APIChange]
_) -> VersionExtra
v' forall a. Ord a => a -> a -> Bool
<= VersionExtra
v) (APIChangelog -> [(VersionExtra, VersionExtra, [APIChange])]
viewChangelog APIChangelog
changelog) of
      Maybe (VersionExtra, VersionExtra, [APIChange])
Nothing         -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just (VersionExtra
v', VersionExtra
v, [APIChange]
_) -> 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 MigrationTag, Set MigrationTag, Set MigrationTag)
changelogTags (ChangesStart Version
_) = (forall a. Set a
Set.empty, forall a. Set a
Set.empty, forall a. Set a
Set.empty)
changelogTags (ChangesUpTo VersionExtra
_ [APIChange]
cs APIChangelog
older) =
    forall {a} {a} {a}.
(Ord a, Ord a, Ord a) =>
[(Set a, Set a, Set a)] -> (Set a, Set a, Set a)
unions3 (forall a b. (a -> b) -> [a] -> [b]
map APIChange -> (Set MigrationTag, Set MigrationTag, Set MigrationTag)
changeTags [APIChange]
cs) 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 MigrationTag, Set MigrationTag, Set MigrationTag)
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 forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set a
x, Set a
b forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set a
y, Set a
c 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 = (forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions [Set a]
xs, forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions [Set a]
ys, 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) = 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 MigrationTag, Set MigrationTag, Set MigrationTag)
changeTags (ChChangeField TypeName
_ FieldName
_ APIType
_ MigrationTag
t) = (forall a. Set a
Set.empty, forall a. Set a
Set.empty, forall a. a -> Set a
Set.singleton MigrationTag
t)
changeTags (ChCustomType TypeName
_ MigrationTag
t)      = (forall a. Set a
Set.empty, forall a. a -> Set a
Set.singleton MigrationTag
t, forall a. Set a
Set.empty)
changeTags (ChCustomAll MigrationTag
t)         = (forall a. a -> Set a
Set.singleton MigrationTag
t, forall a. Set a
Set.empty, forall a. Set a
Set.empty)
changeTags APIChange
_                       = (forall a. Set a
Set.empty, forall a. Set a
Set.empty, 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 = forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe UpdateDeclPos -> UpdateDeclPos
UpdateHere) TypeName
tname forall a b. (a -> b) -> a -> b
$
                          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 (forall a. a -> Set a
Set.singleton TypeName
tname)

    findDecl :: TypeName -> UpdateDeclPos
    findDecl :: TypeName -> UpdateDeclPos
findDecl TypeName
tname' = NormTypeDecl -> UpdateDeclPos
findDecl' forall a b. (a -> b) -> a -> b
$
                      forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => MigrationTag -> a
error MigrationTag
"findUpdatePos: missing type") forall a b. (a -> b) -> a -> b
$
                      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 forall a b. (a -> b) -> a -> b
$ 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  forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap APIType -> Maybe UpdateTypePos
findType NormRecordType
alts
    findDecl' (NEnumType NormEnumType
_)      = forall a. HasCallStack => MigrationTag -> a
error MigrationTag
"findDecl': unexpected enum"
    findDecl' (NTypeSynonym APIType
ty)  = UpdateTypePos -> UpdateDeclPos
UpdateType forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => MigrationTag -> a
error MigrationTag
"findDecl': missing") forall a b. (a -> b) -> a -> b
$
                                                APIType -> Maybe UpdateTypePos
findType APIType
ty
    findDecl' (NNewtype BasicType
_)       = forall a. HasCallStack => MigrationTag -> a
error MigrationTag
"findDecl': unexpected newtype"

    findType :: APIType -> Maybe UpdateTypePos
    findType :: APIType -> Maybe UpdateTypePos
findType (TyList APIType
ty)      = UpdateTypePos -> UpdateTypePos
UpdateList 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> APIType -> Maybe UpdateTypePos
findType APIType
ty
    findType (TyName TypeName
tname')
        | TypeName
tname' forall a. Eq a => a -> a -> Bool
== TypeName
tname Bool -> Bool -> Bool
|| TypeName
tname' forall a. Ord a => a -> Set a -> Bool
`Set.member` Set TypeName
deps = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ TypeName -> UpdateTypePos
UpdateNamed TypeName
tname'
        | Bool
otherwise                                   = forall a. Maybe a
Nothing
    findType (TyBasic BasicType
_)      = forall a. Maybe a
Nothing
    findType APIType
TyJSON           = 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 :: forall db rec fld o v.
(Read db, Read rec, Read fld) =>
(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 = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
  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 (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' :: 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 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  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 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') <- 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
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard (NormAPI
apiEnd forall a. Eq a => a -> a -> Bool
== NormAPI
apiTarget) forall a e. Maybe a -> e -> Either e a
?! VersionExtra
-> VersionExtra
-> Map TypeName (MergeResult NormTypeDecl NormTypeDecl)
-> ValidateFailure
ChangelogIncomplete VersionExtra
verEnd VersionExtra
ver' (forall a k.
(Eq a, Ord k) =>
Map k a -> Map k a -> Map k (MergeResult a a)
diffMaps NormAPI
apiEnd NormAPI
apiTarget)
  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' forall a. Eq a => a -> a -> Bool
== VersionExtra
ver = forall (m :: * -> *) a. Monad m => a -> m a
return ([], VersionExtra
ver')
  | VersionExtra
ver' forall a. Ord a => a -> a -> Bool
>  VersionExtra
ver = do
      APIChangelog -> Either (VersionExtra, VersionExtra) ()
isChangelogOrdered APIChangelog
clog forall e a e'. Either e a -> (e -> e') -> Either e' a
?!? forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry VersionExtra -> VersionExtra -> ValidateFailure
ChangelogOutOfOrder
      let withinRange :: [(VersionExtra, VersionExtra, [APIChange])]
withinRange = forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\ (VersionExtra
_, VersionExtra
v, [APIChange]
_) -> VersionExtra
v forall a. Ord a => a -> a -> Bool
<= VersionExtra
ver') forall a b. (a -> b) -> a -> b
$
                            forall a. (a -> Bool) -> [a] -> [a]
dropWhile (\ (VersionExtra
_, VersionExtra
v, [APIChange]
_) -> VersionExtra
v forall a. Ord a => a -> a -> Bool
<= VersionExtra
ver) forall a b. (a -> b) -> a -> b
$
                                APIChangelog -> [(VersionExtra, VersionExtra, [APIChange])]
viewChangelogReverse APIChangelog
clog
          endVer :: VersionExtra
endVer = case 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
      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 = 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 :: 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
api = do
    (NormAPI
api', [APITableChange]
changes') <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (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 forall a. Ord a => a -> a -> Bool
>= DataChecks
CheckStartAndEnd = NormAPI -> [APITableChange] -> [APITableChange]
addV NormAPI
api forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ NormAPI -> [APITableChange] -> [APITableChange]
addV NormAPI
api' [APITableChange]
changes'
                  | Bool
otherwise                = forall a. [a] -> [a]
reverse [APITableChange]
changes'
    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 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 :: 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, [APITableChange]
changes) APIChange
change = do
    (NormAPI
api', Map TypeName UpdateDeclPos
pos) <- 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
                       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 forall a. a -> [a] -> [a]
: [APITableChange]
changes
        changes'' :: [APITableChange]
changes'' | DataChecks -> APIChange -> Bool
validateAfter DataChecks
chks APIChange
change = NormAPI -> APITableChange
ValidateData NormAPI
api' forall a. a -> [a] -> [a]
: [APITableChange]
changes'
                  | Bool
otherwise                 = [APITableChange]
changes'
    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 :: forall o v.
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
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (TypeName
tname TypeName -> NormAPI -> Bool
`typeDeclaredInApi` NormAPI
api))   forall a e. Maybe a -> e -> Either e a
?! TypeName -> ApplyFailure
TypeExists TypeName
tname
  NormTypeDecl -> NormAPI -> Either (Set TypeName) ()
declIsValid NormTypeDecl
tdecl NormAPI
api                         forall e a e'. Either e a -> (e -> e') -> Either e' a
?!? TypeName -> NormTypeDecl -> Set TypeName -> ApplyFailure
DeclMalformed TypeName
tname NormTypeDecl
tdecl
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TypeName
tname NormTypeDecl
tdecl NormAPI
api, 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
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard (TypeName
tname TypeName -> NormAPI -> Bool
`typeDeclaredInApi` NormAPI
api)         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
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (TypeName
tname TypeName -> NormAPI -> Bool
`typeUsedInApi` NormAPI
api))       forall a e. Maybe a -> e -> Either e a
?! TypeName -> ApplyFailure
TypeInUse TypeName
tname
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall k a. Ord k => k -> Map k a -> Map k a
Map.delete TypeName
tname NormAPI
api, 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
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (TypeName
tname' TypeName -> NormAPI -> Bool
`typeDeclaredInApi` NormAPI
api))  forall a e. Maybe a -> e -> Either e a
?! TypeName -> ApplyFailure
TypeExists TypeName
tname'
  forall (m :: * -> *) a. Monad m => a -> m a
return ( (TypeName -> TypeName -> NormAPI -> NormAPI
renameTypeUses TypeName
tname TypeName
tname'
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TypeName
tname' NormTypeDecl
tinfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Map k a
Map.delete TypeName
tname) NormAPI
api
         , forall k a. Map k a
Map.empty )

applyAPIChangeToAPI TypeName
_ CustomMigrationsTagged o v
custom (ChCustomType TypeName
tname MigrationTag
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' <- forall o v db ty fld.
CustomMigrations o v db ty fld
-> ty -> NormTypeDecl -> Either ApplyFailure (Maybe NormTypeDecl)
typeMigrationSchema CustomMigrationsTagged o v
custom MigrationTag
tag NormTypeDecl
tinfo
  let api' :: NormAPI
api' = case Maybe NormTypeDecl
mb_tinfo' of
                 Just NormTypeDecl
tinfo' -> 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
  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                forall a e. Maybe a -> e -> Either e a
?! TypeName -> TypeKind -> ApplyFailure
TypeWrongKind TypeName
tname TypeKind
TKRecord
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (forall k a. Ord k => k -> Map k a -> Bool
Map.member FieldName
fname NormRecordType
recinfo))           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                            forall e a e'. Either e a -> (e -> e') -> Either e' a
?!? APIType -> Set TypeName -> ApplyFailure
TypeMalformed APIType
ftype
  case Maybe DefaultValue
mb_defval forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> APIType -> Maybe DefaultValue
defaultValueForType APIType
ftype of
    Just DefaultValue
defval -> forall (f :: * -> *). Alternative f => Bool -> f ()
guard (NormAPI -> APIType -> DefaultValue -> Bool
compatibleDefaultValue NormAPI
api APIType
ftype DefaultValue
defval)
                                                   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     -> forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (TypeName -> TypeName -> NormAPI -> Bool
typeUsedInTransitiveDep TypeName
root TypeName
tname NormAPI
api))
                                                   forall a e. Maybe a -> e -> Either e a
?! TypeName -> FieldName -> ApplyFailure
DefaultMissing TypeName
tname FieldName
fname
  let tinfo' :: NormTypeDecl
tinfo' = NormRecordType -> NormTypeDecl
NRecordType (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert FieldName
fname APIType
ftype NormRecordType
recinfo)
  forall (m :: * -> *) a. Monad m => a -> m a
return (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        forall a e. Maybe a -> e -> Either e a
?! TypeName -> TypeKind -> ApplyFailure
TypeWrongKind TypeName
tname TypeKind
TKRecord
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard (forall k a. Ord k => k -> Map k a -> Bool
Map.member FieldName
fname NormRecordType
recinfo)         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 (forall k a. Ord k => k -> Map k a -> Map k a
Map.delete FieldName
fname NormRecordType
recinfo)
  forall (m :: * -> *) a. Monad m => a -> m a
return (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        forall a e. Maybe a -> e -> Either e a
?! TypeName -> TypeKind -> ApplyFailure
TypeWrongKind TypeName
tname TypeKind
TKRecord
  APIType
ftype   <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FieldName
fname NormRecordType
recinfo      forall a e. Maybe a -> e -> Either e a
?! TypeName -> TypeKind -> FieldName -> ApplyFailure
FieldDoesNotExist TypeName
tname TypeKind
TKRecord FieldName
fname
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (forall k a. Ord k => k -> Map k a -> Bool
Map.member FieldName
fname' NormRecordType
recinfo))  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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert FieldName
fname' APIType
ftype
                            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Map k a
Map.delete FieldName
fname) NormRecordType
recinfo
  forall (m :: * -> *) a. Monad m => a -> m a
return (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 MigrationTag
_) NormAPI
api = do
  NormTypeDecl
tinfo   <- TypeName -> NormAPI -> Either ApplyFailure NormTypeDecl
lookupType TypeName
tname NormAPI
api
  NormRecordType
recinfo <- NormTypeDecl -> Maybe NormRecordType
expectRecordType NormTypeDecl
tinfo        forall a e. Maybe a -> e -> Either e a
?! TypeName -> TypeKind -> ApplyFailure
TypeWrongKind TypeName
tname TypeKind
TKRecord
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard (forall k a. Ord k => k -> Map k a -> Bool
Map.member FieldName
fname NormRecordType
recinfo)         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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert FieldName
fname APIType
ftype) NormRecordType
recinfo
  forall (m :: * -> *) a. Monad m => a -> m a
return (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               forall a e. Maybe a -> e -> Either e a
?! TypeName -> TypeKind -> ApplyFailure
TypeWrongKind TypeName
tname TypeKind
TKUnion
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (forall k a. Ord k => k -> Map k a -> Bool
Map.member FieldName
fname NormRecordType
unioninfo))         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                            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 (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert FieldName
fname APIType
ftype NormRecordType
unioninfo)
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TypeName
tname NormTypeDecl
tinfo' NormAPI
api, 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         forall a e. Maybe a -> e -> Either e a
?! TypeName -> TypeKind -> ApplyFailure
TypeWrongKind TypeName
tname TypeKind
TKUnion
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (TypeName -> TypeName -> NormAPI -> Bool
typeUsedInTransitiveDep TypeName
root TypeName
tname NormAPI
api)) forall a e. Maybe a -> e -> Either e a
?! TypeName -> ApplyFailure
TypeInUse TypeName
tname
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard (forall k a. Ord k => k -> Map k a -> Bool
Map.member FieldName
fname NormRecordType
unioninfo)         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 (forall k a. Ord k => k -> Map k a -> Map k a
Map.delete FieldName
fname NormRecordType
unioninfo)
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TypeName
tname NormTypeDecl
tinfo' NormAPI
api, 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        forall a e. Maybe a -> e -> Either e a
?! TypeName -> TypeKind -> ApplyFailure
TypeWrongKind TypeName
tname TypeKind
TKUnion
  APIType
ftype     <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FieldName
fname NormRecordType
unioninfo   forall a e. Maybe a -> e -> Either e a
?! TypeName -> TypeKind -> FieldName -> ApplyFailure
FieldDoesNotExist TypeName
tname TypeKind
TKUnion FieldName
fname
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (forall k a. Ord k => k -> Map k a -> Bool
Map.member FieldName
fname' NormRecordType
unioninfo)) 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert FieldName
fname' APIType
ftype
                           forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Map k a
Map.delete FieldName
fname) NormRecordType
unioninfo
  forall (m :: * -> *) a. Monad m => a -> m a
return (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                 forall a e. Maybe a -> e -> Either e a
?! TypeName -> TypeKind -> ApplyFailure
TypeWrongKind TypeName
tname TypeKind
TKEnum
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (forall a. Ord a => a -> Set a -> Bool
Set.member FieldName
fname NormEnumType
enuminfo))          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 (forall a. Ord a => a -> Set a -> Set a
Set.insert FieldName
fname NormEnumType
enuminfo)
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TypeName
tname NormTypeDecl
tinfo' NormAPI
api, 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          forall a e. Maybe a -> e -> Either e a
?! TypeName -> TypeKind -> ApplyFailure
TypeWrongKind TypeName
tname TypeKind
TKEnum
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (TypeName -> TypeName -> NormAPI -> Bool
typeUsedInTransitiveDep TypeName
root TypeName
tname NormAPI
api)) forall a e. Maybe a -> e -> Either e a
?! TypeName -> ApplyFailure
TypeInUse TypeName
tname
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard (forall a. Ord a => a -> Set a -> Bool
Set.member FieldName
fname NormEnumType
enuminfo)         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 (forall a. Ord a => a -> Set a -> Set a
Set.delete FieldName
fname NormEnumType
enuminfo)
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TypeName
tname NormTypeDecl
tinfo' NormAPI
api, 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         forall a e. Maybe a -> e -> Either e a
?! TypeName -> TypeKind -> ApplyFailure
TypeWrongKind TypeName
tname TypeKind
TKEnum
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard (forall a. Ord a => a -> Set a -> Bool
Set.member FieldName
fname NormEnumType
enuminfo)        forall a e. Maybe a -> e -> Either e a
?! TypeName -> TypeKind -> FieldName -> ApplyFailure
FieldDoesNotExist TypeName
tname TypeKind
TKEnum FieldName
fname
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (forall a. Ord a => a -> Set a -> Bool
Set.member FieldName
fname' NormEnumType
enuminfo)) 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => a -> Set a -> Set a
Set.insert FieldName
fname'
                          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => a -> Set a -> Set a
Set.delete FieldName
fname) NormEnumType
enuminfo
  forall (m :: * -> *) a. Monad m => a -> m a
return (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 MigrationTag
tag) NormAPI
api = do
  Maybe NormAPI
mb_api' <- forall o v db ty fld.
CustomMigrations o v db ty fld
-> db -> NormAPI -> Either ApplyFailure (Maybe NormAPI)
databaseMigrationSchema CustomMigrationsTagged o v
custom MigrationTag
tag NormAPI
api
  forall (m :: * -> *) a. Monad m => a -> m a
return ( forall a. a -> Maybe a -> a
fromMaybe NormAPI
api Maybe NormAPI
mb_api'
         , forall k a. k -> a -> Map k a
Map.singleton TypeName
root (Maybe UpdateDeclPos -> UpdateDeclPos
UpdateHere forall a. Maybe a
Nothing))


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

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

expectEnumType :: NormTypeDecl -> Maybe (Set FieldName)
expectEnumType :: NormTypeDecl -> Maybe NormEnumType
expectEnumType (NEnumType NormEnumType
rinfo) = forall a. a -> Maybe a
Just NormEnumType
rinfo
expectEnumType NormTypeDecl
_                 = 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 = 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
    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 = forall a b c. (a -> b -> c) -> b -> a -> c
flip Value -> Position -> Either (ValueError, Position) Value
alter Position
p 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 = 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
                                                        (forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = 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
                                                        (forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 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  -> 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 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
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Text -> a -> KeyMap a -> KeyMap a
insertKey (FieldName -> Text
_FieldName FieldName
fname) Value
newFieldValue Object
v)
    Maybe DefaultValue
Nothing     -> \ Value
_ Position
p -> 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
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Text -> KeyMap a -> KeyMap a
deleteKey (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 forall a b. (a -> b) -> a -> b
$ \Object
rec Position
p -> case forall a. Text -> KeyMap a -> Maybe a
lookupKey (FieldName -> Text
_FieldName FieldName
fname) Object
rec of
                           Just Value
field -> forall {f :: * -> *} {a}.
Applicative f =>
a -> KeyMap a -> f (KeyMap a)
rename Value
field Object
rec
                           Maybe Value
Nothing    -> forall a b. a -> Either a b
Left (JSONError -> ValueError
JSONError JSONError
MissingField, FieldName -> Step
inField FieldName
fname forall a. a -> [a] -> [a]
: Position
p)
  where
    rename :: a -> KeyMap a -> f (KeyMap a)
rename a
x = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Text -> a -> KeyMap a -> KeyMap a
insertKey (FieldName -> Text
_FieldName FieldName
fname') a
x forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Text -> KeyMap a -> KeyMap a
deleteKey (FieldName -> Text
_FieldName FieldName
fname)

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

applyChangeToData (ChRenameUnionAlt TypeName
_ FieldName
fname FieldName
fname') CustomMigrationsTagged Object Value
_ = (Object -> Position -> Either (ValueError, Position) Object)
-> Value -> Position -> Either (ValueError, Position) Value
withObject forall a b. (a -> b) -> a -> b
$ \Object
un Position
p ->
    case forall a. KeyMap a -> Maybe (Text, a)
matchSingletonObject Object
un of
        Just (Text
k, Value
r) | Text
k forall a. Eq a => a -> a -> Bool
== FieldName -> Text
_FieldName FieldName
fname -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Text -> a -> KeyMap a
singletonObject (FieldName -> Text
_FieldName FieldName
fname') Value
r
                    | Bool
otherwise             -> forall (m :: * -> *) a. Monad m => a -> m a
return Object
un
        Maybe (Text, Value)
Nothing -> forall a b. a -> Either a b
Left (JSONError -> ValueError
JSONError forall a b. (a -> b) -> a -> b
$ MigrationTag -> JSONError
SyntaxError MigrationTag
"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 forall a b. (a -> b) -> a -> b
$ \Text
s Position
_ ->
    if Text
s forall a. Eq a => a -> a -> Bool
== FieldName -> Text
_FieldName FieldName
fname then forall (m :: * -> *) a. Monad m => a -> m a
return (FieldName -> Text
_FieldName FieldName
fname')
                           else forall (m :: * -> *) a. Monad m => a -> m a
return Text
s

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

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


liftMigration :: (a -> Either ValueError b)
                 -> (a -> Position -> Either (ValueError, Position) b)
liftMigration :: forall a b.
(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 forall e a e'. Either e a -> (e -> e') -> Either e' a
?!? 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 = 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 []
    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 = forall a b c. (a -> b -> c) -> b -> a -> c
flip Value -> Position -> Either (ValueError, Position) Value
alter Position
p 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 forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> 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 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    -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Field
x
        Just (Just UpdateTypePos
utp) -> FieldName -> Value -> Field
Field FieldName
fn 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 forall a. a -> [a] -> [a]
: Position
p)
        Maybe (Maybe UpdateTypePos)
Nothing         -> forall a b. a -> Either a b
Left (JSONError -> ValueError
JSONError JSONError
UnexpectedField, FieldName -> Step
inField FieldName
fn 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 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    -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v
        Just (Just UpdateTypePos
utp) -> FieldName -> Value -> Value
Union FieldName
fn 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 forall a. a -> [a] -> [a]
: Position
p)
        Maybe (Maybe UpdateTypePos)
Nothing         -> forall a b. a -> Either a b
Left (JSONError -> ValueError
JSONError JSONError
UnexpectedField, FieldName -> Step
inField FieldName
fn 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 forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> 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 forall a. a -> [a] -> [a]
: Position
p)) (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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v
      Just Value
v' -> Maybe Value -> Value
Maybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just 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 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  -> 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 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> Value -> Record -> Record
insertField FieldName
fname Value
v' 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 -> 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 -> 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> Record -> Record
deleteField FieldName
fname 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> FieldName -> Record -> Record
renameField FieldName
fname FieldName
fname' 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 MigrationTag
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'' <- forall a b.
(a -> Either ValueError b)
-> a -> Position -> Either (ValueError, Position) b
liftMigration (forall o v db ty fld.
CustomMigrations o v db ty fld -> fld -> v -> Either ValueError v
fieldMigration CustomMigrationsTagged Record Value
custom MigrationTag
tag) Value
v' (FieldName -> Step
inField FieldName
fnameforall a. a -> [a] -> [a]
:Position
p)
                                 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            -> forall a b. a -> Either a b
Left (JSONError -> ValueError
JSONError JSONError
MissingField, FieldName -> Step
inField FieldName
fname 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
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! if FieldName
fn 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
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! if FieldName
fn forall a. Eq a => a -> a -> Bool
== FieldName
fname then FieldName -> Value
Enum FieldName
fname' else Value
v

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

applyChangeToData' NormAPI
_ (ChAddType TypeName
_ NormTypeDecl
_)        CustomMigrationsTagged Record Value
_ Value
v Position
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v
applyChangeToData' NormAPI
_ (ChDeleteType TypeName
_)       CustomMigrationsTagged Record Value
_ Value
v Position
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v
applyChangeToData' NormAPI
_ (ChRenameType TypeName
_ TypeName
_)     CustomMigrationsTagged Record Value
_ Value
v Position
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v
applyChangeToData' NormAPI
_ (ChAddUnionAlt TypeName
_ FieldName
_ APIType
_)  CustomMigrationsTagged Record Value
_ Value
v Position
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v
applyChangeToData' NormAPI
_ (ChDeleteUnionAlt TypeName
_ FieldName
_) CustomMigrationsTagged Record Value
_ Value
v Position
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v
applyChangeToData' NormAPI
_ (ChAddEnumVal TypeName
_ FieldName
_)     CustomMigrationsTagged Record Value
_ Value
v Position
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v
applyChangeToData' NormAPI
_ (ChDeleteEnumVal TypeName
_ FieldName
_)  CustomMigrationsTagged Record Value
_ Value
v Position
_ = 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 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 = forall a b. a -> Either a b
Left (JSONError -> ValueError
JSONError 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 forall a. Text -> KeyMap a -> Maybe a
lookupKey Text
field Object
obj of
      Maybe Value
Nothing     -> forall a b. a -> Either a b
Left (JSONError -> ValueError
JSONError JSONError
MissingField, Text -> Step
InField Text
field forall a. a -> [a] -> [a]
: Position
p)
      Just Value
fvalue -> Object -> Value
JS.Object forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Text -> a -> KeyMap a -> KeyMap a
insertKey Text
field
                                       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 forall a. a -> [a] -> [a]
: Position
p))
                                       forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Object
obj)
withObjectField Text
_ Value -> Position -> Either (ValueError, Position) Value
_ Value
v Position
p = forall a b. a -> Either a b
Left (JSONError -> ValueError
JSONError 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 :: forall a.
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 <- forall k a b.
Ord k =>
Map k a -> Map k b -> Either (k, Either a b) (Map k (a, b))
matchMaps (forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys FieldName -> Text
_FieldName Map FieldName a
m) (forall a. KeyMap a -> Map Text a
objectToMap Object
obj) forall e a e'. Either e a -> (e -> e') -> Either e' a
?!? forall {a} {b}. (Text, Either a b) -> (ValueError, Position)
toErr
    Map Text Value
obj' <- 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 forall a. a -> [a] -> [a]
: Position
p))) Map Text (a, Value)
zs
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Object -> Value
JS.Object forall a b. (a -> b) -> a -> b
$ forall a. Map Text a -> KeyMap a
mapToObject 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 forall a. a -> [a] -> [a]
: Position
p)
    toErr (Text
k, Right b
_) = (JSONError -> ValueError
JSONError JSONError
UnexpectedField, Text -> Step
InField Text
k forall a. a -> [a] -> [a]
: Position
p)


withObjectMatchingFields Map FieldName a
_ a -> Value -> Position -> Either (ValueError, Position) Value
_ Value
v Position
p = forall a b. a -> Either a b
Left (JSONError -> ValueError
JSONError 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 :: forall a.
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
  | Just (Text
k, Value
r) <- forall a. KeyMap a -> Maybe (Text, a)
matchSingletonObject Object
obj
  = do a
x  <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Text -> FieldName
FieldName Text
k) Map FieldName a
m forall a e. Maybe a -> e -> Either e a
?! (JSONError -> ValueError
JSONError JSONError
UnexpectedField, Text -> Step
InField Text
k 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 forall a. a -> [a] -> [a]
: Position
p)
       forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Object -> Value
JS.Object forall a b. (a -> b) -> a -> b
$ forall a. Text -> a -> KeyMap a
singletonObject Text
k Value
r'
withObjectMatchingUnion Map FieldName a
_ a -> Value -> Position -> Either (ValueError, Position) Value
_ Value
_ Position
p = forall a b. a -> Either a b
Left (JSONError -> ValueError
JSONError forall a b. (a -> b) -> a -> b
$ MigrationTag -> JSONError
SyntaxError MigrationTag
"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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Vector a -> m (Vector b)
V.mapM (Int, Value) -> Either (ValueError, Position) Value
alterAt (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 forall a. a -> [a] -> [a]
: Position
p)
withArrayElems Value -> Position -> Either (ValueError, Position) Value
_     Value
v              Position
p = forall a b. a -> Either a b
Left (JSONError -> ValueError
JSONError 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
_ = 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 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 = forall a b. a -> Either a b
Left (JSONError -> ValueError
JSONError 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 = 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
_) = forall a. a -> Maybe a
Just DefaultValue
DefValList
defaultValueForType (TyMaybe APIType
_) = forall a. a -> Maybe a
Just DefaultValue
DefValMaybe
defaultValueForType APIType
_           = 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 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 = forall (f :: * -> *) a. Functor f => f a -> f ()
void 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) = 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)  = 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 forall a b. (a -> b) -> a -> b
$ \ Text
s Position
p ->
        if Text -> FieldName
FieldName Text
s forall a. Ord a => a -> Set a -> Bool
`Set.member` NormEnumType
vals
           then forall (m :: * -> *) a. Monad m => a -> m a
return Text
s
           else forall a b. a -> Either a b
Left (JSONError -> ValueError
JSONError JSONError
UnexpectedField, Text -> Step
InField Text
s 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 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
_ -> 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 = forall t.
Decode t
-> Value -> Position -> Either (ValueError, Position) Value
expectDecodes (forall a.
FromJSONWithErrs a =>
Value -> Either [(JSONError, Position)] a
fromJSONWithErrs :: Decode T.Text)
    valueMatchesBasic BasicType
BTbinary = forall t.
Decode t
-> Value -> Position -> Either (ValueError, Position) Value
expectDecodes (forall a.
FromJSONWithErrs a =>
Value -> Either [(JSONError, Position)] a
fromJSONWithErrs :: Decode Binary)
    valueMatchesBasic BasicType
BTbool   = forall t.
Decode t
-> Value -> Position -> Either (ValueError, Position) Value
expectDecodes (forall a.
FromJSONWithErrs a =>
Value -> Either [(JSONError, Position)] a
fromJSONWithErrs :: Decode Bool)
    valueMatchesBasic BasicType
BTint    = forall t.
Decode t
-> Value -> Position -> Either (ValueError, Position) Value
expectDecodes (forall a.
FromJSONWithErrs a =>
Value -> Either [(JSONError, Position)] a
fromJSONWithErrs :: Decode Int)
    valueMatchesBasic BasicType
BTutc    = forall t.
Decode t
-> Value -> Position -> Either (ValueError, Position) Value
expectDecodes (forall a.
FromJSONWithErrs a =>
Value -> Either [(JSONError, Position)] a
fromJSONWithErrs :: Decode UTCTime)

    expectDecodes :: Decode t -> JS.Value -> Position -> Either (ValueError, Position) JS.Value
    expectDecodes :: forall t.
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
_          -> forall (m :: * -> *) a. Monad m => a -> m a
return Value
v
                            Left ((JSONError
je, Position
_):[(JSONError, Position)]
_) -> forall a b. a -> Either a b
Left (JSONError -> ValueError
JSONError JSONError
je, Position
p)
                            Left []          -> forall a b. a -> Either a b
Left (JSONError -> ValueError
JSONError forall a b. (a -> b) -> a -> b
$ MigrationTag -> JSONError
SyntaxError MigrationTag
"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
-> MigrationTag -> MigrationTag -> MigrationTag -> Q [Dec]
generateMigrationKinds APIChangelog
changes MigrationTag
all_nm MigrationTag
rec_nm MigrationTag
fld_nm = do
    forall {m :: * -> *} {a}. (MonadFail m, Show a) => Set a -> m ()
guardNoDups (Set MigrationTag
all_tags forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection` Set MigrationTag
rec_tags)
    forall {m :: * -> *} {a}. (MonadFail m, Show a) => Set a -> m ()
guardNoDups (Set MigrationTag
all_tags forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection` Set MigrationTag
fld_tags)
    forall {m :: * -> *} {a}. (MonadFail m, Show a) => Set a -> m ()
guardNoDups (Set MigrationTag
rec_tags forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection` Set MigrationTag
fld_tags)

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

    guardNoDups :: Set a -> m ()
guardNoDups Set a
xs
      | forall a. Set a -> Bool
Set.null Set a
xs = forall (m :: * -> *) a. Monad m => a -> m a
return ()
      | Bool
otherwise   = forall (m :: * -> *) a. MonadFail m => MigrationTag -> m a
fail forall a b. (a -> b) -> a -> b
$ MigrationTag
"generateMigrationKinds: duplicate custom migrations in changelog: "
                             forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> MigrationTag
show (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 :: MigrationTag -> Set MigrationTag -> [Con]
cons MigrationTag
s Set MigrationTag
xs | Bool -> Bool
not (forall a. Set a -> Bool
Set.null Set MigrationTag
xs) = forall a b. (a -> b) -> [a] -> [b]
map (\ MigrationTag
x -> Name -> [BangType] -> Con
NormalC (MigrationTag -> Name
mkName MigrationTag
x) []) (forall a. Set a -> [a]
Set.toList Set MigrationTag
xs)
              | Bool
otherwise         = [Name -> [BangType] -> Con
NormalC (MigrationTag -> Name
mkName forall a b. (a -> b) -> a -> b
$ MigrationTag
"No" forall a. [a] -> [a] -> [a]
++ MigrationTag
s) []]

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