{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
module Servant.Reason.Internal.Generate where
import Prelude hiding ((<$>))
import Control.Lens (to, (^.))
import Data.Int (Int32)
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 Reason (ReasonDatatype(..), ReasonPrimitive(..))
import qualified Reason
import Servant.API (NoContent (..))
import Servant.Reason.Internal.Foreign (LangReason, getEndpoints)
import Servant.Reason.Internal.Orphans ()
import qualified Servant.Foreign as F
import Text.PrettyPrint.Leijen.Text
data ReasonOptions = ReasonOptions
{
urlPrefix :: UrlPrefix
, reasonExportOptions :: Reason.Options
, emptyResponseReasonTypes :: [ReasonDatatype]
, stringReasonTypes :: [ReasonDatatype]
, intReasonTypes :: [ReasonDatatype]
, floatReasonTypes :: [ReasonDatatype]
, boolReasonTypes :: [ReasonDatatype]
, charReasonTypes :: [ReasonDatatype]
}
data UrlPrefix
= Static T.Text
| Dynamic
defReasonOptions :: ReasonOptions
defReasonOptions = ReasonOptions
{ urlPrefix = Static ""
, reasonExportOptions = Reason.defaultOptions
, emptyResponseReasonTypes =
[ Reason.toReasonType NoContent
, Reason.toReasonType ()
]
, stringReasonTypes =
[ Reason.toReasonType ("" :: String)
, Reason.toReasonType ("" :: T.Text)
]
, intReasonTypes =
[ Reason.toReasonType (0 :: Int)
, Reason.toReasonType (0 :: Int32)
]
, floatReasonTypes =
[ Reason.toReasonType (0 :: Float) ]
, boolReasonTypes =
[ Reason.toReasonType (False :: Bool) ]
, charReasonTypes =
[ Reason.toReasonType (' ' :: Char) ]
}
defReasonImports :: Text
defReasonImports = T.unlines []
generateReasonForAPI
:: ( F.HasForeign LangReason ReasonDatatype api
, F.GenerateList ReasonDatatype (F.Foreign ReasonDatatype api))
=> Proxy api
-> [Text]
generateReasonForAPI =
generateReasonForAPIWith defReasonOptions
generateReasonForAPIWith
:: ( F.HasForeign LangReason ReasonDatatype api
, F.GenerateList ReasonDatatype (F.Foreign ReasonDatatype api))
=> ReasonOptions
-> Proxy api
-> [Text]
generateReasonForAPIWith opts =
nub . map docToText . map (generateReasonForRequest opts) . getEndpoints
i :: Int
i = 4
generateReasonForRequest :: ReasonOptions -> F.Req ReasonDatatype -> Doc
generateReasonForRequest opts request =
funcDef
where
funcDef =
vsep
[
"let" <+> fnName <+> "=" <+> args <+> "=> {"
, case letParams of
Just params ->
indent i
(vsep ["let"
, indent i params <> ";"
, indent i reasonRequest
])
Nothing ->
indent i reasonRequest
, "}"
]
fnName =
request ^. F.reqFuncName . to (T.replace "-" "" . F.camelCase) . to stext
typeSignature =
mkTypeSignature opts request
args =
mkArgs opts request
letParams =
mkLetParams opts request
reasonRequest =
mkRequest opts request
mkTypeSignature :: ReasonOptions -> F.Req ReasonDatatype -> 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
reasonTypeRef :: ReasonDatatype -> Doc
reasonTypeRef eType =
stext (Reason.toReasonTypeRefWith (reasonExportOptions opts) eType)
headerTypes :: [Doc]
headerTypes =
[ header ^. F.headerArg . F.argType . to reasonTypeRef
| header <- request ^. F.reqHeaders
, isNotCookie header
]
urlCaptureTypes :: [Doc]
urlCaptureTypes =
[ F.captureArg capture ^. F.argType . to reasonTypeRef
| capture <- request ^. F.reqUrl . F.path
, F.isCapture capture
]
queryTypes :: [Doc]
queryTypes =
[ arg ^. F.queryArgName . F.argType . to reasonTypeRef
| arg <- request ^. F.reqUrl . F.queryStr
]
bodyType :: Maybe Doc
bodyType =
fmap reasonTypeRef $ request ^. F.reqBody
returnType :: Maybe Doc
returnType = do
result <- fmap reasonTypeRef $ request ^. F.reqReturnType
pure ("Http.Request" <+> parens result)
reasonHeaderArg :: F.HeaderArg ReasonDatatype -> Doc
reasonHeaderArg header =
"header_" <>
header ^. F.headerArg . F.argName . to (stext . T.replace "-" "_" . F.unPathSegment)
reasonCaptureArg :: F.Segment ReasonDatatype -> Doc
reasonCaptureArg segment =
"capture_" <>
F.captureArg segment ^. F.argName . to (stext . F.unPathSegment)
reasonQueryArg :: F.QueryArg ReasonDatatype -> Doc
reasonQueryArg arg =
"query_" <>
arg ^. F.queryArgName . F.argName . to (stext . F.unPathSegment)
reasonBodyArg :: Doc
reasonBodyArg =
"body"
isNotCookie :: F.HeaderArg f -> Bool
isNotCookie header =
header
^. F.headerArg
. F.argName
. to ((/= "cookie") . T.toLower . F.unPathSegment)
mkArgs
:: ReasonOptions
-> F.Req ReasonDatatype
-> Doc
mkArgs opts request =
(tupled . concat) $
[
case urlPrefix opts of
Dynamic -> ["urlBase"]
Static _ -> []
,
[ reasonHeaderArg header
| header <- request ^. F.reqHeaders
, isNotCookie header
]
,
[ reasonCaptureArg segment
| segment <- request ^. F.reqUrl . F.path
, F.isCapture segment
]
,
[ reasonQueryArg arg
| arg <- request ^. F.reqUrl . F.queryStr
]
,
maybe [] (const [reasonBodyArg]) (request ^. F.reqBody)
]
mkLetParams :: ReasonOptions -> F.Req ReasonDatatype -> Maybe Doc
mkLetParams opts request =
if null (request ^. F.reqUrl . F.queryStr) then
Nothing
else
Just $ "params =" <$>
indent i ("List.filter" <> tupled ["((x) => (String.length(x) > 0))", reasonList params])
where
params :: [Doc]
params = map paramToDoc (request ^. F.reqUrl . F.queryStr)
paramToDoc :: F.QueryArg ReasonDatatype -> Doc
paramToDoc qarg =
case qarg ^. F.queryArgType of
F.Normal ->
let
toStringSrc' = toStringSrc opts (qarg ^. F.queryArgName . F.argType)
in
reasonName
<$$> indent 2 ("|>" <+> toStringSrc'
<$$> "|> Js_global.encodeURIComponent"
<$$> "|>" <+> "((x__) => if(String.length(x__) > 0) { "
<> dquotes (reasonName <> equals)
<+> "++ x__ } else {\"\"})")
F.Flag ->
"if" <> parens reasonName <+> braces (dquotes (name <> equals)) <+> "else" <+> braces (dquotes empty)
F.List ->
"String.concat" <> tupled [dquotes "&"
,"List.map((x) => "
<> dquotes (name <> "[]=")
<> " ++ Js_global.encodeURIComponent(" <> toStringSrc opts (qarg ^. F.queryArgName . F.argType) <> "(x)), " <> reasonName <> ")"]
where
reasonName = reasonQueryArg qarg
name = qarg ^. F.queryArgName . F.argName . to (stext . F.unPathSegment)
mkRequest :: ReasonOptions -> F.Req ReasonDatatype -> Doc
mkRequest opts request =
"Js.Promise." <> parens (
line <> indent i
("Fetch.fetchWithInit" <>
tupled [url
,"Fetch.RequestInit.make" <>
tupled (catMaybes [Just $ "~method_=" <> method
,case headers of
[] -> Nothing
_ -> Just $ "~headers="
<$$> indent 2 "Fetch.HeadersInit.makeWithDict("
<$$> indent 3 ("Js.Dict.fromList(")
<$$> indent 4 (reasonListOfMaybes headers) <> "))"
,case body of
Nothing -> Nothing
Just b -> Just $ "~body=" <> b
,Just $ "()"])])
<$$> "|> then_" <> parens ("Fetch.Response." <> expectResponse)
<$$> "|> then_" <> parens ("response => (response |>" <+> expectDecoder <> ")"))
where
method =
request ^. F.reqMethod . to (stext . T.toTitle . T.decodeUtf8)
mkHeader header =
let headerName = header ^. F.headerArg . F.argName . to (stext . F.unPathSegment)
headerArgName = reasonHeaderArg header
argType = header ^. F.headerArg . F.argType
wrapped = isReasonMaybeType argType
toStringSrc' = toStringSrc opts (case argType of
(ReasonPrimitive (ROption t)) -> t
x -> x)
in
"Belt.Option.map" <> parens ((if wrapped then headerArgName else parens ("Some" <> parens headerArgName))
<> ", x => " <> parens (dquotes headerName <> ", x |>" <+> toStringSrc'))
headers =
(case (request ^. F.reqBody, request ^. F.reqBodyContentType) of
(Just _, F.ReqBodyJSON) ->
["Some" <> parens (parens ("\"Content-Type\"" <> comma <> stext "\"application/json\""))]
_ -> [])
++
[ mkHeader header
| header <- request ^. F.reqHeaders
, isNotCookie header
]
url =
mkUrl opts (request ^. F.reqUrl . F.path)
<> mkQueryParams request
body =
case request ^. F.reqBody of
Nothing -> Nothing
Just reasonTypeExpr ->
let encoderName = Reason.toReasonEncoderRefWith (reasonExportOptions opts) reasonTypeExpr
in Just $ "Fetch.BodyInit.make" <> parens ("Js.Json.stringify" <> parens (stext encoderName <> parens reasonBodyArg))
expectResponse =
case request ^. F.reqReturnType of
Just reasonTypeExpr | isEmptyType opts reasonTypeExpr ->
"text"
Just reasonTypeExpr ->
"json"
Nothing ->
error "mkHttpRequest: no reqReturnType?"
expectDecoder =
case request ^. F.reqReturnType of
Just reasonTypeExpr | isEmptyType opts reasonTypeExpr ->
"((x) => if(String.length(x) != 0) { resolve(Belt_Result.Error(\"Expected the response body to empty\")) } else { resolve(Belt_Result.Ok(x)) })"
Just reasonTypeExpr ->
stext (Reason.toReasonDecoderRefWith (reasonExportOptions opts) reasonTypeExpr) <+> "|> ((x) => Belt_Result.Ok(x)) |> resolve"
Nothing -> error "mkHttpRequest: no reqReturnType?"
mkUrl :: ReasonOptions -> [F.Segment ReasonDatatype] -> Doc
mkUrl opts segments =
"String.concat" <> tupled [dquotes "/",
(reasonList)
( case urlPrefix opts of
Dynamic -> "urlBase"
Static url -> dquotes (stext url)
: map segmentToDoc segments)]
where
segmentToDoc :: F.Segment ReasonDatatype -> Doc
segmentToDoc s =
case F.unSegment s of
F.Static path ->
dquotes (stext (F.unPathSegment path))
F.Cap arg ->
let
toStringSrc' = toStringSrc opts (arg ^. F.argType)
in
(reasonCaptureArg s) <+> "|>" <+> toStringSrc' <+> "|>" <+> "Js_global.encodeURIComponent"
mkQueryParams
:: F.Req ReasonDatatype
-> Doc
mkQueryParams request =
if null (request ^. F.reqUrl . F.queryStr) then
empty
else
line <> "++" <+> align ("if(List.length(params)==0)" <+> braces (dquotes empty)
<+> "else" <+> braces (dquotes "?" <+> "++ String.concat" <> tupled [dquotes "&", "params"]))
isEmptyType :: ReasonOptions -> ReasonDatatype -> Bool
isEmptyType opts reasonTypeExpr =
reasonTypeExpr `elem` emptyResponseReasonTypes opts
toStringSrc :: ReasonOptions -> ReasonDatatype -> Doc
toStringSrc opts argType
| isReasonStringType opts argType = stext "((x) => x)"
| otherwise = toStringSrcTypes opts argType
toStringSrcTypes :: ReasonOptions -> ReasonDatatype -> Doc
toStringSrcTypes opts (ReasonPrimitive (ROption argType)) =
"((x) => Belt.Option.mapWithDefault(x, \"\", " <> toStringSrcTypes opts argType <> "))"
toStringSrcTypes _ (ReasonPrimitive (RList (ReasonPrimitive RChar))) = "((x) => x)"
toStringSrcTypes opts (ReasonPrimitive (RList argType)) = toStringSrcTypes opts argType
toStringSrcTypes opts argType
| isReasonStringType opts argType = "((x) => x)"
| isReasonIntType opts argType = "string_of_int"
| isReasonFloatType opts argType = "string_of_float"
| isReasonBoolType opts argType = "string_of_bool"
| isReasonCharType opts argType = "string_of_char"
| otherwise = error $ "Sorry, we don't support other types than `String`, `Int`, `Float`, `Bool`, and `Char` right now. " <> show argType
isReasonStringType :: ReasonOptions -> ReasonDatatype -> Bool
isReasonStringType opts reasonTypeExpr =
reasonTypeExpr `elem` stringReasonTypes opts
isReasonIntType :: ReasonOptions -> ReasonDatatype -> Bool
isReasonIntType opts reasonTypeExpr =
reasonTypeExpr `elem` intReasonTypes opts
isReasonFloatType :: ReasonOptions -> ReasonDatatype -> Bool
isReasonFloatType opts reasonTypeExpr =
reasonTypeExpr `elem` floatReasonTypes opts
isReasonBoolType :: ReasonOptions -> ReasonDatatype -> Bool
isReasonBoolType opts reasonTypeExpr =
reasonTypeExpr `elem` boolReasonTypes opts
isReasonCharType :: ReasonOptions -> ReasonDatatype -> Bool
isReasonCharType opts reasonTypeExpr =
reasonTypeExpr `elem` charReasonTypes opts
isReasonMaybeStringType :: ReasonOptions -> ReasonDatatype -> Bool
isReasonMaybeStringType opts (ReasonPrimitive (ROption reasonTypeExpr)) = reasonTypeExpr `elem` stringReasonTypes opts
isReasonMaybeStringType _ _ = False
isReasonMaybeType :: ReasonDatatype -> Bool
isReasonMaybeType (ReasonPrimitive (ROption _)) = True
isReasonMaybeType _ = False
docToText :: Doc -> Text
docToText =
L.toStrict . displayT . renderPretty 0.4 100
stext :: Text -> Doc
stext = text . L.fromStrict
reasonRecord :: [Doc] -> Doc
reasonRecord = encloseSep (lbrace <> space) (line <> rbrace) (comma <> space)
reasonList :: [Doc] -> Doc
reasonList [] = lbracket <> rbracket
reasonList ds = lbracket <+> hsep (punctuate (line <> comma) ds) <$> rbracket
reasonListOfMaybes :: [Doc] -> Doc
reasonListOfMaybes [] = lbracket <> rbracket
reasonListOfMaybes ds = "Belt.List.keepMap" <> parens (line <> reasonList ds <> ", x => x")