eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Merge pull request #372 from dredozubov/stylish-servant-foreign

Browse source 
Make servant-foreign code nicer
This commit is contained in:
Denis Redozubov 2016-02-17 11:46:26 +03:00
commit 8dc73285ee
8 changed files with 198 additions and 155 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

58
servant-foreign/src/Servant/Foreign.hs
View file

@ -1,36 +1,50 @@
-- | Generalizes all the data needed to make code generation work with
-- arbitrary programming languages.
module Servant.Foreign
( HasForeign(..)
, HasForeignType(..)
( ArgType(..)
, HeaderArg(..)
, QueryArg(..)
, Req(..)
, Segment(..)
, SegmentType(..)
, Url(..)
-- aliases
, Path
, ForeignType
, Arg
, FunctionName
, QueryArg(..)
, HeaderArg(..)
, ArgType(..)
, Req
-- lenses
, reqUrl
, reqMethod
, reqHeaders
, reqBody
, reqReturnType
, reqFuncName
, path
, queryStr
, argName
, argType
-- prisms
, _HeaderArg
, _ReplaceHeaderArg
, _Static
, _Cap
, _Normal
, _Flag
, _List
-- rest of it
, HasForeign(..)
, HasForeignType(..)
, HasNoForeignType
, GenerateList(..)
, NoTypes
, captureArg
, defReq
, isCapture
, concatCase
, snakeCase
, camelCase
-- lenses
, argType
, argName
, isCapture
, funcName
, path
, reqUrl
, reqBody
, reqHeaders
, reqMethod
, reqReturnType
, segment
, queryStr
, defReq
, listFromAPI
, GenerateList(..)
, NoTypes
-- re-exports
, module Servant.API
) where

154
servant-foreign/src/Servant/Foreign/Internal.hs
View file

@ -19,17 +19,19 @@
-- arbitrary programming languages.
module Servant.Foreign.Internal where
import Control.Lens (makeLenses, (%~), (&), (.~), (<>~))
import qualified Data.Char as C
import Control.Lens (makeLenses, makePrisms, (%~), (&), (.~), (<>~))
import qualified Data.Char as C
import Data.Proxy
import Data.Text
import Data.Text.Encoding (decodeUtf8)
import GHC.Exts (Constraint)
import Data.Text.Encoding (decodeUtf8)
import GHC.Exts (Constraint)
import GHC.TypeLits
import qualified Network.HTTP.Types as HTTP
import Prelude hiding (concat)
import qualified Network.HTTP.Types as HTTP
import Prelude hiding (concat)
import Servant.API
type FunctionName = [Text]
-- | Function name builder that simply concat each part together
concatCase :: FunctionName -> Text
concatCase = concat
@ -49,36 +51,50 @@ camelCase = camelCase' . Prelude.map (replace "-" "")
capitalize name = C.toUpper (Data.Text.head name) `cons` Data.Text.tail name
type ForeignType = Text
type Arg = (Text, ForeignType)
newtype Segment = Segment { _segment :: SegmentType }
data SegmentType
= Static Text
-- ^ a static path segment. like "/foo"
| Cap Arg
-- ^ a capture. like "/:userid"
deriving (Eq, Show)
data SegmentType = Static Text -- ^ a static path segment. like "/foo"
| Cap Arg -- ^ a capture. like "/:userid"
makePrisms ''SegmentType
newtype Segment = Segment { unSegment :: SegmentType }
deriving (Eq, Show)
makePrisms ''Segment
type Path = [Segment]
data ArgType =
Normal
data ArgType
= Normal
| Flag
| List
deriving (Eq, Show)
makePrisms ''ArgType
data QueryArg = QueryArg
{ _argName :: Arg
, _argType :: ArgType
} deriving (Eq, Show)
data HeaderArg = HeaderArg
{ headerArg :: Arg
}
| ReplaceHeaderArg
{ headerArg :: Arg
, headerPattern :: Text
} deriving (Eq, Show)
makeLenses ''QueryArg
data HeaderArg = HeaderArg
{ headerArg :: Arg }
| ReplaceHeaderArg
{ headerArg :: Arg
, headerPattern :: Text
} deriving (Eq, Show)
makeLenses ''HeaderArg
makePrisms ''HeaderArg
data Url = Url
{ _path :: Path
@ -88,7 +104,7 @@ data Url = Url
defUrl :: Url
defUrl = Url [] []
type FunctionName = [Text]
makeLenses ''Url
data Req = Req
{ _reqUrl :: Url
@ -96,12 +112,9 @@ data Req = Req
, _reqHeaders :: [HeaderArg]
, _reqBody :: Maybe ForeignType
, _reqReturnType :: ForeignType
, _funcName :: FunctionName
, _reqFuncName :: FunctionName
} deriving (Eq, Show)
makeLenses ''QueryArg
makeLenses ''Segment
makeLenses ''Url
makeLenses ''Req
isCapture :: Segment -> Bool
@ -155,66 +168,66 @@ type family Elem (a :: *) (ls::[*]) :: Constraint where
-- >
--
class HasForeignType lang a where
typeFor :: Proxy lang -> Proxy a -> ForeignType
typeFor :: Proxy lang -> Proxy a -> ForeignType
data NoTypes
instance HasForeignType NoTypes a where
typeFor _ _ = empty
instance HasForeignType NoTypes ftype where
typeFor _ _ = empty
type HasNoForeignType = HasForeignType NoTypes
class HasForeign lang (layout :: *) where
type Foreign layout :: *
foreignFor :: Proxy lang -> Proxy layout -> Req -> Foreign layout
instance (HasForeign lang a, HasForeign lang b)
=> HasForeign lang (a :<|> b) where
=> HasForeign lang (a :<|> b) where
type Foreign (a :<|> b) = Foreign a :<|> Foreign b
foreignFor lang Proxy req =
foreignFor lang (Proxy :: Proxy a) req
:<|> foreignFor lang (Proxy :: Proxy b) req
instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout)
=> HasForeign lang (Capture sym a :> sublayout) where
instance (KnownSymbol sym, HasForeignType lang ftype, HasForeign lang sublayout)
=> HasForeign lang (Capture sym ftype :> sublayout) where
type Foreign (Capture sym a :> sublayout) = Foreign sublayout
foreignFor lang Proxy req =
foreignFor lang (Proxy :: Proxy sublayout) $
req & reqUrl.path <>~ [Segment (Cap arg)]
& funcName %~ (++ ["by", str])
& reqFuncName %~ (++ ["by", str])
where
str = pack . symbolVal $ (Proxy :: Proxy sym)
arg = (str, typeFor lang (Proxy :: Proxy a))
str = pack . symbolVal $ (Proxy :: Proxy sym)
arg = (str, typeFor lang (Proxy :: Proxy ftype))
instance (Elem JSON list, HasForeignType lang a, ReflectMethod method)
=> HasForeign lang (Verb method status list a) where
=> HasForeign lang (Verb method status list a) where
type Foreign (Verb method status list a) = Req
foreignFor lang Proxy req =
req & funcName %~ (methodLC :)
req & reqFuncName %~ (methodLC :)
& reqMethod .~ method
& reqReturnType .~ retType
where
retType = typeFor lang (Proxy :: Proxy a)
method = reflectMethod (Proxy :: Proxy method)
methodLC = toLower $ decodeUtf8 method
retType = typeFor lang (Proxy :: Proxy a)
method = reflectMethod (Proxy :: Proxy method)
methodLC = toLower $ decodeUtf8 method
instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout)
=> HasForeign lang (Header sym a :> sublayout) where
=> HasForeign lang (Header sym a :> sublayout) where
type Foreign (Header sym a :> sublayout) = Foreign sublayout
foreignFor lang Proxy req =
foreignFor lang subP $ req
& reqHeaders <>~ [HeaderArg arg]
where
hname = pack . symbolVal $ (Proxy :: Proxy sym)
arg = (hname, typeFor lang (Proxy :: Proxy a))
subP = Proxy :: Proxy sublayout
hname = pack . symbolVal $ (Proxy :: Proxy sym)
arg = (hname, typeFor lang (Proxy :: Proxy a))
subP = Proxy :: Proxy sublayout
instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout)
=> HasForeign lang (QueryParam sym a :> sublayout) where
=> HasForeign lang (QueryParam sym a :> sublayout) where
type Foreign (QueryParam sym a :> sublayout) = Foreign sublayout
foreignFor lang Proxy req =
@ -222,38 +235,37 @@ instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout)
req & reqUrl.queryStr <>~ [QueryArg arg Normal]
where
str = pack . symbolVal $ (Proxy :: Proxy sym)
arg = (str, typeFor lang (Proxy :: Proxy a))
str = pack . symbolVal $ (Proxy :: Proxy sym)
arg = (str, typeFor lang (Proxy :: Proxy a))
instance (KnownSymbol sym, HasForeignType lang [a], HasForeign lang sublayout)
=> HasForeign lang (QueryParams sym a :> sublayout) where
instance
(KnownSymbol sym, HasForeignType lang [a], HasForeign lang sublayout)
=> HasForeign lang (QueryParams sym a :> sublayout) where
type Foreign (QueryParams sym a :> sublayout) = Foreign sublayout
foreignFor lang Proxy req =
foreignFor lang (Proxy :: Proxy sublayout) $
req & reqUrl.queryStr <>~ [QueryArg arg List]
where
str = pack . symbolVal $ (Proxy :: Proxy sym)
arg = (str, typeFor lang (Proxy :: Proxy [a]))
str = pack . symbolVal $ (Proxy :: Proxy sym)
arg = (str, typeFor lang (Proxy :: Proxy [a]))
instance (KnownSymbol sym, HasForeignType lang a, a ~ Bool, HasForeign lang sublayout)
=> HasForeign lang (QueryFlag sym :> sublayout) where
instance
(KnownSymbol sym, HasForeignType lang Bool, HasForeign lang sublayout)
=> HasForeign lang (QueryFlag sym :> sublayout) where
type Foreign (QueryFlag sym :> sublayout) = Foreign sublayout
foreignFor lang Proxy req =
foreignFor lang (Proxy :: Proxy sublayout) $
req & reqUrl.queryStr <>~ [QueryArg arg Flag]
where
str = pack . symbolVal $ (Proxy :: Proxy sym)
arg = (str, typeFor lang (Proxy :: Proxy a))
str = pack . symbolVal $ (Proxy :: Proxy sym)
arg = (str, typeFor lang (Proxy :: Proxy Bool))
instance HasForeign lang Raw where
type Foreign Raw = HTTP.Method -> Req
foreignFor _ Proxy req method =
req & funcName %~ ((toLower $ decodeUtf8 method) :)
req & reqFuncName %~ ((toLower $ decodeUtf8 method) :)
& reqMethod .~ method
instance (Elem JSON list, HasForeignType lang a, HasForeign lang sublayout)
@ -271,19 +283,21 @@ instance (KnownSymbol path, HasForeign lang sublayout)
foreignFor lang Proxy req =
foreignFor lang (Proxy :: Proxy sublayout) $
req & reqUrl.path <>~ [Segment (Static str)]
& funcName %~ (++ [str])
& reqFuncName %~ (++ [str])
where
str = Data.Text.map (\c -> if c == '.' then '_' else c)
. pack . symbolVal $ (Proxy :: Proxy path)
str =
Data.Text.map (\c -> if c == '.' then '_' else c)
. pack . symbolVal $ (Proxy :: Proxy path)
instance HasForeign lang sublayout => HasForeign lang (RemoteHost :> sublayout) where
instance HasForeign lang sublayout
=> HasForeign lang (RemoteHost :> sublayout) where
type Foreign (RemoteHost :> sublayout) = Foreign sublayout
foreignFor lang Proxy req =
foreignFor lang (Proxy :: Proxy sublayout) req
instance HasForeign lang sublayout => HasForeign lang (IsSecure :> sublayout) where
instance HasForeign lang sublayout
=> HasForeign lang (IsSecure :> sublayout) where
type Foreign (IsSecure :> sublayout) = Foreign sublayout
foreignFor lang Proxy req =
@ -302,7 +316,8 @@ instance HasForeign lang sublayout =>
foreignFor lang Proxy = foreignFor lang (Proxy :: Proxy sublayout)
instance HasForeign lang sublayout => HasForeign lang (HttpVersion :> sublayout) where
instance HasForeign lang sublayout
=> HasForeign lang (HttpVersion :> sublayout) where
type Foreign (HttpVersion :> sublayout) = Foreign sublayout
foreignFor lang Proxy req =
@ -317,10 +332,15 @@ class GenerateList reqs where
instance GenerateList Req where
generateList r = [r]
instance (GenerateList start, GenerateList rest) => GenerateList (start :<|> rest) where
instance (GenerateList start, GenerateList rest)
=> GenerateList (start :<|> rest) where
generateList (start :<|> rest) = (generateList start) ++ (generateList rest)
-- | Generate the necessary data for codegen as a list, each 'Req'
-- describing one endpoint from your API type.
listFromAPI :: (HasForeign lang api, GenerateList (Foreign api)) => Proxy lang -> Proxy api -> [Req]
listFromAPI
:: (HasForeign lang api, GenerateList (Foreign api))
=> Proxy lang
-> Proxy api
-> [Req]
listFromAPI lang p = generateList (foreignFor lang p defReq)

114
servant-foreign/test/Servant/ForeignSpec.hs
View file

@ -15,7 +15,6 @@ module Servant.ForeignSpec where
import Data.Monoid ((<>))
import Data.Proxy
import Servant.Foreign
import Servant.Foreign.Internal
import Test.Hspec
@ -35,15 +34,19 @@ camelCaseSpec = describe "camelCase" $ do
data LangX
instance HasForeignType LangX () where
typeFor _ _ = "voidX"
typeFor _ _ = "voidX"
instance HasForeignType LangX Int where
typeFor _ _ = "intX"
typeFor _ _ = "intX"
instance HasForeignType LangX Bool where
typeFor _ _ = "boolX"
typeFor _ _ = "boolX"
instance OVERLAPPING_ HasForeignType LangX String where
typeFor _ _ = "stringX"
typeFor _ _ = "stringX"
instance OVERLAPPABLE_ HasForeignType LangX a => HasForeignType LangX [a] where
typeFor lang _ = "listX of " <> typeFor lang (Proxy :: Proxy a)
typeFor lang _ = "listX of " <> typeFor lang (Proxy :: Proxy a)
type TestApi
= "test" :> Header "header" [String] :> QueryFlag "flag" :> Get '[JSON] Int
@ -56,58 +59,57 @@ testApi = listFromAPI (Proxy :: Proxy LangX) (Proxy :: Proxy TestApi)
listFromAPISpec :: Spec
listFromAPISpec = describe "listFromAPI" $ do
it "generates 4 endpoints for TestApi" $ do
length testApi `shouldBe` 4
it "generates 4 endpoints for TestApi" $ do
length testApi `shouldBe` 4
let [getReq, postReq, putReq, deleteReq] = testApi
let [getReq, postReq, putReq, deleteReq] = testApi
it "collects all info for get request" $ do
shouldBe getReq $ defReq
{ _reqUrl = Url
[ Segment $ Static "test" ]
[ QueryArg ("flag", "boolX") Flag ]
, _reqMethod = "GET"
, _reqHeaders = [HeaderArg ("header", "listX of stringX")]
, _reqBody = Nothing
, _reqReturnType = "intX"
, _funcName = ["get", "test"]
}
it "collects all info for get request" $ do
shouldBe getReq $ defReq
{ _reqUrl = Url
[ Segment $ Static "test" ]
[ QueryArg ("flag", "boolX") Flag ]
, _reqMethod = "GET"
, _reqHeaders = [HeaderArg ("header", "listX of stringX")]
, _reqBody = Nothing
, _reqReturnType = "intX"
, _reqFuncName = ["get", "test"]
}
it "collects all info for post request" $ do
shouldBe postReq $ defReq
{ _reqUrl = Url
[ Segment $ Static "test" ]
[ QueryArg ("param", "intX") Normal ]
, _reqMethod = "POST"
, _reqHeaders = []
, _reqBody = Just "listX of stringX"
, _reqReturnType = "voidX"
, _funcName = ["post", "test"]
}
it "collects all info for post request" $ do
shouldBe postReq $ defReq
{ _reqUrl = Url
[ Segment $ Static "test" ]
[ QueryArg ("param", "intX") Normal ]
, _reqMethod = "POST"
, _reqHeaders = []
, _reqBody = Just "listX of stringX"
, _reqReturnType = "voidX"
, _reqFuncName = ["post", "test"]
}
it "collects all info for put request" $ do
shouldBe putReq $ defReq
{ _reqUrl = Url
[ Segment $ Static "test" ]
-- Shoud this be |intX| or |listX of intX| ?
[ QueryArg ("params", "listX of intX") List ]
, _reqMethod = "PUT"
, _reqHeaders = []
, _reqBody = Just "stringX"
, _reqReturnType = "voidX"
, _funcName = ["put", "test"]
}
it "collects all info for delete request" $ do
shouldBe deleteReq $ defReq
{ _reqUrl = Url
[ Segment $ Static "test"
, Segment $ Cap ("id", "intX") ]
[]
, _reqMethod = "DELETE"
, _reqHeaders = []
, _reqBody = Nothing
, _reqReturnType = "voidX"
, _funcName = ["delete", "test", "by", "id"]
}
it "collects all info for put request" $ do
shouldBe putReq $ defReq
{ _reqUrl = Url
[ Segment $ Static "test" ]
-- Shoud this be |intX| or |listX of intX| ?
[ QueryArg ("params", "listX of intX") List ]
, _reqMethod = "PUT"
, _reqHeaders = []
, _reqBody = Just "stringX"
, _reqReturnType = "voidX"
, _reqFuncName = ["put", "test"]
}
it "collects all info for delete request" $ do
shouldBe deleteReq $ defReq
{ _reqUrl = Url
[ Segment $ Static "test"
, Segment $ Cap ("id", "intX") ]
[]
, _reqMethod = "DELETE"
, _reqHeaders = []
, _reqBody = Nothing
, _reqReturnType = "voidX"
, _reqFuncName = ["delete", "test", "by", "id"]
}

2
servant-js/src/Servant/JS/Angular.hs
View file

@ -128,7 +128,7 @@ generateAngularJSWith ngOptions opts req = "\n" <>
fsep = if hasService then ":" else " ="
fname = namespace <> (functionNameBuilder opts $ req ^. funcName)
fname = namespace <> (functionNameBuilder opts $ req ^. reqFuncName)
method = req ^. reqMethod
url = if url' == "'" then "'/'" else url'

2
servant-js/src/Servant/JS/Axios.hs
View file

@ -116,7 +116,7 @@ generateAxiosJSWith aopts opts req = "\n" <>
where
hasNoModule = moduleName opts == ""
fname = namespace <> (functionNameBuilder opts $ req ^. funcName)
fname = namespace <> (functionNameBuilder opts $ req ^. reqFuncName)
method = T.toLower . decodeUtf8 $ req ^. reqMethod
url = if url' == "'" then "'/'" else url'

19
servant-js/src/Servant/JS/Internal.hs
View file

@ -51,12 +51,19 @@ type JavaScriptGenerator = [Req] -> Text
-- customize the output
data CommonGeneratorOptions = CommonGeneratorOptions
{
functionNameBuilder :: FunctionName -> Text -- ^ function generating function names
, requestBody :: Text -- ^ name used when a user want to send the request body (to let you redefine it)
, successCallback :: Text -- ^ name of the callback parameter when the request was successful
, errorCallback :: Text -- ^ name of the callback parameter when the request reported an error
, moduleName :: Text -- ^ namespace on which we define the foreign function (empty mean local var)
, urlPrefix :: Text -- ^ a prefix we should add to the Url in the codegen
functionNameBuilder :: FunctionName -> Text
-- ^ function generating function names
, requestBody :: Text
-- ^ name used when a user want to send the request body
-- (to let you redefine it)
, successCallback :: Text
-- ^ name of the callback parameter when the request was successful
, errorCallback :: Text
-- ^ name of the callback parameter when the request reported an error
, moduleName :: Text
-- ^ namespace on which we define the foreign function (empty mean local var)
, urlPrefix :: Text
-- ^ a prefix we should add to the Url in the codegen
}
-- | Default options.

2
servant-js/src/Servant/JS/JQuery.hs
View file

@ -81,7 +81,7 @@ generateJQueryJSWith opts req = "\n" <>
namespace = if (moduleName opts) == ""
then "var "
else (moduleName opts) <> "."
fname = namespace <> (functionNameBuilder opts $ req ^. funcName)
fname = namespace <> (functionNameBuilder opts $ req ^. reqFuncName)
method = req ^. reqMethod
url = if url' == "'" then "'/'" else url'

2
servant-js/src/Servant/JS/Vanilla.hs
View file

@ -93,7 +93,7 @@ generateVanillaJSWith opts req = "\n" <>
namespace = if moduleName opts == ""
then "var "
else (moduleName opts) <> "."
fname = namespace <> (functionNameBuilder opts $ req ^. funcName)
fname = namespace <> (functionNameBuilder opts $ req ^. reqFuncName)
method = req ^. reqMethod
url = if url' == "'" then "'/'" else url'