From 3375a33b4a2844172b2f42623e3ecc12ed41d298 Mon Sep 17 00:00:00 2001
From: Amar <amar@capital-match.com>
Date: Thu, 7 Apr 2016 20:54:11 +0800
Subject: [PATCH] WIP - Mappable

---
 servant/servant.cabal                 |  1 +
 servant/src/Servant/Utils/Map.hs      | 20 ++++++++++++++++++++
 servant/test/Servant/Utils/MapSpec.hs | 27 +++++++++++++++++++++++++++
 3 files changed, 48 insertions(+)
 create mode 100644 servant/src/Servant/Utils/Map.hs
 create mode 100644 servant/test/Servant/Utils/MapSpec.hs

diff --git a/servant/servant.cabal b/servant/servant.cabal
index 51e1ce3b..d0915b78 100644
--- a/servant/servant.cabal
+++ b/servant/servant.cabal
@@ -96,6 +96,7 @@ test-suite spec
       Servant.API.ContentTypesSpec
       Servant.API.ResponseHeadersSpec
       Servant.Utils.LinksSpec
+      Servant.Utils.MapSpec
   build-depends:
       base == 4.*
     , aeson
diff --git a/servant/src/Servant/Utils/Map.hs b/servant/src/Servant/Utils/Map.hs
new file mode 100644
index 00000000..a4fd686a
--- /dev/null
+++ b/servant/src/Servant/Utils/Map.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RankNTypes            #-}
+{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE TypeOperators         #-}
+module Servant.Utils.Map (mapLeaves) where
+
+import           Servant.API
+
+class Mappable s t a b where
+  mapLeaves :: (forall x . a x -> b x) -> s -> t
+
+instance Mappable (a x) (b x) a b where
+  mapLeaves f a = f a
+
+instance Mappable s t a b => Mappable (arg -> s) (arg -> t) a b where
+  mapLeaves f s = mapLeaves f $ s
+
+instance (Mappable left left' a b, Mappable right right' a b) => Mappable (left :<|> right) (left' :<|> right') a b where
+  mapLeaves f (left :<|> right) = mapLeaves f left :<|> mapLeaves f right
diff --git a/servant/test/Servant/Utils/MapSpec.hs b/servant/test/Servant/Utils/MapSpec.hs
new file mode 100644
index 00000000..4945541d
--- /dev/null
+++ b/servant/test/Servant/Utils/MapSpec.hs
@@ -0,0 +1,27 @@
+module Servant.Utils.MapSpec where
+
+import           Test.Hspec
+
+import           Data.Functor.Identity
+import           Servant.API
+import           Servant.Utils.Map
+spec :: Spec
+spec = describe "Map" $ do
+  it "maps " $ do
+    let foo :: Bool -> Int -> String
+        foo _ b = show b
+
+        bar :: () -> String -> Int -> Double
+        bar _ _ i = fromIntegral i
+
+        foobar = foo :<|> bar
+
+        convert :: (Int -> a) -> Identity a
+        convert f = Identity $ f 42
+
+        foo' :: Bool -> Identity String
+        bar' :: () -> String -> Identity Double
+        foo' :<|> bar' = mapLeaves convert foobar
+
+    foo' True `shouldBe` Identity "42"
+    bar' () "" `shouldBe` Identity (42 :: Double)