Generate.hs

{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
module Servant.Elm.Internal.Generate where

import           Prelude                      hiding ((<$>))
import           Control.Lens                 (to, (^.))
import           Data.List                    (intercalate, intersperse, 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           Data.Text.IO                 as TIO

import           Elm.Json (jsonParserForType, jsonSerForType)
import qualified Elm.Module                   as Elm
import           Elm.TyRep (ETCon(..), EType(..), ETypeDef(..), toElmType)
import           Elm.TyRender (renderElm)
import           Elm.Versions (ElmVersion(Elm0p18))

import           Servant.Elm.Internal.Foreign (LangElm, getEndpoints)
import qualified Servant.Foreign              as F
import           System.Directory (createDirectoryIfMissing)
import           Text.PrettyPrint.Leijen.Text


toElmTypeRefWith :: ElmOptions -> EType -> Text
toElmTypeRefWith ElmOptions{..} = T.pack . renderElm . elmTypeAlterations

toElmDecoderRefWith :: ElmOptions -> EType -> Text
toElmDecoderRefWith ElmOptions{..} = T.pack . jsonParserForType . elmTypeAlterations

toElmEncoderRefWith :: ElmOptions -> EType -> Text
toElmEncoderRefWith ElmOptions{..} = T.pack . jsonSerForType . elmTypeAlterations

{-|
Options to configure how code is generated.
-}
data ElmOptions = ElmOptions
  { {- | The protocol, host and any path prefix to be used as the base for all
    requests.

    Example: @Static "https://mydomain.com/api/v1"@

    When @Dynamic@, the generated Elm functions take the base URL as the first
    argument.
    -}
    urlPrefix             :: UrlPrefix
  , elmTypeAlterations        :: (EType -> EType)
    -- ^ Alterations to perform on ETypes before code generation.
  , elmAlterations        :: (ETypeDef -> ETypeDef)
    -- ^ Alterations to perform on ETypeDefs before code generation.
  , elmToString          :: (EType -> Text)
    -- ^ Elm functions creating a string from a given type.
  , emptyResponseElmTypes :: [EType]
    -- ^ Types that represent an empty Http response.
  , stringElmTypes        :: [EType]
    -- ^ Types that represent a String.
  }


data UrlPrefix
  = Static T.Text
  | Dynamic

type Namespace = [String]

{-|
Default options for generating Elm code.

The default options are:

> { urlPrefix =
>     Static ""
> , elmAlterations =
>     Elm.defaultTypeAlterations
> , emptyResponseElmTypes =
>     [ getType (Proxy :: Proxy ()) ]
> , stringElmTypes =
>     [ getType (Proxy :: Proxy String)
>     , getType (Proxy :: Proxy T.Text) ]
> }
-}
defElmOptions :: ElmOptions
defElmOptions = ElmOptions
  { urlPrefix = Static ""
  , elmTypeAlterations = Elm.defaultTypeAlterations
  , elmAlterations = Elm.defaultAlterations
  , elmToString = defaultElmToString
  , emptyResponseElmTypes =
      [ toElmType (Proxy :: Proxy ())
      ]
  , stringElmTypes =
      [ toElmType (Proxy :: Proxy String)
      , toElmType (Proxy :: Proxy T.Text)
      ]
  }


{-|
Default imports required by generated Elm code.

You probably want to include this at the top of your generated Elm module.

The default required imports are:

> import Json.Decode
> import Json.Encode exposing (Value)
> -- The following module comes from bartavelle/json-helpers
> import Json.Helpers exposing (..)
> import Dict exposing (Dict)
> import Set
> import Http
> import String
> import Url.Builder
-}
defElmImports :: Text
defElmImports =
  T.unlines
    [ "import Json.Decode"
    , "import Json.Encode exposing (Value)"
    , "-- The following module comes from bartavelle/json-helpers"
    , "import Json.Helpers exposing (..)"
    , "import Dict exposing (Dict)"
    , "import Set"
    , "import Http"
    , "import String"
    , "import Url.Builder"
    ]

{-|
Helper to generate a complete Elm module given a list of Elm type definitions
and an API.
-}
generateElmModuleWith ::
     ( F.HasForeign LangElm EType api
     , F.GenerateList EType (F.Foreign EType api)
     )
  => ElmOptions
  -> Namespace
  -> Text
  -> FilePath
  -> [Elm.DefineElm]
  -> Proxy api
  -> IO ()
generateElmModuleWith options namespace imports rootDir typeDefs api = do
  let out =
        T.unlines $
        [ T.pack $ Elm.moduleHeader Elm0p18 moduleName
        , ""
        , imports
        , T.pack $ Elm.makeModuleContentWithAlterations (elmAlterations options) typeDefs
        ] ++
        generateElmForAPIWith options api
      moduleName = intercalate "." namespace
      filePath = intercalate "/" $ rootDir:init namespace
      fileName = intercalate "/" $ filePath:[last namespace ++ ".elm"]
  createDirectoryIfMissing True filePath
  TIO.writeFile fileName out

{-|
Calls generateElmModuleWith with @defElmOptions@.
-}
generateElmModule ::
     ( F.HasForeign LangElm EType api
     , F.GenerateList EType (F.Foreign EType api)
     )
  => Namespace
  -> Text
  -> FilePath
  -> [Elm.DefineElm]
  -> Proxy api
  -> IO ()
generateElmModule namespace imports filePath typeDefs api =
  generateElmModuleWith defElmOptions namespace imports filePath typeDefs api

{-|
Generate Elm code for the API with default options.

Returns a list of Elm functions to query your Servant API from Elm.

You could spit these out to a file and call them from your Elm code, but you
would be better off creating a 'Spec' with the result and using 'specsToDir',
which handles the module name for you.
-}
generateElmForAPI
  :: ( F.HasForeign LangElm EType api
     , F.GenerateList EType (F.Foreign EType api))
  => Proxy api
  -> [Text]
generateElmForAPI =
  generateElmForAPIWith defElmOptions


{-|
Generate Elm code for the API with custom options.
-}
generateElmForAPIWith
  :: ( F.HasForeign LangElm EType api
     , F.GenerateList EType (F.Foreign EType api))
  => ElmOptions
  -> Proxy api
  -> [Text]
generateElmForAPIWith opts = intersperse "" .
  nub . map docToText . map (generateElmForRequest opts) . getEndpoints

i :: Int
i = 4

{-|
Generate an Elm function for one endpoint.
-}
generateElmForRequest :: ElmOptions -> F.Req EType -> 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 (replace . F.camelCase) . to stext

    replace = T.replace "-" "" . T.replace "." ""

    typeSignature =
      mkTypeSignature opts request

    args =
      mkArgs opts request

    letParams =
      mkLetParams opts request

    elmRequest =
      mkRequest opts request


mkTypeSignature :: ElmOptions -> F.Req EType -> Doc
mkTypeSignature opts request =
  (hsep . punctuate " ->" . concat)
    [ catMaybes [urlPrefixType]
    , headerTypes
    , urlCaptureTypes
    , queryTypes
    , catMaybes [bodyType, toMsgType, returnType]
    ]
  where
    urlPrefixType :: Maybe Doc
    urlPrefixType =
        case (urlPrefix opts) of
          Dynamic -> Just "String"
          Static _ -> Nothing

    elmTypeRef :: EType -> Doc
    elmTypeRef eType =
      stext (toElmTypeRefWith opts eType)

    headerTypes :: [Doc]
    headerTypes =
      [ header ^. F.headerArg . F.argType . to elmTypeRef
      | header <- request ^. F.reqHeaders
      , isNotCookie header
      ]

    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
      | arg <- request ^. F.reqUrl . F.queryStr
      ]

    bodyType :: Maybe Doc
    bodyType =
        fmap elmTypeRef $ request ^. F.reqBody

    toMsgType :: Maybe Doc
    toMsgType = do
      result <- fmap elmTypeRef $ request ^. F.reqReturnType
      Just ("(Result Http.Error " <+> parens result <+> " -> msg)")

    returnType :: Maybe Doc
    returnType = do
      pure ("Cmd msg")


elmHeaderArg :: F.HeaderArg EType -> Doc
elmHeaderArg header =
  "header_" <>
  header ^. F.headerArg . F.argName . to (stext . T.replace "-" "_" . F.unPathSegment)


elmCaptureArg :: F.Segment EType -> Doc
elmCaptureArg segment =
  "capture_" <>
  F.captureArg segment ^. F.argName . to (stext . replace . F.unPathSegment)
  where
    replace = T.replace "-" "_"


elmQueryArg :: F.QueryArg EType -> Doc
elmQueryArg arg =
  "query_" <>
  arg ^. F.queryArgName . F.argName . to (stext . replace . F.unPathSegment)
  where
    replace = T.replace "-" "_"


elmBodyArg :: Doc
elmBodyArg =
  "body"


isNotCookie :: F.HeaderArg f -> Bool
isNotCookie header =
   header
     ^. F.headerArg
      . F.argName
      . to ((/= "cookie") . T.toLower . F.unPathSegment)


mkArgs
  :: ElmOptions
  -> F.Req EType
  -> Doc
mkArgs opts request =
  (hsep . concat) $
    [ -- Dynamic url prefix
      case urlPrefix opts of
        Dynamic -> ["urlBase"]
        Static _ -> []
    , -- Headers
      [ elmHeaderArg header
      | header <- request ^. F.reqHeaders
      , isNotCookie header
      ]
    , -- URL Captures
      [ elmCaptureArg segment
      | segment <- request ^. F.reqUrl . F.path
      , F.isCapture segment
      ]
    , -- Query params
      [ elmQueryArg arg
      | arg <- request ^. F.reqUrl . F.queryStr
      ]
    , -- Request body
      maybe [] (const [elmBodyArg]) (request ^. F.reqBody)
    , pure "toMsg"
    ]


mkLetParams :: ElmOptions -> F.Req EType -> Maybe Doc
mkLetParams opts request =
    Just $ "params =" <$>
           indent i ("List.filterMap identity" <$>
                      parens ("List.concat" <$>
                              indent i (elmList params)))
  where
    params :: [Doc]
    params = map paramToDoc (request ^. F.reqUrl . F.queryStr)

    paramToDoc :: F.QueryArg EType -> Doc
    paramToDoc qarg =
      -- something wrong with indentation here...
      case qarg ^. F.queryArgType of
        F.Normal ->
          let
            argType = qarg ^. F.queryArgName . F.argType
            wrapped = isElmMaybeType argType
            toStringSrc =
              toString opts (maybeOf argType)
          in
              "[" <+> (if wrapped then elmName else "Just" <+> elmName) <> line <>
                (indent 4 ("|> Maybe.map" <+> composeRight [toStringSrc, "Url.Builder.string" <+> dquotes name]))
                <+> "]"
              -- (if wrapped then name else "Just" <+> name) <$>
              -- indent 4 ("|> Maybe.map" <+> parens (toStringSrc <> "Http.encodeUri >> (++)" <+> dquotes (elmName <> equals)) <$>
              --           "|> Maybe.withDefault" <+> dquotes empty)

        F.Flag ->
            "[" <+>
            ("if" <+> elmName <+> "then" <$>
            indent 4 ("Just" <+> parens ("Url.Builder.string" <+> dquotes name <+> dquotes empty)) <$>
            indent 2 "else" <$>
            indent 4 "Nothing")
            <+> "]"

        F.List ->
            let
              argType = qarg ^. F.queryArgName . F.argType
              toStringSrc =
                toString opts (listOf (maybeOf argType))
            in
            elmName <$>
            indent 4 ("|> List.map"
                      <+> composeRight
                        [ toStringSrc
                        , "Url.Builder.string" <+> dquotes (name <> "[]")
                        , "Just"
                        ]
                      )
                        
      where
        elmName = elmQueryArg qarg
        name = qarg ^. F.queryArgName . F.argName . to (stext . F.unPathSegment)


mkRequest :: ElmOptions -> F.Req EType -> Doc
mkRequest opts request =
  "Http.request" <$>
  indent i
    (elmRecord
       [ "method =" <$>
         indent i (dquotes method)
       , "headers =" <$>
         indent i
           (elmListOfMaybes headers)
       , "url =" <$>
         indent i url
       , "body =" <$>
         indent i body
       , "expect =" <$>
         indent i expect
       , "timeout =" <$>
         indent i "Nothing"
       , "tracker =" <$>
         indent i "Nothing"
       ])
  where
    method =
       request ^. F.reqMethod . to (stext . T.decodeUtf8)

    mkHeader header =
      let headerName = header ^. F.headerArg . F.argName . to (stext . F.unPathSegment)
          headerArgName = elmHeaderArg header
          argType = header ^. F.headerArg . F.argType
          wrapped = isElmMaybeType argType
          toStringSrc = toString opts (maybeOf argType)
      in
        "Maybe.map" <+> composeLeft ["Http.header" <+> dquotes headerName, toStringSrc]
        <+>
        (if wrapped then headerArgName else parens ("Just" <+> headerArgName))

    headers =
      [ 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 ->
          "Http.emptyBody"

        Just elmTypeExpr ->
          let
            encoderName =
              toElmEncoderRefWith opts elmTypeExpr
          in
            "Http.jsonBody" <+> parens (stext encoderName <+> elmBodyArg)

    expect =
      case request ^. F.reqReturnType of
        Just elmTypeExpr
          | isEmptyType opts elmTypeExpr
            -- let elmConstructor = T.pack (renderElm elmTypeExpr)
           ->
            "Http.expectString " <> line <+> indent i "(\\x -> case x of" <> line <+>
            indent i "Err e -> toMsg (Err e)" <> line <+>
            indent i "Ok _ -> toMsg (Ok ()))"
        Just elmTypeExpr ->
          "Http.expectJson toMsg" <+> renderDecoderName elmTypeExpr
        Nothing -> error "mkHttpRequest: no reqReturnType?"
      -- case request ^. F.reqReturnType of
      --   Just elmTypeExpr | isEmptyType opts elmTypeExpr ->
      --     let elmConstructor =
      --           toElmTypeRefWith opts elmTypeExpr
      --     in
      --       "Http.expectStringResponse" <$>
      --       indent i (parens (backslash <> " rsp " <+> "->" <$>
      --                         indent i ("if String.isEmpty rsp.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 (toElmDecoderRefWith opts elmTypeExpr)

      --   Nothing ->
      --     error "mkHttpRequest: no reqReturnType?"

renderDecoderName :: EType -> Doc
renderDecoderName elmTypeExpr =
  case elmTypeExpr of
    ETyApp (ETyCon (ETCon "List")) t ->
      parens ("Json.Decode.list " <> parens (renderDecoderName t))
    ETyApp (ETyCon (ETCon "Maybe")) t ->
      parens ("Json.Decode.maybe " <> parens (renderDecoderName t))
    ETyCon (ETCon "Int") -> "Json.Decode.int"
    ETyCon (ETCon "String") -> "Json.Decode.string"
    _ -> ("jsonDec" <> stext (T.pack (renderElm elmTypeExpr)))


mkUrl :: ElmOptions -> [F.Segment EType] -> Doc
mkUrl opts segments =
  urlBuilder <$>
    (indent i . elmList)
    ( map segmentToDoc segments)
  -- ( case urlPrefix opts of
  --     Dynamic -> "urlBase"
  --     Static url -> dquotes (stext url)
  --   : map segmentToDoc segments)
  where
    urlBuilder :: Doc
    urlBuilder = case urlPrefix opts of
      Dynamic -> "Url.Builder.crossOrigin urlBase" :: Doc
      Static url -> "Url.Builder.crossOrigin" <+> dquotes (stext url)

    segmentToDoc :: F.Segment EType -> Doc
    segmentToDoc s =
      case F.unSegment s of
        F.Static path ->
          dquotes (stext (F.unPathSegment path))
        F.Cap arg ->
          let
            toStringSrc = 
              toString opts (maybeOf (arg ^. F.argType))
          in
            pipeRight [elmCaptureArg s, toStringSrc]


mkQueryParams
  :: F.Req EType
  -> Doc
mkQueryParams _request =
  -- if null (request ^. F.reqUrl . F.queryStr) then
  --   empty
  -- else
    line <> indent 4 (align "params")


{- | Determines whether we construct an Elm function that expects an empty
response body.
-}
isEmptyType :: ElmOptions -> EType -> Bool
isEmptyType opts elmTypeExpr =
  elmTypeExpr `elem` emptyResponseElmTypes opts


{- | Determines whether we call `toString` on URL captures and query params of
this type in Elm.
-}
isElmStringType :: ElmOptions -> EType -> Bool
isElmStringType opts elmTypeExpr =
  elmTypeExpr `elem` stringElmTypes opts

{- | Determines whether a type is 'Maybe a' where 'a' is something akin to a 'String'.
-}
isElmMaybeStringType :: ElmOptions -> EType -> Bool
isElmMaybeStringType opts (ETyApp (ETyCon (ETCon "Maybe")) elmTypeExpr) = elmTypeExpr `elem` stringElmTypes opts
isElmMaybeStringType _ _ = False

isElmMaybeType :: EType -> Bool
isElmMaybeType (ETyApp (ETyCon (ETCon "Maybe")) _) = True
isElmMaybeType _ = False

isElmListOfMaybeBoolType :: EType -> Bool
isElmListOfMaybeBoolType t =
  case t of
    (ETyApp (ETyCon (ETCon "List")) (ETyApp (ETyCon (ETCon "Maybe")) (ETyCon (ETCon "Bool")))) -> True
    _ -> False

-- Doc helpers


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

elmListOfMaybes :: [Doc] -> Doc
elmListOfMaybes [] = lbracket <> rbracket
elmListOfMaybes ds = "List.filterMap identity" <$> indent 4 (elmList ds)

defaultElmToString :: EType -> Text
defaultElmToString argType =
  case argType of
    ETyCon (ETCon "Bool")             -> "(\\value -> if value then \"true\" else \"false\")"
    ETyCon (ETCon "Float")            -> "String.fromFloat"
    ETyCon (ETCon "Char")             -> "String.fromChar"
    ETyApp (ETyCon (ETCon "Maybe")) v -> "(Maybe.map " <> defaultElmToString v <> " >> Maybe.withDefault \"\")"
    _                                 -> "String.fromInt"


maybeOf :: EType -> EType
maybeOf (ETyApp (ETyCon (ETCon "Maybe")) v) = v
maybeOf v = v

listOf :: EType -> EType
listOf (ETyApp (ETyCon (ETCon "List")) v) = v
listOf v = v

toString :: ElmOptions -> EType -> Doc
toString opts argType =
  if isElmStringType opts argType then
    mempty
  else
    stext $ elmToString opts argType

pipeLeft :: [Doc] -> Doc
pipeLeft =
  encloseSep lparen rparen " <| " . filter (not . isEmpty)

pipeRight :: [Doc] -> Doc
pipeRight =
  encloseSep lparen rparen " |> " . filter (not . isEmpty)

composeLeft :: [Doc] -> Doc
composeLeft =
  encloseSep lparen rparen " << " . filter (not . isEmpty)

composeRight :: [Doc] -> Doc
composeRight =
  encloseSep lparen rparen " >> " . filter (not . isEmpty)