123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189 |
- module Gidl.Backend.Rpc (
- rpcBackend
- ) where
- import qualified Paths_gidl as P
- import Gidl.Backend.Cabal
- (cabalFileArtifact,CabalFile(..),defaultCabalFile,filePathToPackage)
- import Gidl.Backend.Haskell.Interface (interfaceModule,ifModuleName)
- import Gidl.Backend.Haskell.Types (typeModule,isUserDefined,typeModuleName)
- import Gidl.Interface (Interface,InterfaceEnv(..))
- import Gidl.Types (Type,TypeEnv(..))
- import Data.Char (isSpace)
- import Data.List (intercalate)
- import Ivory.Artifact
- (Artifact(..),artifactPath,artifactFileName,artifactPath
- ,artifactText,artifactCabalFile)
- import Ivory.Artifact.Template (artifactCabalFileTemplate)
- import Text.PrettyPrint.Mainland
- (Doc,prettyLazyText,text,empty,(<+>),(</>),(<>),char,line,parens
- ,punctuate,stack,sep,tuple,dot,spread,cat)
- -- External Interface ----------------------------------------------------------
- rpcBackend :: TypeEnv -> InterfaceEnv -> String -> String -> [Artifact]
- rpcBackend typeEnv@(TypeEnv te) ifaceEnv@(InterfaceEnv ie) pkgName nsStr =
- cabalFileArtifact (defaultCabalFile pkgName modules buildDeps)
- : artifactCabalFile P.getDataDir "support/rpc/Makefile"
- : map (artifactPath "src") (rpcBaseModule namespace : sourceMods)
- where
- namespace = strToNs nsStr
- buildDeps = [ "cereal", "QuickCheck", "snap-core", "snap-server", "stm"
- , "bytestring" ]
- modules = [ filePathToPackage (artifactFileName m) | m <- sourceMods ]
- sourceMods = tmods ++ imods
- tmods = [ typeModule (namespace ++ ["Types"]) t
- | (_tn, t) <- te
- , isUserDefined t
- ]
- imods = concat [ [ interfaceModule (namespace ++ ["Interface"]) i
- , rpcModule typeEnv namespace i ]
- | (_iname, i) <- ie
- ]
- rpcBaseModule :: [String] -> Artifact
- rpcBaseModule ns =
- artifactPath (foldr (\ p rest -> p ++ "/" ++ rest) "Server" ns) $
- artifactCabalFileTemplate P.getDataDir "support/rpc/Base.hs.template" env
- where
- env = [ ("module_prefix", concatMap (++ ".") ns) ]
- -- Utilities -------------------------------------------------------------------
- strToNs :: String -> [String]
- strToNs str =
- case break (== '.') (dropWhile isSpace str) of
- (a,'.' : b) | null a -> strToNs b
- | otherwise -> trim a : strToNs b
- (a,_) | null a -> []
- | otherwise -> [trim a]
- where
- trim = takeWhile (not . isSpace)
- -- Server Generation -----------------------------------------------------------
- rpcModule :: TypeEnv -> [String] -> Interface -> Artifact
- rpcModule typeEnv ns iface =
- artifactPath (foldr (\ p rest -> p ++ "/" ++ rest) "Server" ns) $
- artifactText (ifaceMod ++ ".hs") $
- prettyLazyText 80 $
- genServer typeEnv ns iface ifaceMod
- where
- ifaceMod = ifModuleName iface
- genServer :: TypeEnv -> [String] -> Interface -> String -> Doc
- genServer typeEnv ns iface ifaceMod =
- stack [ moduleHeader ns ifaceMod
- , importTypes ns typeEnv
- , importInterface ns ifaceMod
- , line
- , ppImport False (ppModName (ns ++ ["Server","Base"])) Nothing
- , line
- , webServerImports
- , line
- , line
- , runServer typeEnv iface
- ]
- moduleHeader :: [String] -> String -> Doc
- moduleHeader ns m =
- spread [ text "module"
- , ppHaskellModule (ns ++ ["Server"]) m
- , tuple [ text "rpcServer", text "Config(..)" ]
- , text "where"
- ]
- -- | Import all of the generated type modules from the type environment.
- importTypes :: [String] -> TypeEnv -> Doc
- importTypes ns (TypeEnv ts) = foldr importType empty ts
- where
- prefix = dots (map text (ns ++ ["Types"]))
- importType (_,t) rest =
- stack [ ppImport False (prefix *. text (typeModuleName t)) Nothing
- , rest
- ]
- importInterface :: [String] -> String -> Doc
- importInterface ns ifaceName =
- ppImport False (dots (map text (ns ++ ["Interface", ifaceName]))) Nothing
- webServerImports :: Doc
- webServerImports =
- stack [ ppImport False (ppModName ["Snap","Http","Server"]) Nothing
- , ppImport True (ppModName ["Data","ByteString"]) Nothing
- ]
- runServer :: TypeEnv -> Interface -> Doc
- runServer typeEnv iface = runServerSig </> runServerDef typeEnv iface
- runServerSig :: Doc
- runServerSig =
- text "rpcServer" <+> text "::"
- <+> arrow [ chan, chan, text "Config", text "IO ()" ]
- where
- chan = text "TChan" <+> text "S.ByteString"
- -- | Generate a definition for the server.
- runServerDef :: TypeEnv -> Interface -> Doc
- runServerDef typeEnv iface = text "rpcServer" <+> body
- where
- body = arg "input" $ \ input ->
- arg "output" $ \ output ->
- arg "cfg" $ \ cfg ->
- char '=' <+> empty
- -- Pretty-printing Helpers -----------------------------------------------------
- arg :: String -> (Doc -> Doc) -> Doc
- arg name k = let x = text name in x <+> k (text name)
- arrow :: [Doc] -> Doc
- arrow ts = spread (punctuate (text "->") ts)
- (*.) :: Doc -> Doc -> Doc
- a *. b = a <> dot <> b
- dots :: [Doc] -> Doc
- dots = cat . punctuate dot
- ppImport :: Bool -> Doc -> Maybe Doc -> Doc
- ppImport isQual modName mbAs =
- spread [ text "import"
- , if isQual then text "qualified" else empty
- , modName
- , case mbAs of
- Just alt -> text "as" <+> alt
- Nothing -> empty
- ]
- ppModName :: [String] -> Doc
- ppModName = dots . map text
- ppHaskellModule :: [String] -> String -> Doc
- ppHaskellModule ns n = foldr (\ m rest -> text m <> char '.' <> rest ) (text n) ns
|