Add access to types in servant-foreign.

servant-foreign/src/Servant/Foreign.hs

@@ -2,6 +2,7 @@
 -- arbitrary programming languages.
 module Servant.Foreign
   ( HasForeign(..)
+  , HasForeignType(..)
   , Segment(..)
   , SegmentType(..)
   , FunctionName
@@ -24,6 +25,7 @@ module Servant.Foreign
   , reqBody
   , reqHeaders
   , reqMethod
+  , reqReturnType
   , segment
   , queryStr
   -- re-exports

servant-foreign/src/Servant/Foreign/Internal.hs

@@ -45,7 +45,8 @@ camelCase = camelCase' . Prelude.map (replace "-" "")
         capitalize ""   = ""
         capitalize name = C.toUpper (Data.Text.head name) `cons` Data.Text.tail name
 
-type Arg = Text
+type ForeignType = Text
+type Arg = (Text, ForeignType)
 
 newtype Segment = Segment { _segment :: SegmentType  }
   deriving (Eq, Show)
@@ -68,10 +69,10 @@ data QueryArg = QueryArg
   } deriving (Eq, Show)
 
 data HeaderArg = HeaderArg
-    { headerArgName :: Text
+    { headerArg :: Arg
     }
   | ReplaceHeaderArg
-    { headerArgName :: Text
+    { headerArg :: Arg
     , headerPattern :: Text
     } deriving (Eq, Show)
 
@@ -91,7 +92,8 @@ data Req = Req
   { _reqUrl        :: Url
   , _reqMethod     :: Method
   , _reqHeaders    :: [HeaderArg]
-  , _reqBody    :: Bool
+  , _reqBody       :: Maybe ForeignType
+  , _reqReturnType :: ForeignType
   , _funcName      :: FunctionName
   } deriving (Eq, Show)
 
@@ -109,7 +111,7 @@ captureArg (Segment (Cap s)) = s
 captureArg                 _ = error "captureArg called on non capture"
 
 defReq :: Req
-defReq = Req defUrl "GET" [] False []
+defReq = Req defUrl "GET" [] Nothing "" []
 
 -- | To be used exclusively as a "negative" return type/constraint
 -- by @'Elem`@ type family.
@@ -120,6 +122,9 @@ type family Elem (a :: *) (ls::[*]) :: Constraint where
   Elem a (a ': list) = ()
   Elem a (b ': list) = Elem a list
 
+class HasForeignType a where
+    typeFor :: Proxy a -> ForeignType
+
 class HasForeign (layout :: *) where
   type Foreign layout :: *
   foreignFor :: Proxy layout -> Req -> Foreign layout
@@ -132,84 +137,107 @@ instance (HasForeign a, HasForeign b)
          foreignFor (Proxy :: Proxy a) req
     :<|> foreignFor (Proxy :: Proxy b) req
 
-instance (KnownSymbol sym, HasForeign sublayout)
+instance (KnownSymbol sym, HasForeignType a, HasForeign sublayout)
       => HasForeign (Capture sym a :> sublayout) where
   type Foreign (Capture sym a :> sublayout) = Foreign sublayout
 
   foreignFor Proxy req =
     foreignFor (Proxy :: Proxy sublayout) $
-      req & reqUrl.path <>~ [Segment (Cap str)]
+      req & reqUrl.path <>~ [Segment (Cap arg)]
           & funcName %~ (++ ["by", str])
 
-    where str = pack . symbolVal $ (Proxy :: Proxy sym)
+    where
+    str = pack . symbolVal $ (Proxy :: Proxy sym)
+    arg = (str, typeFor (Proxy :: Proxy a))
 
-instance Elem JSON list => HasForeign (Delete list a) where
+instance (Elem JSON list, HasForeignType a) => HasForeign (Delete list a) where
   type Foreign (Delete list a) = Req
 
   foreignFor Proxy req =
     req & funcName      %~ ("delete" :)
         & reqMethod     .~ "DELETE"
+        & reqReturnType .~ retType
+    where
+    retType = typeFor (Proxy :: Proxy a)
 
-instance Elem JSON list => HasForeign (Get list a) where
+instance (Elem JSON list, HasForeignType a) => HasForeign (Get list a) where
   type Foreign (Get list a) = Req
 
   foreignFor Proxy req =
     req & funcName  %~ ("get" :)
         & reqMethod .~ "GET"
+        & reqReturnType .~ retType
+    where
+    retType = typeFor (Proxy :: Proxy a)
 
-instance (KnownSymbol sym, HasForeign sublayout)
+instance (KnownSymbol sym, HasForeignType a, HasForeign sublayout)
       => HasForeign (Header sym a :> sublayout) where
   type Foreign (Header sym a :> sublayout) = Foreign sublayout
 
   foreignFor Proxy req =
-    foreignFor subP (req & reqHeaders <>~ [HeaderArg hname])
+    foreignFor subP $ req
+        & reqHeaders <>~ [HeaderArg arg]
 
-    where hname = pack . symbolVal $ (Proxy :: Proxy sym)
+    where
+    hname = pack . symbolVal $ (Proxy :: Proxy sym)
+    arg = (hname, typeFor (Proxy :: Proxy a))
     subP = Proxy :: Proxy sublayout
 
-instance Elem JSON list => HasForeign (Post list a) where
+instance (Elem JSON list, HasForeignType a) => HasForeign (Post list a) where
   type Foreign (Post list a) = Req
 
   foreignFor Proxy req =
     req & funcName  %~ ("post" :)
         & reqMethod .~ "POST"
+        & reqReturnType .~ retType
+    where
+    retType = typeFor (Proxy :: Proxy a)
 
-instance Elem JSON list => HasForeign (Put list a) where
+instance (Elem JSON list, HasForeignType a) => HasForeign (Put list a) where
   type Foreign (Put list a) = Req
 
   foreignFor Proxy req =
     req & funcName  %~ ("put" :)
         & reqMethod .~ "PUT"
+        & reqReturnType .~ retType
+    where
+    retType = typeFor (Proxy :: Proxy a)
 
-instance (KnownSymbol sym, HasForeign sublayout)
+instance (KnownSymbol sym, HasForeignType a, HasForeign sublayout)
       => HasForeign (QueryParam sym a :> sublayout) where
   type Foreign (QueryParam sym a :> sublayout) = Foreign sublayout
 
   foreignFor Proxy req =
     foreignFor (Proxy :: Proxy sublayout) $
-      req & reqUrl.queryStr <>~ [QueryArg str Normal]
+      req & reqUrl.queryStr <>~ [QueryArg arg Normal]
 
-    where str = pack . symbolVal $ (Proxy :: Proxy sym)
+    where
+    str = pack . symbolVal $ (Proxy :: Proxy sym)
+    arg = (str, typeFor (Proxy :: Proxy a))
 
-instance (KnownSymbol sym, HasForeign sublayout)
+instance (KnownSymbol sym, HasForeignType a, HasForeign sublayout)
       => HasForeign (QueryParams sym a :> sublayout) where
   type Foreign (QueryParams sym a :> sublayout) = Foreign sublayout
 
   foreignFor Proxy req =
     foreignFor (Proxy :: Proxy sublayout) $
-      req & reqUrl.queryStr <>~ [QueryArg str List]
+      req & reqUrl.queryStr <>~ [QueryArg arg List]
 
-    where str = pack . symbolVal $ (Proxy :: Proxy sym)
+    where
+    str = pack . symbolVal $ (Proxy :: Proxy sym)
+    arg = (str, typeFor (Proxy :: Proxy a))
 
-instance (KnownSymbol sym, HasForeign sublayout)
+instance (KnownSymbol sym, HasForeignType a, a ~ Bool, HasForeign sublayout)
       => HasForeign (QueryFlag sym :> sublayout) where
   type Foreign (QueryFlag sym :> sublayout) = Foreign sublayout
 
   foreignFor Proxy req =
     foreignFor (Proxy :: Proxy sublayout) $
-      req & reqUrl.queryStr <>~ [QueryArg str Flag]
+      req & reqUrl.queryStr <>~ [QueryArg arg Flag]
 
-    where str = pack . symbolVal $ (Proxy :: Proxy sym)
+    where
+    str = pack . symbolVal $ (Proxy :: Proxy sym)
+    arg = (str, typeFor (Proxy :: Proxy a))
 
 instance HasForeign Raw where
   type Foreign Raw = Method -> Req
@@ -218,12 +246,13 @@ instance HasForeign Raw where
     req & funcName %~ ((toLower method) :)
         & reqMethod .~ method
 
-instance (Elem JSON list, HasForeign sublayout) => HasForeign (ReqBody list a :> sublayout) where
+instance (Elem JSON list, HasForeignType a, HasForeign sublayout)
+      => HasForeign (ReqBody list a :> sublayout) where
   type Foreign (ReqBody list a :> sublayout) = Foreign sublayout
 
   foreignFor Proxy req =
     foreignFor (Proxy :: Proxy sublayout) $
-      req & reqBody .~ True
+      req & reqBody .~ (Just $ typeFor (Proxy :: Proxy a))
 
 instance (KnownSymbol path, HasForeign sublayout)
       => HasForeign (path :> sublayout) where
@@ -234,7 +263,9 @@ instance (KnownSymbol path, HasForeign sublayout)
       req & reqUrl.path <>~ [Segment (Static str)]
           & funcName %~ (++ [str])
 
-    where str = Data.Text.map (\c -> if c == '.' then '_' else c) . pack . symbolVal $ (Proxy :: Proxy path)
+    where
+    str = Data.Text.map (\c -> if c == '.' then '_' else c)
+        . pack . symbolVal $ (Proxy :: Proxy path)
 
 instance HasForeign sublayout => HasForeign (RemoteHost :> sublayout) where
   type Foreign (RemoteHost :> sublayout) = Foreign sublayout