module Servant.PureScript.Internal where
import Control.Lens
import Data.Bifunctor
import Data.Char
import Data.Monoid
import Data.Proxy
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import Data.Typeable
import Language.PureScript.Bridge
import Language.PureScript.Bridge.PSTypes
import Servant.Foreign
data PureScript bridgeSelector
instance (Typeable a, HasBridge bridgeSelector) => HasForeignType (PureScript bridgeSelector) PSType a where
typeFor _ _ _ = languageBridge (Proxy :: Proxy bridgeSelector) (mkTypeInfo (Proxy :: Proxy a))
class HasBridge a where
languageBridge :: Proxy a -> FullBridge
data DefaultBridge
instance HasBridge DefaultBridge where
languageBridge _ = buildBridge defaultBridge
defaultBridgeProxy :: Proxy DefaultBridge
defaultBridgeProxy = Proxy
type ParamName = Text
data Param f = Param {
_pName :: ParamName
, _pType :: f
} deriving (Eq, Ord, Show)
type PSParam = Param PSType
makeLenses ''Param
data Settings = Settings {
_apiModuleName :: Text
, _readerParams :: Set ParamName
, _standardImports :: ImportLines
, _generateSubscriberAPI :: Bool
}
makeLenses ''Settings
defaultSettings :: Settings
defaultSettings = Settings {
_apiModuleName = "ServerAPI"
, _readerParams = Set.singleton baseURLId
, _standardImports = importsFromList
[ ImportLine "Control.Monad.Reader.Class" (Set.fromList [ "class MonadReader", "ask" ])
, ImportLine "Control.Monad.Error.Class" (Set.fromList [ "class MonadError" ])
, ImportLine "Control.Monad.Aff.Class" (Set.fromList [ "class MonadAff", "liftAff" ])
, ImportLine "Network.HTTP.Affjax" (Set.fromList [ "AJAX" ])
, ImportLine "Global" (Set.fromList [ "encodeURIComponent" ])
, ImportLine "Data.Nullable" (Set.fromList [ "Nullable()", "toNullable" ])
, ImportLine "Servant.PureScript.Affjax" (Set.fromList [ "defaultRequest", "affjax", "AjaxError(..)" ])
, ImportLine "Servant.PureScript.Settings" (Set.fromList [ "SPSettings_(..)", "gDefaultToURLPiece" ])
, ImportLine "Servant.PureScript.Util" (Set.fromList [ "encodeListQuery", "encodeURLPiece", "encodeQueryItem", "getResult", "encodeHeader" ])
, ImportLine "Prim" (Set.fromList [ "String" ])
, ImportLine "Data.Argonaut.Generic.Aeson" (Set.fromList [ "encodeJson", "decodeJson" ])
, ImportLine "Data.Maybe" (Set.fromList [ "Maybe(..)"])
, ImportLine "Data.Argonaut.Printer" (Set.fromList [ "printJson" ])
]
, _generateSubscriberAPI = False
}
addReaderParam :: ParamName -> Settings -> Settings
addReaderParam n opts = opts & over readerParams (Set.insert n)
baseURLId :: ParamName
baseURLId = "baseURL"
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)
, HasBridge bridgeSelector
) => Proxy api -> Proxy bridgeSelector -> [Req PSType]
apiToList _ _ = listFromAPI (Proxy :: Proxy (PureScript bridgeSelector)) (Proxy :: Proxy PSType) (Proxy :: Proxy api)
toPSVarName :: Text -> Text
toPSVarName = dropInvalid . unTitle . doPrefix . replaceInvalid
where
unTitle = uncurry mappend . first T.toLower . T.splitAt 1
doPrefix t = let
s = T.head t
cond = isAlpha s || s == '_'
in
if cond then t else "_" <> t
replaceInvalid = T.replace "-" "_"
dropInvalid = let
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 = []
}