servant-purescript 0.2.0.1 → 0.3.0.0
raw patch · 6 files changed
+231/−22 lines, 6 filesdep ~purescript-bridge
Dependency ranges changed: purescript-bridge
Files
- Readme.md +4/−5
- servant-purescript.cabal +4/−3
- src/Servant/PureScript.hs +22/−9
- src/Servant/PureScript/CodeGen.hs +12/−5
- src/Servant/PureScript/Internal.hs +34/−0
- src/Servant/PureScript/Subscriber.hs +155/−0
Readme.md view
@@ -18,11 +18,10 @@ It works! -Documentation is yet to come, but there is a usage example in examples/central-counter-which also employs a very early version of servant-subscriber-used for counter live updates.-The PureScript side of servant-subscriber is very low-level and will-change significantly in the future.+Documentation is yet to come, but there is a usage example in+examples/central-counter which also uses servant-subscriber used for counter+live updates. Generated code is only partly tested, especially Query parameters+are completely untested. For type translations purescript-bridge is used.
servant-purescript.cabal view
@@ -1,5 +1,5 @@ name: servant-purescript-version: 0.2.0.1+version: 0.3.0.0 synopsis: Generate PureScript accessor functions for you servant API description: Please see README.md homepage: https://github.com/eskimor/servant-purescript#readme@@ -19,6 +19,7 @@ hs-source-dirs: src exposed-modules: Servant.PureScript.Internal , Servant.PureScript.CodeGen+ , Servant.PureScript.Subscriber , Servant.PureScript , Servant.API.BrowserHeader @@ -32,7 +33,7 @@ , http-types , lens , mainland-pretty- , purescript-bridge >= 0.6 && < 0.7+ , purescript-bridge >= 0.6 , servant , servant-foreign , servant-server@@ -50,7 +51,7 @@ , containers , mainland-pretty , lens- , purescript-bridge >= 0.6 && < 0.7+ , purescript-bridge >= 0.6 , servant , servant-foreign , servant-purescript
src/Servant/PureScript.hs view
@@ -27,25 +27,30 @@ ) where +import Control.Lens+import Control.Monad (when) import Data.Aeson import Data.Bifunctor-import Data.ByteString (ByteString)-import qualified Data.ByteString.Lazy as BS+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as BS import Data.Monoid import Data.Proxy-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.Encoding as T+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T import Language.PureScript.Bridge-import Network.HTTP.Types (urlDecode, urlEncode)+import Network.HTTP.Types (urlDecode, urlEncode) import Servant.Foreign import Servant.PureScript.CodeGen import Servant.PureScript.Internal+import qualified Servant.PureScript.Subscriber as SubGen import System.Directory import System.FilePath-import System.IO (IOMode (..), withFile)-import Text.PrettyPrint.Mainland (hPutDocLn)+import System.IO (IOMode (..), withFile)+import Text.PrettyPrint.Mainland (hPutDocLn) +-- | Standard entry point - just create a purescript module with default settings+-- for accessing the servant API. writeAPIModule :: forall bridgeSelector api. ( HasForeign (PureScript bridgeSelector) PSType api , GenerateList PSType (Foreign PSType api)@@ -63,10 +68,18 @@ let contents = genModule opts apiList unlessM (doesDirectoryExist mDir) $ createDirectoryIfMissing True mDir withFile mPath WriteMode $ flip hPutDocLn contents+ when (opts ^. generateSubscriberAPI) $ do+ let msContents = SubGen.genModule opts apiList+ unlessM (doesDirectoryExist msDir) $ createDirectoryIfMissing True msDir+ withFile msPath WriteMode $ flip hPutDocLn msContents where- mFile = (joinPath . map T.unpack . T.splitOn "." $ _apiModuleName opts) <> ".purs"+ 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 -- | Use this function for implementing 'parseUrlPiece' in your FromHttpApiData instances
src/Servant/PureScript/CodeGen.hs view
@@ -27,14 +27,19 @@ rParams = getReaderParams opts allParams apiImports = reqsToImportLines reqs imports = mergeImportLines (_standardImports opts) apiImports+ in+ genModuleHeader (_apiModuleName opts) imports + </> genParamSettings rParams <> line+ </> (docIntercalate line . map (genFunction rParams)) reqs++genModuleHeader :: Text -> ImportLines -> Doc+genModuleHeader moduleName imports = let importLines = map (strictText . importLineToText) . Map.elems $ imports in "-- File auto generated by servant-purescript! --"- </> "module" <+> strictText (_apiModuleName opts) <+> "where" <> line+ </> "module" <+> strictText moduleName <+> "where" <> line </> "import Prelude" <> line </> docIntercalate line importLines <> line- </> genParamSettings rParams <> line- </> (docIntercalate line . map (genFunction rParams)) reqs getReaderParams :: Settings -> [PSParam] -> [PSParam] getReaderParams opts allParams = let@@ -83,10 +88,12 @@ genSignature :: Text -> [PSType] -> Maybe PSType -> Doc-genSignature fnName params mRet = fName <+> align (constraint <+/> parameterString)+genSignature = genSignatureBuilder $ "forall eff m." <+/> "(MonadReader (SPSettings_ SPParams_) m, MonadError AjaxError m, MonadAff ( ajax :: AJAX | eff) m)" <+/> "=>"++genSignatureBuilder :: Doc -> Text -> [PSType] -> Maybe PSType -> Doc+genSignatureBuilder constraint fnName params mRet = fName <+> "::" <+> align (constraint <+/> parameterString) where fName = strictText fnName- constraint = ":: forall eff m." <+/> "(MonadReader (SPSettings_ SPParams_) m, MonadError AjaxError m, MonadAff ( ajax :: AJAX | eff) m)" <+/> "=>" retName = maybe "Unit" (strictText . typeInfoToText False) mRet retString = "m" <+> retName typeNames = map (strictText . typeInfoToText True) params
src/Servant/PureScript/Internal.hs view
@@ -83,6 +83,9 @@ -- will be put in the Reader monad, all others will still be passed as function parameter. , _readerParams :: Set ParamName , _standardImports :: ImportLines+ -- | If you want codegen for servant-subscriber, set this to True. See the central-counter example+ -- for a simple usage case.+, _generateSubscriberAPI :: Bool } makeLenses ''Settings @@ -105,6 +108,7 @@ , ImportLine "Data.Maybe" (Set.fromList [ "Maybe(..)"]) , ImportLine "Data.Argonaut.Printer" (Set.fromList [ "printJson" ]) ]+ , _generateSubscriberAPI = False } -- | Add a parameter name to be us put in the Reader monad instead of being passed to the@@ -118,6 +122,12 @@ baseURLParam :: PSParam baseURLParam = Param baseURLId psString +subscriberToUserId :: ParamName+subscriberToUserId = "spToUser_"++makeTypedToUserParam :: PSType -> PSParam+makeTypedToUserParam response = Param subscriberToUserId (psTypedToUser response)+ apiToList :: forall bridgeSelector api. ( HasForeign (PureScript bridgeSelector) PSType api , GenerateList PSType (Foreign PSType api)@@ -141,3 +151,27 @@ isValid c = isAlphaNum c || c == '_' in T.filter isValid++psTypedToUser :: PSType -> PSType+psTypedToUser response = TypeInfo {+ _typePackage = "purescript-subscriber"+ , _typeModule = "Servant.Subscriber.Util"+ , _typeName = "TypedToUser"+ , _typeParameters = [response, psTypeParameterA]+ }++psSubscriptions :: PSType+psSubscriptions = TypeInfo {+ _typePackage = "purescript-subscriber"+ , _typeModule = "Servant.Subscriber.Subscriptions"+ , _typeName = "Subscriptions"+ , _typeParameters = [psTypeParameterA]+ }++psTypeParameterA :: PSType+psTypeParameterA = TypeInfo {+ _typePackage = ""+ , _typeModule = ""+ , _typeName = "a"+ , _typeParameters = []+ }
+ src/Servant/PureScript/Subscriber.hs view
@@ -0,0 +1,155 @@+{-# 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.Subscriber where++import Control.Lens hiding (List)+import Data.Map (Map)+import Data.Maybe (mapMaybe, maybeToList)+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.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 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+ isSubscribable req = T.empty `elem` req ^.reqFuncName . to unFunctionName+ reqs = filter isSubscribable allReqs+ allParams = concatMap reqToParams allReqs+ 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 <> ".Subscriber"+ 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+ responseType = case req ^. reqReturnType of+ 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+ 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++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!"++