{-# LANGUAGE TemplateHaskell #-}
module Data.API.Changes
( migrateDataDump
, migrateDataDump'
, validateChanges
, dataMatchesAPI
, DataChecks(..)
, APIChangelog(..)
, APIWithChangelog
, APIChange(..)
, VersionExtra(..)
, showVersionExtra
, changelogStartVersion
, changelogVersion
, CustomMigrations(..)
, mkRecordMigration
, mkRecordMigration'
, mkRecordMigrationSchema
, noDataChanges
, noSchemaChanges
, generateMigrationKinds
, MigrationTag
, NormAPI
, NormTypeDecl(..)
, NormRecordType
, NormUnionType
, NormEnumType
, apiNormalForm
, declNF
, 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
migrateDataDump :: (Read db, Read rec, Read fld)
=> (API, Version)
-> (API, VersionExtra)
-> APIChangelog
-> CustomMigrations JS.Object JS.Value db rec fld
-> TypeName
-> DataChecks
-> JS.Value
-> 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)
-> (API, VersionExtra)
-> APIChangelog
-> CustomMigrations Record Value db rec fld
-> TypeName
-> DataChecks
-> Value.Value
-> 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)
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)
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)
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
noDataChanges :: a -> Either ValueError a
noDataChanges :: forall a. a -> Either ValueError a
noDataChanges = forall (m :: * -> *) a. Monad m => a -> m a
return
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
data DataChecks = NoChecks
| CheckStartAndEnd
| CheckCustom
| CheckAll
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)
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
changelogStartVersion :: APIChangelog -> Version
changelogStartVersion :: APIChangelog -> Version
changelogStartVersion (ChangesStart Version
v) = Version
v
changelogStartVersion (ChangesUpTo VersionExtra
_ [APIChange]
_ APIChangelog
clog) = APIChangelog -> Version
changelogStartVersion APIChangelog
clog
changelogVersion :: APIChangelog -> VersionExtra
changelogVersion :: APIChangelog -> VersionExtra
changelogVersion (ChangesStart Version
v) = Version -> VersionExtra
Release Version
v
changelogVersion (ChangesUpTo VersionExtra
v [APIChange]
_ APIChangelog
_) = VersionExtra
v
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 ]
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
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)
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
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)
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
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
validateChanges :: (Read db, Read rec, Read fld)
=> (API, Version)
-> (API, VersionExtra)
-> APIChangelog
-> CustomMigrations o v db rec fld
-> TypeName
-> DataChecks
-> 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
validateChanges' :: (API, Version)
-> (API, VersionExtra)
-> APIChangelog
-> CustomMigrationsTagged o v
-> TypeName
-> DataChecks
-> 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
([APIChange]
changes, VersionExtra
verEnd) <- APIChangelog
-> VersionExtra
-> VersionExtra
-> Either ValidateFailure ([APIChange], VersionExtra)
selectChanges APIChangelog
clog (Version -> VersionExtra
Release Version
ver) VersionExtra
ver'
let apiStart :: NormAPI
apiStart = API -> NormAPI
apiNormalForm API
api
apiTarget :: NormAPI
apiTarget = API -> NormAPI
apiNormalForm API
api'
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'
(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
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')
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
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'')
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
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
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
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
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
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
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)
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
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
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
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
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)
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
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
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
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
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)
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
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
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)
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]