servant-to-elm 0.4.1.0 → 0.4.2.0
raw patch · 5 files changed
+520/−261 lines, 5 filesdep +bytestringdep +directorydep +filepathdep ~generics-sopdep ~haskell-to-elmdep ~servant
Dependencies added: bytestring, directory, filepath, hspec, prettyprinter, process, temporary
Dependency ranges changed: generics-sop, haskell-to-elm, servant, unordered-containers
Files
- CHANGELOG.md +5/−0
- servant-to-elm.cabal +20/−9
- src/Servant/To/Elm.hs +363/−251
- test/Spec.hs +66/−1
- test/TestExampleServer.hs +66/−0
CHANGELOG.md view
@@ -2,6 +2,11 @@ ## Unreleased changes +## 0.4.2.0++- Use the `Url.Builder` module from `elm/url` to build URLs (https://github.com/folq/servant-to-elm/pull/6 by https://github.com/rl-king)+- Update `haskell-to-elm` bounds to latest version 0.3.2+ ## 0.4.1.0 - Update to `elm-syntax-0.3.0.0` and `haskell-to-elm-0.3.0.0`, adding support for parameterised types
servant-to-elm.cabal view
@@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.2.+-- This file has been generated from package.yaml by hpack version 0.34.3. -- -- see: https://github.com/sol/hpack ----- hash: 76dda62e30819622cd48fbd148358cdb0b25fddec8951c2cca91efd425813fcb+-- hash: 600be4c131caa5290786ee59b7f6bb34535ebd50ff0b013c8529535fae575747 name: servant-to-elm-version: 0.4.1.0+version: 0.4.2.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@@ -18,7 +18,8 @@ copyright: 2019 Olle Fredriksson license: BSD3 license-file: LICENSE-tested-with: GHC == 8.4.3, GHC == 8.6.5, GHC == 8.8.3+tested-with:+ GHC == 8.4.3, GHC == 8.6.5, GHC == 8.8.3 build-type: Simple extra-source-files: README.md@@ -46,9 +47,9 @@ , base >=4.7 && <5 , bound >=2.0.0 , elm-syntax >=0.3.0 && <0.3.1- , haskell-to-elm >=0.3.0 && <0.3.1+ , haskell-to-elm >=0.3.0 && <0.3.3 , http-types >=0.12.0- , servant >=0.16.0+ , servant >=0.16.0 && <0.17.0 , servant-multipart >=0.11.0 , text >=1.2.0 default-language: Haskell2010@@ -66,7 +67,7 @@ , bound >=2.0.0 , elm-syntax >=0.3.0 && <0.3.1 , generics-sop- , haskell-to-elm >=0.3.0 && <0.3.1+ , haskell-to-elm >=0.3.0 && <0.3.3 , http-types >=0.12.0 , servant , servant-multipart >=0.11.0@@ -81,6 +82,7 @@ type: exitcode-stdio-1.0 main-is: Spec.hs other-modules:+ TestExampleServer Paths_servant_to_elm hs-source-dirs: test@@ -89,11 +91,20 @@ aeson >=1.4.0 , base >=4.7 && <5 , bound >=2.0.0+ , bytestring >=0.10+ , directory >=1.3 , elm-syntax >=0.3.0 && <0.3.1- , haskell-to-elm >=0.3.0 && <0.3.1+ , filepath >=1.4+ , generics-sop >=0.4+ , haskell-to-elm >=0.3.0 && <0.3.3+ , hspec >=2.7 , http-types >=0.12.0- , servant >=0.16.0+ , prettyprinter >=1.2+ , process >=1.6+ , servant >=0.16.0 && <0.17.0 , servant-multipart >=0.11.0 , servant-to-elm+ , temporary >=1.3 , text >=1.2.0+ , unordered-containers >=0.2 default-language: Haskell2010
src/Servant/To/Elm.hs view
@@ -13,7 +13,20 @@ {-# language TypeOperators #-} {-# language UndecidableInstances #-} {-# options_ghc -fno-warn-orphans #-}-module Servant.To.Elm where+module Servant.To.Elm+ ( elmEndpointDefinition+ , elmEndpointRequestInfo+ , HasElmEndpoints(..)+ , elmEndpoints+ , Endpoint(..)+ , PathSegment (..)+ , QueryParamType(..)+ , URL(..)+ , Encoder(..)+ , Decoder(..)+ , makeEncoder+ , makeDecoder+ ) where import qualified Bound import qualified Data.Aeson as Aeson@@ -42,6 +55,9 @@ import Language.Haskell.To.Elm -- | Generate an Elm function for making a request to a Servant endpoint.+--+-- See 'elmEndpointRequestInfo' if you need more flexibility,+-- such as setting timeouts. elmEndpointDefinition :: Expression Void -- ^ The URL base of the endpoint -> Name.Module -- ^ The module that the function should be generated into@@ -49,27 +65,11 @@ -> Definition elmEndpointDefinition urlBase moduleName endpoint = Definition.Constant- (Name.Qualified moduleName functionName)+ (Name.Qualified moduleName (functionName endpoint)) 0 (Bound.toScope $ vacuous $ elmTypeSig)- (error "expression not closed" <$> lambdaArgs argNames elmLambdaBody)+ (error "expression not closed" <$> lambdaArgs (argNames endpoint) 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@@ -78,7 +78,7 @@ | (_, arg, _) <- _headers endpoint ] , [ _encodedType arg- | Capture _ (_, arg) <- numberedPathSegments+ | Capture _ (_, arg) <- numberedPathSegments endpoint ] , [ case type_ of Required ->@@ -121,264 +121,124 @@ [Type.tuple "Http.Error" (Type.App "Maybe.Maybe" $ Type.Record [("metadata", "Http.Metadata"), ("body", "String.String")]), type_] ) - 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 $ Text.decodeUtf8 $ _method endpoint)- , ("headers", elmHeaders)+ , ("headers", elmHeaders endpoint) , ("url", elmUrl)- , ("body", elmBody)- , ("expect", elmExpect)+ , ("body", elmBody endpoint)+ , ("expect", elmExpect endpoint) , ("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)+ Expression.apps+ "Url.Builder.crossOrigin"+ [ vacuous urlBase+ , Expression.List $ fmap elmPathSegment (numberedPathSegments endpoint)+ , Expression.App "List.concat" $ Expression.List (elmParams endpoint)+ ] - where- withoutParams =- Expression.apps- "String.join"- [ Expression.String "/"- , Expression.List $ vacuous urlBase : fmap elmPathSegment numberedPathSegments+-- | Generate an Elm function for creating information needed to make an HTTP request.+-- This gives the user flexibility in how to actually make the request.+--+-- For example, they can use the <https://package.elm-lang.org/packages/elm/http/latest/Http#request>+-- function and provide it with their own @timeout@ and @tracker@ arguments.+--+-- It also leaves building the final URL to the Elm user.+-- This gives them the flexibility to do things like vary the domain used at runtime+-- based on whether the app's in staging or production.+-- Note that they must remember to use BOTH @urlPath@ and @urlQueryParams@.+elmEndpointRequestInfo+ :: Name.Module -- ^ The module that the function should be generated into+ -> Endpoint -- ^ A description of the endpoint+ -> Definition+elmEndpointRequestInfo moduleName endpoint =+ Definition.Constant+ (Name.Qualified moduleName (functionName endpoint))+ 0+ (Bound.toScope $ vacuous $ elmTypeSig)+ (error "expression not closed" <$> lambdaArgs (argNames endpoint) elmLambdaBody)+ where+ elmTypeSig :: Type Void+ elmTypeSig =+ Type.funs+ (concat+ [ [ _encodedType arg+ | (_, arg, _) <- _headers endpoint ]-- 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]- )- ]+ , [ _encodedType arg+ | Capture _ (_, arg) <- numberedPathSegments endpoint+ ]+ , [ case type_ of+ Required ->+ vacuous $ _encodedType arg + Optional ->+ vacuous $ _encodedType arg - elmHeaders =- let- headerDecoder i name arg =- Expression.apps- "Http.header"- [ Expression.String name- , Expression.App- (vacuous $ _encoder arg)- (pure $ headerArgName i)- ]+ Flag ->+ vacuous $ _encodedType arg - optionalHeaderDecoder i name arg =- Expression.apps- "Maybe.map"- [ Expression.App- "Http.header"- (Expression.String name)- , Expression.App- (vacuous $ _encoder arg)- (pure $ headerArgName i)+ List ->+ vacuous $ Type.App "List.List" $ _encodedType arg+ | (_, type_, arg) <- _queryString $ _url endpoint ]- 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+ , [ _encodedType body+ | Just (_, body) <- [_body 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"+ )+ elmReturnType - Just (bodyType, body) ->- Expression.App- (vacuous bodyType)- (Expression.App (vacuous $ _encoder body) $ pure bodyArgName)+ elmReturnType =+ let+ type_ =+ case _returnType endpoint of+ Nothing ->+ "Basics.()" - 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 $- case _returnType endpoint of- Nothing ->- error "elmRequest: No return type" -- TODO?+ Just (Left Servant.NoContent) ->+ "Basics.()" - Just (Left Servant.NoContent) ->- Expression.if_ (Expression.apps ("Basics.==") [pure $ Bound.B 1, Expression.String ""])- (Expression.App "Result.Ok" "Basics.()")- (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)])- )+ Just (Right decoder) ->+ _decodedType decoder - Just (Right elmReturnDecoder) ->- 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" [vacuous $ _decoder elmReturnDecoder, pure $ Bound.B 1]- ]- )- ]+ expectType =+ Type.App+ "Http.Expect"+ (Type.apps+ "Result.Result"+ [ Type.tuple+ "Http.Error"+ (Type.App "Maybe.Maybe" $ Type.Record [("metadata", "Http.Metadata"), ("body", "String.String")])+ , type_+ ])+ in+ Type.Record+ [ ("method", "String.String")+ , ("headers", Type.App "List.List" "Http.Header")+ , ("urlPath", Type.App "List.List" "String.String")+ , ("urlQueryParams", Type.App "List.List" "Url.Builder.QueryParameter")+ , ("body", "Http.Body")+ , ("expect", expectType) ] - 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" <> fromString (show i)-- capturedArgName :: Int -> Text- capturedArgName i =- "capture" <> fromString (show i)-- paramArgName :: Int -> Text- paramArgName i =- "param" <> fromString (show i)+ elmLambdaBody :: Expression Text+ elmLambdaBody =+ Expression.Record+ [ ("method", Expression.String $ Text.decodeUtf8 $ _method endpoint)+ , ("headers", elmHeaders endpoint)+ , ("urlPath", Expression.List (fmap elmPathSegment (numberedPathSegments endpoint)))+ , ("urlQueryParams", Expression.List (elmParams endpoint))+ , ("body", elmBody endpoint)+ , ("expect", elmExpect endpoint)+ ] ------------------------------------------------------------------------------- -- * Endpoints@@ -635,3 +495,255 @@ instance HasElmEncoder (Servant.MultipartData tag) (Servant.MultipartData tag) where elmEncoder = "Basics.identity"++-------------------------------------------------------------------------------+-- * Internal++elmHeaders :: Endpoint -> Expression Text+elmHeaders endpoint =+ 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+ ]+ ]++headerArgName :: Int -> Text+headerArgName i =+ "header" <> fromString (show i)++numberedPathSegments :: Endpoint -> [PathSegment (Int, Encoder)]+numberedPathSegments endpoint =+ 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'++elmParams :: Endpoint -> [Expression Text]+elmParams endpoint =+ [ case type_ of+ Required ->+ Expression.List+ [ Expression.apps "Url.Builder.string"+ [ Expression.String name, encode (pure $ paramArgName i) ]+ ]++ Optional ->+ Expression.apps+ "Maybe.withDefault"+ [ Expression.List []+ , Expression.apps "Maybe.map"+ [ "List.singleton" Expression.<<+ Expression.App "Url.Builder.string" (Expression.String name)+ , encode $ pure $ paramArgName i+ ]+ ]++ Flag ->+ Expression.if_+ (pure $ paramArgName i)+ (Expression.List+ [ Expression.apps "Url.Builder.string"+ [ Expression.String name+ , Expression.String "true"+ ]+ ]+ )+ (Expression.List [])++ List ->+ Expression.apps+ "List.map"+ [ Expression.App "Url.Builder.string" (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+ ]++paramArgName :: Int -> Text+paramArgName i =+ "param" <> fromString (show i)++elmPathSegment :: PathSegment (Int, Encoder) -> Expression Text+elmPathSegment pathSegment =+ case pathSegment of+ Static s ->+ Expression.String s++ Capture _ (i, arg) ->+ Expression.App+ (vacuous $ _encoder arg)+ (pure $ capturedArgName i)++capturedArgName :: Int -> Text+capturedArgName i =+ "capture" <> fromString (show i)++elmBody :: Endpoint -> Expression Text+elmBody endpoint =+ case _body endpoint of+ Nothing ->+ "Http.emptyBody"++ Just (bodyType, body) ->+ Expression.App+ (vacuous bodyType)+ (Expression.App (vacuous $ _encoder body) $ pure bodyArgName)++elmExpect :: Endpoint -> Expression a+elmExpect endpoint =+ 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 $+ case _returnType endpoint of+ Nothing ->+ error "elmRequest: No return type" -- TODO?++ Just (Left Servant.NoContent) ->+ Expression.if_ (Expression.apps ("Basics.==") [pure $ Bound.B 1, Expression.String ""])+ (Expression.App "Result.Ok" "Basics.()")+ (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)])+ )++ Just (Right elmReturnDecoder) ->+ 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" [vacuous $ _decoder elmReturnDecoder, pure $ Bound.B 1]+ ]+ )+ ]+ ]++bodyArgName :: Text+bodyArgName =+ "body"++lambdaArgs :: [Text] -> Expression Text -> Expression Text+lambdaArgs args rhs =+ case args of+ [] ->+ rhs++ arg:args' ->+ Expression.Lam $ Bound.abstract1 arg $ lambdaArgs args' rhs++argNames :: Endpoint -> [Text]+argNames endpoint =+ concat+ [ [ headerArgName i+ | (i, _) <- zip [0..] $ _headers endpoint+ ]+ , [ capturedArgName i+ | Capture _ (i, _) <- numberedPathSegments endpoint+ ]+ , [ paramArgName i+ | (i, _) <- zip [0..] $ _queryString $ _url endpoint+ ]+ , [ bodyArgName+ | Just _ <- [_body endpoint]+ ]+ ]++functionName :: Endpoint -> Text+functionName endpoint =+ case Text.filter Char.isAlphaNum <$> _functionName endpoint of+ [] ->+ ""++ firstPart:rest ->+ firstPart <> foldMap capitalise rest+ where+ capitalise s =+ case Text.uncons s of+ Nothing ->+ ""++ Just (c, s') ->+ Text.cons (Char.toUpper c) s'
test/Spec.hs view
@@ -1,2 +1,67 @@+{-# language OverloadedStrings #-}+{-# language ScopedTypeVariables #-}+module Main where++import qualified Data.ByteString as BS+import Data.Foldable+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import qualified Data.List as List+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Text.Encoding (encodeUtf8)+import qualified Data.Text.Prettyprint.Doc as Pretty+import System.Directory+import System.FilePath+import System.IO.Temp+import System.Process (callCommand)+import Test.Hspec++import qualified TestExampleServer+ main :: IO ()-main = putStrLn "Test suite not yet implemented"+main =+ hspec spec++spec :: Spec+spec = do+ describe "servant-to-elm" $ do+ it "elmEndpointDefinition" $+ withTempDir (testElmClient TestExampleServer.definitionModules)+ it "elmEndpointRequestInfo" $+ withTempDir (testElmClient TestExampleServer.requestInfoModules)+ where+ withTempDir =+ withSystemTempDirectory+ "servant-to-elm" -- temp dir name template++testElmClient :: HashMap [Text] (Pretty.Doc ann) -> FilePath -> IO ()+testElmClient elmModules tempDir = do+ let srcDir = tempDir </> "src"+ createDirectory srcDir+ createDirectory (srcDir </> "Api")++ for_ (List.sortOn fst (HashMap.toList elmModules)) $ \(moduleName, content) ->+ writeElmModule srcDir moduleName content++ copyFile ("test" </> "elm.json") (tempDir </> "elm.json")++ copyFile ("test" </> "Config.elm") (srcDir </> "Config.elm")++ compileGeneratedElm+ where+ compileGeneratedElm :: IO ()+ compileGeneratedElm =+ withCurrentDirectory tempDir $+ callCommand "elm make src/**.elm"++writeElmModule :: FilePath -> [Text] -> Pretty.Doc ann -> IO ()+writeElmModule srcDir moduleName content =+ BS.writeFile+ path+ (encodeUtf8 (Text.pack (show content)))+ where+ path :: FilePath+ path =+ foldl' (</>) mempty (srcDir : fmap Text.unpack moduleName)+ <> ".elm"
+ test/TestExampleServer.hs view
@@ -0,0 +1,66 @@+{-# language AllowAmbiguousTypes #-}+{-# language DataKinds #-}+{-# language DeriveAnyClass #-}+{-# language DeriveGeneric #-}+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language MultiParamTypeClasses #-}+{-# language OverloadedStrings #-}+{-# language PolyKinds #-}+{-# language ScopedTypeVariables #-}+{-# language TypeApplications #-}+{-# language TypeOperators #-}+module TestExampleServer where++import qualified Data.Aeson as Aeson+import Data.HashMap.Strict (HashMap)+import Data.Text (Text)+import qualified Data.Text.Prettyprint.Doc as Pretty+import GHC.Generics+import qualified Generics.SOP as SOP+import qualified Language.Elm.Definition as Elm (Definition)+import qualified Language.Elm.Pretty as Pretty+import qualified Language.Elm.Simplification as Simplification+import Servant.API+import Servant.To.Elm++import Language.Haskell.To.Elm++data User = User+ { name :: Text+ , age :: Int+ } deriving (Generic, Aeson.ToJSON, SOP.Generic, SOP.HasDatatypeInfo)++instance HasElmType User where+ elmDefinition =+ Just $ deriveElmTypeDefinition @User defaultOptions "Api.User.User"++instance HasElmDecoder Aeson.Value User where+ elmDecoderDefinition =+ Just $ deriveElmJSONDecoder @User defaultOptions Aeson.defaultOptions "Api.User.decoder"++instance HasElmEncoder Aeson.Value User where+ elmEncoderDefinition =+ Just $ deriveElmJSONEncoder @User defaultOptions Aeson.defaultOptions "Api.User.encoder"++type UserAPI+ = "user" :> Get '[JSON] User+ :<|> "user" :> ReqBody '[JSON] User :> PostNoContent '[JSON] NoContent++definitionModules :: HashMap [Text] (Pretty.Doc ann)+definitionModules =+ Pretty.modules (Simplification.simplifyDefinition <$> definitions)+ where+ definitions :: [Elm.Definition]+ definitions =+ map (elmEndpointDefinition "Config.urlBase" ["Api"]) (elmEndpoints @UserAPI)+ <> jsonDefinitions @User++requestInfoModules :: HashMap [Text] (Pretty.Doc ann)+requestInfoModules =+ Pretty.modules (Simplification.simplifyDefinition <$> definitions)+ where+ definitions :: [Elm.Definition]+ definitions =+ map (elmEndpointRequestInfo ["Api"]) (elmEndpoints @UserAPI)+ <> jsonDefinitions @User