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

Add access to types in servant-foreign.

Browse source
This commit is contained in:
Maksymilian Owsianny 2015-11-28 08:13:26 +00:00
parent 8bf804e292
commit 8932cb242c
2 changed files with 67 additions and 34 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

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

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

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