api-tools 0.3 → 0.4

raw patch · 13 files changed

+470/−219 lines, 13 filesdep ~Cabaldep ~QuickCheckdep ~aeson-prettyPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: Cabal, QuickCheck, aeson-pretty, array, attoparsec, case-insensitive, containers, lens, old-locale, regex-compat-tdfa, safe, safecopy, tasty, tasty-hunit, tasty-quickcheck, template-haskell, text, time, unordered-containers, vector

API changes (from Hackage documentation)

Files

• api-tools.cabal +68/−68
• dist/build/Data/API/Parse.hs +77/−33
• dist/build/Data/API/Scan.hs +112/−13
• main/Data/API/MigrationTool.hs +4/−5
• src/Data/API/Changes.hs +52/−24
• src/Data/API/JSON.hs +89/−19
• src/Data/API/Parse.y +1/−1
• src/Data/API/Tools/JSON.hs +16/−25
• src/Data/API/Tutorial.hs +7/−7
• src/Data/API/Types.hs +17/−1
• tests/Data/API/Test/Gen.hs +1/−1
• tests/Data/API/Test/JSON.hs +8/−6
• tests/Data/API/Test/Migration.hs +18/−16

@@ -1,5 +1,5 @@ Name:                api-tools-Version:             0.3+Version:             0.4 Synopsis:            DSL for generating API boilerplate and docs Description:         api-tools provides a compact DSL for describing an API.                      It uses Template Haskell to generate the@@ -25,7 +25,7 @@ Source-Repository this   Type:              git   Location:          git://github.com/iconnect/api-tools.git-  Tag:               0.3+  Tag:               0.4  Library   Hs-Source-Dirs:    src@@ -65,28 +65,29 @@         Data.API.TH    Build-depends:-        Cabal                >= 1.9.2       ,-        QuickCheck           >= 2.5.1,-        aeson                >= 0.6.2 && < 0.7,-        aeson-pretty         <= 0.7         ,-        array                >= 0.4,-        attoparsec           >= 0.10.4,-        base                 == 4.*,-        base64-bytestring    == 1.0.*,-        bytestring           >= 0.9     && < 0.11,-        case-insensitive     >= 1.0,-        containers           >= 0.5,-        lens                 >= 3.8.7,-        old-locale           >= 1.0.0.4,-        regex-compat-tdfa    >= 0.95.1,-        safe                 >= 0.3.3,-        safecopy             >= 0.8.1,-        time                 >= 1.4,-        template-haskell     >= 2.7,-        text                 >= 0.11.3,-        unordered-containers >= 0.2.3.0     ,-        vector               >= 0.10.0.1+        Cabal                >= 1.4      && < 2    ,+        QuickCheck           >= 2.5.1    && < 2.8  ,+        aeson                >= 0.6.2    && < 0.7  ,+        aeson-pretty         >= 0.1      && < 0.8  ,+        array                >= 0.4      && < 0.5  ,+        attoparsec           >= 0.10.4   && < 0.12 ,+        base                 >= 4        && < 5    ,+        base64-bytestring    >= 1.0      && < 1.1  ,+        bytestring           >= 0.9      && < 0.11 ,+        case-insensitive     >= 1.0      && < 1.3  ,+        containers           >= 0.5      && < 0.6  ,+        lens                 >= 3.8.7    && < 4    ,+        old-locale           >= 1.0.0.4  && < 1.1  ,+        regex-compat-tdfa    >= 0.95.1   && < 0.96 ,+        safe                 >= 0.3.3    && < 0.4  ,+        safecopy             >= 0.8.1    && < 0.9  ,+        time                 >= 1.4      && < 1.5  ,+        template-haskell     >= 2.7      && < 2.9  ,+        text                 >= 0.11.3   && < 1.2  ,+        unordered-containers >= 0.2.3.0  && < 0.3  ,+        vector               >= 0.10.0.1 && < 0.11 +   Build-tools:         alex,         happy@@ -105,27 +106,26 @@    Build-depends:         api-tools,-        Cabal                >= 1.9.2       ,-        QuickCheck           >= 2.5.1,-        aeson                >= 0.6.2 && < 0.7,-        aeson-pretty         <= 0.7         ,-        array                >= 0.4,-        attoparsec           >= 0.10.4,-        base                 == 4.*,-        base64-bytestring    == 1.0.*,-        bytestring           >= 0.9     && < 0.11,-        case-insensitive     >= 1.0,-        containers           >= 0.5,-        lens                 >= 3.8.7,-        old-locale           >= 1.0.0.4,-        regex-compat-tdfa    >= 0.95.1,-        safe                 >= 0.3.3,-        safecopy             >= 0.8.1,-        time                 >= 1.4,-        template-haskell     >= 2.7,-        text                 >= 0.11.3,-        unordered-containers >= 0.2.3.0     ,-        vector               >= 0.10.0.1+        QuickCheck           >= 2.5.1    && < 2.8  ,+        aeson                >= 0.6.2    && < 0.7  ,+        aeson-pretty         >= 0.1      && < 0.8  ,+        array                >= 0.4      && < 0.5  ,+        attoparsec           >= 0.10.4   && < 0.12 ,+        base                 >= 4        && < 5    ,+        base64-bytestring    >= 1.0      && < 1.1  ,+        bytestring           >= 0.9      && < 0.11 ,+        case-insensitive     >= 1.0      && < 1.3  ,+        containers           >= 0.5      && < 0.6  ,+        lens                 >= 3.8.7    && < 4    ,+        old-locale           >= 1.0.0.4  && < 1.1  ,+        regex-compat-tdfa    >= 0.95.1   && < 0.96 ,+        safe                 >= 0.3.3    && < 0.4  ,+        safecopy             >= 0.8.1    && < 0.9  ,+        time                 >= 1.4      && < 1.5  ,+        template-haskell     >= 2.7      && < 2.9  ,+        text                 >= 0.11.3   && < 1.2  ,+        unordered-containers >= 0.2.3.0  && < 0.3  ,+        vector               >= 0.10.0.1 && < 0.11    GHC-Options:         -main-is Data.API.MigrationTool@@ -151,30 +151,30 @@    Build-depends:         api-tools,-        Cabal                >= 1.9.2       ,-        QuickCheck           >= 2.5.1,-        aeson                >= 0.6.2 && < 0.7,-        aeson-pretty         <= 0.7         ,-        array                >= 0.4,-        attoparsec           >= 0.10.4,-        base                 == 4.*,-        base64-bytestring    == 1.0.*,-        bytestring           >= 0.9     && < 0.11,-        case-insensitive     >= 1.0,-        containers           >= 0.5,-        lens                 >= 3.8.7,-        old-locale           >= 1.0.0.4,-        regex-compat-tdfa    >= 0.95.1,-        safe                 >= 0.3.3,-        safecopy             >= 0.8.1,-        tasty                >= 0.3         ,-        tasty-hunit          >= 0.2         ,-        tasty-quickcheck     >= 0.3         ,-        time                 >= 1.4,-        template-haskell     >= 2.7,-        text                 >= 0.11.3,-        unordered-containers >= 0.2.3.0     ,-        vector               >= 0.10.0.1+        Cabal                >= 1.4      && < 2    ,+        QuickCheck           >= 2.5.1    && < 2.8  ,+        aeson                >= 0.6.2    && < 0.7  ,+        aeson-pretty         >= 0.1      && < 0.8  ,+        array                >= 0.4      && < 0.5  ,+        attoparsec           >= 0.10.4   && < 0.12 ,+        base                 >= 4        && < 5    ,+        base64-bytestring    >= 1.0      && < 1.1  ,+        bytestring           >= 0.9      && < 0.11 ,+        case-insensitive     >= 1.0      && < 1.3  ,+        containers           >= 0.5      && < 0.6  ,+        lens                 >= 3.8.7    && < 4    ,+        old-locale           >= 1.0.0.4  && < 1.1  ,+        regex-compat-tdfa    >= 0.95.1   && < 0.96 ,+        safe                 >= 0.3.3    && < 0.4  ,+        safecopy             >= 0.8.1    && < 0.9  ,+        tasty                >= 0.3      && < 0.9  ,+        tasty-hunit          >= 0.2      && < 0.9  ,+        tasty-quickcheck     >= 0.3      && < 0.9  ,+        time                 >= 1.4      && < 1.5  ,+        template-haskell     >= 2.7      && < 2.9  ,+        text                 >= 0.11.3   && < 1.2  ,+        unordered-containers >= 0.2.3.0  && < 0.3  ,+        vector               >= 0.10.0.1 && < 0.11    GHC-Options:         -main-is Data.API.Test.Main

@@ -26,7 +26,7 @@ import qualified Data.Array as Happy_Data_Array import qualified GHC.Exts as Happy_GHC_Exts --- parser produced by Happy Version 1.19.0+-- parser produced by Happy Version 1.19.2  newtype HappyAbsSyn  = HappyAbsSyn HappyAny #if __GLASGOW_HASKELL__ >= 607@@ -1056,7 +1056,7 @@ 	 = case happyOut32 happy_x_3 of { happy_var_3 ->  	case happyOut47 happy_x_4 of { happy_var_4 ->  	happyIn38-		 ([ChCustomRecord happy_var_3 happy_var_4]+		 ([ChCustomType happy_var_3 happy_var_4] 	) `HappyStk` happyRest}}  happyReduce_77 = happySpecReduce_2  33# happyReduction_77@@ -1479,6 +1479,49 @@ {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "<command-line>" #-}+{-# LINE 8 "<command-line>" #-}+# 1 "/usr/include/stdc-predef.h" 1 3 4++# 17 "/usr/include/stdc-predef.h" 3 4+++++++++++++++# 1 "/usr/include/x86_64-linux-gnu/bits/predefs.h" 1 3 4++# 18 "/usr/include/x86_64-linux-gnu/bits/predefs.h" 3 4+++++++++++++# 31 "/usr/include/stdc-predef.h" 2 3 4+++++++++{-# LINE 8 "<command-line>" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} -- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp  @@ -1488,6 +1531,7 @@   +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. #if __GLASGOW_HASKELL__ > 706 #define LT(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.<# m)) :: Bool) #define GTE(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.>=# m)) :: Bool)@@ -1497,7 +1541,7 @@ #define GTE(n,m) (n Happy_GHC_Exts.>=# m) #define EQ(n,m) (n Happy_GHC_Exts.==# m) #endif-{-# LINE 45 "templates/GenericTemplate.hs" #-}+{-# LINE 46 "templates/GenericTemplate.hs" #-}   data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList@@ -1506,11 +1550,11 @@   -{-# LINE 66 "templates/GenericTemplate.hs" #-}+{-# LINE 67 "templates/GenericTemplate.hs" #-} -{-# LINE 76 "templates/GenericTemplate.hs" #-}+{-# LINE 77 "templates/GenericTemplate.hs" #-} -{-# LINE 85 "templates/GenericTemplate.hs" #-}+{-# LINE 86 "templates/GenericTemplate.hs" #-}  infixr 9 `HappyStk` data HappyStk a = HappyStk a (HappyStk a)@@ -1527,9 +1571,9 @@ -- parse (a %partial parser).  We must ignore the saved token on the top of -- the stack in this case. happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) =-	happyReturn1 ans+        happyReturn1 ans happyAccept j tk st sts (HappyStk ans _) = -	(happyTcHack j (happyTcHack st)) (happyReturn1 ans)+        (happyTcHack j (happyTcHack st)) (happyReturn1 ans)  ----------------------------------------------------------------------------- -- Arrays only: do the next action@@ -1537,35 +1581,35 @@   happyDoAction i tk st-	= {- nothing -}+        = {- nothing -}  -	  case action of-		0#		  -> {- nothing -}-				     happyFail i tk st-		-1# 	  -> {- nothing -}-				     happyAccept i tk st-		n | LT(n,(0# :: Happy_GHC_Exts.Int#)) -> {- nothing -}+          case action of+                0#           -> {- nothing -}+                                     happyFail i tk st+                -1#          -> {- nothing -}+                                     happyAccept i tk st+                n | LT(n,(0# :: Happy_GHC_Exts.Int#)) -> {- nothing -} -				     (happyReduceArr Happy_Data_Array.! rule) i tk st-				     where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#))))))-		n		  -> {- nothing -}+                                                   (happyReduceArr Happy_Data_Array.! rule) i tk st+                                                   where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#))))))+                n                 -> {- nothing -}  -				     happyShift new_state i tk st+                                     happyShift new_state i tk st                                      where new_state = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#))    where off    = indexShortOffAddr happyActOffsets st          off_i  = (off Happy_GHC_Exts.+# i)-	 check  = if GTE(off_i,(0# :: Happy_GHC_Exts.Int#))+         check  = if GTE(off_i,(0# :: Happy_GHC_Exts.Int#))                   then EQ(indexShortOffAddr happyCheck off_i, i)-		  else False+                  else False          action           | check     = indexShortOffAddr happyTable off_i           | otherwise = indexShortOffAddr happyDefActions st   indexShortOffAddr (HappyA# arr) off =-	Happy_GHC_Exts.narrow16Int# i+        Happy_GHC_Exts.narrow16Int# i   where         i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low)         high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#)))@@ -1584,7 +1628,7 @@ ----------------------------------------------------------------------------- -- HappyState data type (not arrays) -{-# LINE 169 "templates/GenericTemplate.hs" #-}+{-# LINE 170 "templates/GenericTemplate.hs" #-}  ----------------------------------------------------------------------------- -- Shifting a token@@ -1626,9 +1670,9 @@      = happyFail 0# tk st sts stk happyReduce k nt fn j tk st sts stk      = case happyDrop (k Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) sts of-	 sts1@((HappyCons (st1@(action)) (_))) ->-        	let r = fn stk in  -- it doesn't hurt to always seq here...-       		happyDoSeq r (happyGoto nt j tk st1 sts1 r)+         sts1@((HappyCons (st1@(action)) (_))) ->+                let r = fn stk in  -- it doesn't hurt to always seq here...+                happyDoSeq r (happyGoto nt j tk st1 sts1 r)  happyMonadReduce k nt fn 0# tk st sts stk      = happyFail 0# tk st sts stk@@ -1680,7 +1724,7 @@ -- parse error if we are in recovery and we fail again happyFail 0# tk old_st _ stk@(x `HappyStk` _) =      let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in---	trace "failing" $ +--      trace "failing" $          happyError_ i tk  {-  We don't need state discarding for our restricted implementation of@@ -1689,16 +1733,16 @@  -- discard a state happyFail  0# tk old_st (HappyCons ((action)) (sts)) -						(saved_tok `HappyStk` _ `HappyStk` stk) =---	trace ("discarding state, depth " ++ show (length stk))  $-	happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk))+                                                (saved_tok `HappyStk` _ `HappyStk` stk) =+--      trace ("discarding state, depth " ++ show (length stk))  $+        happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) -}  -- Enter error recovery: generate an error token, --                       save the old token and carry on. happyFail  i tk (action) sts stk = --      trace "entering error recovery" $-	happyDoAction 0# tk action sts ( (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk)+        happyDoAction 0# tk action sts ( (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk)  -- Internal happy errors: @@ -1716,9 +1760,9 @@  ----------------------------------------------------------------------------- -- Seq-ing.  If the --strict flag is given, then Happy emits ---	happySeq = happyDoSeq+--      happySeq = happyDoSeq -- otherwise it emits--- 	happySeq = happyDontSeq+--      happySeq = happyDontSeq  happyDoSeq, happyDontSeq :: a -> b -> b happyDoSeq   a b = a `seq` b

@@ -38,6 +38,54 @@ {-# LINE 1 "templates/wrappers.hs" #-} {-# LINE 1 "templates/wrappers.hs" #-} {-# LINE 1 "<command-line>" #-}+++++++# 1 "/usr/include/stdc-predef.h" 1 3 4++# 17 "/usr/include/stdc-predef.h" 3 4+++++++++++++++# 1 "/usr/include/x86_64-linux-gnu/bits/predefs.h" 1 3 4++# 18 "/usr/include/x86_64-linux-gnu/bits/predefs.h" 3 4+++++++++++++# 31 "/usr/include/stdc-predef.h" 2 3 4+++++++++{-# LINE 6 "<command-line>" #-} {-# LINE 1 "templates/wrappers.hs" #-} -- ----------------------------------------------------------------------------- -- Alex wrapper code.@@ -98,11 +146,11 @@                               in p' `seq`  Just (b, (p', c, bs, s))  -{-# LINE 89 "templates/wrappers.hs" #-}+{-# LINE 92 "templates/wrappers.hs" #-} -{-# LINE 103 "templates/wrappers.hs" #-}+{-# LINE 106 "templates/wrappers.hs" #-} -{-# LINE 118 "templates/wrappers.hs" #-}+{-# LINE 121 "templates/wrappers.hs" #-}  -- ----------------------------------------------------------------------------- -- Token positions@@ -130,27 +178,27 @@ -- ----------------------------------------------------------------------------- -- Default monad -{-# LINE 239 "templates/wrappers.hs" #-}+{-# LINE 242 "templates/wrappers.hs" #-}   -- ----------------------------------------------------------------------------- -- Monad (with ByteString input) -{-# LINE 328 "templates/wrappers.hs" #-}+{-# LINE 333 "templates/wrappers.hs" #-}   -- ----------------------------------------------------------------------------- -- Basic wrapper -{-# LINE 355 "templates/wrappers.hs" #-}+{-# LINE 360 "templates/wrappers.hs" #-}   -- ----------------------------------------------------------------------------- -- Basic wrapper, ByteString version -{-# LINE 373 "templates/wrappers.hs" #-}+{-# LINE 378 "templates/wrappers.hs" #-} -{-# LINE 386 "templates/wrappers.hs" #-}+{-# LINE 392 "templates/wrappers.hs" #-}   -- -----------------------------------------------------------------------------@@ -173,7 +221,7 @@ -- ----------------------------------------------------------------------------- -- Posn wrapper, ByteString version -{-# LINE 418 "templates/wrappers.hs" #-}+{-# LINE 424 "templates/wrappers.hs" #-}   -- -----------------------------------------------------------------------------@@ -357,6 +405,55 @@ {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "<command-line>" #-}++++++++# 1 "/usr/include/stdc-predef.h" 1 3 4++# 17 "/usr/include/stdc-predef.h" 3 4+++++++++++++++# 1 "/usr/include/x86_64-linux-gnu/bits/predefs.h" 1 3 4++# 18 "/usr/include/x86_64-linux-gnu/bits/predefs.h" 3 4+++++++++++++# 31 "/usr/include/stdc-predef.h" 2 3 4+++++++++{-# LINE 7 "<command-line>" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} -- ----------------------------------------------------------------------------- -- ALEX TEMPLATE@@ -373,6 +470,7 @@   +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. #if __GLASGOW_HASKELL__ > 706 #define GTE(n,m) (tagToEnum# (n >=# m)) #define EQ(n,m) (tagToEnum# (n ==# m))@@ -380,11 +478,11 @@ #define GTE(n,m) (n >=# m) #define EQ(n,m) (n ==# m) #endif-{-# LINE 50 "templates/GenericTemplate.hs" #-}+{-# LINE 51 "templates/GenericTemplate.hs" #-}   data AlexAddr = AlexA# Addr#-+-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. #if __GLASGOW_HASKELL__ < 503 uncheckedShiftL# = shiftL# #endif@@ -427,6 +525,7 @@   + #if __GLASGOW_HASKELL__ < 503 quickIndex arr i = arr ! i #else@@ -515,7 +614,7 @@ 	check_accs (AlexAccNone) = last_acc 	check_accs (AlexAcc a  ) = AlexLastAcc a input (I# (len)) 	check_accs (AlexAccSkip) = AlexLastSkip  input (I# (len))-{-# LINE 196 "templates/GenericTemplate.hs" #-}+{-# LINE 198 "templates/GenericTemplate.hs" #-}  data AlexLastAcc a   = AlexNone@@ -531,7 +630,7 @@   = AlexAccNone   | AlexAcc a   | AlexAccSkip-{-# LINE 240 "templates/GenericTemplate.hs" #-}+{-# LINE 242 "templates/GenericTemplate.hs" #-}  -- used by wrappers iUnbox (I# (i)) = i

@@ -74,12 +74,11 @@     deriving (Read, Show)  customMigrations :: CustomMigrations ChangeTag ChangeTag ChangeTag-customMigrations = CustomMigrations nope (\ _ _ -> Nothing)-                                    nope (\ _ _ -> Nothing)-                                    nofld+customMigrations = CustomMigrations (nope JS.Object) (const noSchemaChanges)+                                    (nope id)        (const noSchemaChanges)+                                    (nope id)   where-    nope  _ v = Left (CustomMigrationError "No custom migrations defined" (JS.Object v))-    nofld _ v = Left (CustomMigrationError "No field custom migrations defined" v)+    nope toVal _ v = Left (CustomMigrationError "No custom migrations defined" (toVal v))  compareJSON :: FilePath -> FilePath -> IO () compareJSON file1 file2 = do

@@ -22,6 +22,10 @@        -- * Custom migrations     , CustomMigrations(..)+    , mkRecordMigration+    , mkRecordMigrationSchema+    , noDataChanges+    , noSchemaChanges     , generateMigrationKinds     , MigrationTag @@ -148,8 +152,8 @@     | ChDeleteEnumVal TypeName FieldName     | ChRenameEnumVal TypeName FieldName FieldName -      -- Custom value (not type) changes-    | ChCustomRecord  TypeName MigrationTag+      -- Custom migrations+    | ChCustomType    TypeName MigrationTag     | ChCustomAll     MigrationTag     deriving (Eq, Show) @@ -163,34 +167,57 @@ -- * Whole-database migrations, which may arbitrarily change the API -- schema and the data to match; ----- * Record migrations, which may change the schema of a single--- record; and+-- * Type migrations, which may change the schema of a single type; and -- -- * Single field migrations, which may change only the type of the -- field (with the new type specified in the changelog). ----- For database and record migrations, if the schema is unchanged, the+-- For database and type migrations, if the schema is unchanged, the -- corresponding function should return 'Nothing'. ----- The @db@, @rec@ and @fld@ parameters should be instantiated with+-- The @db@, @ty@ and @fld@ parameters should be instantiated with -- the enumeration types generated by 'generateMigrationKinds', which -- correspond to the exact set of custom migration tags used in the -- changelog.-data CustomMigrations db rec fld = CustomMigrations+data CustomMigrations db ty fld = CustomMigrations     { databaseMigration       :: db -> JS.Object -> Either ValueError JS.Object-    , databaseMigrationSchema :: db -> NormAPI -> Maybe NormAPI-    , recordMigration         :: rec -> JS.Object -> Either ValueError JS.Object-    , recordMigrationSchema   :: rec -> NormRecordType -> Maybe NormRecordType+    , databaseMigrationSchema :: db -> NormAPI -> Either ApplyFailure (Maybe NormAPI)+    , typeMigration           :: ty -> JS.Value -> Either ValueError JS.Value+    , typeMigrationSchema     :: ty -> NormTypeDecl -> Either ApplyFailure (Maybe NormTypeDecl)     , fieldMigration          :: fld -> JS.Value -> Either ValueError JS.Value }  type CustomMigrationsTagged = CustomMigrations MigrationTag MigrationTag MigrationTag -readCustomMigrations :: (Read db, Read rec, Read fld)-                     => CustomMigrations db rec fld -> CustomMigrationsTagged+readCustomMigrations :: (Read db, Read ty, Read fld)+                     => CustomMigrations db ty fld -> CustomMigrationsTagged readCustomMigrations (CustomMigrations db dbs r rs f) =     CustomMigrations (db . read) (dbs . read) (r . read) (rs . read) (f . read) +-- | Lift a custom record migration to work on arbitrary values+mkRecordMigration :: (JS.Object -> Either ValueError JS.Object)+                  -> (JS.Value  -> Either ValueError JS.Value)+mkRecordMigration f (JS.Object o) = JS.Object <$> f o+mkRecordMigration _ v             = Left $ JSONError $ expectedObject v +-- | Lift a schema change on record types to work on arbitrary type declarations+mkRecordMigrationSchema :: TypeName+                        -> (NormRecordType -> Either ApplyFailure (Maybe NormRecordType))+                        -> (NormTypeDecl   -> Either ApplyFailure (Maybe NormTypeDecl))+mkRecordMigrationSchema tname f tinfo = do+  recinfo <- expectRecordType tinfo ?! TypeWrongKind tname TKRecord+  fmap NRecordType <$> f recinfo++-- | Use for 'databaseMigration', 'typeMigration' or 'fieldMigration'+-- to indicate that changes to the data are not required+noDataChanges :: a -> Either ValueError a+noDataChanges = return++-- | Use for 'databaseMigrationSchema' or 'typeMigrationSchema' to+-- indicate that the schema should not be changed+noSchemaChanges :: a -> Either ApplyFailure (Maybe a)+noSchemaChanges _ = Right Nothing++ -- | When to validate the data against the schema (each level implies -- the preceding levels): data DataChecks = NoChecks         -- ^ Not at all@@ -202,7 +229,7 @@ -- | Whether to validate the dataset after this change validateAfter :: DataChecks -> APIChange -> Bool validateAfter chks (ChChangeField{})  = chks >= CheckCustom-validateAfter chks (ChCustomRecord{}) = chks >= CheckCustom+validateAfter chks (ChCustomType{})   = chks >= CheckCustom validateAfter chks (ChCustomAll{})    = chks >= CheckCustom validateAfter chks _                  = chks >= CheckAll @@ -271,7 +298,7 @@ -- | Sets of custom migration tags in a single change changeTags :: APIChange -> (Set MigrationTag, Set MigrationTag, Set MigrationTag) changeTags (ChChangeField _ _ _ t) = (Set.empty, Set.empty, Set.singleton t)-changeTags (ChCustomRecord _ t)    = (Set.empty, Set.singleton t, Set.empty)+changeTags (ChCustomType _ t)      = (Set.empty, Set.singleton t, Set.empty) changeTags (ChCustomAll t)         = (Set.singleton t, Set.empty, Set.empty) changeTags _                       = (Set.empty, Set.empty, Set.empty) @@ -508,13 +535,13 @@             . Map.insert tname' tinfo . Map.delete tname) api          , Map.empty ) -applyAPIChangeToAPI _ custom (ChCustomRecord tname tag) api = do+applyAPIChangeToAPI _ custom (ChCustomType tname tag) api = do   -- to make some change to values of a type, the type name must exist-  tinfo   <- lookupType tname api-  recinfo <- expectRecordType tinfo               ?! TypeWrongKind tname TKRecord-  let api' = case recordMigrationSchema custom tag recinfo of-                 Just recinfo' -> Map.insert tname (NRecordType recinfo') api-                 Nothing       -> api+  tinfo  <- lookupType tname api+  mb_tinfo' <- typeMigrationSchema custom tag tinfo+  let api' = case mb_tinfo' of+                 Just tinfo' -> Map.insert tname tinfo' api+                 Nothing     -> api   return (api', findUpdatePos tname api)  applyAPIChangeToAPI root _ (ChAddField tname fname ftype mb_defval) api = do@@ -602,8 +629,9 @@                           . Set.delete fname) enuminfo   return (Map.insert tname tinfo' api, findUpdatePos tname api) -applyAPIChangeToAPI root custom (ChCustomAll tag) api =-  return ( fromMaybe api (databaseMigrationSchema custom tag api)+applyAPIChangeToAPI root custom (ChCustomAll tag) api = do+  mb_api' <- databaseMigrationSchema custom tag api+  return ( fromMaybe api mb_api'          , Map.singleton root (UpdateHere Nothing))  @@ -709,7 +737,7 @@     if s == fieldKey fname then return (fieldKey fname')                            else return s -applyChangeToData (ChCustomRecord _ tag) custom = withObject (liftMigration $ recordMigration custom tag)+applyChangeToData (ChCustomType _ tag)   custom = liftMigration $ typeMigration custom tag applyChangeToData (ChCustomAll tag)      custom = withObject (liftMigration $ databaseMigration custom tag)  applyChangeToData (ChAddType _ _)        _ = pure . pure@@ -970,7 +998,7 @@                                       , "  alternative removed " ++ pp f]   ppLines (ChRenameEnumVal t f f')  = [ "changed enum " ++ pp t                                       , "  alternative renamed " ++ pp f ++ " to " ++ pp f']-  ppLines (ChCustomRecord t c)      = ["changed record " ++ pp t ++ " migration " ++ pp c]+  ppLines (ChCustomType t c)        = ["migration record " ++ pp t ++ " " ++ pp c]   ppLines (ChCustomAll c)           = ["migration " ++ pp c]  instance PPLines MigrateFailure where

@@ -21,14 +21,19 @@        -- * Parser with multiple error support     , ParserWithErrs+    , ParseFlags(useDefaults, enforceReadOnlyFields)+    , defaultParseFlags     , runParserWithErrsTop        -- * FromJSON class with multiple error support     , FromJSONWithErrs(..)     , fromJSONWithErrs+    , fromJSONWithErrs'     , decodeWithErrs+    , decodeWithErrs'        -- * ParserWithErrs combinators+    , withParseFlags     , failWith     , expectedArray     , expectedBool@@ -47,8 +52,10 @@     , withUTCRange     , withVersion     , withField+    , withDefaultField     , (.:.)     , (.::)+    , withUnion     ) where  import           Data.API.Types@@ -179,13 +186,13 @@ -- --    * @pf \`ap\` ps@  returns errors from @pf@ only newtype ParserWithErrs a = ParserWithErrs {-    runParserWithErrs :: Position -> Either [(JSONError, Position)] a }+    runParserWithErrs :: ParseFlags -> Position -> Either [(JSONError, Position)] a }   deriving Functor  instance Applicative ParserWithErrs where-  pure x    = ParserWithErrs $ const $ Right x-  pf <*> ps = ParserWithErrs $ \ z ->-                  case (runParserWithErrs pf z, runParserWithErrs ps z) of+  pure x    = ParserWithErrs $ \ _ _ -> Right x+  pf <*> ps = ParserWithErrs $ \ q z ->+                  case (runParserWithErrs pf q z, runParserWithErrs ps q z) of                       (Right f, Right s)  -> Right $ f s                       (Left es, Right _)  -> Left es                       (Right _, Left es)  -> Left es@@ -193,22 +200,40 @@  instance Alternative ParserWithErrs where   empty   = failWith $ SyntaxError "No alternative"-  px <|> py = ParserWithErrs $ \ z -> case runParserWithErrs px z of+  px <|> py = ParserWithErrs $ \ q z -> case runParserWithErrs px q z of                                         Right v -> Right v-                                        Left  _ -> runParserWithErrs py z+                                        Left  _ -> runParserWithErrs py q z  instance Monad ParserWithErrs where   return   = pure-  px >>= f = ParserWithErrs $ \ z ->-                  case runParserWithErrs px z of-                    Right x -> runParserWithErrs (f x) z+  px >>= f = ParserWithErrs $ \ q z ->+                  case runParserWithErrs px q z of+                    Right x -> runParserWithErrs (f x) q z                     Left es -> Left es   fail     = failWith . SyntaxError -runParserWithErrsTop :: ParserWithErrs a -> Either [(JSONError, Position)] a-runParserWithErrsTop p = runParserWithErrs p [] +-- | Options to modify the behaviour of the JSON parser+data ParseFlags = ParseFlags+    { useDefaults           :: Bool+      -- ^ If true, default values from the schema will be used when a+      -- field is missing from the JSON data+    , enforceReadOnlyFields :: Bool+      -- ^ If true, fields in the schema marked read-only will be+      -- overwritten with default values+    } +-- | Use this as a basis for overriding individual fields of the+-- 'ParseFlags' record, in case more flags are added in the future.+defaultParseFlags :: ParseFlags+defaultParseFlags = ParseFlags { useDefaults           = False+                               , enforceReadOnlyFields = False+                               }++runParserWithErrsTop :: ParseFlags -> ParserWithErrs a -> Either [(JSONError, Position)] a+runParserWithErrsTop q p = runParserWithErrs p q []++ -------------------------------------------------- -- FromJSON class with multiple error support --@@ -246,6 +271,7 @@   parseJSONWithErrs (JS.Array a) = traverse help $ zip (V.toList a) [0..]     where       help (x, i) = stepInside (InElem i) $ parseJSONWithErrs x+  parseJSONWithErrs JS.Null      = pure []   parseJSONWithErrs v            = failWith $ expectedArray v  instance FromJSONWithErrs Int where@@ -275,30 +301,45 @@ -- implementation of 'parseJSONWithErrs' as it will not pass on the -- current position. fromJSONWithErrs :: FromJSONWithErrs a => JS.Value -> Either [(JSONError, Position)] a-fromJSONWithErrs = runParserWithErrsTop . parseJSONWithErrs+fromJSONWithErrs = fromJSONWithErrs' defaultParseFlags +-- | Run the JSON parser on a value to produce a result or a list of+-- errors with their positions.  This version allows the 'ParseFlags'+-- to be specified.+fromJSONWithErrs' :: FromJSONWithErrs a => ParseFlags -> JS.Value -> Either [(JSONError, Position)] a+fromJSONWithErrs' q = runParserWithErrsTop q . parseJSONWithErrs++ -- | Decode a 'ByteString' and run the JSON parser decodeWithErrs :: FromJSONWithErrs a => BL.ByteString -> Either [(JSONError, Position)] a-decodeWithErrs x = case JS.eitherDecode x of+decodeWithErrs = decodeWithErrs' defaultParseFlags++-- | Decode a 'ByteString' and run the JSON parser, allowing the+-- 'ParseFlags' to be specified+decodeWithErrs' :: FromJSONWithErrs a => ParseFlags -> BL.ByteString -> Either [(JSONError, Position)] a+decodeWithErrs' q x = case JS.eitherDecode x of                      Left e  -> Left [(SyntaxError e, [])]-                     Right v -> fromJSONWithErrs v+                     Right v -> fromJSONWithErrs' q v   --------------------------------- -- ParserWithErrs combinators -- +withParseFlags :: (ParseFlags -> ParserWithErrs a) -> ParserWithErrs a+withParseFlags k = ParserWithErrs $ \ q -> runParserWithErrs (k q) q+ failWith :: JSONError -> ParserWithErrs a-failWith e = ParserWithErrs $ \ z -> Left [(e, z)]+failWith e = ParserWithErrs $ \ _ z -> Left [(e, z)]  stepInside :: Step -> ParserWithErrs a -> ParserWithErrs a-stepInside s p = ParserWithErrs $ \ z -> runParserWithErrs p (s:z)+stepInside s p = ParserWithErrs $ \ q z -> runParserWithErrs p q (s:z)  -- | If this parser returns any errors at the current position, modify -- them using the supplied function. modifyTopError :: (JSONError -> JSONError)                -> ParserWithErrs a -> ParserWithErrs a-modifyTopError f p = ParserWithErrs $ \ z -> case runParserWithErrs p z of+modifyTopError f p = ParserWithErrs $ \ q z -> case runParserWithErrs p q z of                                                Left es -> Left $ map (modifyIfAt z) es                                                r       -> r   where@@ -389,9 +430,24 @@ withField k f m = stepInside (InField k) $ modifyTopError treatAsMissing $ f v   where     v = fromMaybe JS.Null $ HMap.lookup k m-    treatAsMissing (Expected _ _ JS.Null) = MissingField-    treatAsMissing e                      = e +treatAsMissing :: JSONError -> JSONError+treatAsMissing (Expected _ _ JS.Null) = MissingField+treatAsMissing e                      = e++-- | Look up the value of a field, which may be read-only or use a+-- default value (depending on the 'ParseFlags').+withDefaultField :: Bool -> Maybe JS.Value -> T.Text -> (JS.Value -> ParserWithErrs a)+                 -> JS.Object -> ParserWithErrs a+withDefaultField readOnly mb_defVal k f m =+    stepInside (InField k) $ modifyTopError treatAsMissing $ withParseFlags foo+  where+    foo q | readOnly && enforceReadOnlyFields q = f defVal+          | useDefaults q                       = f $ fromMaybe defVal  $ HMap.lookup k m+          | otherwise                           = f $ fromMaybe JS.Null $ HMap.lookup k m++    defVal = fromMaybe JS.Null mb_defVal+ -- | Look up the value of a field, failing on missing fields withStrictField :: T.Text -> (JS.Value -> ParserWithErrs a)           -> JS.Object -> ParserWithErrs a@@ -406,6 +462,20 @@ -- | Parse the value of a field, failing on missing fields (.::) :: FromJSONWithErrs a => JS.Object -> T.Text -> ParserWithErrs a m .:: k = withStrictField k parseJSONWithErrs m+++-- | Match an inhabitant of a disjoint union, which should be an+-- object with a single field, and call the continuation corresponding+-- to the field name.+withUnion :: [(T.Text, JS.Value -> ParserWithErrs a)] -> JS.Value -> ParserWithErrs a+withUnion xs (JS.Object hs) =+   case HMap.toList hs of+      [(k, v)] -> case lookup k xs of+                    Just c  -> stepInside (InField k) $ c v+                    Nothing -> failWith $ MissingAlt $ map (T.unpack . fst) xs+      []       -> failWith $ MissingAlt $ map (T.unpack . fst) xs+      _:_:_    -> failWith UnexpectedField+withUnion _ val = failWith $ Expected ExpObject "Union" val   deriveJSON defaultOptions ''JSONError

@@ -242,7 +242,7 @@     | changed record TypeName RFieldChanges { map (fldChangeToAPIChange $3)   (reverse $4) }     | changed union  TypeName RUnionChanges { map (unionChangeToAPIChange $3) (reverse $4) }     | changed enum   TypeName REnumChanges  { map (enumChangeToAPIChange $3)  (reverse $4) }-    | migration record TypeName MigrationTag { [ChCustomRecord $3 $4]       }+    | migration record TypeName MigrationTag { [ChCustomType $3 $4]         }     | migration MigrationTag             { [ChCustomAll $2]                 }     | comment                            { []                               } 

@@ -16,6 +16,7 @@  import           Data.Aeson hiding (withText, withBool) import           Control.Applicative+import qualified Data.HashMap.Strict            as HMap import qualified Data.Map                       as Map import           Data.Monoid import qualified Data.Text                      as T@@ -112,6 +113,7 @@             v .: "Input"                            <*>             v .: "Output"                           <*>             v .: "PipelineId"+     parseJSONWithErrs Null       = parseJSONWithErrs (Object HMap.empty)      parseJSONWithErrs v          = failWith $ expectedObject val -} @@ -119,12 +121,17 @@ gen_sr_fm = mkTool $ \ ts (an, sr) -> do     x <- newName "x"     optionalInstanceD ts ''FromJSONWithErrs [nodeRepT an]-                      [funD 'parseJSONWithErrs [cl an sr x, cl' x]]+                      [funD 'parseJSONWithErrs [cl an sr x, clNull, cl' x]]   where     cl an sr x  = clause [conP 'Object [varP x]] (normalB bdy) []-      where bdy = applicativeE (nodeConE an) [ [e| $(varE x) .:. $(fieldNameE fn) |]-                                             | (fn, _) <- srFields sr ]+      where+        bdy = applicativeE (nodeConE an) $ map project (srFields sr)+        project (fn, ft) = [e| withDefaultField ro (fmap defaultValueAsJsValue mb_dv) $(fieldNameE fn) parseJSONWithErrs $(varE x) |]+          where ro    = ftReadOnly ft+                mb_dv = ftDefault ft +    clNull = clause [conP 'Null []] (normalB [e| parseJSONWithErrs (Object HMap.empty) |]) []+     cl'  x = clause [varP x] (normalB (bdy' x)) []     bdy' x = [e| failWith (expectedObject $(varE x)) |] @@ -148,34 +155,18 @@  {- instance FromJSONWithErrs Foo where-    parseJSONWithErrs (Object v) = alternatives (failWith $ MissingAlt ["x", "y"])-        [ Bar <$> v .:: "x"-        , Baz <$> v .:: "y"-        ]-    parseJSONWithErrs val        = failWith $ expectedObject val+    parseJSONWithErrs = withUnion [ ("x", fmap Bar . parseJSONWithErrs)+                                  , ("y", fmap Baz . parseJSONWithErrs) ] -}  gen_su_fm :: Tool (APINode, SpecUnion)-gen_su_fm = mkTool $ \ ts (an, su) -> do-    x <- newName "x"+gen_su_fm = mkTool $ \ ts (an, su) ->     optionalInstanceD ts ''FromJSONWithErrs [nodeRepT an]-                      [funD 'parseJSONWithErrs (cls an su x)]+                      [simpleD 'parseJSONWithErrs (bdy an su)]  where-  cls an su x = [cl, cl']-   where-    cl  = clause [conP 'Object [varP x]] (normalB bdy) []-    bdy = [e| alternatives (failWith $ MissingAlt $ss) $alts |]--    alt fn = [e| fmap $(nodeAltConE an fn) ($(varE x) .:: $(fieldNameE fn)) |]--    alts = listE $ map alt fns-    ss   = listE $ map fieldNameE fns--    fns  = map fst $ suFields su--    cl'  = clause [varP x] (normalB bdy') []-    bdy' = [e| failWith (expectedObject $(varE x)) |]+    bdy an su = varE 'withUnion `appE` listE (map (alt an) (suFields su)) +    alt an (fn, _) = [e| ( $(fieldNameE fn) , fmap $(nodeAltConE an fn) . parseJSONWithErrs ) |]   {-

@@ -211,12 +211,12 @@ the primitive changes, /custom/ migrations can be used to migrate data between versions. -Custom migrations can be applied to the whole dataset, a single record+Custom migrations can be applied to the whole dataset, a single type or an individual record field, thus:  > version "0.42" >   migration MigrateWholeDataset->   migration record Widget MigrateWidgetRecord+>   migration record Widget MigrateWidgetType >   changed record Widget where >     field changed foo :: String migration MigrateFooField @@ -226,12 +226,12 @@ which describes how to transform the data (and 'API', if appropriate) for each custom migration.  For example, -> $(generateMigrationKinds myChangelog "DatabaseMigration" "RecordMigration" "FieldMigration")+> $(generateMigrationKinds myChangelog "DatabaseMigration" "TypeMigration" "FieldMigration")  with the changelog fragment above would give  > data DatabaseMigration = MigrateWholeDatabase | ...-> data RecordMigration   = MigrateWidgetRecord  | ...+> data TypeMigration     = MigrateWidgetType    | ... > data FieldMigration    = MigrateFooField      | ...  Calls to 'migrateDataDump' should include a suitable@@ -246,9 +246,9 @@ > ...  A field migration may change the type of the field by listing the new-type in the changelog.  Whole-database and individual-record-migrations may describe the changes they make to the schema in the-'databaseMigrationSchema' and 'recordMigrationSchema' fields of the+type in the changelog.  Whole-database and individual-type migrations+may describe the changes they make to the schema in the+'databaseMigrationSchema' and 'typeMigrationSchema' fields of the 'CustomMigrations' record.  In order to check that custom migrations result in data that matches

@@ -39,6 +39,7 @@ import           Data.Aeson import           Data.Aeson.Types import           Data.Aeson.TH+import           Data.Maybe import qualified Data.Text                      as T import qualified Data.Text.Encoding             as T import qualified Data.ByteString.Char8          as B@@ -144,9 +145,12 @@ instance Lift UTCRange where     lift (UTCRange lo hi) = [e| UTCRange $(liftMaybeUTCTime lo) $(liftMaybeUTCTime hi) |] +liftUTC :: UTCTime -> ExpQ+liftUTC u = [e| fromMaybe (error "liftUTC") (parseUTC_ $(stringE (mkUTC_ u))) |]+ liftMaybeUTCTime :: Maybe UTCTime -> ExpQ liftMaybeUTCTime Nothing  = [e| Nothing |]-liftMaybeUTCTime (Just u) = [e| parseUTC_ $(stringE (mkUTC_ u)) |]+liftMaybeUTCTime (Just u) = [e| Just $(liftUTC u) |]   data RegEx =@@ -219,6 +223,10 @@     | TyJSON                -- ^ a generic JSON value     deriving (Eq, Show) +-- | It is sometimes helpful to write a type name directly as a string+instance IsString APIType where+  fromString = TyName . fromString+ -- | the basic JSON types (N.B., no floating point numbers, yet) data BasicType     = BTstring -- ^ a JSON UTF-8 string@@ -237,6 +245,14 @@     | DefValInt    Int     | DefValUtc    UTCTime     deriving (Eq, Show)++instance Lift DefaultValue where+  lift DefValList       = [e| DefValList     |]+  lift DefValMaybe      = [e| DefValMaybe    |]+  lift (DefValString s) = [e| DefValString (T.pack $(lift (T.unpack s))) |]+  lift (DefValBool   b) = [e| DefValBool b   |]+  lift (DefValInt    i) = [e| DefValInt i    |]+  lift (DefValUtc    u) = [e| DefValUtc $(liftUTC u) |]  -- | Convert a default value to an Aeson 'Value'.  This differs from -- 'toJSON' as it will not round-trip with 'fromJSON': UTC default

@@ -12,7 +12,7 @@ import           Data.API.Tools.Example import           Control.Applicative import           Language.Haskell.TH-import           Test.QuickCheck+import           Test.QuickCheck                ( Arbitrary(..) )  $(generate         DSL.example) $(generateAPITools DSL.example

@@ -18,7 +18,7 @@  import           Test.Tasty import           Test.Tasty.HUnit-import           Test.Tasty.QuickCheck+import qualified Test.Tasty.QuickCheck    as QC   $(generate         startSchema)@@ -51,12 +51,14 @@  -- | Test that the correct errors are generated for bad JSON data errorDecoding :: [TestTree]-errorDecoding = [ help "not enough bytes" ""         (proxy :: Int)-                      [(SyntaxError "not enough bytes", [])]+errorDecoding = [ help "not enough input" ""         (proxy :: Int)+                      [(SyntaxError "not enough input", [])]                 , help "object for int"   "{}"       (proxy :: Int)                       [(Expected ExpInt "Int" (JS.Object HMap.empty), [])]                 , help "missing alt"      "{}"       (proxy :: AUnion)                       [(MissingAlt ["bar"], [])]+                , help "error inside alt" "{\"bar\": {}}" (proxy :: AUnion)+                      [(MissingField, [InField "id", InField "bar"])]                 , help "unexpected value" "[\"no\"]" (proxy :: [AnEnum])                       [(UnexpectedEnumVal ["bar", "foo"] "no", [InElem 0])]                 , help "missing field"    "{}"       (proxy :: Bar)@@ -77,8 +79,8 @@   [ testCase  "Basic value decoding"  basicValueDecoding   , testGroup "Decoding invalid data" errorDecoding   , testGroup "Round-trip tests"-      [ testGroup "example"  $ map (uncurry testProperty) exampleSimpleTests-      , testGroup "example2" $ map (uncurry testProperty) example2SimpleTests-      , testGroup "api"      $ map (uncurry testProperty) apiAPISimpleTests+      [ testGroup "example"  $ map (uncurry QC.testProperty) exampleSimpleTests+      , testGroup "example2" $ map (uncurry QC.testProperty) example2SimpleTests+      , testGroup "api"      $ map (uncurry QC.testProperty) apiAPISimpleTests       ]   ]

@@ -27,7 +27,7 @@ import           Data.Version import           Test.Tasty               as Test import           Test.Tasty.HUnit-import           Test.Tasty.QuickCheck+import qualified Test.Tasty.QuickCheck    as QC import           Test.QuickCheck.Property as P  @@ -43,20 +43,20 @@     recur <- HMap.lookup "recur" x ?! CustomMigrationError "missing recur" (JS.Object x)     return $ HMap.insert "recur2" recur x -testDatabaseMigrationSchema :: TestDatabaseMigration -> NormAPI -> Maybe NormAPI-testDatabaseMigrationSchema DuplicateBar _ = Nothing+testDatabaseMigrationSchema :: TestDatabaseMigration -> NormAPI -> Either ApplyFailure (Maybe NormAPI)+testDatabaseMigrationSchema DuplicateBar _ = Right Nothing testDatabaseMigrationSchema DuplicateRecursive napi =     let Just recur = Map.lookup (TypeName "Recursive") napi         Just (NRecordType dbs) = Map.lookup root_ napi         dbs' = Map.insert (FieldName "recur2") (TyMaybe (TyList (TyName "DuplicateRecursive"))) dbs-    in Just $ Map.insert (TypeName "DuplicateRecursive") recur $-              Map.insert root_ (NRecordType dbs') napi+    in Right $ Just $ Map.insert (TypeName "DuplicateRecursive") recur $+                      Map.insert root_ (NRecordType dbs') napi   -- Test of a single-record migration: copy the value in the id field -- onto the end of the c field-testRecordMigration :: TestRecordMigration -> JS.Object -> Either ValueError JS.Object-testRecordMigration CopyIDtoC x = do+testRecordMigration :: TestRecordMigration -> JS.Value -> Either ValueError JS.Value+testRecordMigration CopyIDtoC = mkRecordMigration $ \ x -> do     i <- HMap.lookup "id" x ?! CustomMigrationError "missing id" (JS.Object x)     b <- HMap.lookup "c" x  ?! CustomMigrationError "missing b" (JS.Object x)     r <- case (i, b) of@@ -64,14 +64,14 @@             -> return $ JS.String $ t `T.append` T.pack (show j)         _   -> Left $ CustomMigrationError "bad data" (JS.Object x)     return $ HMap.insert "c" r x-testRecordMigration DuplicateNew x = do+testRecordMigration DuplicateNew = mkRecordMigration $ \ x -> do     new <- HMap.lookup "new" x ?! CustomMigrationError "missing new" (JS.Object x)     return $ HMap.insert "newnew" new x -testRecordMigrationSchema :: TestRecordMigration -> NormRecordType -> Maybe NormRecordType-testRecordMigrationSchema CopyIDtoC _ = Nothing-testRecordMigrationSchema DuplicateNew r =-    Just $ Map.insert (FieldName "newnew") (TyBasic BTstring) r+testRecordMigrationSchema :: TestRecordMigration -> NormTypeDecl -> Either ApplyFailure (Maybe NormTypeDecl)+testRecordMigrationSchema CopyIDtoC    = noSchemaChanges+testRecordMigrationSchema DuplicateNew = mkRecordMigrationSchema "Recursive" $ \ r ->+    return $ Just $ Map.insert (FieldName "newnew") (TyBasic BTstring) r  -- Test of a single-field migration: change the type of the field from -- binary to string by base64-decoding the contents@@ -84,8 +84,10 @@   testMigration :: CustomMigrations TestDatabaseMigration TestRecordMigration TestFieldMigration-testMigration = CustomMigrations testDatabaseMigration testDatabaseMigrationSchema-                                 testRecordMigration   testRecordMigrationSchema+testMigration = CustomMigrations testDatabaseMigration+                                 testDatabaseMigrationSchema+                                 testRecordMigration+                                 testRecordMigrationSchema                                  testFieldMigration  @@ -148,7 +150,7 @@     Right (_, ws) -> failedBecause ("migration generated warnings: " ++ show ws)     Left err      -> failedBecause ("migration failed: " ++ prettyMigrateFailure err)   where-    failedBecause e = P.MkResult (Just False) True e False False [] []+    failedBecause e = failed { reason = e }   migrationTests :: TestTree@@ -156,5 +158,5 @@   [ testCase     "Basic migration using sample changelog" basicMigrationTest   , testGroup    "Invalid changes"    $ map applyFailureTest   expectedApplyFailures   , testGroup    "Invalid migrations" $ map migrateFailureTest expectedMigrateFailures-  , testProperty "Valid migrations"     validMigrationProperty+  , QC.testProperty "Valid migrations" validMigrationProperty   ]