{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}

module Data.JsonSpec.Elm.Servant (
  -- * Generating Elm Clients
  servantDefs,
  generateElm,

  -- * Extensions
  {-|
    The symbols in this section are mainly exposed in case you are using
    some extensions to the standard servant types and need to build some
    companion extensions to generate proper Elm types for them. For most
    normal usage you will probably just use 'generateElm' (or possibly
    'servantDefs').
  -}
  Elmable(..),
  IsParam(..),
  Param(..),
  PathParam(..),
  HeaderParam(..),
  QP(..),
) where


import Bound (Var(B, F), Scope, abstract1, closed, toScope)
import Control.Monad.Writer (MonadTrans(lift), MonadWriter(tell), execWriter)
import Data.Foldable (Foldable(fold), traverse_)
import Data.HashMap.Strict (HashMap)
import Data.JsonSpec
  ( HasJsonDecodingSpec(DecodingSpec), HasJsonEncodingSpec(EncodingSpec)
  )
import Data.JsonSpec.Elm (HasType(decoderOf, encoderOf, typeOf), Definitions)
import Data.List (drop, foldl', init, unlines)
import Data.Maybe (fromJust, fromMaybe, mapMaybe)
import Data.Proxy (Proxy(Proxy))
import Data.Set (Set)
import Data.String (IsString(fromString))
import Data.Text (Text)
import Data.Void (Void, absurd)
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
import Language.Elm.Definition (Definition)
import Language.Elm.Expression ((<|), Expression)
import Language.Elm.Name (Module)
import Language.Elm.Pretty (modules)
import Language.Elm.Type (Type)
import Network.HTTP.Types (Method)
import Prelude
  ( Applicative(pure), Bool(False, True), Eq((==)), Foldable(foldr, length)
  , Functor(fmap), Maybe(Just, Nothing), Monad((>>=)), Monoid(mconcat)
  , Semigroup((<>)), Show(show), Traversable(sequence, traverse), ($), (.)
  , (<$>), IO, Int, String, error, putStrLn, reverse
  )
import Prettyprinter (defaultLayoutOptions, layoutPretty)
import Prettyprinter.Render.Text (renderStrict)
import Servant.API
  ( ReflectMethod(reflectMethod), (:<|>), (:>), Capture, Header', Headers, JSON
  , NamedRoutes, NoContent, NoContentVerb, Optional, QueryParam', ReqBody'
  , Required, ToServantApi, Verb
  )
import System.Directory.OsPath
  ( createDirectoryIfMissing, doesDirectoryExist, listDirectory
  )
import System.OsPath ((</>), OsPath, OsString, osp, splitExtension)
import System.Process (readProcess)
import qualified Data.HashMap.Strict as HM
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.Text.Encoding as TE
import qualified Data.Text.IO as TIO
import qualified Language.Elm.Definition as Def
import qualified Language.Elm.Expression as Expr
import qualified Language.Elm.Name as Name
import qualified Language.Elm.Pattern as Pat
import qualified Language.Elm.Type as Type
import qualified System.OsPath as OsPath


{-|
  This function will traverse the @api@ type, generating elm definitions for:

  * Http requests for each endpoint, including encoders and decoders for
    anonymous elm types.

  * Named Elm types (i.e. Any 'Specification' that is bound to a name using
    'JsonLet'

  * Decoders and Encoders for named elm types.

  You can consume the resulting 'Definition's using the
  [elm-syntax:Language.Elm.Pretty](https://hackage.haskell.org/package/elm-syntax-0.3.3.0/docs/Language-Elm-Pretty.html)
  module.
-}
servantDefs :: forall api. (Elmable api) => Proxy api -> Set Definition
servantDefs :: forall {k} (api :: k). Elmable api => Proxy api -> Set Definition
servantDefs Proxy api
_ =
  Set Definition
builtins
  Set Definition -> Set Definition -> Set Definition
forall a. Semigroup a => a -> a -> a
<> Writer (Set Definition) () -> Set Definition
forall w a. Writer w a -> w
execWriter (forall (e :: k). Elmable e => [Param] -> Writer (Set Definition) ()
forall {k} (e :: k).
Elmable e =>
[Param] -> Writer (Set Definition) ()
endpoints @api [])


builtins :: Set Definition
builtins :: Set Definition
builtins =
  [Definition] -> Set Definition
forall a. Ord a => [a] -> Set a
Set.fromList
    [ Qualified -> Int -> Scope Int Type Void -> Definition
Def.Alias
        Qualified
"Api.Req.Request"
        Int
1
        (
          Type (Var Int Void) -> Scope Int Type Void
forall (f :: * -> *) b a. Monad f => f (Var b a) -> Scope b f a
toScope (Type (Var Int Void) -> Scope Int Type Void)
-> Type (Var Int Void) -> Scope Int Type Void
forall a b. (a -> b) -> a -> b
$
            [(Field, Type (Var Int Void))] -> Type (Var Int Void)
forall v. [(Field, Type v)] -> Type v
Type.Record
              [ (Text -> Field
Name.Field Text
"method", Type (Var Int Void)
"Basics.String")
              , (Text -> Field
Name.Field Text
"headers", Type (Var Int Void)
"Basics.List" Type (Var Int Void) -> Type (Var Int Void) -> Type (Var Int Void)
forall v. Type v -> Type v -> Type v
`Type.App` Type (Var Int Void)
"Http.Header")
              , (Text -> Field
Name.Field Text
"url", Type (Var Int Void)
"Basics.String")
              , (Text -> Field
Name.Field Text
"body", Type (Var Int Void)
"Http.Body")
              , ( Text -> Field
Name.Field Text
"decoder"
                , Type (Var Int Void)
"Api.Req.Either"
                    Type (Var Int Void) -> Type (Var Int Void) -> Type (Var Int Void)
forall v. Type v -> Type v -> Type v
`Type.App` Var Int Void -> Type (Var Int Void)
forall v. v -> Type v
Type.Var (Int -> Var Int Void
forall b a. b -> Var b a
B Int
0)
                    Type (Var Int Void) -> Type (Var Int Void) -> Type (Var Int Void)
forall v. Type v -> Type v -> Type v
`Type.App` (Type (Var Int Void)
"Json.Decode.Decoder" Type (Var Int Void) -> Type (Var Int Void) -> Type (Var Int Void)
forall v. Type v -> Type v -> Type v
`Type.App` Var Int Void -> Type (Var Int Void)
forall v. v -> Type v
Type.Var (Int -> Var Int Void
forall b a. b -> Var b a
B Int
0))
                )
              ]
        )
    , Qualified
-> Int -> [(Constructor, [Scope Int Type Void])] -> Definition
Def.Type
        Qualified
"Api.Req.Either"
        Int
2
        [ ( Text -> Constructor
Name.Constructor Text
"Left"
          , [Type (Var Int Void) -> Scope Int Type Void
forall (f :: * -> *) b a. Monad f => f (Var b a) -> Scope b f a
toScope (Var Int Void -> Type (Var Int Void)
forall v. v -> Type v
Type.Var (Int -> Var Int Void
forall b a. b -> Var b a
B Int
0))]
          )
        , ( Text -> Constructor
Name.Constructor Text
"Right"
          , [Type (Var Int Void) -> Scope Int Type Void
forall (f :: * -> *) b a. Monad f => f (Var b a) -> Scope b f a
toScope (Var Int Void -> Type (Var Int Void)
forall v. v -> Type v
Type.Var (Int -> Var Int Void
forall b a. b -> Var b a
B Int
1))]
          )
        ]
    , Qualified
-> Int -> Scope Int Type Void -> Expression Void -> Definition
Def.Constant
        Qualified
"Api.Req.task"
        Int
1
        (
          Type (Var Int Void) -> Scope Int Type Void
forall (f :: * -> *) b a. Monad f => f (Var b a) -> Scope b f a
toScope (Type (Var Int Void) -> Scope Int Type Void)
-> Type (Var Int Void) -> Scope Int Type Void
forall a b. (a -> b) -> a -> b
$
            let
              var :: Type (Bound.Var Int a)
              var :: forall a. Type (Var Int a)
var = Var Int a -> Type (Var Int a)
forall v. v -> Type v
Type.Var (Int -> Var Int a
forall b a. b -> Var b a
B Int
0)
            in
              Type (Var Int Void) -> Type (Var Int Void) -> Type (Var Int Void)
forall v. Type v -> Type v -> Type v
Type.Fun
                (Type (Var Int Void)
"Api.Req.Request" Type (Var Int Void) -> Type (Var Int Void) -> Type (Var Int Void)
forall v. Type v -> Type v -> Type v
`Type.App` Type (Var Int Void)
forall a. Type (Var Int a)
var)
                (Type (Var Int Void) -> [Type (Var Int Void)] -> Type (Var Int Void)
forall v. Type v -> [Type v] -> Type v
Type.apps Type (Var Int Void)
"Task.Task" [Type (Var Int Void)
"Http.Error", Type (Var Int Void)
forall a. Type (Var Int a)
var])
        )
        (
          Scope () Expression Void -> Expression Void
forall v. Scope () Expression v -> Expression v
Expr.Lam (Scope () Expression Void -> Expression Void)
-> (Expression (Var () Void) -> Scope () Expression Void)
-> Expression (Var () Void)
-> Expression Void
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expression (Var () Void) -> Scope () Expression Void
forall (f :: * -> *) b a. Monad f => f (Var b a) -> Scope b f a
toScope (Expression (Var () Void) -> Expression Void)
-> Expression (Var () Void) -> Expression Void
forall a b. (a -> b) -> a -> b
$
            let
              req :: Expression (Bound.Var () a)
              req :: forall a. Expression (Var () a)
req = Var () a -> Expression (Var () a)
forall v. v -> Expression v
Expr.Var (() -> Var () a
forall b a. b -> Var b a
B ())

              f :: Text -> b -> (Name.Field, b)
              f :: forall b. Text -> b -> (Field, b)
f Text
name b
expr = (Text -> Field
Name.Field Text
name, b
expr)

              p :: Expression v -> Text -> Expression v
              p :: forall v. Expression v -> Text -> Expression v
p Expression v
v Text
name = Field -> Expression v
forall v. Field -> Expression v
Expr.Proj (Text -> Field
Name.Field Text
name) Expression v -> Expression v -> Expression v
forall v. Expression v -> Expression v -> Expression v
`Expr.App` Expression v
v
            in
              Expression (Var () Void)
"Http.task" Expression (Var () Void)
-> Expression (Var () Void) -> Expression (Var () Void)
forall v. Expression v -> Expression v -> Expression v
<|
                [(Field, Expression (Var () Void))] -> Expression (Var () Void)
forall v. [(Field, Expression v)] -> Expression v
Expr.Record
                  [ Text
-> Expression (Var () Void) -> (Field, Expression (Var () Void))
forall b. Text -> b -> (Field, b)
f Text
"method"   (Expression (Var () Void) -> (Field, Expression (Var () Void)))
-> Expression (Var () Void) -> (Field, Expression (Var () Void))
forall a b. (a -> b) -> a -> b
$ Expression (Var () Void) -> Text -> Expression (Var () Void)
forall v. Expression v -> Text -> Expression v
p Expression (Var () Void)
forall a. Expression (Var () a)
req Text
"method"
                  , Text
-> Expression (Var () Void) -> (Field, Expression (Var () Void))
forall b. Text -> b -> (Field, b)
f Text
"headers"  (Expression (Var () Void) -> (Field, Expression (Var () Void)))
-> Expression (Var () Void) -> (Field, Expression (Var () Void))
forall a b. (a -> b) -> a -> b
$ Expression (Var () Void) -> Text -> Expression (Var () Void)
forall v. Expression v -> Text -> Expression v
p Expression (Var () Void)
forall a. Expression (Var () a)
req Text
"headers"
                  , Text
-> Expression (Var () Void) -> (Field, Expression (Var () Void))
forall b. Text -> b -> (Field, b)
f Text
"url"      (Expression (Var () Void) -> (Field, Expression (Var () Void)))
-> Expression (Var () Void) -> (Field, Expression (Var () Void))
forall a b. (a -> b) -> a -> b
$ Expression (Var () Void) -> Text -> Expression (Var () Void)
forall v. Expression v -> Text -> Expression v
p Expression (Var () Void)
forall a. Expression (Var () a)
req Text
"url"
                  , Text
-> Expression (Var () Void) -> (Field, Expression (Var () Void))
forall b. Text -> b -> (Field, b)
f Text
"body"     (Expression (Var () Void) -> (Field, Expression (Var () Void)))
-> Expression (Var () Void) -> (Field, Expression (Var () Void))
forall a b. (a -> b) -> a -> b
$ Expression (Var () Void) -> Text -> Expression (Var () Void)
forall v. Expression v -> Text -> Expression v
p Expression (Var () Void)
forall a. Expression (Var () a)
req Text
"body"
                  , Text
-> Expression (Var () Void) -> (Field, Expression (Var () Void))
forall b. Text -> b -> (Field, b)
f Text
"timeout"    Expression (Var () Void)
"Maybe.Nothing"
                  , Text
-> Expression (Var () Void) -> (Field, Expression (Var () Void))
forall b. Text -> b -> (Field, b)
f Text
"resolver" (Expression (Var () Void) -> (Field, Expression (Var () Void)))
-> Expression (Var () Void) -> (Field, Expression (Var () Void))
forall a b. (a -> b) -> a -> b
$
                      Expression (Var () Void)
"Http.stringResolver" Expression (Var () Void)
-> Expression (Var () Void) -> Expression (Var () Void)
forall v. Expression v -> Expression v -> Expression v
`Expr.App`
                        (
                          Scope () Expression (Var () Void) -> Expression (Var () Void)
forall v. Scope () Expression v -> Expression v
Expr.Lam (Scope () Expression (Var () Void) -> Expression (Var () Void))
-> (Expression (Var () (Var () Void))
    -> Scope () Expression (Var () Void))
-> Expression (Var () (Var () Void))
-> Expression (Var () Void)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expression (Var () (Var () Void))
-> Scope () Expression (Var () Void)
forall (f :: * -> *) b a. Monad f => f (Var b a) -> Scope b f a
toScope (Expression (Var () (Var () Void)) -> Expression (Var () Void))
-> Expression (Var () (Var () Void)) -> Expression (Var () Void)
forall a b. (a -> b) -> a -> b
$
                            let
                              var :: Expression (Bound.Var () a)
                              var :: forall a. Expression (Var () a)
var = Var () a -> Expression (Var () a)
forall v. v -> Expression v
Expr.Var (() -> Var () a
forall b a. b -> Var b a
B ())

                              pat
                                :: Name.Qualified
                                -> [Pat.Pattern v]
                                -> Expression (Bound.Var b a)
                                -> (Pat.Pattern v, Scope b Expression a)
                              pat :: forall v b a.
Qualified
-> [Pattern v]
-> Expression (Var b a)
-> (Pattern v, Scope b Expression a)
pat Qualified
con [Pattern v]
vars Expression (Var b a)
expr =
                                (Qualified -> [Pattern v] -> Pattern v
forall v. Qualified -> [Pattern v] -> Pattern v
Pat.Con Qualified
con [Pattern v]
vars, Expression (Var b a) -> Scope b Expression a
forall (f :: * -> *) b a. Monad f => f (Var b a) -> Scope b f a
toScope Expression (Var b a)
expr)

                              patVar :: Int -> Expression (Bound.Var Int a)
                              patVar :: forall a. Int -> Expression (Var Int a)
patVar Int
n = Var Int a -> Expression (Var Int a)
forall v. v -> Expression v
Expr.Var (Int -> Var Int a
forall b a. b -> Var b a
B Int
n)
                            in
                              Expression (Var () (Var () Void))
-> [(Pattern Int, Scope Int Expression (Var () (Var () Void)))]
-> Expression (Var () (Var () Void))
forall v.
Expression v
-> [(Pattern Int, Scope Int Expression v)] -> Expression v
Expr.Case
                                Expression (Var () (Var () Void))
forall a. Expression (Var () a)
var
                                [ Qualified
-> [Pattern Int]
-> Expression (Var Int (Var () (Var () Void)))
-> (Pattern Int, Scope Int Expression (Var () (Var () Void)))
forall v b a.
Qualified
-> [Pattern v]
-> Expression (Var b a)
-> (Pattern v, Scope b Expression a)
pat Qualified
"Http.BadUrl_" [Int -> Pattern Int
forall v. v -> Pattern v
Pat.Var Int
0] (Expression (Var Int (Var () (Var () Void)))
 -> (Pattern Int, Scope Int Expression (Var () (Var () Void))))
-> Expression (Var Int (Var () (Var () Void)))
-> (Pattern Int, Scope Int Expression (Var () (Var () Void)))
forall a b. (a -> b) -> a -> b
$
                                    Expression (Var Int (Var () (Var () Void)))
"Result.Err" Expression (Var Int (Var () (Var () Void)))
-> Expression (Var Int (Var () (Var () Void)))
-> Expression (Var Int (Var () (Var () Void)))
forall v. Expression v -> Expression v -> Expression v
`Expr.App`
                                      (Expression (Var Int (Var () (Var () Void)))
"Http.BadUrl" Expression (Var Int (Var () (Var () Void)))
-> Expression (Var Int (Var () (Var () Void)))
-> Expression (Var Int (Var () (Var () Void)))
forall v. Expression v -> Expression v -> Expression v
`Expr.App` Int -> Expression (Var Int (Var () (Var () Void)))
forall a. Int -> Expression (Var Int a)
patVar Int
0)
                                , Qualified
-> [Pattern Int]
-> Expression (Var Int (Var () (Var () Void)))
-> (Pattern Int, Scope Int Expression (Var () (Var () Void)))
forall v b a.
Qualified
-> [Pattern v]
-> Expression (Var b a)
-> (Pattern v, Scope b Expression a)
pat Qualified
"Http.Timeout_" [] (Expression (Var Int (Var () (Var () Void)))
 -> (Pattern Int, Scope Int Expression (Var () (Var () Void))))
-> Expression (Var Int (Var () (Var () Void)))
-> (Pattern Int, Scope Int Expression (Var () (Var () Void)))
forall a b. (a -> b) -> a -> b
$
                                    Expression (Var Int (Var () (Var () Void)))
"Result.Err" Expression (Var Int (Var () (Var () Void)))
-> Expression (Var Int (Var () (Var () Void)))
-> Expression (Var Int (Var () (Var () Void)))
forall v. Expression v -> Expression v -> Expression v
`Expr.App` Expression (Var Int (Var () (Var () Void)))
"Http.Timeout"
                                , Qualified
-> [Pattern Int]
-> Expression (Var Int (Var () (Var () Void)))
-> (Pattern Int, Scope Int Expression (Var () (Var () Void)))
forall v b a.
Qualified
-> [Pattern v]
-> Expression (Var b a)
-> (Pattern v, Scope b Expression a)
pat Qualified
"Http.NetworkError_" [] (Expression (Var Int (Var () (Var () Void)))
 -> (Pattern Int, Scope Int Expression (Var () (Var () Void))))
-> Expression (Var Int (Var () (Var () Void)))
-> (Pattern Int, Scope Int Expression (Var () (Var () Void)))
forall a b. (a -> b) -> a -> b
$
                                    Expression (Var Int (Var () (Var () Void)))
"Result.Err" Expression (Var Int (Var () (Var () Void)))
-> Expression (Var Int (Var () (Var () Void)))
-> Expression (Var Int (Var () (Var () Void)))
forall v. Expression v -> Expression v -> Expression v
`Expr.App` Expression (Var Int (Var () (Var () Void)))
"Http.NetworkError"
                                , Qualified
-> [Pattern Int]
-> Expression (Var Int (Var () (Var () Void)))
-> (Pattern Int, Scope Int Expression (Var () (Var () Void)))
forall v b a.
Qualified
-> [Pattern v]
-> Expression (Var b a)
-> (Pattern v, Scope b Expression a)
pat Qualified
"Http.BadStatus_" [Int -> Pattern Int
forall v. v -> Pattern v
Pat.Var Int
0, Int -> Pattern Int
forall v. v -> Pattern v
Pat.Var Int
1] (Expression (Var Int (Var () (Var () Void)))
 -> (Pattern Int, Scope Int Expression (Var () (Var () Void))))
-> Expression (Var Int (Var () (Var () Void)))
-> (Pattern Int, Scope Int Expression (Var () (Var () Void)))
forall a b. (a -> b) -> a -> b
$
                                    Expression (Var Int (Var () (Var () Void)))
"Result.Err" Expression (Var Int (Var () (Var () Void)))
-> Expression (Var Int (Var () (Var () Void)))
-> Expression (Var Int (Var () (Var () Void)))
forall v. Expression v -> Expression v -> Expression v
`Expr.App`
                                      (
                                        Expression (Var Int (Var () (Var () Void)))
"Http.BadStatus" Expression (Var Int (Var () (Var () Void)))
-> Expression (Var Int (Var () (Var () Void)))
-> Expression (Var Int (Var () (Var () Void)))
forall v. Expression v -> Expression v -> Expression v
`Expr.App`
                                          Expression (Var Int (Var () (Var () Void)))
-> Text -> Expression (Var Int (Var () (Var () Void)))
forall v. Expression v -> Text -> Expression v
p (Int -> Expression (Var Int (Var () (Var () Void)))
forall a. Int -> Expression (Var Int a)
patVar Int
0) Text
"statusCode"
                                      )
                                , Qualified
-> [Pattern Int]
-> Expression (Var Int (Var () (Var () Void)))
-> (Pattern Int, Scope Int Expression (Var () (Var () Void)))
forall v b a.
Qualified
-> [Pattern v]
-> Expression (Var b a)
-> (Pattern v, Scope b Expression a)
pat
                                    Qualified
"Http.GoodStatus_"
                                    [Int -> Pattern Int
forall v. v -> Pattern v
Pat.Var Int
0, Int -> Pattern Int
forall v. v -> Pattern v
Pat.Var Int
1]
                                    (
                                      Expression (Var Int (Var () (Var () Void)))
-> [(Pattern Int,
     Scope Int Expression (Var Int (Var () (Var () Void))))]
-> Expression (Var Int (Var () (Var () Void)))
forall v.
Expression v
-> [(Pattern Int, Scope Int Expression v)] -> Expression v
Expr.Case
                                        ( Var () (Var () Void) -> Var Int (Var () (Var () Void))
forall b a. a -> Var b a
F (Var () (Var () Void) -> Var Int (Var () (Var () Void)))
-> (Var () Void -> Var () (Var () Void))
-> Var () Void
-> Var Int (Var () (Var () Void))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var () Void -> Var () (Var () Void)
forall b a. a -> Var b a
F (Var () Void -> Var Int (Var () (Var () Void)))
-> Expression (Var () Void)
-> Expression (Var Int (Var () (Var () Void)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression (Var () Void) -> Text -> Expression (Var () Void)
forall v. Expression v -> Text -> Expression v
p Expression (Var () Void)
forall a. Expression (Var () a)
req Text
"decoder")
                                        [ Qualified
-> [Pattern Int]
-> Expression (Var Int (Var Int (Var () (Var () Void))))
-> (Pattern Int,
    Scope Int Expression (Var Int (Var () (Var () Void))))
forall v b a.
Qualified
-> [Pattern v]
-> Expression (Var b a)
-> (Pattern v, Scope b Expression a)
pat Qualified
"Api.Req.Left" [Int -> Pattern Int
forall v. v -> Pattern v
Pat.Var Int
0] (Expression (Var Int (Var Int (Var () (Var () Void))))
 -> (Pattern Int,
     Scope Int Expression (Var Int (Var () (Var () Void)))))
-> Expression (Var Int (Var Int (Var () (Var () Void))))
-> (Pattern Int,
    Scope Int Expression (Var Int (Var () (Var () Void))))
forall a b. (a -> b) -> a -> b
$
                                            Expression (Var Int (Var Int (Var () (Var () Void))))
"Result.Ok" Expression (Var Int (Var Int (Var () (Var () Void))))
-> Expression (Var Int (Var Int (Var () (Var () Void))))
-> Expression (Var Int (Var Int (Var () (Var () Void))))
forall v. Expression v -> Expression v -> Expression v
`Expr.App` Int -> Expression (Var Int (Var Int (Var () (Var () Void))))
forall a. Int -> Expression (Var Int a)
patVar Int
0
                                        , Qualified
-> [Pattern Int]
-> Expression (Var Int (Var Int (Var () (Var () Void))))
-> (Pattern Int,
    Scope Int Expression (Var Int (Var () (Var () Void))))
forall v b a.
Qualified
-> [Pattern v]
-> Expression (Var b a)
-> (Pattern v, Scope b Expression a)
pat Qualified
"Api.Req.Right" [Int -> Pattern Int
forall v. v -> Pattern v
Pat.Var Int
0] (Expression (Var Int (Var Int (Var () (Var () Void))))
 -> (Pattern Int,
     Scope Int Expression (Var Int (Var () (Var () Void)))))
-> Expression (Var Int (Var Int (Var () (Var () Void))))
-> (Pattern Int,
    Scope Int Expression (Var Int (Var () (Var () Void))))
forall a b. (a -> b) -> a -> b
$
                                            Expression (Var Int (Var Int (Var () (Var () Void))))
-> [(Pattern Int,
     Scope Int Expression (Var Int (Var Int (Var () (Var () Void)))))]
-> Expression (Var Int (Var Int (Var () (Var () Void))))
forall v.
Expression v
-> [(Pattern Int, Scope Int Expression v)] -> Expression v
Expr.Case
                                              (
                                                Expression (Var Int (Var Int (Var () (Var () Void))))
-> [Expression (Var Int (Var Int (Var () (Var () Void))))]
-> Expression (Var Int (Var Int (Var () (Var () Void))))
forall (f :: * -> *) v.
Foldable f =>
Expression v -> f (Expression v) -> Expression v
Expr.apps
                                                  Expression (Var Int (Var Int (Var () (Var () Void))))
"Json.Decode.decodeString"
                                                  [ Int -> Expression (Var Int (Var Int (Var () (Var () Void))))
forall a. Int -> Expression (Var Int a)
patVar Int
0
                                                  , Var Int (Var () (Var () Void))
-> Var Int (Var Int (Var () (Var () Void)))
forall b a. a -> Var b a
F (Var Int (Var () (Var () Void))
 -> Var Int (Var Int (Var () (Var () Void))))
-> Expression (Var Int (Var () (Var () Void)))
-> Expression (Var Int (Var Int (Var () (Var () Void))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Expression (Var Int (Var () (Var () Void)))
forall a. Int -> Expression (Var Int a)
patVar Int
1
                                                  ]
                                              )
                                              [ Qualified
-> [Pattern Int]
-> Expression (Var Int (Var Int (Var Int (Var () (Var () Void)))))
-> (Pattern Int,
    Scope Int Expression (Var Int (Var Int (Var () (Var () Void)))))
forall v b a.
Qualified
-> [Pattern v]
-> Expression (Var b a)
-> (Pattern v, Scope b Expression a)
pat Qualified
"Result.Err" [Int -> Pattern Int
forall v. v -> Pattern v
Pat.Var Int
0] (Expression (Var Int (Var Int (Var Int (Var () (Var () Void)))))
 -> (Pattern Int,
     Scope Int Expression (Var Int (Var Int (Var () (Var () Void))))))
-> Expression (Var Int (Var Int (Var Int (Var () (Var () Void)))))
-> (Pattern Int,
    Scope Int Expression (Var Int (Var Int (Var () (Var () Void)))))
forall a b. (a -> b) -> a -> b
$
                                                  Expression (Var Int (Var Int (Var Int (Var () (Var () Void)))))
"Result.Err"
                                                    Expression (Var Int (Var Int (Var Int (Var () (Var () Void)))))
-> Expression (Var Int (Var Int (Var Int (Var () (Var () Void)))))
-> Expression (Var Int (Var Int (Var Int (Var () (Var () Void)))))
forall v. Expression v -> Expression v -> Expression v
<| Expression (Var Int (Var Int (Var Int (Var () (Var () Void)))))
"Http.BadBody"
                                                    Expression (Var Int (Var Int (Var Int (Var () (Var () Void)))))
-> Expression (Var Int (Var Int (Var Int (Var () (Var () Void)))))
-> Expression (Var Int (Var Int (Var Int (Var () (Var () Void)))))
forall v. Expression v -> Expression v -> Expression v
<| Expression (Var Int (Var Int (Var Int (Var () (Var () Void)))))
"Json.Decode.errorToString"
                                                    Expression (Var Int (Var Int (Var Int (Var () (Var () Void)))))
-> Expression (Var Int (Var Int (Var Int (Var () (Var () Void)))))
-> Expression (Var Int (Var Int (Var Int (Var () (Var () Void)))))
forall v. Expression v -> Expression v -> Expression v
<| Int
-> Expression (Var Int (Var Int (Var Int (Var () (Var () Void)))))
forall a. Int -> Expression (Var Int a)
patVar Int
0
                                              , Qualified
-> [Pattern Int]
-> Expression (Var Int (Var Int (Var Int (Var () (Var () Void)))))
-> (Pattern Int,
    Scope Int Expression (Var Int (Var Int (Var () (Var () Void)))))
forall v b a.
Qualified
-> [Pattern v]
-> Expression (Var b a)
-> (Pattern v, Scope b Expression a)
pat Qualified
"Result.Ok" [Int -> Pattern Int
forall v. v -> Pattern v
Pat.Var Int
0] (Expression (Var Int (Var Int (Var Int (Var () (Var () Void)))))
 -> (Pattern Int,
     Scope Int Expression (Var Int (Var Int (Var () (Var () Void))))))
-> Expression (Var Int (Var Int (Var Int (Var () (Var () Void)))))
-> (Pattern Int,
    Scope Int Expression (Var Int (Var Int (Var () (Var () Void)))))
forall a b. (a -> b) -> a -> b
$
                                                  Expression (Var Int (Var Int (Var Int (Var () (Var () Void)))))
"Result.Ok" Expression (Var Int (Var Int (Var Int (Var () (Var () Void)))))
-> Expression (Var Int (Var Int (Var Int (Var () (Var () Void)))))
-> Expression (Var Int (Var Int (Var Int (Var () (Var () Void)))))
forall v. Expression v -> Expression v -> Expression v
<| Int
-> Expression (Var Int (Var Int (Var Int (Var () (Var () Void)))))
forall a. Int -> Expression (Var Int a)
patVar Int
0
                                              ]
                                        ]
                                    )
                                ]
                        )
                  ]

        )
    ]


{-| Class of servant APIs for which Elm client code can be generated. -}
class Elmable e where
  {-|
    Collect all the Elm definitions needed to implement a client for
    the API.  This is called recursively on our walk down the API tree,
    and the @['Param']@ argument contains all the request parameters
    (like 'Servant.API.Capture', 'Servant.API.ReqBody'', etc) that have been encountered so far on
    whatever particular branch . It will start out empty at the API root.
  -}
  endpoints :: [Param] -> Definitions ()
instance (Elmable a, Elmable b) => Elmable (a :<|> b) where
  endpoints :: [Param] -> Writer (Set Definition) ()
endpoints [Param]
params = do
    forall e. Elmable e => [Param] -> Writer (Set Definition) ()
forall {k} (e :: k).
Elmable e =>
[Param] -> Writer (Set Definition) ()
endpoints @a [Param]
params
    forall e. Elmable e => [Param] -> Writer (Set Definition) ()
forall {k} (e :: k).
Elmable e =>
[Param] -> Writer (Set Definition) ()
endpoints @b [Param]
params
instance (Elmable (ToServantApi api)) => Elmable (NamedRoutes api) where
  endpoints :: [Param] -> Writer (Set Definition) ()
endpoints = forall e. Elmable e => [Param] -> Writer (Set Definition) ()
forall {k} (e :: k).
Elmable e =>
[Param] -> Writer (Set Definition) ()
endpoints @(ToServantApi api)
instance (IsParam a, Elmable b) => Elmable (a :> b) where
  endpoints :: [Param] -> Writer (Set Definition) ()
endpoints [Param]
params = do
    p <- forall (a :: k). IsParam a => Definitions Param
forall {k} (a :: k). IsParam a => Definitions Param
param @a
    endpoints @b (p : params)
instance (Elmable (Verb m c t r)) => Elmable (Verb m c t (Headers h r)) where
  endpoints :: [Param] -> Writer (Set Definition) ()
endpoints = forall e. Elmable e => [Param] -> Writer (Set Definition) ()
forall {k} (e :: k).
Elmable e =>
[Param] -> Writer (Set Definition) ()
endpoints @(Verb m c t r)
instance {- Elmable (Verb m c t NoContent) -}
    (Elmable (NoContentVerb m))
  =>
    Elmable (Verb m c t NoContent)
  where
    endpoints :: [Param] -> Writer (Set Definition) ()
endpoints = forall e. Elmable e => [Param] -> Writer (Set Definition) ()
forall {k} (e :: k).
Elmable e =>
[Param] -> Writer (Set Definition) ()
endpoints @(NoContentVerb m)
instance {- Elmable (Verb method code types response) -}
    {-# overlaps #-}
    ( HasType (EncodingSpec response)
    , ReflectMethod method
    )
  =>
    Elmable (Verb method code types response)
  where
    endpoints :: [Param] -> Writer (Set Definition) ()
endpoints ([Param] -> [Param]
forall a. [a] -> [a]
reverse -> [Param]
params) = do
      responseType <- forall (spec :: Specification) v.
HasType spec =>
Definitions (Type v)
typeOf @(EncodingSpec response)
      decoder <- decoderOf @(EncodingSpec response)
      tell . Set.singleton $
        Def.Constant
          (requestFunctionName @method params)
          (length params)
          (requestFunctionType params responseType)
          (
            requestFunctionBody
              params
              (reflectMethod (Proxy @method))
              ("Api.Req.Right" `Expr.App` decoder)
          )
      pure ()
instance (ReflectMethod method) => Elmable (NoContentVerb method) where
  endpoints :: [Param] -> Writer (Set Definition) ()
endpoints ([Param] -> [Param]
forall a. [a] -> [a]
reverse -> [Param]
params) = do
    Set Definition -> Writer (Set Definition) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Set Definition -> Writer (Set Definition) ())
-> (Definition -> Set Definition)
-> Definition
-> Writer (Set Definition) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Definition -> Set Definition
forall a. a -> Set a
Set.singleton (Definition -> Writer (Set Definition) ())
-> Definition -> Writer (Set Definition) ()
forall a b. (a -> b) -> a -> b
$
      Qualified
-> Int -> Scope Int Type Void -> Expression Void -> Definition
Def.Constant
        (forall (method :: k1). ReflectMethod method => [Param] -> Qualified
forall {k} (method :: k).
ReflectMethod method =>
[Param] -> Qualified
requestFunctionName @method [Param]
params)
        ([Param] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Param]
params)
        ([Param] -> Type Void -> Scope Int Type Void
requestFunctionType [Param]
params Type Void
"Basics.()")
        (
          [Param] -> Method -> Expression Void -> Expression Void
requestFunctionBody
            [Param]
params
            (Proxy method -> Method
forall {k} (a :: k). ReflectMethod a => Proxy a -> Method
reflectMethod (forall (t :: k1). Proxy t
forall {k} (t :: k). Proxy t
Proxy @method))
            (Expression Void
"Api.Req.Left" Expression Void -> Expression Void -> Expression Void
forall v. Expression v -> Expression v -> Expression v
`Expr.App` Expression Void
"Basics.()")
        )
    () -> Writer (Set Definition) ()
forall a. a -> WriterT (Set Definition) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


{-|
  Obtain a value-level request parameter type from the type-level servant
  parameter type.
-}
class IsParam a where
  param :: Definitions Param
{-|
  The default instance assumes that the API combinator does not contribute
  to the parameter list or the "name of the endpoint" in any way. This
  covers things like 'Summary' and 'Description', or potentially custom
  combinators created by the user. In the case of custom combinators,
  you may need to create an overlapping instance if you wish it to affect
  the elm function parameters or function name.
-}
instance {-# OVERLAPPABLE #-} IsParam a where
  param :: Definitions Param
param = Param -> Definitions Param
forall a. a -> WriterT (Set Definition) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Param
Ignore
instance (KnownSymbol name) => IsParam (Capture name tpy) where
  param :: Definitions Param
param = Param -> Definitions Param
forall a. a -> WriterT (Set Definition) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Param -> Definitions Param) -> Param -> Definitions Param
forall a b. (a -> b) -> a -> b
$ PathParam -> Param
PathParam (Text -> PathParam
Capture (forall (a :: Symbol) b. (IsString b, KnownSymbol a) => b
sym @name))
instance (KnownSymbol name) => IsParam (Header' (Optional : mods) name a) where
  param :: Definitions Param
param = Param -> Definitions Param
forall a. a -> WriterT (Set Definition) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Param -> Definitions Param) -> Param -> Definitions Param
forall a b. (a -> b) -> a -> b
$ HeaderParam -> Param
HeaderParam (Text -> HeaderParam
OptionalHeader (forall (a :: Symbol) b. (IsString b, KnownSymbol a) => b
sym @name))
instance (KnownSymbol name) => IsParam (Header' (Required : mods) name a) where
  param :: Definitions Param
param = Param -> Definitions Param
forall a. a -> WriterT (Set Definition) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Param -> Definitions Param) -> Param -> Definitions Param
forall a b. (a -> b) -> a -> b
$ HeaderParam -> Param
HeaderParam (Text -> HeaderParam
RequiredHeader (forall (a :: Symbol) b. (IsString b, KnownSymbol a) => b
sym @name))
instance {- IsParam (Header' (other : mods) name a) -}
    {-# OVERLAPS #-} (IsParam (Header' mods name a))
  =>
    IsParam (Header' (other : mods) name a)
  where
    param :: Definitions Param
param = forall a. IsParam a => Definitions Param
forall {k} (a :: k). IsParam a => Definitions Param
param @(Header' mods name a)
instance {- IsParam (ReqBody' (Required : mods) (JSON : accept) a) -}
    (HasType (DecodingSpec a))
  =>
    IsParam (ReqBody' (Required : mods) (JSON : accept) a)
  where
    param :: Definitions Param
param = do
      elmType <- forall (spec :: Specification) v.
HasType spec =>
Definitions (Type v)
typeOf @(DecodingSpec a)
      encoder <- encoderOf @(DecodingSpec a)
      pure $ BodyEncoder {elmType, encoder}
instance {- IsParam (ReqBody' (other : mods) (JSON : accept) a) -}
    {-# overlaps #-} (IsParam (ReqBody' mods '[JSON] a))
  =>
    IsParam (ReqBody' (other : mods) (JSON : accept) a)
  where
    param :: Definitions Param
param = forall a. IsParam a => Definitions Param
forall {k} (a :: k). IsParam a => Definitions Param
param @(ReqBody' mods '[JSON] a)
instance {- IsParam (ReqBody' mods (other : accept) a) -}
    {-# overlaps #-} (IsParam (ReqBody' mods accept a))
  =>
    IsParam (ReqBody' mods (other : accept) a)
  where
    param :: Definitions Param
param = forall a. IsParam a => Definitions Param
forall {k} (a :: k). IsParam a => Definitions Param
param @(ReqBody' mods accept a)
instance (KnownSymbol segment) => IsParam (segment :: Symbol) where
  param :: Definitions Param
param = Param -> Definitions Param
forall a. a -> WriterT (Set Definition) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Param -> Definitions Param) -> Param -> Definitions Param
forall a b. (a -> b) -> a -> b
$ PathParam -> Param
PathParam (Text -> PathParam
Static (forall (a :: Symbol) b. (IsString b, KnownSymbol a) => b
sym @segment))
instance {- IsParam (QueryParam' (Optional : more) name typ) -}
    (KnownSymbol name)
  =>
    IsParam (QueryParam' (Optional : more) name typ)
  where
    param :: Definitions Param
param = Param -> Definitions Param
forall a. a -> WriterT (Set Definition) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Param -> Definitions Param) -> Param -> Definitions Param
forall a b. (a -> b) -> a -> b
$ QP -> Param
QueryParam (Text -> QP
OptionalQP (forall (a :: Symbol) b. (IsString b, KnownSymbol a) => b
sym @name))
instance {- IsParam (QueryParam' (Required : more) name typ) -}
    (KnownSymbol name)
  =>
    IsParam (QueryParam' (Required : more) name typ)
  where
    param :: Definitions Param
param = Param -> Definitions Param
forall a. a -> WriterT (Set Definition) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Param -> Definitions Param) -> Param -> Definitions Param
forall a b. (a -> b) -> a -> b
$ QP -> Param
QueryParam (Text -> QP
RequiredQP (forall (a :: Symbol) b. (IsString b, KnownSymbol a) => b
sym @name))
instance {- IsParam (QueryParam' (other : more) name typ) -}
    {-# overlaps #-} (IsParam (QueryParam' more name typ))
  =>
    IsParam (QueryParam' (other : more) name typ)
  where
    param :: Definitions Param
param = forall a. IsParam a => Definitions Param
forall {k} (a :: k). IsParam a => Definitions Param
param @(QueryParam' more name typ)


requestFunctionName
  :: forall method. (ReflectMethod method)
  => [Param]
  -> Name.Qualified
requestFunctionName :: forall {k} (method :: k).
ReflectMethod method =>
[Param] -> Qualified
requestFunctionName [Param]
params =
    Module -> Text -> Qualified
Name.Qualified
      [Text
"Api", Text
"Req"]
      (Module -> Text
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Text
methodName Text -> Module -> Module
forall a. a -> [a] -> [a]
: Module
pathParts))
  where
    methodName :: Text
    methodName :: Text
methodName =
      Text -> Text
Text.toLower
      (Text -> Text) -> (Proxy method -> Text) -> Proxy method -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Method -> Text
TE.decodeUtf8
      (Method -> Text)
-> (Proxy method -> Method) -> Proxy method -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy method -> Method
forall {k} (a :: k). ReflectMethod a => Proxy a -> Method
reflectMethod
      (Proxy method -> Text) -> Proxy method -> Text
forall a b. (a -> b) -> a -> b
$ forall (t :: k). Proxy t
forall {k} (t :: k). Proxy t
Proxy @method

    pathParts :: [Text]
    pathParts :: Module
pathParts =
      Text -> Text
Text.toTitle (Text -> Text) -> Module -> Module
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        (Param -> Maybe Text) -> [Param] -> Module
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
          (\case
            PathParam (Static Text
segment) -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Text
munge Text
segment)
            PathParam (Capture Text
name) -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Text
munge Text
name)
            Param
_ -> Maybe Text
forall a. Maybe a
Nothing
          )
          [Param]
params

    {-
      Try to generate valid names in the face of common api path
      idioms. It isn't really worth it for this to be complete, but we
      at least want to cover the basics
    -}
    munge :: Text -> Text
    munge :: Text -> Text
munge = HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
Text.replace Text
"-" Text
"_"


requestFunctionType
  :: [Param]
  -> Type Void
  -> Scope Int Type Void
requestFunctionType :: [Param] -> Type Void -> Scope Int Type Void
requestFunctionType [Param]
params Type Void
responseType =
    Type Void -> Scope Int Type Void
forall (m :: * -> *) a. Monad m => m a -> Scope Int m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Type Void
funType
  where
    funType :: Type Void
    funType :: Type Void
funType =
      (Type Void -> Type Void -> Type Void)
-> Type Void -> [Type Void] -> Type Void
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
        Type Void -> Type Void -> Type Void
forall v. Type v -> Type v -> Type v
Type.Fun
        (Type Void
"Api.Req.Request" Type Void -> Type Void -> Type Void
forall v. Type v -> Type v -> Type v
`Type.App` Type Void
responseType)
        (
          (Param -> Maybe (Type Void)) -> [Param] -> [Type Void]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
            (\case
              PathParam (Capture Text
_) -> Type Void -> Maybe (Type Void)
forall a. a -> Maybe a
Just Type Void
"Basics.String"
              PathParam (Static Text
_) -> Maybe (Type Void)
forall a. Maybe a
Nothing
              QueryParam (RequiredQP Text
_) -> Type Void -> Maybe (Type Void)
forall a. a -> Maybe a
Just Type Void
"Basics.String"
              QueryParam (OptionalQP Text
_) ->
                Type Void -> Maybe (Type Void)
forall a. a -> Maybe a
Just (Type Void
"Basics.Maybe" Type Void -> Type Void -> Type Void
forall v. Type v -> Type v -> Type v
`Type.App` Type Void
"Basics.String")
              HeaderParam (RequiredHeader Text
_) -> Type Void -> Maybe (Type Void)
forall a. a -> Maybe a
Just Type Void
"Basics.String"
              HeaderParam (OptionalHeader Text
_) ->
                Type Void -> Maybe (Type Void)
forall a. a -> Maybe a
Just (Type Void
"Basics.Maybe" Type Void -> Type Void -> Type Void
forall v. Type v -> Type v -> Type v
`Type.App` Type Void
"Basics.String")
              BodyEncoder Type Void
typ Expression Void
_ -> Type Void -> Maybe (Type Void)
forall a. a -> Maybe a
Just Type Void
typ
              Param
Ignore -> Maybe (Type Void)
forall a. Maybe a
Nothing
            )
            [Param]
params
        )


requestFunctionBody
  :: [Param]
  -> Method
  -> Expression Void
  -> Expression Void
requestFunctionBody :: [Param] -> Method -> Expression Void -> Expression Void
requestFunctionBody [Param]
params Method
method Expression Void
decoder =
    [Param] -> Expression Param -> Expression Void
buildLambda
      ([Param] -> [Param]
forall a. [a] -> [a]
reverse [Param]
params)
      (
        [(Field, Expression Param)] -> Expression Param
forall v. [(Field, Expression v)] -> Expression v
Expr.Record
          [ (Text -> Field
Name.Field Text
"method", Text -> Expression Param
forall v. Text -> Expression v
Expr.String (Method -> Text
TE.decodeUtf8 Method
method))
          , (Text -> Field
Name.Field Text
"headers", Expression Param
headers)
          , (Text -> Field
Name.Field Text
"url", Expression Param
url)
          , (Text -> Field
Name.Field Text
"body", Expression Param
body)
          , (Text -> Field
Name.Field Text
"decoder", (Qualified -> Expression Param)
-> (Void -> Expression Param)
-> Expression Void
-> Expression Param
forall v v'.
(Qualified -> Expression v')
-> (v -> Expression v') -> Expression v -> Expression v'
Expr.bind Qualified -> Expression Param
forall any. Qualified -> Expression any
g Void -> Expression Param
forall a. Void -> a
absurd Expression Void
decoder)
          ]
      )
  where
    headers :: Expression Param
    headers :: Expression Param
headers =
        Expression Param -> [Expression Param] -> Expression Param
forall (f :: * -> *) v.
Foldable f =>
Expression v -> f (Expression v) -> Expression v
Expr.apps
          Expression Param
"List.filterMap"
          [ Expression Param
"Basics.identity"
          , [Expression Param] -> Expression Param
forall v. [Expression v] -> Expression v
Expr.List
              [ HeaderParam -> Expression Param
headerExpr HeaderParam
header
              | HeaderParam HeaderParam
header <- [Param]
params
              ]
          ]
      where
        headerExpr :: HeaderParam -> Expression Param
        headerExpr :: HeaderParam -> Expression Param
headerExpr HeaderParam
header =
            Expression Param -> [Expression Param] -> Expression Param
forall (f :: * -> *) v.
Foldable f =>
Expression v -> f (Expression v) -> Expression v
Expr.apps
              Expression Param
"Maybe.map"
              [ Expression Param
"Http.header" Expression Param -> Expression Param -> Expression Param
forall v. Expression v -> Expression v -> Expression v
`Expr.App` Text -> Expression Param
forall v. Text -> Expression v
Expr.String Text
name
              , case HeaderParam
header of
                  RequiredHeader Text
_ ->
                    Expression Param
"Maybe.Just" Expression Param -> Expression Param -> Expression Param
forall v. Expression v -> Expression v -> Expression v
`Expr.App` Param -> Expression Param
forall v. v -> Expression v
Expr.Var (HeaderParam -> Param
HeaderParam HeaderParam
header)
                  OptionalHeader Text
_ -> Param -> Expression Param
forall v. v -> Expression v
Expr.Var (HeaderParam -> Param
HeaderParam HeaderParam
header)
              ]
          where
            name :: Text
            name :: Text
name =
              case HeaderParam
header of
                  RequiredHeader Text
n -> Text
n
                  OptionalHeader Text
n -> Text
n

    url :: Expression Param
    url :: Expression Param
url =
      Expression Param -> [Expression Param] -> Expression Param
forall (f :: * -> *) v.
Foldable f =>
Expression v -> f (Expression v) -> Expression v
Expr.apps
        Expression Param
"Url.Builder.absolute"
        [
          [Expression Param] -> Expression Param
forall v. [Expression v] -> Expression v
Expr.List
            [ case PathParam
pp of
                Static Text
part -> Text -> Expression Param
forall v. Text -> Expression v
Expr.String Text
part
                Capture Text
_ -> Param -> Expression Param
forall v. v -> Expression v
Expr.Var Param
param_
            | param_ :: Param
param_@(PathParam PathParam
pp) <- [Param]
params
            ]
        , Expression Param -> [Expression Param] -> Expression Param
forall (f :: * -> *) v.
Foldable f =>
Expression v -> f (Expression v) -> Expression v
Expr.apps
            Expression Param
"List.filterMap"
            [ Expression Param
"Basics.identity"
            , [Expression Param] -> Expression Param
forall v. [Expression v] -> Expression v
Expr.List
                [ let
                    name :: Text
                    name :: Text
name  = case QP
qp of { RequiredQP Text
n -> Text
n; OptionalQP Text
n -> Text
n}

                    queryExpr :: Expression Param
                    queryExpr :: Expression Param
queryExpr =
                      Expression Param -> [Expression Param] -> Expression Param
forall (f :: * -> *) v.
Foldable f =>
Expression v -> f (Expression v) -> Expression v
Expr.apps
                        Expression Param
"Maybe.map"
                        [ Expression Param
"Url.Builder.string" Expression Param -> Expression Param -> Expression Param
forall v. Expression v -> Expression v -> Expression v
`Expr.App` Text -> Expression Param
forall v. Text -> Expression v
Expr.String Text
name
                        , case QP
qp of
                            RequiredQP Text
_ ->
                              Expression Param
"Maybe.Just" Expression Param -> Expression Param -> Expression Param
forall v. Expression v -> Expression v -> Expression v
`Expr.App` Param -> Expression Param
forall v. v -> Expression v
Expr.Var Param
param_
                            OptionalQP Text
_ -> Param -> Expression Param
forall v. v -> Expression v
Expr.Var Param
param_
                        ]
                  in
                    Expression Param
queryExpr
                | param_ :: Param
param_@(QueryParam QP
qp) <- [Param]
params
                ]
            ]
        ]

    body :: Expression Param
    body :: Expression Param
body =
      case
        [ Qualified -> Expression Param
forall any. Qualified -> Expression any
g Qualified
"Http.jsonBody" Expression Param -> Expression Param -> Expression Param
forall v. Expression v -> Expression v -> Expression v
`Expr.App`
            ((Void -> Param
forall a. Void -> a
absurd (Void -> Param) -> Expression Void -> Expression Param
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression Void
encoder) Expression Param -> Expression Param -> Expression Param
forall v. Expression v -> Expression v -> Expression v
`Expr.App` Param -> Expression Param
forall v. v -> Expression v
Expr.Var Param
param_)
        | param_ :: Param
param_@(BodyEncoder Type Void
_ Expression Void
encoder) <- [Param]
params
        ]
      of
        [] -> Qualified -> Expression Param
forall any. Qualified -> Expression any
g Qualified
"Http.emptyBody"
        (Expression Param
encoder : [Expression Param]
_) -> Expression Param
encoder

    buildLambda :: [Param] -> Expression Param -> Expression Void
    buildLambda :: [Param] -> Expression Param -> Expression Void
buildLambda = \cases
      [] Expression Param
e ->
        Expression Void -> Maybe (Expression Void) -> Expression Void
forall a. a -> Maybe a -> a
fromMaybe
          (String -> Expression Void
forall a. HasCallStack => String -> a
error String
"Paramaters in expression to not match the parameter list.")
          (Expression Param -> Maybe (Expression Void)
forall (f :: * -> *) a b. Traversable f => f a -> Maybe (f b)
Bound.closed Expression Param
e)
      (PathParam (Static Text
_) : [Param]
more) Expression Param
e ->
        [Param] -> Expression Param -> Expression Void
buildLambda [Param]
more Expression Param
e
      (Param
Ignore : [Param]
more) Expression Param
e ->
        [Param] -> Expression Param -> Expression Void
buildLambda [Param]
more Expression Param
e
      (Param
p : [Param]
more) Expression Param
e ->
        [Param] -> Expression Param -> Expression Void
buildLambda
          [Param]
more
          (Scope () Expression Param -> Expression Param
forall v. Scope () Expression v -> Expression v
Expr.Lam (Param -> Expression Param -> Scope () Expression Param
forall (f :: * -> *) a. (Monad f, Eq a) => a -> f a -> Scope () f a
abstract1 Param
p Expression Param
e))


data Param
  = PathParam PathParam
  | HeaderParam HeaderParam
  | QueryParam QP
  | BodyEncoder
      { Param -> Type Void
elmType :: Type Void
      , Param -> Expression Void
encoder :: Expression Void
      }
  | Ignore {-^ This is for things like `Summary` -}
  deriving stock (Param -> Param -> Bool
(Param -> Param -> Bool) -> (Param -> Param -> Bool) -> Eq Param
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Param -> Param -> Bool
== :: Param -> Param -> Bool
$c/= :: Param -> Param -> Bool
/= :: Param -> Param -> Bool
Eq)


data QP
  = RequiredQP Text
  | OptionalQP Text
  deriving stock (QP -> QP -> Bool
(QP -> QP -> Bool) -> (QP -> QP -> Bool) -> Eq QP
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: QP -> QP -> Bool
== :: QP -> QP -> Bool
$c/= :: QP -> QP -> Bool
/= :: QP -> QP -> Bool
Eq)


data PathParam
  = Static Text
  | Capture Text
  deriving stock (PathParam -> PathParam -> Bool
(PathParam -> PathParam -> Bool)
-> (PathParam -> PathParam -> Bool) -> Eq PathParam
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PathParam -> PathParam -> Bool
== :: PathParam -> PathParam -> Bool
$c/= :: PathParam -> PathParam -> Bool
/= :: PathParam -> PathParam -> Bool
Eq)


data HeaderParam
  = RequiredHeader Text
  | OptionalHeader Text
  deriving stock (HeaderParam -> HeaderParam -> Bool
(HeaderParam -> HeaderParam -> Bool)
-> (HeaderParam -> HeaderParam -> Bool) -> Eq HeaderParam
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HeaderParam -> HeaderParam -> Bool
== :: HeaderParam -> HeaderParam -> Bool
$c/= :: HeaderParam -> HeaderParam -> Bool
/= :: HeaderParam -> HeaderParam -> Bool
Eq)


g :: Name.Qualified -> Expression any
g :: forall any. Qualified -> Expression any
g = Qualified -> Expression any
forall any. Qualified -> Expression any
Expr.Global


sym
  :: forall a b.
     ( IsString b
     , KnownSymbol a
     )
  => b
sym :: forall (a :: Symbol) b. (IsString b, KnownSymbol a) => b
sym = String -> b
forall a. IsString a => String -> a
fromString (String -> b) -> String -> b
forall a b. (a -> b) -> a -> b
$ Proxy a -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @a)


{-|
  "Batteries included" way to generate some Elm code on disk in a given
  a directory. The directory should be dedicated to the generated Elm
  code and you shouldn't try to store anything else in that directory,
  Elm files or otherwise.

  This function will succeed without error if (and only if) the directory
  already exists /and/ its contents exactly match what would be generated
  anyway.

  If the files on disk are wrong, then an error is thrown, and the files
  are unmodified.

  If the directory does not exist, then it is created and the Elm code
  is generated inside the directory, /then an error is thrown/.

  The intent is that you can use this function (thinly wrapped with
  the appropriate directory and api spec) as the main function for a
  test suite, where the "test" is that the files on disk are /already/
  correct. We throw an error even in the case where we generate files
  for you because, for instance, you wouldn't want CI to be generating
  these files when you forgot to check them in in the first place.
-}
generateElm
  :: forall api. (Elmable api)
  => OsPath {-^ The directory in which to deposit Elm code. -}
  -> Proxy api
  -> IO ()
generateElm :: forall {k} (api :: k). Elmable api => OsPath -> Proxy api -> IO ()
generateElm OsPath
dir Proxy api
Proxy = do
    definitions :: HashMap Module Text
      <-
        (Doc Any -> IO Text)
-> HashMap Module (Doc Any) -> IO (HashMap Module Text)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> HashMap Module a -> f (HashMap Module b)
traverse
          (
            Text -> IO Text
elmFormat
            (Text -> IO Text) -> (Doc Any -> Text) -> Doc Any -> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n")
            (Text -> Text) -> (Doc Any -> Text) -> Doc Any -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleDocStream Any -> Text
forall ann. SimpleDocStream ann -> Text
renderStrict
            (SimpleDocStream Any -> Text)
-> (Doc Any -> SimpleDocStream Any) -> Doc Any -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc Any -> SimpleDocStream Any
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
defaultLayoutOptions
          )
        (HashMap Module (Doc Any) -> IO (HashMap Module Text))
-> (Set Definition -> HashMap Module (Doc Any))
-> Set Definition
-> IO (HashMap Module Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Definition] -> HashMap Module (Doc Any)
forall ann. [Definition] -> HashMap Module (Doc ann)
modules
        ([Definition] -> HashMap Module (Doc Any))
-> (Set Definition -> [Definition])
-> Set Definition
-> HashMap Module (Doc Any)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Definition -> [Definition]
forall a. Set a -> [a]
Set.toList
        (Set Definition -> IO (HashMap Module Text))
-> Set Definition -> IO (HashMap Module Text)
forall a b. (a -> b) -> a -> b
$ Proxy api -> Set Definition
forall {k} (api :: k). Elmable api => Proxy api -> Set Definition
servantDefs (forall (t :: k). Proxy t
forall {k} (t :: k). Proxy t
Proxy @api)

    doesDirectoryExist dir >>= \case
      Bool
False -> do
        ((Module, Text) -> IO ()) -> [(Module, Text)] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Module, Text) -> IO ()
writeModule (HashMap Module Text -> [(Module, Text)]
forall k v. HashMap k v -> [(k, v)]
HM.toList HashMap Module Text
definitions)
        String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
          [String] -> String
unlines
            [ String
""
            , String
"   We successfully generated the elm code, but we are going to"
            , String
"   fail the test anyway because the the success criteria for"
            , String
"   the test is that the generated files on disk are _already_"
            , String
"   correct. You wouldn't want CI to pass in this case,"
            , String
"   for instance."
            ]
      Bool
True -> do
        HashMap Module Text -> IO ()
checkModules HashMap Module Text
definitions
        String -> IO ()
putStrLn String
"Test passes. Generated files are up to date."
  where
    elmFormat :: Text -> IO Text
    elmFormat :: Text -> IO Text
elmFormat Text
elmCode = do
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Formatting: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
elmCode
      result <-
        String -> Text
Text.pack (String -> Text) -> IO String -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
          String -> [String] -> String -> IO String
readProcess
            String
"elm-format"
            [String
"--stdin"]
            (Text -> String
Text.unpack Text
elmCode)
      putStrLn $ "Result: " <> show result
      pure result


    checkModules :: HashMap Module Text -> IO ()
    checkModules :: HashMap Module Text -> IO ()
checkModules HashMap Module Text
generatedModules = do
        modulesOnDisk <- OsPath -> IO (HashMap Module Text)
getFiles OsPath
dir
        if modulesOnDisk == generatedModules
          then pure ()
          else do
            putStrLn $
              unlines
                [ "expected: " <> show generatedModules
                , "actual:   " <> show modulesOnDisk
                , ""
                ]
            error $
              "Please regenerate modules by completely deleting the `"
              <> show dir <> "` directory and then running the test again."
      where
        getFiles :: OsPath -> IO (HashMap Module Text)
        getFiles :: OsPath -> IO (HashMap Module Text)
getFiles OsPath
path =
          case OsPath -> (OsPath, OsPath)
splitExtension OsPath
path of
            (OsPath -> String
pToStr -> String
mod, OsPath -> String
pToStr -> String
".elm") -> do
              content <- String -> IO Text
TIO.readFile (OsPath -> String
pToStr OsPath
path)
              pure $
                HM.singleton
                  (
                    drop 1
                    . Text.split (== '/')
                    . Text.pack
                    $ mod
                  )
                  content
            (OsPath, OsPath)
_ -> do
              children <- OsPath -> IO [OsPath]
listDirectory OsPath
path
              fmap mconcat . sequence $
                [ getFiles (path </> child)
                | child <- children
                ]


    writeModule :: (Module, Text) -> IO ()
    writeModule :: (Module, Text) -> IO ()
writeModule (Module
module_, Text
content) = do
        Bool -> OsPath -> IO ()
createDirectoryIfMissing Bool
True OsPath
dirname
        path <- OsPath -> IO String
forall (m :: * -> *). MonadThrow m => OsPath -> m String
OsPath.decodeUtf OsPath
filename
        TIO.writeFile path content
      where
        pathName :: [Text] -> OsPath
        pathName :: Module -> OsPath
pathName =
          (OsPath -> OsPath -> OsPath) -> OsPath -> [OsPath] -> OsPath
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' OsPath -> OsPath -> OsPath
(</>) OsPath
dir
          ([OsPath] -> OsPath) -> (Module -> [OsPath]) -> Module -> OsPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> OsPath) -> Module -> [OsPath]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe OsPath -> OsPath
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe OsPath -> OsPath)
-> (Text -> Maybe OsPath) -> Text -> OsPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe OsPath
forall (m :: * -> *). MonadThrow m => String -> m OsPath
OsPath.encodeUtf (String -> Maybe OsPath)
-> (Text -> String) -> Text -> Maybe OsPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack)

        filename :: OsPath
        filename :: OsPath
filename = Module -> OsPath
pathName Module
module_ OsPath -> OsPath -> OsPath
forall a. Semigroup a => a -> a -> a
<> [osp|.elm|]

        dirname :: OsPath
        dirname :: OsPath
dirname = Module -> OsPath
pathName (Module -> Module
forall a. HasCallStack => [a] -> [a]
init Module
module_)

    pToStr :: OsString -> String
    pToStr :: OsPath -> String
pToStr = (OsChar -> Char) -> [OsChar] -> String
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap OsChar -> Char
OsPath.toChar ([OsChar] -> String) -> (OsPath -> [OsChar]) -> OsPath -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OsPath -> [OsChar]
OsPath.unpack