diff --git a/src/ProtoRoute.hs b/src/ProtoRoute.hs index aa773be..892459e 100644 --- a/src/ProtoRoute.hs +++ b/src/ProtoRoute.hs @@ -2,22 +2,14 @@ module ProtoRoute ( main ) where -import Data.ProtoLens -import Language.Haskell.Ghcid (execStream, startGhci, stopGhci) -import System.Directory (getCurrentDirectory) +import Data.Text (pack) +import ProtoRoute.Ghcid (runGhci) +import ProtoRoute.Message (MsgName (..), FieldName (..), FVType (..), + FieldValue (..), constructProtoMsg) main :: IO () -main = do - let f = \_ s -> putStrLn s - curDir <- getCurrentDirectory - (g, _) <- startGhci "ghci" (Just curDir) f - let runCmd s = execStream g s f - runCmd "import Data.Text" - runCmd "import Data.ProtoLens.Encoding" - runCmd ":load src/ProtoExports" - runCmd "test = \"someQuery\"" - runCmd $ passArgs "test" [] - -- Value of generated msg, and its serialized representation - runCmd "sr" - runCmd "encodeMessage sr" - stopGhci g +main = runGhci $ constructProtoMsg sreq [(query, someText)] + where + sreq = MN $ pack "SearchRequest" + query = FN $ pack "query" + someText = FieldText (Req $ pack "someText") diff --git a/src/ProtoRoute/Ghcid.hs b/src/ProtoRoute/Ghcid.hs index 6eda6fe..bf91d2d 100644 --- a/src/ProtoRoute/Ghcid.hs +++ b/src/ProtoRoute/Ghcid.hs @@ -2,16 +2,17 @@ module ProtoRoute.Ghcid ( runGhci ) where -import Data.Text (unpack) +import Data.Text (unpack, Text) import Language.Haskell.Ghcid (execStream, startGhci, stopGhci) -import ProtoRoute.Message (constructProtoMessage, FieldName, FieldValue, MessageName) +import ProtoRoute.Message (constructProtoMsg) import System.Directory (getCurrentDirectory) -- Should runGhci have the following type signature and start off like so? runGhci :: Text -> IO () -runGhci = do +runGhci stuff = do let f = \_ s -> putStrLn s curDir <- getCurrentDirectory (g, _) <- startGhci "ghci" (Just curDir) f let runCmd s = execStream g s f + runCmd ("let testMsg = " ++ unpack stuff) stopGhci g diff --git a/src/ProtoRoute/Message.hs b/src/ProtoRoute/Message.hs index 2adfabf..6e42958 100644 --- a/src/ProtoRoute/Message.hs +++ b/src/ProtoRoute/Message.hs @@ -1,26 +1,35 @@ module ProtoRoute.Message - ( constructProtoMessage - , MessageName - , FieldName - , FieldValue - ) where + ( MsgName (..) + , FieldName (..) + , FVType (..) + , Msg (..) + , FieldValue (..) + , constructProtoMsg) where -import Data.ProtoLens -import Data.Text (pack) -import ProtoExports +import Data.Text (pack, Text) +newtype MsgName = MN Text deriving (Show) +newtype FieldName = FN Text deriving (Show) -newtype MessageName = MessageName { unMessageName :: Text } -newtype FieldName = FieldName { unFieldName :: Text } -data FieldValue = FV [Int] | FV [Text] | FV [FieldValue] +data FieldValue a = Req a | Opt (Maybe a) | Rep [a] deriving (Show) +data FVType = FieldText (FieldValue Text) | FieldInt (FieldValue Int) | + FieldMsg (FieldValue Msg) deriving (Show) +-- Typesafe representation of a protobuf mesage +data Msg = Msg + { messageName :: MsgName + , messageFields :: [(FieldName, FVType)] + } deriving (Show) -constructProtoMessage :: MessageName -> [(FieldName, FieldValue)] -> Text -constructProtoMessage msgName namesVals = msgName ++ pack " {" +constructProtoMsg :: MsgName -> [(FieldName, FVType)] -> Text +constructProtoMsg msgName namesVals = + pack (show msgName ++ " {" ++ addRest msgName namesVals ++ "} ") where - singleEntry = pack ("_" ++ msgName ++ "\'" ++ fn ++ " = " ++ pack . show fv) + singleEntry :: MsgName -> (FieldName, FVType) -> String + singleEntry name (fn, fv) = + "_" ++ show name ++ "\'" ++ show fn ++ " = " ++ show fv - addRest :: MessageName -> [(FieldName, FieldValue)] -> Text - addRest _ [] = pack "" - addRest _ [(fn, fv)] = singleEntry - addRest msgName (fn,fv):others = - pack (singleEntry ++ ", " ++ addRest msgName rest) + addRest :: MsgName -> [(FieldName, FVType)] -> String + addRest _ [] = "" + addRest name [(fn, fv)] = singleEntry name (fn, fv) + addRest name ((fn, fv) : others) = + singleEntry name (fn, fv) ++ ", " ++ addRest name others