servant-purescript 0.3.0.0 → 0.3.1.0
raw patch · 4 files changed
+200/−105 lines, 4 files
Files
- servant-purescript.cabal +2/−1
- src/Servant/PureScript.hs +16/−15
- src/Servant/PureScript/MakeRequests.hs +159/−0
- src/Servant/PureScript/Subscriber.hs +23/−89
servant-purescript.cabal view
@@ -1,5 +1,5 @@ name: servant-purescript-version: 0.3.0.0+version: 0.3.1.0 synopsis: Generate PureScript accessor functions for you servant API description: Please see README.md homepage: https://github.com/eskimor/servant-purescript#readme@@ -20,6 +20,7 @@ exposed-modules: Servant.PureScript.Internal , Servant.PureScript.CodeGen , Servant.PureScript.Subscriber+ , Servant.PureScript.MakeRequests , Servant.PureScript , Servant.API.BrowserHeader
src/Servant/PureScript.hs view
@@ -44,10 +44,11 @@ import Servant.PureScript.CodeGen import Servant.PureScript.Internal import qualified Servant.PureScript.Subscriber as SubGen+import qualified Servant.PureScript.MakeRequests as MakeRequests import System.Directory import System.FilePath import System.IO (IOMode (..), withFile)-import Text.PrettyPrint.Mainland (hPutDocLn)+import Text.PrettyPrint.Mainland (hPutDocLn, Doc) -- | Standard entry point - just create a purescript module with default settings -- for accessing the servant API.@@ -64,22 +65,22 @@ , HasBridge bridgeSelector ) => Settings -> FilePath -> Proxy bridgeSelector -> Proxy api -> IO () writeAPIModuleWithSettings opts root pBr pAPI = do- let apiList = apiToList pAPI pBr- let contents = genModule opts apiList- unlessM (doesDirectoryExist mDir) $ createDirectoryIfMissing True mDir- withFile mPath WriteMode $ flip hPutDocLn contents+ writeModule (opts ^. apiModuleName) genModule when (opts ^. generateSubscriberAPI) $ do- let msContents = SubGen.genModule opts apiList- unlessM (doesDirectoryExist msDir) $ createDirectoryIfMissing True msDir- withFile msPath WriteMode $ flip hPutDocLn msContents+ writeModule (opts ^. apiModuleName <> ".Subscriber") SubGen.genModule+ writeModule (opts ^. apiModuleName <> ".MakeRequests") MakeRequests.genModule where- moduleToFile mName = (joinPath . map T.unpack . T.splitOn "." $ mName) <> ".purs"- mFile = moduleToFile $ _apiModuleName opts- msFile = moduleToFile $ _apiModuleName opts <> ".Subscriber"- mPath = root </> mFile- msPath = root </> msFile- mDir = takeDirectory mPath- msDir = takeDirectory msPath+ apiList = apiToList pAPI pBr++ writeModule :: Text -> (Settings -> [Req PSType] -> Doc) -> IO ()+ writeModule mName genModule' = let+ fileName = (joinPath . map T.unpack . T.splitOn "." $ mName) <> ".purs"+ mPath = root </> fileName+ mDir = takeDirectory mPath+ contents = genModule' opts apiList+ in do+ unlessM (doesDirectoryExist mDir) $ createDirectoryIfMissing True mDir+ withFile mPath WriteMode $ flip hPutDocLn contents -- | Use this function for implementing 'parseUrlPiece' in your FromHttpApiData instances
+ src/Servant/PureScript/MakeRequests.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}++-- TODO: This module duplicates quite a lot of code from CodeGen.hs.+module Servant.PureScript.MakeRequests where++import Control.Lens hiding (List)+import Data.Map (Map)+import Data.Maybe (mapMaybe, maybeToList)+import Data.Proxy (Proxy (Proxy))+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Language.PureScript.Bridge+import Language.PureScript.Bridge (buildBridge, defaultBridge)+import Language.PureScript.Bridge.PSTypes (psString, psUnit)+import Network.HTTP.Types.URI (urlEncode)+import Servant.Foreign+import Servant.PureScript.CodeGen hiding (genBuildHeader,+ genBuildHeaders,+ genBuildPath,+ genBuildQuery,+ genBuildQueryArg,+ genBuildSegment, genFnBody,+ genFunction, genModule,+ genSignature)+import Servant.PureScript.Internal+import Servant.Subscriber.Request (HttpRequest)+import Text.PrettyPrint.Mainland++subscriberImportLines :: Map Text ImportLine+subscriberImportLines = importsFromList+ [+ ImportLine "Servant.Subscriber.Subscriptions" (Set.fromList [ "Subscriptions"+ , "makeSubscriptions"+ ])+ , ImportLine "Servant.Subscriber.Util" (Set.fromList [ "toUserType"+ , "subGenNormalQuery"+ , "subGenListQuery"+ , "subGenFlagQuery"+ , "TypedToUser"+ ])+ , ImportLine "Servant.Subscriber" (Set.fromList ["ToUserType"])+ , ImportLine "Servant.Subscriber.Request" (Set.fromList ["HttpRequest(..)"])+ , ImportLine "Servant.Subscriber.Types" (Set.fromList ["Path(..)"])+ , ImportLine "Data.Tuple" (Set.fromList ["Tuple(..)"])+ ]++genModule :: Settings -> [Req PSType] -> Doc+genModule opts reqs = let+ allParams = concatMap reqToParams reqs+ rParams = getReaderParams opts allParams+ apiImports = reqsToImportLines reqs+ webAPIImports = importsFromList [+ ImportLine (opts ^. apiModuleName) (Set.fromList ["SPParams_(..)"])+ ]+ imports = _standardImports opts+ `mergeImportLines` apiImports+ `mergeImportLines` subscriberImportLines+ `mergeImportLines` webAPIImports+ moduleName = _apiModuleName opts <> ".MakeRequests"+ in+ genModuleHeader moduleName imports+ </> (docIntercalate line . map (genFunction rParams)) reqs++genFunction :: [PSParam] -> Req PSType -> Doc+genFunction allRParams req = let+ rParamsSet = Set.fromList allRParams+ fnName = req ^. reqFuncName ^. camelCaseL+ allParamsList = baseURLParam : reqToParams req+ allParams = Set.fromList allParamsList+ fnParams = filter (not . flip Set.member rParamsSet) allParamsList -- Use list not set, as we don't want to change order of parameters+ rParams = Set.toList $ rParamsSet `Set.intersection` allParams++ pTypes = map _pType fnParams+ pNames = map _pName fnParams+ signature = genSignature fnName pTypes (Just psHttpRequest)+ body = genFnHead fnName pNames <+> genFnBody rParams req+ in signature </> body+++genSignature :: Text -> [PSType] -> Maybe PSType -> Doc+genSignature = genSignatureBuilder $ "forall m." <+/> "MonadReader (SPSettings_ SPParams_) m" <+/> "=>"++genFnBody :: [PSParam] -> Req PSType -> Doc+genFnBody rParams req = "do"+ </> indent 2 (+ "spOpts_' <- ask"+ </> "let spOpts_ = case spOpts_' of SPSettings_ o -> o"+ </> "let spParams_ = case spOpts_.params of SPParams_ ps_ -> ps_"+ </> genGetReaderParams rParams+ </> hang 6 ("let httpMethod =" <+> dquotes (req ^. reqMethod ^. to T.decodeUtf8 ^. to strictText))+ </> hang 6 ("let reqPath =" <+> genBuildPath (req ^. reqUrl . path))+ </> "let reqHeaders =" </> indent 6 (req ^. reqHeaders ^. to genBuildHeaders)+ </> "let reqQuery =" </> indent 6 (req ^. reqUrl ^. queryStr . to genBuildQuery)+ </> "let spReq = " <> hang 2 ("HttpRequest" </>+ "{ httpMethod:" <+> "httpMethod"+ </> ", httpPath:" <+> "reqPath"+ </> ", httpHeaders:" <+> "reqHeaders"+ </> ", httpQuery:" <+> "reqQuery"+ </> ", httpBody:" <+> case req ^. reqBody of+ Nothing -> "\"\""+ Just _ -> "printJson <<< encodeJson $ reqBody"+ </> "}")+ </> "pure spReq"+ ) <> "\n"++----------+genBuildPath :: Path PSType -> Doc+genBuildPath p = "Path ["+ <> (docIntercalate (softline <> ", ") . map (genBuildSegment . unSegment)) p+ <> "]"++genBuildSegment :: SegmentType PSType -> Doc+genBuildSegment (Static (PathSegment seg)) = dquotes $ strictText seg+genBuildSegment (Cap arg) = "gDefaultToURLPiece" <+> arg ^. argName ^. to unPathSegment ^. to psVar++----------+genBuildQuery :: [QueryArg PSType] -> Doc+genBuildQuery [] = "[]"+genBuildQuery args = docIntercalate (softline <> "<> ") . map genBuildQueryArg $ args++genBuildQueryArg :: QueryArg PSType -> Doc+genBuildQueryArg arg = case arg ^. queryArgType of+ Normal -> genQueryEncoding "subGenNormalQuery"+ Flag -> genQueryEncoding "subGenFlagQuery"+ List -> genQueryEncoding "subGenListQuery"+ where+ argText = arg ^. queryArgName ^. argName ^. to unPathSegment+ argDoc = strictText argText+ genQueryEncoding fn = fn <+> dquotes argDoc <+> psVar argText++-----------++genBuildHeaders :: [HeaderArg PSType] -> Doc+genBuildHeaders = list . map genBuildHeader++genBuildHeader :: HeaderArg PSType -> Doc+genBuildHeader (HeaderArg arg) = let+ argText = arg ^. argName ^. to unPathSegment+ argDoc = strictText argText+ in+ align $ "Tuple" <+> dquotes argDoc <+> "(gDefaultToURLPiece" <+> psVar argText <> ")"+genBuildHeader (ReplaceHeaderArg _ _) = error "ReplaceHeaderArg - not yet implemented!"++++psHttpRequest :: PSType+psHttpRequest = let+ haskType' = mkTypeInfo (Proxy :: Proxy HttpRequest)+ bridge = buildBridge defaultBridge+ in+ bridge haskType'
src/Servant/PureScript/Subscriber.hs view
@@ -6,7 +6,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} --- TODO: This module duplicates quite a lot of code from CodeGen.hs.+-- TODO: This module duplicates quite a lot of code from MakeRequests.hs. module Servant.PureScript.Subscriber where import Control.Lens hiding (List)@@ -20,35 +20,18 @@ import Language.PureScript.Bridge.PSTypes (psString, psUnit) import Network.HTTP.Types.URI (urlEncode) import Servant.Foreign-import Servant.PureScript.CodeGen hiding (genBuildHeader,- genBuildHeaders,- genBuildPath,- genBuildQuery,- genBuildQueryArg,- genBuildSegment, genFnBody,+import Servant.PureScript.CodeGen (docIntercalate, genFnHead,+ genModuleHeader,+ getReaderParams, psVar,+ reqToParams,+ reqsToImportLines,+ genSignatureBuilder)+import Servant.PureScript.Internal+import Servant.PureScript.MakeRequests hiding (genFnBody, genFunction, genModule, genSignature)-import Servant.PureScript.Internal import Text.PrettyPrint.Mainland -subscriberImportLines :: Map Text ImportLine-subscriberImportLines = importsFromList- [- ImportLine "Servant.Subscriber.Subscriptions" (Set.fromList [ "Subscriptions"- , "makeSubscriptions"- ])- , ImportLine "Servant.Subscriber.Util" (Set.fromList [ "toUserType"- , "subGenNormalQuery"- , "subGenListQuery"- , "subGenFlagQuery"- , "TypedToUser"- ])- , ImportLine "Servant.Subscriber" (Set.fromList ["ToUserType"])- , ImportLine "Servant.Subscriber.Request" (Set.fromList ["HttpRequest(..)"])- , ImportLine "Servant.Subscriber.Types" (Set.fromList ["Path(..)"])- , ImportLine "Data.Tuple" (Set.fromList ["Tuple(..)"])- ]- genModule :: Settings -> [Req PSType] -> Doc genModule opts allReqs = let isSubscribable :: Req PSType -> Bool@@ -67,6 +50,8 @@ moduleName = _apiModuleName opts <> ".Subscriber" in genModuleHeader moduleName imports+ </> "import" <+> opts ^. apiModuleName . to strictText <> ".MakeRequests as MakeRequests"+ </> "" </> (docIntercalate line . map (genFunction rParams)) reqs genFunction :: [PSParam] -> Req PSType -> Doc@@ -77,79 +62,28 @@ Nothing -> psUnit Just t -> t allParamsList = makeTypedToUserParam responseType : baseURLParam : reqToParams req- allParams = Set.fromList allParamsList fnParams = filter (not . flip Set.member rParamsSet) allParamsList -- Use list not set, as we don't want to change order of parameters- rParams = Set.toList $ rParamsSet `Set.intersection` allParams pTypes = map _pType fnParams pNames = map _pName fnParams signature = genSignature fnName pTypes (Just psSubscriptions)- body = genFnHead fnName pNames <+> genFnBody rParams req+ -- | Well - if you really want to put the ToUserType parameter into the Reader monad - this will crash:+ body = genFnHead fnName pNames <+> genFnBody fnName (tail pNames) in signature </> body genSignature :: Text -> [PSType] -> Maybe PSType -> Doc genSignature = genSignatureBuilder $ "forall m a." <+/> "MonadReader (SPSettings_ SPParams_) m" <+/> "=>" -genFnBody :: [PSParam] -> Req PSType -> Doc-genFnBody rParams req = "do"- </> indent 2 (- "spOpts_' <- ask"- </> "let spOpts_ = case spOpts_' of SPSettings_ o -> o"- </> "let spParams_ = case spOpts_.params of SPParams_ ps_ -> ps_"- </> genGetReaderParams rParams- </> hang 6 ("let httpMethod =" <+> dquotes (req ^. reqMethod ^. to T.decodeUtf8 ^. to strictText))- </> hang 6 ("let reqPath =" <+> genBuildPath (req ^. reqUrl . path))- </> "let reqHeaders =" </> indent 6 (req ^. reqHeaders ^. to genBuildHeaders)- </> "let reqQuery =" </> indent 6 (req ^. reqUrl ^. queryStr . to genBuildQuery)- </> "let spReq = " <> hang 2 ("HttpRequest" </>- "{ httpMethod:" <+> "httpMethod"- </> ", httpPath:" <+> "reqPath"- </> ", httpHeaders:" <+> "reqHeaders"- </> ", httpQuery:" <+> "reqQuery"- </> ", httpBody:" <+> case req ^. reqBody of- Nothing -> "\"\""- Just _ -> "printJson <<< encodeJson $ reqBody"- </> "}")- </> "pure $ makeSubscriptions spReq (toUserType " <> strictText subscriberToUserId <> ")"- )-------------genBuildPath :: Path PSType -> Doc-genBuildPath p = "Path ["- <> (docIntercalate (softline <> ", ") . map (genBuildSegment . unSegment)) p- <> "]"--genBuildSegment :: SegmentType PSType -> Doc-genBuildSegment (Static (PathSegment seg)) = dquotes $ strictText seg-genBuildSegment (Cap arg) = "gDefaultToURLPiece" <+> arg ^. argName ^. to unPathSegment ^. to psVar-------------genBuildQuery :: [QueryArg PSType] -> Doc-genBuildQuery [] = "[]"-genBuildQuery args = docIntercalate (softline <> "<> ") . map genBuildQueryArg $ args+genFnBody :: Text -> [Text] -> Doc+genFnBody fName params = "do"+ </> indent 2 (+ "spReq <- MakeRequests." <> genFnCall fName params+ </> "pure $ makeSubscriptions spReq (toUserType " <> strictText subscriberToUserId <> ")"+ ) <> "\n" -genBuildQueryArg :: QueryArg PSType -> Doc-genBuildQueryArg arg = case arg ^. queryArgType of- Normal -> genQueryEncoding "subGenNormalQuery"- Flag -> genQueryEncoding "subGenFlagQuery"- List -> genQueryEncoding "subGenListQuery"+genFnCall :: Text -> [Text] -> Doc+genFnCall fnName params = fName <+> align (docIntercalate softline docParams) where- argText = arg ^. queryArgName ^. argName ^. to unPathSegment- argDoc = strictText argText- genQueryEncoding fn = fn <+> dquotes argDoc <+> psVar argText---------------genBuildHeaders :: [HeaderArg PSType] -> Doc-genBuildHeaders = list . map genBuildHeader--genBuildHeader :: HeaderArg PSType -> Doc-genBuildHeader (HeaderArg arg) = let- argText = arg ^. argName ^. to unPathSegment- argDoc = strictText argText- in- align $ "Tuple" <+> dquotes argDoc <+> "(gDefaultToURLPiece" <+> psVar argText <> ")"-genBuildHeader (ReplaceHeaderArg _ _) = error "ReplaceHeaderArg - not yet implemented!"--+ docParams = map psVar params+ fName = strictText fnName