servant-to-elm (empty) → 0.1.0.0
raw patch · 8 files changed
+954/−0 lines, 8 filesdep +aesondep +basedep +boundsetup-changed
Dependencies added: aeson, base, bound, elm-syntax, generics-sop, haskell-to-elm, http-types, protolude, servant, servant-to-elm, text, unordered-containers
Files
- CHANGELOG.md +7/−0
- LICENSE +30/−0
- README.md +140/−0
- Setup.hs +2/−0
- examples/UserAPI.hs +62/−0
- servant-to-elm.cabal +98/−0
- src/Servant/To/Elm.hs +613/−0
- test/Spec.hs +2/−0
+ CHANGELOG.md view
@@ -0,0 +1,7 @@+# Changelog for servant-to-elm++## Unreleased changes++## 0.1.0.0++- Initial release
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Olle Fredriksson (c) 2019++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Olle Fredriksson nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,140 @@+# servant-to-elm++This is a library for generating Elm client libraries from Servant API+definitions.++See [haskell-to-elm](https://github.com/folq/haskell-to-elm) for background+information and a more elaborate motivation.++## Basic usage++Given a Servant API like the following++```haskell+type UserAPI+ = "user" :> Get '[JSON] User+ :<|> "user" :> ReqBody '[JSON] User :> Post '[JSON] NoContent+```++we can generate the Elm code for making requests against it as follows:++```haskell+main :: IO ()+main = do+ let+ definitions =+ map (elmEndpointDefinition "Config.urlBase" ["Api"]) (elmEndpoints @UserAPI)+ <> jsonDefinitions @User++ modules =+ Pretty.modules definitions++ forM_ (HashMap.toList modules) $ \(_moduleName, contents) ->+ print contents+```++Running `main` prints:++```elm+module Api exposing (..)++import Api.User+import Config+import Http+import Json.Decode+import NoContent+++getUser : Cmd (Result (Http.Error , Maybe { metadata : Http.Metadata+ , body : String }) Api.User.User)+getUser =+ Http.request { method = "GET"+ , headers = []+ , url = String.join "/" [Config.urlBase, "user"]+ , body = Http.emptyBody+ , expect = Http.expectStringResponse identity (\a -> case a of+ Http.BadUrl_ b ->+ Err (Http.BadUrl b , Nothing)++ Http.Timeout_ ->+ Err (Http.Timeout , Nothing)++ Http.NetworkError_ ->+ Err (Http.NetworkError , Nothing)++ Http.BadStatus_ b c ->+ Err (Http.BadStatus b.statusCode , Just { metadata = b, body = c })++ Http.GoodStatus_ b c ->+ Result.mapError (\d -> (Http.BadBody (Json.Decode.errorToString d) , Just { metadata = b+ , body = c })) (Json.Decode.decodeString Api.User.decoder c))+ , timeout = Nothing+ , tracker = Nothing }+++postUser : Api.User.User -> Cmd (Result (Http.Error , Maybe { metadata : Http.Metadata+ , body : String }) NoContent.NoContent)+postUser a =+ Http.request { method = "POST"+ , headers = []+ , url = String.join "/" [Config.urlBase, "user"]+ , body = Http.jsonBody (Api.User.encoder a)+ , expect = Http.expectStringResponse identity (\b -> case b of+ Http.BadUrl_ c ->+ Err (Http.BadUrl c , Nothing)++ Http.Timeout_ ->+ Err (Http.Timeout , Nothing)++ Http.NetworkError_ ->+ Err (Http.NetworkError , Nothing)++ Http.BadStatus_ c d ->+ Err (Http.BadStatus c.statusCode , Just { metadata = c, body = d })++ Http.GoodStatus_ c d ->+ if d == "" then+ Ok NoContent.NoContent++ else+ Err (Http.BadBody "Expected the response body to be empty" , Just { metadata = c+ , body = d }))+ , timeout = Nothing+ , tracker = Nothing }+module Api.User exposing (..)++import Json.Decode+import Json.Decode.Pipeline+import Json.Encode+++type alias User =+ { name : String, age : Int }+++encoder : User -> Json.Encode.Value+encoder a =+ Json.Encode.object [ ("name" , Json.Encode.string a.name)+ , ("age" , Json.Encode.int a.age) ]+++decoder : Json.Decode.Decoder User+decoder =+ Json.Decode.succeed User |>+ Json.Decode.Pipeline.required "name" Json.Decode.string |>+ Json.Decode.Pipeline.required "age" Json.Decode.int+```++In an actual project we would be writing the code to disk instead of printing it.++See [this file](examples/UserAPI.hs) for the full code with imports.++## Related projects++Libraries that use or are used by servant-to-elm:+- [haskell-to-elm](https://github.com/folq/haskell-to-elm) generates Elm types and JSON encoders and decoders from Haskell types.+- [elm-syntax](https://github.com/folq/elm-syntax) defines Haskell ASTs for Elm's syntax, and lets us pretty-print it.+- [haskell-to-elm-test](https://github.com/folq/haskell-to-elm-test) does end-to-end testing of this library.++Others:+- [servant-elm](http://hackage.haskell.org/package/servant-elm)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/UserAPI.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+module UserAPI where++import Protolude++import qualified Data.Aeson as Aeson+import qualified Data.HashMap.Lazy as HashMap+import qualified Generics.SOP as SOP+import Servant.API++import qualified Language.Elm.Pretty as Pretty+import Language.Haskell.To.Elm+import Servant.To.Elm++data User = User+ { name :: Text+ , age :: Int+ } deriving+ ( Generic+ , Aeson.ToJSON+ , SOP.Generic+ , SOP.HasDatatypeInfo+ , HasElmDecoder Aeson.Value+ , HasElmEncoder Aeson.Value+ , HasElmType+ )++instance HasElmDefinition User where+ elmDefinition =+ deriveElmTypeDefinition @User defaultOptions "Api.User.User"++instance HasElmDecoderDefinition Aeson.Value User where+ elmDecoderDefinition =+ deriveElmJSONDecoder @User defaultOptions Aeson.defaultOptions "Api.User.decoder"++instance HasElmEncoderDefinition Aeson.Value User where+ elmEncoderDefinition =+ deriveElmJSONEncoder @User defaultOptions Aeson.defaultOptions "Api.User.encoder"++type UserAPI+ = "user" :> Get '[JSON] User+ :<|> "user" :> ReqBody '[JSON] User :> Post '[JSON] NoContent++main :: IO ()+main = do+ let+ definitions =+ map (elmEndpointDefinition "Config.urlBase" ["Api"]) (elmEndpoints @UserAPI)+ <> jsonDefinitions @User++ modules =+ Pretty.modules definitions++ forM_ (HashMap.toList modules) $ \(_moduleName, contents) ->+ print contents
+ servant-to-elm.cabal view
@@ -0,0 +1,98 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: a72d33a5b5a0f94d44e7e4e23970669fe65894da52c59170b08a0c87725c898e++name: servant-to-elm+version: 0.1.0.0+synopsis: Automatically generate Elm clients for Servant APIs+description: Please see the README on GitHub at <https://github.com/folq/servant-to-elm#readme>+category: Servant, API, Elm, Compiler+homepage: https://github.com/folq/servant-to-elm#readme+bug-reports: https://github.com/folq/servant-to-elm/issues+author: Olle Fredriksson+maintainer: fredriksson.olle@gmail.com+copyright: 2019 Olle Fredriksson+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/folq/servant-to-elm++flag examples+ description: Build examples+ manual: True+ default: False++library+ exposed-modules:+ Servant.To.Elm+ other-modules:+ Paths_servant_to_elm+ hs-source-dirs:+ src+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -Wtabs -funbox-strict-fields+ build-depends:+ aeson >=1.4.0+ , base >=4.7 && <5+ , bound >=2.0.0+ , elm-syntax >=0.1.0 && <0.1.1+ , haskell-to-elm >=0.1.0 && <0.1.1+ , http-types >=0.12.0+ , protolude >=0.2.3+ , servant >=0.16.0+ , text >=1.2.0+ default-language: Haskell2010++executable user-example+ main-is: UserAPI.hs+ other-modules:+ Paths_servant_to_elm+ hs-source-dirs:+ examples+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -Wtabs -funbox-strict-fields+ build-depends:+ aeson >=1.4.0+ , base >=4.7 && <5+ , bound >=2.0.0+ , elm-syntax >=0.1.0 && <0.1.1+ , generics-sop+ , haskell-to-elm >=0.1.0 && <0.1.1+ , http-types >=0.12.0+ , protolude >=0.2.3+ , servant+ , servant-to-elm+ , text >=1.2.0+ , unordered-containers+ if !flag(examples)+ buildable: False+ default-language: Haskell2010++test-suite servant-to-elm-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Paths_servant_to_elm+ hs-source-dirs:+ test+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -Wtabs -funbox-strict-fields -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ aeson >=1.4.0+ , base >=4.7 && <5+ , bound >=2.0.0+ , elm-syntax >=0.1.0 && <0.1.1+ , haskell-to-elm >=0.1.0 && <0.1.1+ , http-types >=0.12.0+ , protolude >=0.2.3+ , servant >=0.16.0+ , servant-to-elm+ , text >=1.2.0+ default-language: Haskell2010
+ src/Servant/To/Elm.hs view
@@ -0,0 +1,613 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Servant.To.Elm where++import Protolude hiding (Type, functionName, moduleName)++import qualified Bound+import qualified Data.Aeson as Aeson+import qualified Data.Char as Char+import qualified Data.Text as Text+import qualified Network.HTTP.Types as HTTP+import Servant.API ((:<|>), (:>))+import qualified Servant.API as Servant+import qualified Servant.API.Modifiers as Servant++import Language.Elm.Definition (Definition)+import qualified Language.Elm.Definition as Definition+import Language.Elm.Expression (Expression)+import qualified Language.Elm.Expression as Expression+import qualified Language.Elm.Name as Name+import qualified Language.Elm.Pattern as Pattern+import Language.Elm.Type (Type)+import qualified Language.Elm.Type as Type+import Language.Haskell.To.Elm++-- | Generate an Elm function for making a request to a Servant endpoint.+elmEndpointDefinition+ :: Expression Void -- ^ The URL base of the endpoint+ -> Name.Module -- ^ The module that the function should be generated into+ -> Endpoint -- ^ A description of the endpoint+ -> Definition+elmEndpointDefinition urlBase moduleName endpoint =+ Definition.Constant+ (Name.Qualified moduleName functionName)+ elmTypeSig+ (panic "expression not closed" <$> lambdaArgs argNames elmLambdaBody)+ where+ functionName =+ case _functionName endpoint of+ [] ->+ ""++ firstPart:rest ->+ firstPart <> foldMap capitalise rest++ capitalise s =+ case Text.uncons s of+ Nothing ->+ ""++ Just (c, s') ->+ Text.cons (Char.toUpper c) s'++ elmTypeSig :: Type Void+ elmTypeSig =+ Type.funs+ (concat+ [ [ _encodedType arg+ | (_, arg, _) <- _headers endpoint+ ]+ , [ _encodedType arg+ | Capture _ (_, arg) <- numberedPathSegments+ ]+ , [ case type_ of+ Required ->+ vacuous $ _encodedType arg++ Optional ->+ vacuous $ _encodedType arg++ Flag ->+ vacuous $ _encodedType arg++ List ->+ vacuous $ Type.App "List.List" $ _encodedType arg+ | (_, type_, arg) <- _queryString $ _url endpoint+ ]+ , [ _encodedType body+ | Just body <- [_body endpoint]+ ]+ ]+ )+ elmReturnType++ elmReturnType =+ let+ type_ =+ maybe "Basics.()" _decodedType $ _returnType endpoint+ in+ Type.App+ "Cmd.Cmd"+ (Type.apps+ "Result.Result"+ [Type.tuple "Http.Error" (Type.App "Maybe.Maybe" $ Type.Record [("metadata", "Http.Metadata"), ("body", "String.String")]), type_]+ )++ elmReturnDecoder =+ case _returnType endpoint of+ Nothing ->+ panic "elmRequest: No return type" -- TODO?++ Just ret ->+ vacuous $ _decoder ret++ numberedPathSegments =+ go 0 $ _path $ _url endpoint+ where+ go !i segments =+ case segments of+ [] ->+ []++ Static p:segments' ->+ Static p : go i segments'++ Capture str arg:segments' ->+ Capture str (i, arg) : go (i + 1) segments'++ argNames =+ concat+ [ [ headerArgName i+ | (i, _) <- zip [0..] $ _headers endpoint+ ]+ , [ capturedArgName i+ | Capture _ (i, _) <- numberedPathSegments+ ]+ , [ paramArgName i+ | (i, _) <- zip [0..] $ _queryString $ _url endpoint+ ]+ , [ bodyArgName+ | Just _ <- [_body endpoint]+ ]+ ]++ lambdaArgs :: [Text] -> Expression Text -> Expression Text+ lambdaArgs args rhs =+ case args of+ [] ->+ rhs++ arg:args' ->+ Expression.Lam $ Bound.abstract1 arg $ lambdaArgs args' rhs++ elmLambdaBody :: Expression Text+ elmLambdaBody =+ Expression.App+ "Http.request"+ (Expression.Record+ [ ("method", Expression.String $ toS $ _method endpoint)+ , ("headers", elmHeaders)+ , ("url", elmUrl)+ , ("body", elmBody)+ , ("expect", elmExpect)+ , ("timeout", "Maybe.Nothing")+ , ("tracker", "Maybe.Nothing")+ ]+ )++ elmParams =+ [ case type_ of+ Required ->+ Expression.List+ [Expression.String (name <> "=") Expression.++ encode (pure $ paramArgName i)]++ Optional ->+ Expression.apps+ "Maybe.Extra.unwrap"+ [ Expression.List []+ , "List.singleton" Expression.<< Expression.App "Basics.++" (Expression.String $ name <> "=")+ , encode $ pure $ paramArgName i+ ]++ Flag ->+ Expression.If+ (pure $ paramArgName i)+ (Expression.List [Expression.String name])+ (Expression.List [])++ List ->+ Expression.apps+ "List.map"+ [ Expression.App "Basics.++" (Expression.String (name <> "[]=")) Expression.<< encoder+ , pure $ paramArgName i+ ]+ | (i, (name, type_, arg)) <- zip [0..] $ _queryString $ _url endpoint+ , let+ encoder =+ vacuous $ _encoder arg++ encode =+ Expression.App encoder+ ]++ elmUrl =+ case elmParams of+ [] ->+ withoutParams++ [elmParams'] ->+ withParams elmParams'++ _ ->+ withParams (Expression.App "List.concat" $ Expression.List elmParams)++ where+ withoutParams =+ Expression.apps+ "String.join"+ [ Expression.String "/"+ , Expression.List $ vacuous urlBase : fmap elmPathSegment numberedPathSegments+ ]++ withParams params =+ withoutParams Expression.+++ Expression.Case params+ [ (Pattern.List [], Bound.toScope $ Expression.String "")+ , ( Pattern.Var 0+ , Bound.toScope $ Expression.String "?" Expression.++ Expression.apps "String.join" [Expression.String "&", pure $ Bound.B 0]+ )+ ]+++ elmHeaders =+ let+ headerDecoder i name arg =+ Expression.apps+ "Http.header"+ [ Expression.String name+ , Expression.App+ (vacuous $ _encoder arg)+ (pure $ headerArgName i)+ ]++ optionalHeaderDecoder i name arg =+ Expression.apps+ "Maybe.map"+ [ Expression.App+ "Http.header"+ (Expression.String name)+ , Expression.App+ (vacuous $ _encoder arg)+ (pure $ headerArgName i)+ ]+ in+ case _headers endpoint of+ [] ->+ Expression.List []++ _+ | all (\(_, _, required) -> required) (_headers endpoint) ->+ Expression.List+ [ headerDecoder i name arg+ | (i, (name, arg, _)) <- zip [0..] $ _headers endpoint+ ]++ _ ->+ Expression.apps "List.filterMap"+ [ "Basics.identity"+ , Expression.List+ [ if required then+ Expression.App "Maybe.Just" $ headerDecoder i name arg++ else+ optionalHeaderDecoder i name arg+ | (i, (name, arg, required)) <- zip [0..] $ _headers endpoint+ ]+ ]+++ elmBody =+ case _body endpoint of+ Nothing ->+ "Http.emptyBody"++ Just body ->+ Expression.App+ "Http.jsonBody"+ (Expression.App (vacuous $ _encoder body) $ pure bodyArgName)++ elmExpect =+ Expression.apps+ "Http.expectStringResponse"+ [ "Basics.identity"+ , Expression.Lam $ Bound.toScope $+ Expression.Case (pure $ Bound.B ())+ [ ( Pattern.Con "Http.BadUrl_" [Pattern.Var 0]+ , Bound.toScope $+ Expression.App "Result.Err" $+ Expression.tuple (Expression.App "Http.BadUrl" $ pure (Bound.B 0)) "Maybe.Nothing"+ )+ , ( Pattern.Con "Http.Timeout_" []+ , Bound.toScope $+ Expression.App "Result.Err" $+ Expression.tuple "Http.Timeout" "Maybe.Nothing"+ )+ , ( Pattern.Con "Http.NetworkError_" []+ , Bound.toScope $+ Expression.App "Result.Err" $+ Expression.tuple "Http.NetworkError" "Maybe.Nothing"+ )+ , ( Pattern.Con "Http.BadStatus_" [Pattern.Var 0, Pattern.Var 1]+ , Bound.toScope $+ Expression.App "Result.Err" $+ Expression.tuple+ (Expression.App "Http.BadStatus" (Expression.App (Expression.Proj "statusCode") $ pure $ Bound.B 0))+ (Expression.App "Maybe.Just" $ Expression.Record [("metadata", pure $ Bound.B 0), ("body", pure $ Bound.B 1)])+ )+ , ( Pattern.Con "Http.GoodStatus_" [Pattern.Var 0, Pattern.Var 1]+ , Bound.toScope $+ if fmap _decodedType (_returnType endpoint) == Just (elmType @Servant.NoContent) then+ Expression.If (Expression.apps ("Basics.==") [pure $ Bound.B 1, Expression.String ""])+ (Expression.App "Result.Ok" "NoContent.NoContent")+ (Expression.App "Result.Err" $+ Expression.tuple+ (Expression.App "Http.BadBody" $ Expression.String "Expected the response body to be empty")+ (Expression.App "Maybe.Just" $ Expression.Record [("metadata", pure $ Bound.B 0), ("body", pure $ Bound.B 1)])+ )++ else+ Expression.apps "Result.mapError"+ [ Expression.Lam $ Bound.toScope $+ Expression.tuple+ (Expression.App "Http.BadBody" $+ Expression.App "Json.Decode.errorToString" $+ pure $ Bound.B ()+ )+ (Expression.App "Maybe.Just" $ Expression.Record [("metadata", pure $ Bound.F $ Bound.B 0), ("body", pure $ Bound.F $ Bound.B 1)])+ , Expression.apps "Json.Decode.decodeString" [elmReturnDecoder, pure $ Bound.B 1]+ ]+ )+ ]+ ]++ elmPathSegment pathSegment =+ case pathSegment of+ Static s ->+ Expression.String s++ Capture _ (i, arg) ->+ Expression.App+ (vacuous $ _encoder arg)+ (pure $ capturedArgName i)++ bodyArgName :: Text+ bodyArgName =+ "body"++ headerArgName :: Int -> Text+ headerArgName i =+ "header" <> show i++ capturedArgName :: Int -> Text+ capturedArgName i =+ "capture" <> show i++ paramArgName :: Int -> Text+ paramArgName i =+ "param" <> show i++-------------------------------------------------------------------------------+-- * Endpoints++-- | @'HasElmEndpoints' api@ means that the Servant API @api@ can be converted+-- to a list of 'Endpoint's, which contains the information we need to generate+-- an Elm client library for the API.+class HasElmEndpoints api where+ elmEndpoints' :: Endpoint -> [Endpoint]++-- | Convert an API to a list of Elm endpoint descriptors, 'Endpoint'.+--+-- Usage: @'elmEndpoints' \@MyAPI@+elmEndpoints :: forall api. HasElmEndpoints api => [Endpoint]+elmEndpoints = elmEndpoints' @api Endpoint+ { _url = URL+ { _path = []+ , _queryString = []+ }+ , _method = "GET"+ , _headers = []+ , _body = Nothing+ , _returnType = Nothing+ , _functionName = []+ }++-- | Contains the information we need about an endpoint to generate an Elm+-- definition that calls it.+data Endpoint = Endpoint+ { _url :: URL+ , _method :: HTTP.Method+ , _headers :: [(Text, Encoder, Bool)]+ , _body :: Maybe Encoder+ , _returnType :: Maybe Decoder+ , _functionName :: [Text]+ }++data PathSegment e+ = Static Text+ | Capture Text e+ deriving (Show)++data QueryParamType+ = Required+ | Optional+ | Flag+ | List+ deriving (Show)++data URL = URL+ { _path :: [PathSegment Encoder]+ , _queryString :: [(Text, QueryParamType, Encoder)]+ }+ deriving (Show)++data Encoder = Encoder { _encoder :: Expression Void, _encodedType :: Type Void }+ deriving (Show)+data Decoder = Decoder { _decoder :: Expression Void, _decodedType :: Type Void }+ deriving (Show)++makeEncoder :: forall value a. HasElmEncoder value a => Encoder+makeEncoder = Encoder (elmEncoder @value @a) (elmType @a)++makeDecoder :: forall value a. HasElmDecoder value a => Decoder+makeDecoder = Decoder (elmDecoder @value @a) (elmType @a)++instance HasElmEndpoints Servant.EmptyAPI where+ elmEndpoints' _ = []++instance (HasElmEndpoints a, HasElmEndpoints b) => HasElmEndpoints (a :<|> b) where+ elmEndpoints' prefix =+ elmEndpoints' @a prefix <> elmEndpoints' @b prefix++instance (KnownSymbol symbol, HasElmEncoder Text a, HasElmEndpoints api)+ => HasElmEndpoints (Servant.Capture' mods symbol a :> api) where+ elmEndpoints' prefix =+ elmEndpoints' @api prefix+ { _url = (_url prefix)+ { _path = _path (_url prefix) <> [Capture str $ makeEncoder @Text @a]+ }+ , _functionName = _functionName prefix <> ["by", str]+ }+ where+ str =+ toS $ symbolVal $ Proxy @symbol++instance (KnownSymbol symbol, HasElmEncoder Text a, HasElmEndpoints api)+ => HasElmEndpoints (Servant.CaptureAll symbol a :> api) where+ elmEndpoints' prefix =+ elmEndpoints' @api prefix+ { _url = (_url prefix)+ { _path = _path (_url prefix) <> [Capture str $ makeEncoder @Text @a]+ }+ , _functionName = _functionName prefix <> ["by", str]+ }+ where+ str =+ toS $ symbolVal $ Proxy @symbol++instance (Servant.ReflectMethod method, HasElmDecoder Aeson.Value a, list ~ '[Servant.JSON])+ => HasElmEndpoints (Servant.Verb method status list a) where+ elmEndpoints' prefix =+ [ prefix+ { _method = method+ , _returnType = Just $ makeDecoder @Aeson.Value @a+ , _functionName = Text.toLower (toS method) : _functionName prefix+ }+ ]+ where+ method =+ Servant.reflectMethod $ Proxy @method++instance+ ( Servant.SBoolI (Servant.FoldRequired mods)+ , KnownSymbol symbol+ , HasElmEncoder (Servant.RequiredArgument mods Text) (Servant.RequiredArgument mods a)+ , HasElmEndpoints api+ ) => HasElmEndpoints (Servant.Header' mods symbol a :> api) where+ elmEndpoints' prefix =+ elmEndpoints' @api prefix+ { _headers = _headers prefix <>+ [ ( toS $ symbolVal $ Proxy @symbol+ , makeEncoder @(Servant.RequiredArgument mods Text) @(Servant.RequiredArgument mods a)+ , case Servant.sbool @(Servant.FoldRequired mods) of+ Servant.STrue ->+ True++ Servant.SFalse ->+ False+ )+ ]+ }++instance+ ( Servant.SBoolI (Servant.FoldRequired mods)+ , KnownSymbol symbol+ , HasElmEncoder (Servant.RequiredArgument mods Text) (Servant.RequiredArgument mods a)+ , HasElmEndpoints api+ ) => HasElmEndpoints (Servant.QueryParam' mods symbol a :> api) where+ elmEndpoints' prefix =+ elmEndpoints' @api prefix+ { _url = (_url prefix)+ { _queryString =+ _queryString (_url prefix) <>+ [ ( toS $ symbolVal $ Proxy @symbol+ , case Servant.sbool @(Servant.FoldRequired mods) of+ Servant.STrue ->+ Required++ Servant.SFalse ->+ Optional+ , makeEncoder @(Servant.RequiredArgument mods Text) @(Servant.RequiredArgument mods a)+ )+ ]+ }+ }++instance (KnownSymbol symbol, HasElmEncoder Text a, HasElmEndpoints api)+ => HasElmEndpoints (Servant.QueryParams symbol a :> api) where+ elmEndpoints' prefix =+ elmEndpoints' @api prefix+ { _url = (_url prefix)+ { _queryString =+ _queryString (_url prefix) <>+ [ ( toS $ symbolVal $ Proxy @symbol+ , List+ , makeEncoder @Text @a+ )+ ]+ }+ }++instance (KnownSymbol symbol, HasElmEndpoints api)+ => HasElmEndpoints (Servant.QueryFlag symbol :> api) where+ elmEndpoints' prefix =+ elmEndpoints' @api prefix+ { _url = (_url prefix)+ { _queryString =+ _queryString (_url prefix) <>+ [ ( toS $ symbolVal $ Proxy @symbol+ , Flag+ , Encoder "Basics.identity" "Basics.Bool"+ )+ ]+ }+ }++instance (HasElmEncoder Aeson.Value a, HasElmEndpoints api, list ~ '[Servant.JSON])+ => HasElmEndpoints (Servant.ReqBody' mods list a :> api) where+ elmEndpoints' prefix =+ elmEndpoints' @api prefix+ { _body = Just $ makeEncoder @Aeson.Value @a+ }++instance (KnownSymbol path, HasElmEndpoints api) => HasElmEndpoints (path :> api) where+ elmEndpoints' prefix =+ elmEndpoints' @api prefix+ { _url = (_url prefix)+ { _path = _path (_url prefix) <> [Static path]+ }+ , _functionName = _functionName prefix <> [path]+ }+ where+ path =+ toS $ symbolVal $ Proxy @path++instance HasElmEndpoints api => HasElmEndpoints (Servant.RemoteHost :> api) where+ elmEndpoints' = elmEndpoints' @api++instance HasElmEndpoints api => HasElmEndpoints (Servant.IsSecure :> api) where+ elmEndpoints' = elmEndpoints' @api++instance HasElmEndpoints api => HasElmEndpoints (Servant.Vault :> api) where+ elmEndpoints' = elmEndpoints' @api++instance HasElmEndpoints api => HasElmEndpoints (Servant.WithNamedContext name context api) where+ elmEndpoints' = elmEndpoints' @api++instance HasElmEndpoints api => HasElmEndpoints (Servant.HttpVersion :> api) where+ elmEndpoints' = elmEndpoints' @api++instance HasElmEndpoints api => HasElmEndpoints (Servant.Summary summary :> api) where+ elmEndpoints' = elmEndpoints' @api++instance HasElmEndpoints api => HasElmEndpoints (Servant.Description description :> api) where+ elmEndpoints' = elmEndpoints' @api++-------------------------------------------------------------------------------+-- Orphans++instance HasElmDefinition Servant.NoContent where+ elmDefinition =+ Definition.Type "NoContent.NoContent" [("NoContent", [])]++instance HasElmType Servant.NoContent where+ elmType =+ "NoContent.NoContent"++instance HasElmDecoder Aeson.Value Servant.NoContent where+ elmDecoder =+ Expression.App "Json.Decode.succeed" "NoContent.NoContent"
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"