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(..)
-  , 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

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

@@ -19,7 +19,7 @@
 -- arbitrary programming languages.
 module Servant.Foreign.Internal where
 
-import           Control.Lens          (makeLenses, (%~), (&), (.~), (<>~))
+import           Control.Lens (makeLenses, makePrisms, (%~), (&), (.~), (<>~))
 import qualified Data.Char as C
 import           Data.Proxy
 import           Data.Text
@@ -30,6 +30,8 @@ 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)
 
+makeLenses ''QueryArg
+
 data HeaderArg = HeaderArg
-    { headerArg :: Arg
-    }
+  { 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
@@ -159,9 +172,11 @@ class HasForeignType lang a where
 
 data NoTypes
 
-instance HasForeignType NoTypes a where
+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
@@ -174,25 +189,24 @@ instance (HasForeign lang a, HasForeign lang b)
          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))
+      arg = (str, typeFor lang (Proxy :: Proxy ftype))
 
 instance (Elem JSON list, HasForeignType lang a, ReflectMethod method)
   => 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
@@ -207,7 +221,6 @@ instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang 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))
@@ -225,35 +238,34 @@ instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout)
       str = pack . symbolVal $ (Proxy :: Proxy sym)
       arg = (str, typeFor lang (Proxy :: Proxy a))
 
-instance (KnownSymbol sym, HasForeignType lang [a], HasForeign lang sublayout)
+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]))
 
-instance (KnownSymbol sym, HasForeignType lang a, a ~ Bool, HasForeign lang sublayout)
+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))
+      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 =
+        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
 
@@ -36,12 +35,16 @@ data LangX
 
 instance HasForeignType LangX () where
   typeFor _ _ = "voidX"
+
 instance HasForeignType LangX Int where
   typeFor _ _ = "intX"
+
 instance HasForeignType LangX Bool where
   typeFor _ _ = "boolX"
+
 instance OVERLAPPING_ HasForeignType LangX String where
   typeFor _ _ = "stringX"
+
 instance OVERLAPPABLE_ HasForeignType LangX a => HasForeignType LangX [a] where
   typeFor lang _ = "listX of " <> typeFor lang (Proxy :: Proxy a)
 
@@ -70,7 +73,7 @@ listFromAPISpec = describe "listFromAPI" $ do
       , _reqHeaders    = [HeaderArg ("header", "listX of stringX")]
       , _reqBody       = Nothing
       , _reqReturnType = "intX"
-            , _funcName      = ["get", "test"]
+      , _reqFuncName      = ["get", "test"]
       }
 
   it "collects all info for post request" $ do
@@ -82,7 +85,7 @@ listFromAPISpec = describe "listFromAPI" $ do
       , _reqHeaders    = []
       , _reqBody       = Just "listX of stringX"
       , _reqReturnType = "voidX"
-            , _funcName      = ["post", "test"]
+      , _reqFuncName      = ["post", "test"]
       }
 
   it "collects all info for put request" $ do
@@ -95,7 +98,7 @@ listFromAPISpec = describe "listFromAPI" $ do
       , _reqHeaders    = []
       , _reqBody       = Just "stringX"
       , _reqReturnType = "voidX"
-            , _funcName      = ["put", "test"]
+      , _reqFuncName      = ["put", "test"]
       }
 
   it "collects all info for delete request" $ do
@@ -108,6 +111,5 @@ listFromAPISpec = describe "listFromAPI" $ do
       , _reqHeaders    = []
       , _reqBody       = Nothing
       , _reqReturnType = "voidX"
-            , _funcName      = ["delete", "test", "by", "id"]
+      , _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
-  , 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.

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'