api-tools 0.9.0.0 → 0.10.0.0

raw patch · 18 files changed

+392/−87 lines, 18 filesdep +regex-basedep +regex-tdfadep −regex-compat-tdfadep ~aesondep ~attoparsecdep ~lensPVP ok

version bump matches the API change (PVP)

Dependencies added: regex-base, regex-tdfa

Dependencies removed: regex-compat-tdfa

Dependency ranges changed: aeson, attoparsec, lens, template-haskell, text, time, vector

API changes (from Hackage documentation)

Files

• LICENSE +17/−1
• api-tools.cabal +14/−11
• changelog +6/−0
• src/Data/API/Changes.hs +15/−18
• src/Data/API/Error.hs +1/−1
• src/Data/API/JSON.hs +7/−6
• src/Data/API/JSON/Compat.hs +144/−0
• src/Data/API/JSONToCBOR.hs +22/−11
• src/Data/API/TH/Compat.hs +8/−2
• src/Data/API/Tools/JSON.hs +2/−3
• src/Data/API/Types.hs +47/−21
• src/Data/API/Value.hs +4/−4
• src/Data/Binary/Serialise/CBOR/JSON.hs +4/−3
• src/Text/Regex.hs +82/−0
• tests/Data/API/Test/DSL.hs +4/−1
• tests/Data/API/Test/Gen.hs +5/−0
• tests/Data/API/Test/JSON.hs +2/−3
• tests/Data/API/Test/Migration.hs +8/−2

@@ -1,4 +1,4 @@-Copyright (c) 2013-2014, Iris Connect+Copyright (c) 2013-2022, Iris Connect  All rights reserved. @@ -28,3 +28,19 @@ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.++++The Text.Regex module is derived from the regex-compat-tdfa package under the following license:++Copyright (c) 2007, Christopher Kuklewicz+Copyright (c) 2012, shelarcy+All rights reserved.++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.+    * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.+    * The names of the contributors may not be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -1,5 +1,5 @@ Name:                api-tools-Version:             0.9.0.0+Version:             0.10.0.0 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@@ -12,12 +12,12 @@ License-file:        LICENSE Author:              Chris Dornan <chrisd@irisconnect.co.uk> and Adam Gundry <adam@well-typed.com> Maintainer:          Chris Dornan <chrisd@irisconnect.co.uk> and Adam Gundry <adam@well-typed.com>-Copyright:           (c) Iris Connect 2013-2021+Copyright:           (c) Iris Connect 2013-2022 Category:            Network, Web, Cloud, Distributed Computing Build-type:          Simple Extra-source-files:  changelog Cabal-version:       >=1.10-Tested-with:         GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.4+Tested-with:         GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.2  Source-Repository head   Type:              git@@ -26,7 +26,7 @@ Source-Repository this   Type:              git   Location:          git://github.com/iconnect/api-tools.git-  Tag:               0.9.0.0+  Tag:               0.10.0.0  Library   Hs-Source-Dirs:    src@@ -41,6 +41,7 @@         Data.API.Doc.Subst         Data.API.Error         Data.API.JSON+        Data.API.JSON.Compat         Data.API.JSONToCBOR         Data.API.Markdown         Data.API.NormalForm@@ -74,13 +75,14 @@         Data.API.Doc.Types         Data.API.Scan         Data.API.TH.Compat+        Text.Regex    Build-depends:         QuickCheck           >= 2.5.1    && < 2.15 ,-        aeson                >= 0.10     && < 1.6  ,+        aeson                >= 0.10 && < 1.6 || >= 2.0 && < 2.1  ,         aeson-pretty         >= 0.1      && < 0.9  ,         array                >= 0.4      && < 0.6  ,-        attoparsec           >= 0.10.4   && < 0.14 ,+        attoparsec           >= 0.10.4   && < 0.15 ,         base                 >= 4.9      && < 5    ,         base16-bytestring    >= 0.1      && < 1.1  ,         base64-bytestring    >= 1.0      && < 1.3  ,@@ -89,15 +91,16 @@         cborg                >= 0.1.1.0  && < 0.3  ,         containers           >= 0.5      && < 0.7  ,         deepseq              >= 1.1      && < 1.5  ,-        lens                 >= 3.8.7    && < 4.20 ,-        regex-compat-tdfa    >= 0.95.1   && < 0.96 ,+        lens                 >= 3.8.7    && < 5.2  ,+        regex-base           >= 0.93     && < 0.95 ,+        regex-tdfa           >= 1.1.0    && < 1.4  ,         safe                 >= 0.3.3    && < 0.4  ,         safecopy             >= 0.8.1    && < 0.11 ,         scientific           >= 0.3      && < 0.4  ,         serialise            >= 0.1.0.0  && < 0.3  ,-        template-haskell     >= 2.7      && < 2.17 ,-        text                 >= 0.11.3   && < 1.3  ,-        time                 >= 1.5.0    && < 1.10,+        template-haskell     >= 2.7      && < 2.19 ,+        text                 >= 0.11.3   && < 2.1  ,+        time                 >= 1.5.0    && < 1.13 ,         unordered-containers >= 0.2.3.0  && < 0.3  ,         vector               >= 0.10.0.1 && < 0.13 

@@ -1,5 +1,11 @@ -*-change-log-*- +0.10.0.0 Adam Gundry <adam@well-typed.com> June 2022+	* Adjust dependency bounds and support building on GHC 9.2.x+	* Add support for aeson-2.0+	* Drop dependency on regex-compat-tdfa+	* Expose new module Data.API.JSON.Compat (primarily for internal use)+ 0.9.0.0 Adam Gundry <adam@well-typed.com> March 2021 	* Adjust dependency bounds and support building on GHC 8.10.x 	* Drop support for GHC verisons older than 8.4.x

@@ -57,6 +57,7 @@ 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@@ -73,7 +74,6 @@ import           Data.Maybe import           Data.Set (Set) import qualified Data.Set as Set-import qualified Data.HashMap.Strict as HMap import qualified Data.Vector as V import qualified Data.Text as T import           Data.Time@@ -585,27 +585,27 @@ applyChangeToData (ChAddField tname fname ftype mb_defval) _ =   case mb_defval <|> defaultValueForType ftype of     Just defval -> let newFieldValue = defaultValueAsJsValue defval-                   in withObject (\ v _ -> pure $ HMap.insert (_FieldName fname) newFieldValue v)+                   in withObject (\ v _ -> pure $ insertKey (_FieldName fname) newFieldValue v)     Nothing     -> \ _ p -> Left (InvalidAPI (DefaultMissing tname fname), p)  applyChangeToData (ChDeleteField _ fname) _ =-    withObject (\ v _ -> pure $ HMap.delete (_FieldName fname) v)+    withObject (\ v _ -> pure $ deleteKey (_FieldName fname) v)  applyChangeToData (ChRenameField _ fname fname') _ =-    withObject $ \rec p -> case HMap.lookup (_FieldName fname) rec of+    withObject $ \rec p -> case lookupKey (_FieldName fname) rec of                            Just field -> rename field rec                            Nothing    -> Left (JSONError MissingField, inField fname : p)   where-    rename x = pure . HMap.insert (_FieldName fname') x . HMap.delete (_FieldName fname)+    rename x = pure . insertKey (_FieldName fname') x . deleteKey (_FieldName fname)  applyChangeToData (ChChangeField _ fname _ftype tag) custom =     withObjectField (_FieldName fname) (liftMigration $ fieldMigration custom tag)  applyChangeToData (ChRenameUnionAlt _ fname fname') _ = withObject $ \un p ->-    case HMap.toList un of-        [(k, r)] | k == _FieldName fname -> return $ HMap.singleton (_FieldName fname') r-                 | otherwise             -> return un-        _ -> Left (JSONError $ SyntaxError "Not singleton", p)+    case matchSingletonObject un of+        Just (k, r) | k == _FieldName fname -> return $ singletonObject (_FieldName fname') r+                    | otherwise             -> return un+        Nothing -> Left (JSONError $ SyntaxError "Not singleton", p)  applyChangeToData (ChRenameEnumVal _ fname fname') _ = withString $ \s _ ->     if s == _FieldName fname then return (_FieldName fname')@@ -748,9 +748,9 @@ withObjectField :: T.Text -> (JS.Value -> Position -> Either (ValueError, Position) JS.Value)                 -> JS.Value -> Position -> Either (ValueError, Position) JS.Value withObjectField field alter (JS.Object obj) p =-    case HMap.lookup field obj of+    case lookupKey field obj of       Nothing     -> Left (JSONError MissingField, InField field : p)-      Just fvalue -> JS.Object <$> (HMap.insert field+      Just fvalue -> JS.Object <$> (insertKey field                                        <$> (alter fvalue (InField field : p))                                        <*> pure obj) withObjectField _ _ v p = Left (JSONError $ expectedObject v, p)@@ -759,27 +759,24 @@                          -> (a -> JS.Value -> Position -> Either (ValueError, Position) JS.Value)                          -> JS.Value -> Position -> Either (ValueError, Position) JS.Value withObjectMatchingFields m f (JS.Object obj) p = do-    zs <- matchMaps (Map.mapKeys _FieldName m) (hmapToMap obj) ?!? toErr+    zs <- matchMaps (Map.mapKeys _FieldName m) (objectToMap obj) ?!? toErr     obj' <- Map.traverseWithKey (\ k (ty, val) -> (f ty val (InField k : p))) zs-    return $ JS.Object $ mapToHMap obj'+    return $ JS.Object $ mapToObject obj'   where     toErr (k, Left _)  = (JSONError MissingField, InField k : p)     toErr (k, Right _) = (JSONError UnexpectedField, InField k : p) -    hmapToMap = Map.fromList . HMap.toList -    mapToHMap = HMap.fromList . Map.toList- withObjectMatchingFields _ _ v p = Left (JSONError $ expectedObject v, p)  withObjectMatchingUnion :: Map FieldName a                          -> (a -> JS.Value -> Position -> Either (ValueError, Position) JS.Value)                          -> JS.Value -> Position -> Either (ValueError, Position) JS.Value withObjectMatchingUnion m f (JS.Object obj) p-  | [(k, r)] <- HMap.toList obj+  | Just (k, r) <- matchSingletonObject obj   = do x  <- Map.lookup (FieldName k) m ?! (JSONError UnexpectedField, InField k : p)        r' <- f x r (InField k : p)-       return $ JS.Object $ HMap.singleton k r'+       return $ JS.Object $ singletonObject k r' withObjectMatchingUnion _ _ _ p = Left (JSONError $ SyntaxError "Not singleton", p)  withArrayElems :: (JS.Value -> Position -> Either (ValueError, Position) JS.Value)

@@ -365,8 +365,8 @@                                        : indent (ppLines af)  -$(deriveJSON defaultOptions ''JSONError) $(deriveJSON defaultOptions ''Expected) $(deriveJSON defaultOptions ''FormatExpected) $(deriveJSON defaultOptions ''Step)+$(deriveJSON defaultOptions ''JSONError) $(SC.deriveSafeCopy 1 'SC.base ''Step)

@@ -2,6 +2,7 @@ {-# LANGUAGE DefaultSignatures          #-} {-# LANGUAGE DeriveFunctor              #-} {-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE ViewPatterns               #-} {-# LANGUAGE TemplateHaskell            #-}  -- | This module defines a JSON parser, like Aeson's 'FromJSON', but@@ -64,6 +65,7 @@     ) where  import           Data.API.Error+import           Data.API.JSON.Compat import           Data.API.Time import           Data.API.Types import           Data.API.Utils@@ -77,7 +79,6 @@ import qualified Data.ByteString.Char8          as B import qualified Data.ByteString.Base64         as B64 import qualified Data.ByteString.Lazy           as BL-import qualified Data.HashMap.Strict            as HMap import           Data.Maybe import qualified Data.Text                      as T import qualified Data.Text.Encoding             as T@@ -368,7 +369,7 @@           -> JS.Object -> ParserWithErrs a withField k f m = stepInside (InField k) $ modifyTopError treatAsMissing $ f v   where-    v = fromMaybe JS.Null $ HMap.lookup k m+    v = fromMaybe JS.Null $ lookupKey k m  treatAsMissing :: JSONError -> JSONError treatAsMissing (Expected _ _ JS.Null) = MissingField@@ -382,15 +383,15 @@     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+          | useDefaults q                       = f $ fromMaybe defVal  $ lookupKey k m+          | otherwise                           = f $ fromMaybe JS.Null $ lookupKey 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-withStrictField k f m = stepInside (InField k) $ case HMap.lookup k m of+withStrictField k f m = stepInside (InField k) $ case lookupKey k m of                             Nothing -> failWith MissingField                             Just r  -> f r @@ -408,7 +409,7 @@ -- 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+   case objectToList hs of       [(k, v)] -> case lookup k xs of                     Just c  -> stepInside (InField k) $ c v                     Nothing -> failWith $ MissingAlt $ map (T.unpack . fst) xs

@@ -0,0 +1,144 @@+{-# LANGUAGE CPP #-}++-- | This module provides wrappers for compatibility between versions of @aeson@+-- prior to and after 2.0.  It is not necessarily stable.+--+module Data.API.JSON.Compat+    ( Key+    , KeyMap++    , lookupKey+    , listToObject+    , objectToList+    , matchSingletonObject+    , singletonObject+    , insertKey+    , deleteKey+    , objectToMap+    , mapToObject+    , traverseObjectWithKey+    , adjustObject++    , fieldNameToKey+    , keyToFieldName+    , textToKey+    , keyToText+    ) where++import           Data.API.Types++import qualified Data.Map.Strict                as Map+import qualified Data.Text                      as T++#if MIN_VERSION_aeson(2,0,0)++import           Data.Aeson.Key (Key)+import qualified Data.Aeson.Key                 as Key+import           Data.Aeson.KeyMap (KeyMap)+import qualified Data.Aeson.KeyMap              as KeyMap++lookupKey :: T.Text -> KeyMap a -> Maybe a+lookupKey k m = KeyMap.lookup (Key.fromText k) m++listToObject :: [(T.Text, a)] -> KeyMap a+listToObject = KeyMap.fromList . map (\ (x, y) -> (Key.fromText x, y))++objectToList :: KeyMap a -> [(T.Text, a)]+objectToList = map (\ (x, y) -> (Key.toText x, y)) . KeyMap.toList++matchSingletonObject :: KeyMap a -> Maybe (T.Text, a)+matchSingletonObject km = case objectToList km of+                            [(k, v)] -> Just (k, v)+                            _        -> Nothing++singletonObject :: T.Text -> a -> KeyMap a+singletonObject k = KeyMap.singleton (Key.fromText k)++insertKey :: T.Text -> a -> KeyMap a -> KeyMap a+insertKey k = KeyMap.insert (Key.fromText k)++deleteKey :: T.Text -> KeyMap a -> KeyMap a+deleteKey k = KeyMap.delete (Key.fromText k)++objectToMap :: KeyMap a -> Map.Map T.Text a+objectToMap = KeyMap.toMapText++mapToObject :: Map.Map T.Text a -> KeyMap a+mapToObject = KeyMap.fromMapText++traverseObjectWithKey :: Applicative f => (T.Text -> v1 -> f v2) -> KeyMap v1 -> f (KeyMap v2)+traverseObjectWithKey f = KeyMap.traverseWithKey (\ k -> f (Key.toText k))++fieldNameToKey :: FieldName -> Key+fieldNameToKey = Key.fromText . _FieldName++textToKey :: T.Text -> Key+textToKey = Key.fromText++keyToFieldName :: Key -> FieldName+keyToFieldName = FieldName . Key.toText++keyToText :: Key -> T.Text+keyToText = Key.toText++adjustObject :: (v -> v) -> Key -> KeyMap v -> KeyMap v+adjustObject f k m = case KeyMap.lookup k m of+                       Nothing -> m+                       Just v  -> KeyMap.insert k (f v) m++#else++import qualified Data.HashMap.Strict as HMap++type Key = T.Text++type KeyMap = HMap.HashMap Key++lookupKey :: T.Text -> KeyMap a -> Maybe a+lookupKey = HMap.lookup++listToObject :: [(T.Text, a)] -> KeyMap a+listToObject = HMap.fromList++objectToList :: KeyMap a -> [(T.Text, a)]+objectToList = HMap.toList++matchSingletonObject :: KeyMap a -> Maybe (T.Text, a)+matchSingletonObject km = case objectToList km of+                            [(k, v)] -> Just (k, v)+                            _        -> Nothing++singletonObject :: T.Text -> a -> KeyMap a+singletonObject = HMap.singleton++insertKey :: T.Text -> a -> KeyMap a -> KeyMap a+insertKey = HMap.insert++deleteKey :: T.Text -> KeyMap a -> KeyMap a+deleteKey = HMap.delete++objectToMap :: KeyMap a -> Map.Map T.Text a+objectToMap = Map.fromList . HMap.toList++mapToObject :: Map.Map T.Text a -> KeyMap a+mapToObject = HMap.fromList . Map.toList++traverseObjectWithKey :: Applicative f => (T.Text -> v1 -> f v2) -> KeyMap v1 -> f (KeyMap v2)+traverseObjectWithKey = HMap.traverseWithKey++adjustObject :: (v -> v) -> Key -> KeyMap v -> KeyMap v+adjustObject = HMap.adjust++fieldNameToKey :: FieldName -> Key+fieldNameToKey = _FieldName++keyToFieldName :: Key -> FieldName+keyToFieldName = FieldName++textToKey :: T.Text -> Key+textToKey = id++keyToText :: Key -> T.Text+keyToText = id++#endif

@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-} module Data.API.JSONToCBOR     ( serialiseJSONWithSchema     , jsonToCBORWithSchema@@ -8,6 +9,7 @@  import           Data.API.Changes import           Data.API.JSON+import           Data.API.JSON.Compat import           Data.API.Time import           Data.API.Types import           Data.API.Utils@@ -16,7 +18,6 @@ import           Data.Aeson hiding (encode) import qualified Data.ByteString.Base64         as B64 import qualified Data.ByteString.Lazy           as LBS-import qualified Data.HashMap.Strict            as HMap import qualified Data.Map                       as Map import           Data.Traversable import qualified Data.Vector                    as Vec@@ -36,6 +37,16 @@ -- schema-dependent fashion.  This is necessary because the JSON -- representation carries less information than we need in CBOR -- (e.g. it lacks a distinction between bytestrings and text).+--+-- There is a corner case where this may lose information: if the schema+-- contains a field with type @? json@ (i.e. @'Maybe' 'Value'@), then we have+--+-- > toJSON Nothing     == Null+-- > toJSON (Just Null) == Null+--+-- so 'serialiseJSONWithSchema' cannot distinguish these values, and will use+-- the CBOR-encoding of 'Nothing' for both.+-- serialiseJSONWithSchema :: API -> TypeName -> Value -> LBS.ByteString serialiseJSONWithSchema api tn v = serialise $ jsonToCBORWithSchema api tn v @@ -73,14 +84,14 @@     Object hm -> TMap $ map (f hm) $ Map.toAscList nrt     _         -> error "serialiseJSONWithSchema: expected object"   where-    f hm (fn, ty) = case HMap.lookup (_FieldName fn) hm of+    f hm (fn, ty) = case lookupKey (_FieldName fn) hm of                       Nothing -> error $ "serialiseJSONWithSchema: missing field " ++ T.unpack (_FieldName fn)                       Just v' -> (TString (_FieldName fn), jsonToCBORType napi ty v')  -- | Encode a union as a single-element map from the field name to the value. jsonToCBORUnion :: NormAPI -> NormUnionType -> Value -> Term jsonToCBORUnion napi nut v = case v of-    Object hm | [(k, r)] <- HMap.toList hm -> case Map.lookup (FieldName k) nut of+    Object hm | Just (k, r) <- matchSingletonObject hm -> case Map.lookup (FieldName k) nut of        Just ty -> TMap [(TString k, jsonToCBORType napi ty r)]        Nothing -> error "serialiseJSONWithSchema: unexpected alternative in union"     _ -> error "serialiseJSONWithSchema: expected single-field object"@@ -155,9 +166,9 @@                     _         -> Left $ JSONError $ expectedArray v     TyName tn  -> postprocessJSONTypeName napi tn v     TyBasic BTutc -> case v of-      Object obj -> case HMap.toList obj of-        [(k1, Number v0), (km12, Number v1)]-          | T.unpack k1 == "1" && T.unpack km12 == "-12" ->+      Object obj+        | Just (Number v0) <- lookupKey "1" obj+        , Just (Number v1) <- lookupKey "-12" obj ->           -- Taken from @Codec.Serialise.Class@:           let psecs :: Pico               psecs = realToFrac v1 / 1000000000000@@ -166,7 +177,7 @@               dt = realToFrac v0 + realToFrac psecs            in pure $! String $! printUTC $! forceUTCTime (posixSecondsToUTCTime dt)-        _ -> Left $ JSONError UnexpectedField+        | otherwise -> Left $ JSONError (Expected ExpObject "UTCTime" v)       String t -> case parseUTC t of         Nothing -> Left $ JSONError $ SyntaxError $                      "UTC time in wrong format: " ++ T.unpack t@@ -181,15 +192,15 @@  postprocessJSONRecord :: NormAPI -> NormRecordType -> Value -> Either ValueError Value postprocessJSONRecord napi nrt v = case v of-    Object hm -> Object <$> HMap.traverseWithKey f hm+    Object hm -> Object <$> traverseObjectWithKey f hm     _         -> Left $ JSONError $ expectedObject v   where-    f t v' = do ty <- Map.lookup (FieldName t) nrt ?! JSONError UnexpectedField+    f t v' = do ty <- Map.lookup (FieldName t) nrt ?! JSONError MissingField                 postprocessJSONType napi ty v'  postprocessJSONUnion :: NormAPI -> NormUnionType -> Value -> Either ValueError Value postprocessJSONUnion napi nut v = case v of-    Object hm | [(k, r)] <- HMap.toList hm+    Object hm | Just (k, r) <- matchSingletonObject hm               , Just ty <- Map.lookup (FieldName k) nut-              -> Object . HMap.singleton k <$> postprocessJSONType napi ty r+              -> Object . singletonObject k <$> postprocessJSONType napi ty r     _ -> Left $ JSONError $ expectedObject v

@@ -3,7 +3,13 @@  import Language.Haskell.TH -mkDataD :: Cxt -> Name -> [TyVarBndr] -> [Con] -> [Name] -> Dec+#if MIN_VERSION_template_haskell(2,17,0)+type TyVarBndr' = TyVarBndr ()+#else+type TyVarBndr' = TyVarBndr+#endif++mkDataD :: Cxt -> Name -> [TyVarBndr'] -> [Con] -> [Name] -> Dec mkDataD cxt1 name tyVarBndrs cons drvs = #if MIN_VERSION_template_haskell(2,12,0)   DataD cxt1 name tyVarBndrs Nothing cons [DerivClause Nothing (map ConT drvs)]@@ -21,7 +27,7 @@   InstanceD #endif -mkNewtypeD :: Cxt -> Name -> [TyVarBndr] -> Con -> [Name] -> Dec+mkNewtypeD :: Cxt -> Name -> [TyVarBndr'] -> Con -> [Name] -> Dec mkNewtypeD cxt1 name tyVarBndrs cons drvs = #if MIN_VERSION_template_haskell(2,12,0)   NewtypeD cxt1 name tyVarBndrs Nothing cons [DerivClause Nothing (map ConT drvs)]

@@ -17,7 +17,6 @@  import           Data.Aeson hiding (withText, withBool) import           Control.Applicative-import qualified Data.HashMap.Strict            as HMap import           Data.Maybe import qualified Data.Map                       as Map import           Data.Monoid@@ -133,7 +132,7 @@             v .: "Input"                            <*>             v .: "Output"                           <*>             v .: "PipelineId"-     parseJSONWithErrs Null       = parseJSONWithErrs (Object HMap.empty)+     parseJSONWithErrs Null       = parseJSONWithErrs (Object mempty)      parseJSONWithErrs v          = failWith $ expectedObject val -} @@ -150,7 +149,7 @@           where ro    = ftReadOnly ft                 mb_dv = ftDefault ft -    clNull = clause [conP 'Null []] (normalB [e| parseJSONWithErrs (Object HMap.empty) |]) []+    clNull = clause [conP 'Null []] (normalB [e| parseJSONWithErrs (Object mempty) |]) []      cl'  x = clause [varP x] (normalB (bdy' x)) []     bdy' x = [e| failWith (expectedObject $(varE x)) |]

@@ -358,20 +358,44 @@   liftTyped (APINode a b c d e) = [e|| APINode a b $$(liftTypedPrefix c) d e ||] #endif ++#if MIN_VERSION_template_haskell(2,17,0)+liftPrefix :: Quote m => Prefix -> m Exp+liftText :: Quote m => T.Text -> m Exp+liftUTC :: Quote m => UTCTime -> m Exp+liftMaybeUTCTime :: Quote m => Maybe UTCTime -> m Exp+#else liftPrefix :: Prefix -> ExpQ+liftText :: T.Text -> ExpQ+liftUTC :: UTCTime -> ExpQ+liftMaybeUTCTime :: Maybe UTCTime -> ExpQ+#endif+ liftPrefix ci = let s = CI.original ci in [e| CI.mk s |] -liftText :: T.Text -> ExpQ liftText s = [e| T.pack $(litE (stringL (T.unpack s))) |] -liftUTC :: UTCTime -> ExpQ liftUTC u = [e| unsafeParseUTC $(liftText (printUTC u)) |] -liftMaybeUTCTime :: Maybe UTCTime -> ExpQ liftMaybeUTCTime Nothing  = [e| Nothing |] liftMaybeUTCTime (Just u) = [e| Just $(liftUTC u) |] -#if MIN_VERSION_template_haskell(2,16,0)+++#if MIN_VERSION_template_haskell(2,17,0)+liftTypedPrefix :: Quote m => Prefix -> Code m Prefix+liftTypedPrefix ci = let s = CI.original ci in [e|| CI.mk s ||]++liftTypedText :: Quote m => T.Text -> Code m T.Text+liftTypedText s = [e|| T.pack $$(liftTyped (T.unpack s)) ||]++liftTypedUTC :: Quote m => UTCTime -> Code m UTCTime+liftTypedUTC u = [e|| unsafeParseUTC $$(liftTypedText (printUTC u)) ||]++liftTypedMaybeUTCTime :: Quote m => Maybe UTCTime -> Code m (Maybe UTCTime)+liftTypedMaybeUTCTime Nothing  = [e|| Nothing ||]+liftTypedMaybeUTCTime (Just u) = [e|| Just $$(liftTypedUTC u) ||]+#elif MIN_VERSION_template_haskell(2,16,0) liftTypedPrefix :: Prefix -> TExpQ Prefix liftTypedPrefix ci = let s = CI.original ci in [e|| CI.mk s ||] @@ -429,20 +453,22 @@  $(deriveSafeCopy 0 'base ''Binary) -$(deriveJSON defaultOptions ''Thing)-$(deriveJSON defaultOptions ''APINode)-$(deriveJSON defaultOptions ''TypeName)-$(deriveJSON defaultOptions ''FieldName)-$(deriveJSON defaultOptions ''Spec)-$(deriveJSON defaultOptions ''APIType)-$(deriveJSON defaultOptions ''DefaultValue)-$(deriveJSON defaultOptions ''SpecEnum)-$(deriveJSON defaultOptions ''SpecUnion)-$(deriveJSON defaultOptions ''SpecRecord)-$(deriveJSON defaultOptions ''FieldType)-$(deriveJSON defaultOptions ''SpecNewtype)-$(deriveJSON defaultOptions ''Filter)-$(deriveJSON defaultOptions ''IntRange)-$(deriveJSON defaultOptions ''UTCRange)-$(deriveJSON defaultOptions ''BasicType)-$(deriveJSON defaultOptions ''CI.CI)+$(let deriveJSONs = fmap concat . mapM (deriveJSON defaultOptions)+  in deriveJSONs [ ''CI.CI+                 , ''TypeName+                 , ''FieldName+                 , ''DefaultValue+                 , ''SpecEnum+                 , ''SpecUnion+                 , ''SpecRecord+                 , ''FieldType+                 , ''SpecNewtype+                 , ''Filter+                 , ''IntRange+                 , ''UTCRange+                 , ''BasicType+                 , ''APIType+                 , ''Spec+                 , ''APINode+                 , ''Thing+                 ])

@@ -46,6 +46,7 @@  import           Data.API.Error import           Data.API.JSON+import           Data.API.JSON.Compat import           Data.API.NormalForm import           Data.API.Time import           Data.API.Types@@ -61,7 +62,6 @@ import           Data.Binary.Serialise.CBOR.Extra import qualified Codec.CBOR.FlatTerm as CBOR import           Data.Binary.Serialise.CBOR.JSON-import qualified Data.HashMap.Strict            as HMap import           Data.List (sortBy) import qualified Data.Map.Strict                as Map import           Data.Monoid@@ -174,9 +174,9 @@                 List vs        -> JS.toJSON vs                 Maybe Nothing  -> JS.Null                 Maybe (Just v) -> JS.toJSON v-                Union fn v     -> JS.object [_FieldName fn JS..= v]+                Union fn v     -> JS.object [fieldNameToKey fn JS..= v]                 Enum fn        -> JS.String (_FieldName fn)-                Record xs      -> JS.object $ map (\ (Field fn v) -> _FieldName fn JS..= v) xs+                Record xs      -> JS.object $ map (\ (Field fn v) -> fieldNameToKey fn JS..= v) xs                 JSON js        -> js  -- | Parse a generic 'Value' from a JSON 'JS.Value', given the schema@@ -403,7 +403,7 @@ arbitraryJSONValue :: QC.Gen JS.Value arbitraryJSONValue =     QC.sized $ \ size ->-        QC.oneof [ JS.Object . HMap.fromList <$> QC.resize (size `div` 2) (QC.listOf ((,) <$> QC.arbitrary <*> arbitraryJSONValue))+        QC.oneof [ JS.Object . listToObject <$> QC.resize (size `div` 2) (QC.listOf ((,) <$> QC.arbitrary <*> arbitraryJSONValue))                  , JS.Array . V.fromList <$> QC.resize (size `div` 2) (QC.listOf arbitraryJSONValue)                  , JS.String <$> QC.arbitrary                  , JS.Number . fromInteger <$> QC.arbitrary

@@ -6,10 +6,11 @@     decodeJSON,   ) where +import           Data.API.JSON.Compat+ import qualified Data.Aeson          as JSON import qualified Data.Scientific     as Scientific import qualified Data.Vector         as Vec-import qualified Data.HashMap.Strict as HashMap  import           Data.Text (Text) import qualified Data.Text                       as Text@@ -81,7 +82,7 @@ --    integers into strings containing their decimal representation); --    however, doing so introduces a danger of key collision. -cborToJson (TMap  kvs) = JSON.object [ (cborToJsonString k, cborToJson v)+cborToJson (TMap  kvs) = JSON.object [ (textToKey (cborToJsonString k), cborToJson v)                                      | (k, v) <- kvs ]  -- o  False (major type 7, additional information 20) becomes a JSON false.@@ -170,7 +171,7 @@  jsonToCbor :: JSON.Value -> CBOR.Term jsonToCbor (JSON.Object kvs) = CBOR.TMap [ (CBOR.TString k, jsonToCbor v)-                                         | (k, v) <- HashMap.toList kvs ]+                                         | (k, v) <- objectToList kvs ] jsonToCbor (JSON.Array  vs)  = CBOR.TList [ jsonToCbor v | v <- Vec.toList vs ] jsonToCbor (JSON.String str) = CBOR.TString str jsonToCbor (JSON.Number n)   = case Scientific.floatingOrInteger n of

@@ -0,0 +1,82 @@+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Regex+-- Copyright   :  (c) Chris Kuklewicz 2006, (c) shelarcy 2012, derived from (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable (regex-base needs MPTC+FD)+--+-- Regular expression matching.  Uses the POSIX regular expression+-- interface in "Text.Regex.TDFA".+--+---------------------------------------------------------------------------++--+-- Modified by Chris Kuklewicz to be a thin layer over the regex-posix+-- package, and moved into a regex-compat package.+--+-- Modified by Adam Gundry to contain only the functions needed for api-tools.+--+module Text.Regex (+    -- * Regular expressions+    Regex,+    mkRegex,+    mkRegexWithOpts,+    matchRegex,+    matchRegexAll+  ) where++import Text.Regex.Base(RegexMaker(makeRegexOpts),defaultCompOpt,defaultExecOpt,RegexContext(matchM))+import Text.Regex.TDFA(Regex,caseSensitive,multiline,newSyntax)++-- | Makes a regular expression with the default options (multi-line,+-- case-sensitive).  The syntax of regular expressions is+-- otherwise that of @egrep@ (i.e. POSIX \"extended\" regular+-- expressions).+mkRegex :: String -> Regex+mkRegex s = makeRegexOpts opt defaultExecOpt s+  where opt = defaultCompOpt { newSyntax = True, multiline = True }++-- | Makes a regular expression, where the multi-line and+-- case-sensitive options can be changed from the default settings.+mkRegexWithOpts+   :: String  -- ^ The regular expression to compile+   -> Bool    -- ^ 'True' @\<=>@ @\'^\'@ and @\'$\'@ match the beginning and+              -- end of individual lines respectively, and @\'.\'@ does /not/+              -- match the newline character.+   -> Bool    -- ^ 'True' @\<=>@ matching is case-sensitive+   -> Regex   -- ^ Returns: the compiled regular expression++mkRegexWithOpts s single_line case_sensitive+  = let opt = defaultCompOpt+                { multiline    = (if single_line then True else False)+                , caseSensitive = (if case_sensitive then True else False)+                , newSyntax     = True }+    in makeRegexOpts opt defaultExecOpt s++-- | Match a regular expression against a string+matchRegex+   :: Regex     -- ^ The regular expression+   -> String    -- ^ The string to match against+   -> Maybe [String] -- ^ Returns: @'Just' strs@ if the match succeeded+                     -- (and @strs@ is the list of subexpression matches),+                     -- or 'Nothing' otherwise.+matchRegex p str = fmap (\(_,_,_,str) -> str) (matchRegexAll p str)++-- | Match a regular expression against a string, returning more information+-- about the match.+matchRegexAll+   :: Regex  -- ^ The regular expression+   -> String -- ^ The string to match against+   -> Maybe ( String, String, String, [String] )+                -- ^ Returns: 'Nothing' if the match failed, or:+                --+                -- >  Just ( everything before match,+                -- >         portion matched,+                -- >         everything after the match,+                -- >         subexpression matches )++matchRegexAll p str = matchM p str

@@ -118,7 +118,10 @@  mt :: MaybeThing     = record-        thing :: ? JSON+        thing :: JSON  // This used to be ? JSON but aeson doesn't round-trip for Maybe Value,+                       // so prop_jsonToCBOR can be violated.  There doesn't seem to be a good+                       // solution for this other than disabling the test.  If a field in the schema+                       // has type  ? json  then storing Just Null in it may get read back as Nothing.i  nu :: NewUnion     = union

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP                        #-} {-# LANGUAGE DeriveGeneric              #-} {-# LANGUAGE TemplateHaskell            #-} {-# LANGUAGE OverloadedStrings          #-}@@ -13,7 +14,9 @@ import           Data.API.Tools import           Data.API.Tools.Datatypes import           Data.API.Tools.Example+#if !MIN_VERSION_aeson(2,0,3) import           Data.API.Value ( arbitraryJSONValue )+#endif  import           Control.Applicative import qualified Control.Monad.Fail as Fail@@ -117,8 +120,10 @@ -- | These instances are required by the generated code, but we don't -- really want to force them on clients of the library, so just define -- orphans here.+#if !MIN_VERSION_aeson(2,0,3) instance Arbitrary JS.Value where     arbitrary = arbitraryJSONValue+#endif  instance SafeCopy JS.Value where   getCopy = error "Not implemented"

@@ -20,7 +20,6 @@ import qualified Data.API.Value           as Value  import qualified Data.Aeson               as JS-import qualified Data.HashMap.Strict      as HMap  import           Test.Tasty import           Test.Tasty.HUnit@@ -49,7 +48,7 @@                                , help (JS.Number 2)     True        False                                , help (JS.String "0")   False       False                                , help (JS.String "1")   True        False-                               , help (JS.Object (HMap.singleton "id" (JS.Number 3)))+                               , help (JS.object ["id" JS..= JS.Number 3])                                       (Recursive (Id 3) Nothing)                                       True                                , help' noFilter (JS.Number 0) (UnsafeMkFilteredInt 0) True@@ -73,7 +72,7 @@                       [(SyntaxError "not enough input", [])] #endif                 , help "object for int"   "{}"       (proxy :: Int)-                      [(Expected ExpInt "Int" (JS.Object HMap.empty), [])]+                      [(Expected ExpInt "Int" (JS.Object mempty), [])]                 , help "missing alt"      "{}"       (proxy :: AUnion)                       [(MissingAlt ["bar"], [])]                 , help "error inside alt" "{\"bar\": {}}" (proxy :: AUnion)

@@ -1,8 +1,9 @@+{-# LANGUAGE CPP                        #-} {-# LANGUAGE OverloadedStrings          #-} {-# LANGUAGE QuasiQuotes                #-} {-# LANGUAGE TemplateHaskell            #-} {-# LANGUAGE DeriveDataTypeable         #-}-{-# OPTIONS_GHC -XNoCPP -fno-warn-unused-binds  #-}+{-# OPTIONS_GHC -fno-warn-unused-binds  #-}  module Data.API.Test.Migration     ( migrationTests@@ -23,7 +24,6 @@ import qualified Data.ByteString.Char8    as B import qualified Data.ByteString.Base64   as B64 import qualified Data.ByteString.Lazy.Char8 as BL-import qualified Data.HashMap.Strict      as HMap import qualified Data.Map                 as Map import qualified Data.Text                as T import qualified Data.Text.Encoding       as TE@@ -32,6 +32,12 @@ import qualified Test.Tasty.HUnit         as HUnit import qualified Test.Tasty.QuickCheck    as QC import           Test.QuickCheck.Property as P++#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.KeyMap        as HMap+#else+import qualified Data.HashMap.Strict      as HMap+#endif   $(generateMigrationKinds changelog "TestDatabaseMigration" "TestRecordMigration" "TestFieldMigration")