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
@@ -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)

src/Data/Swagger/Internal/Schema.hs

@@ -50,6 +50,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 +196,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 +215,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 +257,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 +269,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).
@@ -605,7 +607,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

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
 

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/OrdHashMap.hs

@@ -0,0 +1,199 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+-- | This is internal module, which provides 'OrdHashMap' data type.
+module Data.Swagger.OrdHashMap (
+    OrdHashMap,
+    -- * Basic interface
+    empty,
+    member,
+    lookup,
+    delete,
+    -- * Combine
+    unionWith,
+    -- * Conversions
+    keys,
+    toList,
+    fromList, 
+    fromHashMap,
+    ) where
+
+#ifndef MIN_VERSION_aeson
+#define MIN_VERSION_aeson(x,y,z) 0
+#endif
+
+import Prelude ()
+import Prelude.Compat hiding (lookup)
+
+import           Control.Arrow            (second)
+import           Data.Aeson
+import qualified Data.Aeson.Types         as JSON
+import           Data.Data                (Data, Typeable)
+import           Data.Hashable            (Hashable)
+import           Data.List                (sortBy)
+import           Data.Ord                 (comparing)
+import           Data.Text                (Text)
+import qualified GHC.Exts                 as Exts
+
+import Control.Lens (Ixed(..), At(..), Index, IxValue, (<&>), _2)
+import Control.Monad.Trans.State.Strict (State, runState, state)
+
+import           Data.HashMap.Strict      (HashMap)
+import qualified Data.HashMap.Strict      as HashMap
+
+-------------------------------------------------------------------------------
+-- Strict Pair Int a
+-------------------------------------------------------------------------------
+
+data P a = P !Int !a
+    deriving (Functor, Foldable, Traversable, Typeable, Data)
+
+getPK :: P a -> Int
+getPK (P i _) = i
+{-# INLINE getPK #-}
+
+getPV :: P a -> a
+getPV (P _ a) = a
+{-# INLINE getPV #-}
+
+incPK :: Int -> P a -> P a
+incPK i (P j x) = P (i + j) x
+{-# INLINE incPK #-}
+
+instance Eq a => Eq (P a) where
+    P _ a == P _ b = a == b
+
+instance Ord a => Ord (P a) where
+    P _ a `compare` P _ b = a `compare` b
+
+instance Show a => Show (P a) where
+    showsPrec d (P _ x) = showsPrec d x
+
+-------------------------------------------------------------------------------
+-- OrdHashMap
+-------------------------------------------------------------------------------
+
+-- | 'HashMap' which tries it's best to remember insertion order of elements.
+data OrdHashMap k v = OrdHashMap
+    { getIndex      :: !Int
+    , getOrdHashMap :: !(HashMap k (P v))
+    }
+    deriving (Eq, Functor, Typeable, Data)
+
+instance (Show k, Show v) => Show (OrdHashMap k v) where
+    showsPrec d m = showParen (d > 10) $
+        showString "fromList " . showsPrec 11 (toList m)
+
+-- TODO: define instance of Semigroup
+
+instance (Eq k, Hashable k) => Monoid (OrdHashMap k v) where
+    mempty = empty 
+    mappend = unionWith const 
+
+-- See https://github.com/bos/aeson/pull/341
+instance ToJSON v => ToJSON (OrdHashMap Text v) where
+    toJSON = object . map f . toList
+      where
+        f (k, v) = k .= v
+
+#if MIN_VERSION_aeson(0,10,0)
+    toEncoding = pairs . mconcat . map f . toList
+      where
+        f (k, v) = k .= v
+#endif
+
+instance FromJSON v => FromJSON (OrdHashMap Text v) where
+    parseJSON = fmap fromHashMap . parseJSON
+
+instance (Eq k, Hashable k) => Exts.IsList (OrdHashMap k v) where
+    type Item (OrdHashMap k v) = (k, v)
+    fromList = fromList
+    toList   = toList
+
+-------------------------------------------------------------------------------
+-- Lens
+-------------------------------------------------------------------------------
+
+type instance Index (OrdHashMap k v) = k
+type instance IxValue (OrdHashMap k v) = v
+
+instance (Eq k, Hashable k) => Ixed (OrdHashMap k v) where
+  ix k f m = case lookup k m of
+     Just v  -> f v <&> \v' -> insert k v' m -- update?
+     Nothing -> pure m
+  {-# INLINE ix #-}
+
+instance (Eq k, Hashable k) => At (OrdHashMap k a) where
+  at k f m = f mv <&> \r -> case r of
+    Nothing -> maybe m (const (delete k m)) mv
+    Just v' -> insert k v' m -- update?
+    where mv = lookup k m
+
+-------------------------------------------------------------------------------
+-- Functions
+-------------------------------------------------------------------------------
+
+empty :: OrdHashMap k v
+empty = OrdHashMap 0 HashMap.empty
+{-# INLINE empty #-}
+
+member :: (Eq k, Hashable k) => k -> OrdHashMap k a -> Bool
+member k = HashMap.member k . getOrdHashMap
+{-# INLINE member #-}
+
+lookup :: (Eq k, Hashable k) => k -> OrdHashMap k v -> Maybe v
+lookup k = fmap getPV . HashMap.lookup k . getOrdHashMap
+{-# INLINE lookup #-}
+
+delete :: (Eq k, Hashable k) => k -> OrdHashMap k v -> OrdHashMap k v
+delete k (OrdHashMap i m) = OrdHashMap i $ HashMap.delete k m
+{-# INLINE delete #-}
+
+insert :: (Eq k, Hashable k) => k -> v -> OrdHashMap k v -> OrdHashMap k v
+insert k v om@(OrdHashMap i m) =
+    OrdHashMap (i + 1) $ HashMap.insert k (P i v) m
+
+-- | The union of two maps.  If a key occurs in both maps,
+-- the provided function (first argument) will be used to compute the result.
+--
+-- Ordered traversal will go thru keys in the first map first.
+unionWith
+    :: (Eq k, Hashable k)
+    => (v -> v -> v)
+    -> OrdHashMap k v -> OrdHashMap k v -> OrdHashMap k v
+unionWith f (OrdHashMap i a) (OrdHashMap j b) =
+    OrdHashMap (i + j) $ HashMap.unionWith f' a b'
+  where
+    b' = fmap (incPK i) b
+    f' (P ii x) (P _ y) = P ii (f x y)
+
+keys :: OrdHashMap k v -> [k]
+keys = HashMap.keys . getOrdHashMap
+{-# INLINE keys #-}
+
+fromList :: forall k v. (Eq k, Hashable k) => [(k, v)] -> OrdHashMap k v
+fromList
+    = mk
+    . flip runState 0
+    . (traverse . _2) newP
+  where
+    mk :: ([(k, P v)], Int) -> OrdHashMap k v
+    mk (m, i) = OrdHashMap i (HashMap.fromList m)
+
+toList :: OrdHashMap k v -> [(k, v)]
+toList
+    = map (second getPV)
+    . sortBy (comparing (getPK . snd))
+    . HashMap.toList
+    . getOrdHashMap
+
+fromHashMap :: HashMap k v -> OrdHashMap k v
+fromHashMap = mk . flip runState 0 . traverse newP 
+  where
+    mk (m, i) = OrdHashMap i m
+
+newP :: a -> State Int (P a)
+newP x = state $ \s -> (P s x, s + 1)

stack.yaml

@@ -1,5 +1,6 @@
 flags: {}
 packages:
 - '.'
-extra-deps: []
-resolver: nightly-2016-01-26
+extra-deps:
+- aeson-0.11.1.0
+resolver: nightly-2016-03-04

swagger2.cabal

@@ -33,6 +33,7 @@ library
     Data.Swagger.SchemaOptions
 
     -- internal modules
+    Data.Swagger.OrdHashMap
     Data.Swagger.Internal
     Data.Swagger.Internal.Schema
     Data.Swagger.Internal.Schema.Validation

test/Data/Swagger/OrdHashMapSpec.hs

@@ -0,0 +1,32 @@
+module Data.Swagger.OrdHashMapSpec where
+
+import Prelude ()
+import Prelude.Compat
+
+import Data.List (nubBy)
+import Data.Function (on)
+import Data.Monoid ((<>))
+
+import Data.Swagger.OrdHashMap (OrdHashMap)
+import qualified Data.Swagger.OrdHashMap as OrdHashMap
+
+import Test.Hspec
+import Test.QuickCheck
+
+spec :: Spec 
+spec =
+  describe "OrdHashMap" $ do
+    it "toList . fromList === id" $ property $ toListFromList
+    it "toList distributes over mappend " $ property $ toListMappendDistribute
+
+toListFromList :: [(Int, Int)] -> Property
+toListFromList l = l' === OrdHashMap.toList (OrdHashMap.fromList l)
+  where l' = reverse . nubBy (on (==) fst) .  reverse $ l
+
+toListMappendDistribute :: [(Int, Int)] -> [(Int, Int)] -> Property
+toListMappendDistribute a b = rhs === lhs
+  where
+    a' = OrdHashMap.fromList a
+    b' = foldr OrdHashMap.delete (OrdHashMap.fromList b) (OrdHashMap.keys a')
+    rhs = OrdHashMap.toList (a' <> b')
+    lhs = OrdHashMap.toList a' <> OrdHashMap.toList b'

test/Data/Swagger/SchemaSpec.hs

@@ -17,6 +17,7 @@ import qualified Data.Set as Set
 import qualified Data.Text as Text
 import GHC.Generics
 
+import qualified Data.Swagger.OrdHashMap as OrdHashMap
 import Data.Swagger
 import Data.Swagger.Declare
 
@@ -34,7 +35,7 @@ checkSchemaName sname proxy =
 checkDefs :: ToSchema a => Proxy a -> [String] -> Spec
 checkDefs proxy names =
   it ("uses these definitions " ++ show names) $
-    Set.fromList (HashMap.keys defs) `shouldBe` Set.fromList (map Text.pack names)
+    Set.fromList (OrdHashMap.keys defs) `shouldBe` Set.fromList (map Text.pack names)
   where
     defs = execDeclare (declareNamedSchema proxy) mempty