module Servant.Elm.Internal.Generate where
import Prelude hiding ((<$>))
import Control.Lens (to, (^.))
import Data.List (nub)
import Data.Maybe (catMaybes)
import Data.Proxy (Proxy)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as L
import qualified Data.Text.Encoding as T
import Elm (ElmDatatype)
import qualified Elm
import Servant.API (NoContent (..))
import Servant.Elm.Internal.Foreign (LangElm, getEndpoints)
import Servant.Elm.Internal.Orphans ()
import qualified Servant.Foreign as F
import Text.PrettyPrint.Leijen.Text
data ElmOptions = ElmOptions
{
urlPrefix :: UrlPrefix
, elmExportOptions :: Elm.Options
, emptyResponseElmTypes :: [ElmDatatype]
, stringElmTypes :: [ElmDatatype]
}
data UrlPrefix
= Static T.Text
| Dynamic
defElmOptions :: ElmOptions
defElmOptions = ElmOptions
{ urlPrefix = Static ""
, elmExportOptions = Elm.defaultOptions
, emptyResponseElmTypes =
[ Elm.toElmType NoContent
, Elm.toElmType ()
]
, stringElmTypes =
[ Elm.toElmType ("" :: String)
, Elm.toElmType ("" :: T.Text)
]
}
defElmImports :: Text
defElmImports =
T.unlines
[ "import Json.Decode exposing (..)"
, "import Json.Decode.Pipeline exposing (..)"
, "import Json.Encode"
, "import Http"
, "import String"
]
generateElmForAPI
:: ( F.HasForeign LangElm ElmDatatype api
, F.GenerateList ElmDatatype (F.Foreign ElmDatatype api))
=> Proxy api
-> [Text]
generateElmForAPI =
generateElmForAPIWith defElmOptions
generateElmForAPIWith
:: ( F.HasForeign LangElm ElmDatatype api
, F.GenerateList ElmDatatype (F.Foreign ElmDatatype api))
=> ElmOptions
-> Proxy api
-> [Text]
generateElmForAPIWith opts =
nub . map docToText . map (generateElmForRequest opts) . getEndpoints
i :: Int
i = 4
generateElmForRequest :: ElmOptions -> F.Req ElmDatatype -> Doc
generateElmForRequest opts request =
funcDef
where
funcDef =
vsep
[ fnName <+> ":" <+> typeSignature
, fnName <+> args <+> equals
, case letParams of
Just params ->
indent i
(vsep ["let"
, indent i params
, "in"
, indent i elmRequest
])
Nothing ->
indent i elmRequest
]
fnName =
request ^. F.reqFuncName . to (T.replace "-" "" . F.camelCase) . to stext
typeSignature =
mkTypeSignature opts request
args =
mkArgs opts request
letParams =
mkLetParams opts request
elmRequest =
mkRequest opts request
mkTypeSignature :: ElmOptions -> F.Req ElmDatatype -> Doc
mkTypeSignature opts request =
(hsep . punctuate " ->" . concat)
[ catMaybes [urlPrefixType]
, headerTypes
, urlCaptureTypes
, queryTypes
, catMaybes [bodyType, returnType]
]
where
urlPrefixType :: Maybe Doc
urlPrefixType =
case (urlPrefix opts) of
Dynamic -> Just "String"
Static _ -> Nothing
elmTypeRef :: ElmDatatype -> Doc
elmTypeRef eType =
stext (Elm.toElmTypeRefWith (elmExportOptions opts) eType)
headerTypes :: [Doc]
headerTypes =
[ header ^. F.headerArg . F.argType . to elmTypeRef
| header <- request ^. F.reqHeaders
]
urlCaptureTypes :: [Doc]
urlCaptureTypes =
[ F.captureArg capture ^. F.argType . to elmTypeRef
| capture <- request ^. F.reqUrl . F.path
, F.isCapture capture
]
queryTypes :: [Doc]
queryTypes =
[ arg ^. F.queryArgName . F.argType . to (elmTypeRef . wrapper)
| arg <- request ^. F.reqUrl . F.queryStr
, wrapper <- [
case arg ^. F.queryArgType of
F.Normal ->
Elm.ElmPrimitive . Elm.EMaybe
_ ->
id
]
]
bodyType :: Maybe Doc
bodyType =
fmap elmTypeRef $ request ^. F.reqBody
returnType :: Maybe Doc
returnType = do
result <- fmap elmTypeRef $ request ^. F.reqReturnType
pure ("Http.Request" <+> parens result)
elmHeaderArg :: F.HeaderArg ElmDatatype -> Doc
elmHeaderArg header =
"header_" <>
header ^. F.headerArg . F.argName . to (stext . F.unPathSegment)
elmCaptureArg :: F.Segment ElmDatatype -> Doc
elmCaptureArg segment =
"capture_" <>
F.captureArg segment ^. F.argName . to (stext . F.unPathSegment)
elmQueryArg :: F.QueryArg ElmDatatype -> Doc
elmQueryArg arg =
"query_" <>
arg ^. F.queryArgName . F.argName . to (stext . F.unPathSegment)
elmBodyArg :: Doc
elmBodyArg =
"body"
mkArgs
:: ElmOptions
-> F.Req ElmDatatype
-> Doc
mkArgs opts request =
(hsep . concat) $
[
case urlPrefix opts of
Dynamic -> ["urlBase"]
Static _ -> []
,
[ elmHeaderArg header
| header <- request ^. F.reqHeaders
]
,
[ elmCaptureArg segment
| segment <- request ^. F.reqUrl . F.path
, F.isCapture segment
]
,
[ elmQueryArg arg
| arg <- request ^. F.reqUrl . F.queryStr
]
,
maybe [] (const [elmBodyArg]) (request ^. F.reqBody)
]
mkLetParams :: ElmOptions -> F.Req ElmDatatype -> Maybe Doc
mkLetParams opts request =
if null (request ^. F.reqUrl . F.queryStr) then
Nothing
else
Just $ "params =" <$>
indent i ("List.filter (not << String.isEmpty)" <$>
indent i (elmList params))
where
params :: [Doc]
params = map paramToDoc (request ^. F.reqUrl . F.queryStr)
paramToDoc :: F.QueryArg ElmDatatype -> Doc
paramToDoc qarg =
case qarg ^. F.queryArgType of
F.Normal ->
let
toStringSrc =
if isElmStringType opts (qarg ^. F.queryArgName . F.argType) then
""
else
"toString >> "
in
name <$>
indent 4 ("|> Maybe.map" <+> parens (toStringSrc <> "Http.encodeUri >> (++)" <+> dquotes (elmName <> equals)) <$>
"|> Maybe.withDefault" <+> dquotes empty)
F.Flag ->
"if" <+> name <+> "then" <$>
indent 4 (dquotes (name <> equals)) <$>
indent 2 "else" <$>
indent 4 (dquotes empty)
F.List ->
name <$>
indent 4 ("|> List.map" <+> parens (backslash <> "val ->" <+> dquotes (name <> "[]=") <+> "++ (val |> toString |> Http.encodeUri)") <$>
"|> String.join" <+> dquotes "&")
where
name = elmQueryArg qarg
elmName= qarg ^. F.queryArgName . F.argName . to (stext . F.unPathSegment)
mkRequest :: ElmOptions -> F.Req ElmDatatype -> Doc
mkRequest opts request =
"Http.request" <$>
indent i
(elmRecord
[ "method =" <$>
indent i (dquotes method)
, "headers =" <$>
indent i
(elmList headers)
, "url =" <$>
indent i url
, "body =" <$>
indent i body
, "expect =" <$>
indent i expect
, "timeout =" <$>
indent i "Nothing"
, "withCredentials =" <$>
indent i "False"
])
where
method =
request ^. F.reqMethod . to (stext . T.decodeUtf8)
headers =
[("Http.header" <+> dquotes headerName <+>
(if isElmStringType opts (header ^. F.headerArg . F.argType) then
headerArgName
else
parens ("toString " <> headerArgName)
))
| header <- request ^. F.reqHeaders
, headerName <- [header ^. F.headerArg . F.argName . to (stext . F.unPathSegment)]
, headerArgName <- [elmHeaderArg header]
]
url =
mkUrl opts (request ^. F.reqUrl . F.path)
<> mkQueryParams request
body =
case request ^. F.reqBody of
Nothing ->
"Http.emptyBody"
Just elmTypeExpr ->
let
encoderName =
Elm.toElmEncoderRefWith (elmExportOptions opts) elmTypeExpr
in
"Http.jsonBody" <+> parens (stext encoderName <+> elmBodyArg)
expect =
case request ^. F.reqReturnType of
Just elmTypeExpr | isEmptyType opts elmTypeExpr ->
let elmConstructor =
Elm.toElmTypeRefWith (elmExportOptions opts) elmTypeExpr
in
"Http.expectStringResponse" <$>
indent i (parens (backslash <> braces " body " <+> "->" <$>
indent i ("if String.isEmpty body then" <$>
indent i "Ok" <+> stext elmConstructor <$>
"else" <$>
indent i ("Err" <+> dquotes "Expected the response body to be empty")) <> line))
Just elmTypeExpr ->
"Http.expectJson" <+> stext (Elm.toElmDecoderRefWith (elmExportOptions opts) elmTypeExpr)
Nothing ->
error "mkHttpRequest: no reqReturnType?"
mkUrl :: ElmOptions -> [F.Segment ElmDatatype] -> Doc
mkUrl opts segments =
"String.join" <+> dquotes "/" <$>
(indent i . elmList)
( case urlPrefix opts of
Dynamic -> "urlBase"
Static url -> dquotes (stext url)
: map segmentToDoc segments)
where
segmentToDoc :: F.Segment ElmDatatype -> Doc
segmentToDoc s =
case F.unSegment s of
F.Static path ->
dquotes (stext (F.unPathSegment path))
F.Cap arg ->
let
toStringSrc =
if isElmStringType opts (arg ^. F.argType) then
empty
else
" |> toString"
in
(elmCaptureArg s) <> toStringSrc <> " |> Http.encodeUri"
mkQueryParams
:: F.Req ElmDatatype
-> Doc
mkQueryParams request =
if null (request ^. F.reqUrl . F.queryStr) then
empty
else
line <> "++" <+> align ("if List.isEmpty params then" <$>
indent i (dquotes empty) <$>
"else" <$>
indent i (dquotes "?" <+> "++ String.join" <+> dquotes "&" <+> "params"))
isEmptyType :: ElmOptions -> ElmDatatype -> Bool
isEmptyType opts elmTypeExpr =
elmTypeExpr `elem` emptyResponseElmTypes opts
isElmStringType :: ElmOptions -> ElmDatatype -> Bool
isElmStringType opts elmTypeExpr =
elmTypeExpr `elem` stringElmTypes opts
docToText :: Doc -> Text
docToText =
L.toStrict . displayT . renderPretty 0.4 100
stext :: Text -> Doc
stext = text . L.fromStrict
elmRecord :: [Doc] -> Doc
elmRecord = encloseSep (lbrace <> space) (line <> rbrace) (comma <> space)
elmList :: [Doc] -> Doc
elmList [] = lbracket <> rbracket
elmList ds = lbracket <+> hsep (punctuate (line <> comma) ds) <$> rbracket