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

Make servant-foreign code nicer

servant-foreign/src/Servant/Foreign.hs

@@ -1,36 +1,50 @@
 -- | Generalizes all the data needed to make code generation work with
 -- arbitrary programming languages.
 module Servant.Foreign
-  ( HasForeign(..)
+  ( ArgType(..)
-  , HasForeignType(..)
+  , HeaderArg(..)
+  , QueryArg(..)
+  , Req(..)
   , Segment(..)
   , SegmentType(..)
+  , Url(..)
+    -- aliases
+  , Path
+  , ForeignType
+  , Arg
   , FunctionName
-  , QueryArg(..)
+    -- lenses
-  , HeaderArg(..)
+  , reqUrl
-  , ArgType(..)
+  , reqMethod
-  , Req
+  , 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
+  , defReq
-  , argType
-  , argName
-  , isCapture
-  , funcName
-  , path
-  , reqUrl
-  , reqBody
-  , reqHeaders
-  , reqMethod
-  , reqReturnType
-  , segment
-  , queryStr
   , listFromAPI
-  , GenerateList(..)
-  , NoTypes
   -- re-exports
   , module Servant.API
   ) where

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

@@ -19,17 +19,19 @@
 -- arbitrary programming languages.
 module Servant.Foreign.Internal where
 
-import           Control.Lens          (makeLenses, (%~), (&), (.~), (<>~))
+import           Control.Lens (makeLenses, makePrisms, (%~), (&), (.~), (<>~))
-import qualified Data.Char             as C
+import qualified Data.Char as C
 import           Data.Proxy
 import           Data.Text
-import           Data.Text.Encoding    (decodeUtf8)
+import           Data.Text.Encoding (decodeUtf8)
-import           GHC.Exts              (Constraint)
+import           GHC.Exts (Constraint)
 import           GHC.TypeLits
-import qualified Network.HTTP.Types    as HTTP
+import qualified Network.HTTP.Types as HTTP
-import           Prelude               hiding (concat)
+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"
+makePrisms ''SegmentType
-                 | Cap Arg        -- ^ a capture. like "/:userid"
+
+newtype Segment = Segment { unSegment :: SegmentType  }
   deriving (Eq, Show)
 
+makePrisms ''Segment
+
 type Path = [Segment]
 
-data ArgType =
+data ArgType
-    Normal
+  = Normal
   | Flag
   | List
   deriving (Eq, Show)
 
+makePrisms ''ArgType
+
 data QueryArg = QueryArg
   { _argName :: Arg
   , _argType :: ArgType
   } deriving (Eq, Show)
 
-data HeaderArg = HeaderArg
+makeLenses ''QueryArg
-    { headerArg :: Arg
-    }
-  | ReplaceHeaderArg
-    { headerArg :: Arg
-    , headerPattern :: Text
-    } deriving (Eq, Show)
 
+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
+instance HasForeignType NoTypes ftype where
-    typeFor _ _ = empty
+  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)
+instance (KnownSymbol sym, HasForeignType lang ftype, HasForeign lang sublayout)
-      => HasForeign lang (Capture sym a :> sublayout) where
+  => 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)
+      str = pack . symbolVal $ (Proxy :: Proxy sym)
-    arg = (str, typeFor lang (Proxy :: Proxy a))
+      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)
+      retType  = typeFor lang (Proxy :: Proxy a)
-    method   = reflectMethod (Proxy :: Proxy method)
+      method   = reflectMethod (Proxy :: Proxy method)
-    methodLC = toLower $ decodeUtf8 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)
+      hname = pack . symbolVal $ (Proxy :: Proxy sym)
-    arg = (hname, typeFor lang (Proxy :: Proxy a))
+      arg = (hname, typeFor lang (Proxy :: Proxy a))
-    subP = Proxy :: Proxy sublayout
+      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)
+      str = pack . symbolVal $ (Proxy :: Proxy sym)
-    arg = (str, typeFor lang (Proxy :: Proxy a))
+      arg = (str, typeFor lang (Proxy :: Proxy a))
 
-instance (KnownSymbol sym, HasForeignType lang [a], HasForeign lang sublayout)
+instance
-      => HasForeign lang (QueryParams sym a :> sublayout) where
+  (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)
+      str = pack . symbolVal $ (Proxy :: Proxy sym)
-    arg = (str, typeFor lang (Proxy :: Proxy [a]))
+      arg = (str, typeFor lang (Proxy :: Proxy [a]))
 
-instance (KnownSymbol sym, HasForeignType lang a, a ~ Bool, HasForeign lang sublayout)
+instance
-      => HasForeign lang (QueryFlag sym :> sublayout) where
+  (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)
+      str = pack . symbolVal $ (Proxy :: Proxy sym)
-    arg = (str, typeFor lang (Proxy :: Proxy a))
+      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)
+      str =
-        . pack . symbolVal $ (Proxy :: Proxy path)
+        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)

servant-foreign/test/Servant/ForeignSpec.hs

@@ -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
+  it "generates 4 endpoints for TestApi" $ do
-        length testApi `shouldBe` 4
+    length testApi `shouldBe` 4
 
-    let [getReq, postReq, putReq, deleteReq] = testApi
+  let [getReq, postReq, putReq, deleteReq] = testApi
 
-    it "collects all info for get request" $ do
+  it "collects all info for get request" $ do
-        shouldBe getReq $ defReq
+    shouldBe getReq $ defReq
-            { _reqUrl        = Url
+      { _reqUrl        = Url
-                [ Segment $ Static "test" ]
+          [ Segment $ Static "test" ]
-                [ QueryArg ("flag", "boolX") Flag ]
+          [ QueryArg ("flag", "boolX") Flag ]
-            , _reqMethod     = "GET"
+      , _reqMethod     = "GET"
-            , _reqHeaders    = [HeaderArg ("header", "listX of stringX")]
+      , _reqHeaders    = [HeaderArg ("header", "listX of stringX")]
-            , _reqBody       = Nothing
+      , _reqBody       = Nothing
-            , _reqReturnType = "intX"
+      , _reqReturnType = "intX"
-            , _funcName      = ["get", "test"]
+      , _reqFuncName      = ["get", "test"]
-            }
+      }
 
-    it "collects all info for post request" $ do
+  it "collects all info for post request" $ do
-        shouldBe postReq $ defReq
+    shouldBe postReq $ defReq
-            { _reqUrl        = Url
+      { _reqUrl        = Url
-                [ Segment $ Static "test" ]
+          [ Segment $ Static "test" ]
-                [ QueryArg ("param", "intX") Normal ]
+          [ QueryArg ("param", "intX") Normal ]
-            , _reqMethod     = "POST"
+      , _reqMethod     = "POST"
-            , _reqHeaders    = []
+      , _reqHeaders    = []
-            , _reqBody       = Just "listX of stringX"
+      , _reqBody       = Just "listX of stringX"
-            , _reqReturnType = "voidX"
+      , _reqReturnType = "voidX"
-            , _funcName      = ["post", "test"]
+      , _reqFuncName      = ["post", "test"]
-            }
+      }
 
-    it "collects all info for put request" $ do
+  it "collects all info for put request" $ do
-        shouldBe putReq $ defReq
+    shouldBe putReq $ defReq
-            { _reqUrl        = Url
+      { _reqUrl        = Url
-                [ Segment $ Static "test" ]
+          [ Segment $ Static "test" ]
-                -- Shoud this be |intX| or |listX of intX| ?
+          -- Shoud this be |intX| or |listX of intX| ?
-                [ QueryArg ("params", "listX of intX") List ]
+          [ QueryArg ("params", "listX of intX") List ]
-            , _reqMethod     = "PUT"
+      , _reqMethod     = "PUT"
-            , _reqHeaders    = []
+      , _reqHeaders    = []
-            , _reqBody       = Just "stringX"
+      , _reqBody       = Just "stringX"
-            , _reqReturnType = "voidX"
+      , _reqReturnType = "voidX"
-            , _funcName      = ["put", "test"]
+      , _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"
-            , _funcName      = ["delete", "test", "by", "id"]
-            }
 
+  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"]
+      }

servant-js/src/Servant/JS/Angular.hs

@@ -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'

servant-js/src/Servant/JS/Axios.hs

@@ -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'

servant-js/src/Servant/JS/Internal.hs

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

servant-js/src/Servant/JS/JQuery.hs

@@ -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'

servant-js/src/Servant/JS/Vanilla.hs

@@ -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'