Add OrdHashMap

src/Data/Swagger/Internal.hs

@@ -38,10 +38,13 @@ import           Network                  (HostName, PortNumber)
 import           Network.HTTP.Media       (MediaType)
 import           Text.Read                (readMaybe)
 
+import           Data.Swagger.OrdHashMap    (OrdHashMap)
+import qualified Data.Swagger.OrdHashMap as OrdHashMap
+
 import Data.Swagger.Internal.Utils
 
 -- | A list of definitions that can be used in references.
-type Definitions = HashMap Text
+type Definitions = OrdHashMap Text
 
 -- | This is the root document object for the API specification.
 data Swagger = Swagger
@@ -73,7 +76,7 @@ data Swagger = Swagger
     -- | The available paths and operations for the API.
     -- Holds the relative paths to the individual endpoints.
     -- The path is appended to the @'basePath'@ in order to construct the full URL.
-  , _swaggerPaths :: HashMap FilePath PathItem
+  , _swaggerPaths :: OrdHashMap FilePath PathItem
 
     -- | An object to hold data types produced and consumed by operations.
   , _swaggerDefinitions :: Definitions Schema
@@ -482,7 +485,7 @@ data Schema = Schema
   , _schemaRequired :: [ParamName]
 
   , _schemaAllOf :: Maybe [Schema]
-  , _schemaProperties :: HashMap Text (Referenced Schema)
+  , _schemaProperties :: Definitions (Referenced Schema)
   , _schemaAdditionalProperties :: Maybe Schema
 
   , _schemaDiscriminator :: Maybe Text
@@ -574,7 +577,7 @@ data Responses = Responses
 
     -- | Any HTTP status code can be used as the property name (one property per HTTP status code).
     -- Describes the expected response for those HTTP status codes.
-  , _responsesResponses :: HashMap HttpStatusCode (Referenced Response)
+  , _responsesResponses :: OrdHashMap HttpStatusCode (Referenced Response)
   } deriving (Eq, Show, Generic, Data, Typeable)
 
 type HttpStatusCode = Int
@@ -593,7 +596,7 @@ data Response = Response
   , _responseSchema :: Maybe (Referenced Schema)
 
     -- | A list of headers that are sent with the response.
-  , _responseHeaders :: HashMap HeaderName Header
+  , _responseHeaders :: OrdHashMap HeaderName Header
 
     -- | An example of the response message.
   , _responseExamples :: Maybe Example
@@ -659,7 +662,7 @@ data OAuth2Params = OAuth2Params
     _oauth2Flow :: OAuth2Flow
 
     -- | The available scopes for the OAuth2 security scheme.
-  , _oauth2Scopes :: HashMap Text Text
+  , _oauth2Scopes :: OrdHashMap Text Text
   } deriving (Eq, Show, Generic, Data, Typeable)
 
 data SecuritySchemeType
@@ -680,7 +683,7 @@ data SecurityScheme = SecurityScheme
 -- The object can have multiple security schemes declared in it which are all required
 -- (that is, there is a logical AND between the schemes).
 newtype SecurityRequirement = SecurityRequirement
-  { getSecurityRequirement :: HashMap Text [Text]
+  { getSecurityRequirement :: OrdHashMap Text [Text]
   } deriving (Eq, Read, Show, Monoid, ToJSON, FromJSON, Data, Typeable)
 
 -- | Tag name.
@@ -818,6 +821,10 @@ instance OVERLAPPING_ SwaggerMonoid (HashMap FilePath PathItem) where
   swaggerMempty = HashMap.empty
   swaggerMappend = HashMap.unionWith mappend
 
+instance OVERLAPPING_ SwaggerMonoid (OrdHashMap FilePath PathItem) where
+  swaggerMempty = OrdHashMap.empty
+  swaggerMappend = OrdHashMap.unionWith mappend
+
 instance Monoid a => SwaggerMonoid (Referenced a) where
   swaggerMempty = Inline mempty
   swaggerMappend (Inline x) (Inline y) = Inline (x <> y)
@@ -972,7 +979,7 @@ instance ToJSON ParamOtherSchema where
 
 instance ToJSON Responses where
   toJSON (Responses def rs) = omitEmpties $
-    toJSON (hashMapMapKeys show rs) <+> object [ "default" .= def ]
+    toJSON (OrdHashMap.mapKeys show rs) <+> object [ "default" .= def ]
 
 instance ToJSON Response where
   toJSON = omitEmpties . genericToJSON (jsonPrefix "response")
@@ -1071,7 +1078,7 @@ instance FromJSON SecurityScheme where
 
 instance FromJSON Schema where
   parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "schema")
-    `withDefaults` [ "properties" .= (mempty :: HashMap Text Schema)
+    `withDefaults` [ "properties" .= (mempty :: OrdHashMap Text Schema)
                    , "required"   .= ([] :: [ParamName]) ]
 
 instance FromJSON Header where
@@ -1119,7 +1126,7 @@ instance FromJSON ParamOtherSchema where
 instance FromJSON Responses where
   parseJSON (Object o) = Responses
     <$> o .:? "default"
-    <*> (parseJSON (Object (HashMap.delete "default" o)) >>= hashMapReadKeys)
+    <*> (parseJSON (Object (HashMap.delete "default" o)))
   parseJSON _ = empty
 
 instance FromJSON Example where
@@ -1129,7 +1136,7 @@ instance FromJSON Example where
 
 instance FromJSON Response where
   parseJSON = genericParseJSON (jsonPrefix "response")
-    `withDefaults` [ "headers" .= (mempty :: HashMap HeaderName Header) ]
+    `withDefaults` [ "headers" .= (mempty :: OrdHashMap HeaderName Header) ]
 
 instance FromJSON Operation where
   parseJSON = genericParseJSON (jsonPrefix "operation")

src/Data/Swagger/Internal/Schema.hs

@@ -25,6 +25,7 @@ import Control.Applicative
 import Control.Monad
 import Control.Monad.Writer
 import Data.Aeson
+import qualified Data.Aeson.Types as Aeson
 import Data.Char
 import Data.Data (Data)
 import Data.Foldable (traverse_)
@@ -50,6 +51,8 @@ import qualified Data.Vector.Unboxed as VU
 import Data.Word
 import GHC.Generics
 
+import Data.Swagger.OrdHashMap    (OrdHashMap)
+import qualified Data.Swagger.OrdHashMap as OrdHashMap
 import Data.Swagger.Declare
 import Data.Swagger.Internal
 import Data.Swagger.Internal.ParamSchema (ToParamSchema(..))
@@ -194,7 +197,7 @@ declareSchemaRef proxy = do
       -- have already declared it.
       -- If we have, we don't need to declare anything for
       -- this schema this time and thus simply return the reference.
-      known <- looks (HashMap.member name)
+      known <- looks (OrdHashMap.member name)
       when (not known) $ do
         declare [(name, schema)]
         void $ declareNamedSchema proxy
@@ -213,7 +216,7 @@ inlineSchemasWhen p defs = template %~ deref
   where
     deref r@(Ref (Reference name))
       | p name =
-          case HashMap.lookup name defs of
+          case OrdHashMap.lookup name defs of
             Just schema -> Inline (inlineSchemasWhen p defs schema)
             Nothing -> r
       | otherwise = r
@@ -255,7 +258,7 @@ inlineNonRecursiveSchemas :: Data s => (Definitions Schema) -> s -> s
 inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs
   where
     nonRecursive name =
-      case HashMap.lookup name defs of
+      case OrdHashMap.lookup name defs of
         Just schema -> name `notElem` execDeclare (usedNames schema) mempty
         Nothing     -> False
 
@@ -267,7 +270,7 @@ inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs
         seen <- looks (name `elem`)
         when (not seen) $ do
           declare [name]
-          traverse_ usedNames (HashMap.lookup name defs)
+          traverse_ usedNames (OrdHashMap.lookup name defs)
       Inline subschema -> usedNames subschema
 
 -- | Default schema for binary data (any sequence of octets).
@@ -331,7 +334,7 @@ sketchSchema = sketch . toJSON
     go js@(Object o) = mempty
       & type_         .~ SwaggerObject
       & required      .~ HashMap.keys o
-      & properties    .~ fmap (Inline . go) o
+      & properties    .~ fmap (Inline . go) (OrdHashMap.fromHashMap o)
 
 -- | Make a restrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
 -- Produced schema uses as much constraints as possible.
@@ -381,7 +384,7 @@ sketchStrictSchema = go . toJSON
     go js@(Object o) = mempty
       & type_         .~ SwaggerObject
       & required      .~ names
-      & properties    .~ fmap (Inline . go) o
+      & properties    .~ fmap (Inline . go) (OrdHashMap.fromHashMap o)
       & maxProperties ?~ fromIntegral (length names)
       & minProperties ?~ fromIntegral (length names)
       & enum_         ?~ [js]
@@ -605,7 +608,7 @@ gdeclareSchemaRef opts proxy = do
       -- have already declared it.
       -- If we have, we don't need to declare anything for
       -- this schema this time and thus simply return the reference.
-      known <- looks (HashMap.member name)
+      known <- looks (OrdHashMap.member name)
       when (not known) $ do
         declare [(name, schema)]
         void $ gdeclareNamedSchema opts proxy mempty
@@ -662,7 +665,10 @@ gdeclareNamedSumSchema opts proxy s
 
     toStringTag schema = mempty
       & type_ .~ SwaggerString
-      & enum_ ?~ map toJSON (schema ^.. properties.ifolded.asIndex)
+      & enum_ ?~ map toJSON'  (schema ^.. properties.ifolded.asIndex)
+
+    -- TODO:
+    toJSON' = toJSON :: T.Text -> Value
 
 type AllNullary = All
 

src/Data/Swagger/Internal/Schema/Validation.hs

@@ -38,6 +38,8 @@ import qualified Data.Text as Text
 import Data.Vector (Vector)
 import qualified Data.Vector as Vector
 
+import Data.Swagger.OrdHashMap    (OrdHashMap)
+import qualified Data.Swagger.OrdHashMap as OrdHashMap
 import Data.Swagger.Declare
 import Data.Swagger.Internal
 import Data.Swagger.Internal.Schema
@@ -174,7 +176,7 @@ sub_ = lmap . view
 -- | Validate value against a schema given schema reference and validation function.
 withRef :: Reference -> (Schema -> Validation s a) -> Validation s a
 withRef (Reference ref) f = withConfig $ \cfg ->
-  case HashMap.lookup ref (configDefinitions cfg) of
+  case OrdHashMap.lookup ref (configDefinitions cfg) of
     Nothing -> invalid $ "unknown schema " ++ show ref
     Just s  -> f s
 
@@ -290,7 +292,7 @@ validateObject o = withSchema $ \schema ->
         case v of
           Null | not (k `elem` (schema ^. required)) -> valid  -- null is fine for non-required property
           _ ->
-            case HashMap.lookup k (schema ^. properties) of
+            case OrdHashMap.lookup k (schema ^. properties) of
               Nothing -> check additionalProperties $ \s -> sub s $ validateWithSchema v
               Just s  -> validateWithSchemaRef s v
 

src/Data/Swagger/Internal/Utils.hs

@@ -20,6 +20,8 @@ import Data.Data
 import Data.Hashable (Hashable)
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
+import Data.Swagger.OrdHashMap (OrdHashMap)
+import qualified Data.Swagger.OrdHashMap as OrdHashMap
 import Data.Map (Map)
 import Data.Monoid
 import Data.Set (Set)
@@ -161,6 +163,10 @@ instance (Eq k, Hashable k) => SwaggerMonoid (HashMap k v) where
   swaggerMempty = mempty
   swaggerMappend = HashMap.unionWith (\_old new -> new)
 
+instance (Eq k, Hashable k) => SwaggerMonoid (OrdHashMap k v) where
+  swaggerMempty = mempty
+  swaggerMappend = OrdHashMap.unionWith (\_old new -> new)
+
 instance SwaggerMonoid Text where
   swaggerMempty = mempty
   swaggerMappend x "" = x

src/Data/Swagger/Operation.hs

@@ -41,6 +41,8 @@ import Data.Monoid
 import qualified Data.Set as Set
 import Data.Traversable
 
+import Data.Swagger.OrdHashMap (OrdHashMap)
+import qualified Data.Swagger.OrdHashMap as OrdHashMap
 import Data.Swagger.Declare
 import Data.Swagger.Internal
 import Data.Swagger.Lens
@@ -58,10 +60,8 @@ import Data.Swagger.Schema
 -- >>> encode $ prependPath "user/{user_id}" api ^. paths
 -- "{\"/user/{user_id}/info\":{}}"
 prependPath :: FilePath -> Swagger -> Swagger
-prependPath path = paths %~ mapKeys (path </>)
+prependPath path = paths %~ OrdHashMap.mapKeys (path </>)
   where
-    mapKeys f = HashMap.fromList . map (first f) . HashMap.toList
-
     x </> y = case trim y of
       "" -> "/" <> trim x
       y' -> "/" <> trim x <> "/" <> y'
@@ -88,7 +88,7 @@ operationsOf sub = paths.itraversed.withIndex.subops
   where
     -- | Traverse operations that correspond to paths and methods of the sub API.
     subops :: Traversal' (FilePath, PathItem) Operation
-    subops f (path, item) = case HashMap.lookup path (sub ^. paths) of
+    subops f (path, item) = case OrdHashMap.lookup path (sub ^. paths) of
       Just subitem -> (,) path <$> methodsOf subitem f item
       Nothing      -> pure (path, item)