WIP - Mappable

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

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

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)