diff --git a/src/Tui.hs b/src/Tui.hs index 77ec84f..e634e1d 100644 --- a/src/Tui.hs +++ b/src/Tui.hs @@ -18,7 +18,8 @@ import Brick.Widgets.Border import Brick.Widgets.Border.Style import Brick.Widgets.Center import Data.Char (toUpper) -import Data.List (intercalate) +import Data.Foldable (for_) +import Data.List ((!!), insert) import Text.Read (readEither) import ProtoRoute.Ghcid (runGhci) import ProtoRoute.Message ( MsgName (..) @@ -50,7 +51,7 @@ setAttr s1 opts = withBorderStyle unicodeBold setMsgName :: Widget () setMsgName = setAttr "Construct a message" [("Enter", "Type msg name")] onMsgName :: Widget () -onMsgName = setAttr ("**" ++ map toUpper "Construct a message" ++ "**") +onMsgName = setAttr (">>>>" ++ map toUpper "Construct a message" ++ "<<<<") [("Enter", "Type msg name")] setFieldName :: Widget () @@ -61,119 +62,166 @@ onFieldName = setAttr (">>>>" ++ map toUpper "Press enter to type field name" ++ "<<<<") [("Enter", "Type field name")] +fromRule :: SchemaRule -> String +fromRule r = case r of + SReq -> "required" + SOpt -> "optional" + SRep -> "repeated" + +toRule :: String -> SchemaRule +toRule s = case s of + "required" -> SReq + "optional" -> SOpt + "repeated" -> SRep + _ -> SOpt + +fromType :: SchemaType -> String +fromType t = case t of + SText -> "string" + SInt -> "int32" + SMsg -> "message" + +toType :: String -> SchemaType +toType s = case s of + "string" -> SText + "int32" -> SInt + "message" -> SMsg + _ -> SMsg + fieldToDisplay :: SchemaField -> (String, String) fieldToDisplay (SchemaField sfr sft sfn) = (protoLine, description) where description = case sfr of SReq -> "Must give " ++ fromType sft ++ " here for valid msg" - SOpt -> "Nothing or Just , must be of type " ++ fromType sft - SRep -> "Empty list i.e. [], or list of type " ++ fromType sft - protoLine = intercalate " " [fromRule sfr, fromType sft, unFieldName sfn] - - fromRule :: SchemaRule -> String - fromRule r = case r of - SReq -> "required" - SOpt -> "optional" - SRep -> "repeated" - - fromType :: SchemaType -> String - fromType t = case t of - SText -> "string" - SInt -> "int" - SMsg -> "message" + SOpt -> "Nothing or Just , " ++ fromType sft + SRep -> "Empty list i.e. [], or " ++ fromType sft ++ " list" + protoLine = unwords [fromRule sfr, fromType sft, unFieldName sfn] showSchema :: MessageSchema -> Widget () showSchema (MessageSchema smn sFields) = setAttr ("MESSAGE NAME: " ++ unMsgName smn) $ map fieldToDisplay (init sFields) -setValue :: FieldName -> Widget () -setValue s = case toFC msgSchema s of - Right SReq -> setAttr "Press enter: give value for new field" - [("Enter", "Type new value in string quotes")] - Right SOpt -> setAttr "Press enter: give optional value for new field" - [("Enter", "Type Nothing or Just \"yourValue\" ")] - Right SRep -> setAttr "Press enter: give repeated value for new field" - [("Enter", "Type list of values")] - Left _ -> onFieldName - -msgSchema :: MessageSchema -msgSchema = MessageSchema { msgSchemaName = MN "SearchRequest" - , msgSchemaFields = [ - SchemaField - { schemaFieldRule = SReq - , schemaFieldType = SText - , schemaFieldName = FN "query" - } - , SchemaField - { schemaFieldRule = SOpt - , schemaFieldType = SInt - , schemaFieldName = FN "maybeNum" - } - , SchemaField - { schemaFieldRule = SRep - , schemaFieldType = SInt - , schemaFieldName = FN "numList" - } - , SchemaField - { schemaFieldRule = SRep +setValue :: FieldName -> MessageSchema -> Widget () +setValue s sch = case toFCTC sch s of + (Right SReq, _) -> setAttr "Press enter: give value for new field" + [("Enter", "Type new value in string quotes")] + (Right SOpt, _) -> setAttr "Press enter: give optional value for new field" + [("Enter", "Type Nothing or Just \"yourValue\" ")] + (Right SRep, _) -> setAttr "Press enter: give repeated value for new field" + [("Enter", "Type list of values")] + (Left _, _) -> onFieldName + +unknownFields :: SchemaField +unknownFields = SchemaField { schemaFieldRule = SRep , schemaFieldType = SText , schemaFieldName = FN "_unknownFields" - }] - } + } + +msgSchema :: IO MessageSchema +msgSchema = do + name <- parseName fp + stuff <- parseFields fp + return $ MessageSchema (MN name) (stuff ++ [unknownFields]) + where + fp = "proto/protobuf2.proto" + +parseName :: FilePath -> IO String +parseName fp = do + content <- readFile fp + return $ name $ lines content + where + name :: [String] -> String + name parts = words (head parts) !! 1 + +parseField :: String -> SchemaField +parseField s = do + let comps = words s + let sfr = toRule (head comps) + let sft = toType $ comps !! 1 + let sfn = FN $ comps !! 2 + toField sfr sft sfn + where + toField :: SchemaRule -> SchemaType -> FieldName -> SchemaField + toField = SchemaField -toFC :: MessageSchema -> FieldName -> Either String SchemaRule -toFC (MessageSchema _ []) _ = Left "Invalid field" -toFC sch@(MessageSchema _ (SchemaField sfr _ sfn : sFields)) fn = +parseFields :: FilePath -> IO [SchemaField] +parseFields fp = do + content <- readFile fp + let (_,fields) = splitAt 3 $ lines content + -- toFields fields + return $ map parseField (init fields) + +toFCTC :: MessageSchema + -> FieldName + -> (Either String SchemaRule, Either String SchemaType) +toFCTC (MessageSchema _ []) _ = (Left "Invalid field", Left "No fields") +toFCTC sch@(MessageSchema _ (SchemaField sfr sft sfn : sFields)) fn = if fn == sfn - then Right sfr - else toFC (sch {msgSchemaFields = sFields}) fn - -processFTV :: Either String SchemaRule -> String -> Either String FieldValue -processFTV field value = case field of - Right SReq -> FText . Req <$> readEither value - Right SOpt -> FInt . Opt <$> readEither value - Right SRep -> FInt . Rep <$> readEither value + then (Right sfr, Right sft) + else toFCTC (sch {msgSchemaFields = sFields}) fn + +processFV :: (Read a) + => Either String SchemaRule + -> String + -> Either String (TValue a) +processFV rule value = case rule of + Right SReq -> Req <$> readEither value + Right SOpt -> Opt <$> readEither value + Right SRep -> Rep <$> readEither value + Left _ -> Left "Invalid value" + +processFTV :: (Either String SchemaRule, Either String SchemaType) + -> String + -> Either String FieldValue +processFTV (rule, schType) value = case schType of + Right SText -> FText <$> processFV rule value + Right SInt -> FInt <$> processFV rule value + Right SMsg -> FMsg <$> processFV rule value Left _ -> Left "Wrong field names" -addMsgName :: IO MsgName -addMsgName = do - simpleMain $ vBox [onMsgName, setFieldName, showSchema msgSchema] +addMsgName :: MessageSchema -> IO MsgName +addMsgName sch = do + simpleMain $ vBox [onMsgName, setFieldName, showSchema sch] msgName <- getLine let mn = MN msgName return mn -addFVPair :: IO (FieldName, FieldValue) -addFVPair = do - simpleMain $ vBox [setMsgName, onFieldName, showSchema msgSchema] +addFVPair :: MessageSchema -> IO (FieldName, FieldValue) +addFVPair sch = do + simpleMain $ vBox [setMsgName, onFieldName, showSchema sch] putStrLn "If you are changing a value, type the same field name as before" field <- getLine let fn = FN field - let fc = toFC msgSchema fn + let fc = toFCTC sch fn case fc of - Right _ -> do - simpleMain (setValue fn) + (Right _, Right _) -> do + simpleMain (setValue fn sch) val <- getLine let fv = either read id (processFTV fc val) return (fn,fv) - Left _ -> addFVPair + _ -> addFVPair sch -completeField :: IO (FieldName, FieldValue) -completeField = do - (fn, fv) <- addFVPair +completeField :: MessageSchema -> IO (FieldName, FieldValue) +completeField sch = do + (fn, fv) <- addFVPair sch putStrLn "Change this field's value? y to keep editing, any other key to continue" choice <- getLine if choice == "y" then do - (fn2, fv2) <- addFVPair + (fn2, fv2) <- addFVPair sch return (fn2, fv2) else return (fn, fv) -serialize :: MsgName -> [(FieldName, FieldValue)] -> [MessageField] -> IO () -serialize mn namesVals fields = do +serialize :: MsgName + -> [(FieldName, FieldValue)] + -> [MessageField] + -> MessageSchema + -> IO () +serialize mn namesVals fields sch = do let stringMsg = constructProtoMsg mn namesVals - let msg = Message {messageName = mn, messageFields = fields} - let validationWrong = validateMessage msgSchema msg + let msg = Message mn fields + let validationWrong = validateMessage sch msg if validationWrong == Right () then runGhci stringMsg else print validationWrong @@ -183,58 +231,62 @@ replace n arg list = x ++ arg : ys where (x,_:ys) = splitAt n list -main :: IO () -main = do - mn <- addMsgName - (fnA, fvA) <- completeField - let field1 = (MessageField fnA fvA) - (fnB, fvB) <- completeField - let field2 = (MessageField fnB fvB) - (fnC, fvC) <- completeField - let field3 = (MessageField fnC fvC) - let namesVals = [(fnA, fvA) - , (fnB, fvB) - , (fnC, fvC) - , (FN "_unknownFields", FText (Rep []))] - let fields = [field1, field2, field3] - serialize mn namesVals fields - changeFieldsOrNot mn namesVals fields - where - changeFieldsOrNot :: MsgName - -> [(FieldName, FieldValue)] - -> [MessageField] - -> IO () - changeFieldsOrNot mn namesVals fields = do - putStrLn "Change any field's value? y for yes, s to serialize, any other key to quit" - choice <- getLine - if choice == "y" - then do - (newFN, newFV) <- completeField - if | newFN == messageFieldName (fields!!0) -> - let (newNamesVals, newFields) = doubleReplace 0 (newFN, newFV) namesVals fields - in changeFieldsOrNot mn newNamesVals newFields - | newFN == messageFieldName (fields!!1) -> - let (newNamesVals, newFields) = doubleReplace 1 (newFN, newFV) namesVals fields - in changeFieldsOrNot mn newNamesVals newFields - | otherwise -> - let (newNamesVals, newFields) = doubleReplace 2 (newFN, newFV) namesVals fields - in changeFieldsOrNot mn newNamesVals newFields - else if choice == "s" - then useTwo serialize changeFieldsOrNot mn namesVals fields - else putStrLn "Ok, see final serialisation above." - - doubleReplace :: Int - -> (FieldName, FieldValue) +changeFieldsOrNot :: MsgName -> [(FieldName, FieldValue)] -> [MessageField] - -> ([(FieldName, FieldValue)], [MessageField]) - doubleReplace n (newFN, newFV) namesVals fields = - ( replace n (newFN, newFV) namesVals - , replace n (MessageField newFN newFV) fields) - - useTwo :: (a -> b -> c -> IO ()) - -> (a -> b -> c -> IO ()) - -> a -> b -> c -> IO () - useTwo f g a b c = do - f a b c - g a b c + -> MessageSchema + -> IO () +changeFieldsOrNot mn namesVals fields schema = do + putStrLn "Change any field's value? y for yes, s to serialize, any other key to quit" + choice <- getLine + if choice == "y" + then do + (newFN, newFV) <- completeField schema + if | newFN == messageFieldName (head fields) -> + let (newNamesVals, newFields) = doubleReplace 0 (newFN, newFV) namesVals fields + in changeFieldsOrNot mn newNamesVals newFields schema + | newFN == messageFieldName (fields!!1) -> + let (newNamesVals, newFields) = doubleReplace 1 (newFN, newFV) namesVals fields + in changeFieldsOrNot mn newNamesVals newFields schema + | otherwise -> + let (newNamesVals, newFields) = doubleReplace 2 (newFN, newFV) namesVals fields + in changeFieldsOrNot mn newNamesVals newFields schema + else if choice == "s" + then useTwo serialize changeFieldsOrNot mn namesVals fields schema + else putStrLn "Ok, see final serialisation above." + +doubleReplace :: Int + -> (FieldName, FieldValue) + -> [(FieldName, FieldValue)] + -> [MessageField] + -> ([(FieldName, FieldValue)], [MessageField]) +doubleReplace n (newFN, newFV) namesVals fields = + ( replace n (newFN, newFV) namesVals + , replace n (MessageField newFN newFV) fields) + +useTwo :: (a -> b -> c -> d -> IO ()) + -> (a -> b -> c -> d -> IO ()) + -> a -> b -> c -> d -> IO () +useTwo f g a b c d = do + f a b c d + g a b c d + +getNameVals :: MessageSchema -> IO [(FieldName, FieldValue)] +getNameVals sch = do + (fn, fv) <- completeField sch + moreInputs <- getNameVals sch + return ((fn, fv) : moreInputs) + +toMF :: (FieldName, FieldValue) -> MessageField +toMF (fn, fv) = MessageField fn fv + +main :: IO () +main = do + someSchema <- msgSchema + mn <- addMsgName someSchema + schFields <- parseFields "proto/protobuf2.proto" + namesVals <- getNameVals someSchema + let msgFields = map toMF namesVals + let namesVals' = namesVals ++ [(FN "_unknownFields", FText (Rep []))] + serialize mn namesVals' msgFields someSchema + changeFieldsOrNot mn namesVals' msgFields someSchema