diff --git a/Test.hs b/Test.hs new file mode 100644 index 0000000..b254b6f --- /dev/null +++ b/Test.hs @@ -0,0 +1,9 @@ +module Test where + +import Brick + +ui :: Widget () +ui = str "Sup world" + +main :: IO () +main = simpleMain ui diff --git a/app/Main.hs b/app/Main.hs index 84971a7..724419c 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,6 +1,8 @@ module Main where -import qualified ProtoRoute +-- import qualified ProtoRoute +import qualified Tui main :: IO () -main = ProtoRoute.main +-- main = ProtoRoute.main +main = Tui.main diff --git a/proto-route.cabal b/proto-route.cabal index bc87e45..bbeecf8 100644 --- a/proto-route.cabal +++ b/proto-route.cabal @@ -15,7 +15,7 @@ extra-doc-files: README.md , CHANGELOG.md cabal-version: 1.24 tested-with: GHC == 8.4.3 -extra-source-files: proto/protobuf1.proto +extra-source-files: proto/*.proto source-repository head type: git @@ -33,16 +33,21 @@ library ProtoRoute ProtoRoute.Ghcid ProtoRoute.Message - Proto.Protobuf1 - Proto.Protobuf1_Fields + Proto.Protobuf2 + Proto.Protobuf2_Fields + Tui ghc-options: -Wall build-depends: base >=4.7 && <5 + , brick + , containers , directory , ghcid + , linear , protobuf , proto-lens , proto-lens-protoc , text + , vty default-language: Haskell2010 @@ -51,11 +56,15 @@ executable proto-route main-is: Main.hs ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends: base + , brick + , containers , directory , ghcid + , linear , protobuf , proto-lens , proto-lens-protoc , proto-route , text + , vty default-language: Haskell2010 diff --git a/proto/protobuf1.proto b/proto/protobuf2.proto similarity index 70% rename from proto/protobuf1.proto rename to proto/protobuf2.proto index 0b25c8c..a1f6ca3 100644 --- a/proto/protobuf1.proto +++ b/proto/protobuf2.proto @@ -2,5 +2,4 @@ syntax = "proto2"; message SearchRequest { required string query = 1; - optional string browser = 2; } diff --git a/report.html b/report.html new file mode 100644 index 0000000..54c61d5 --- /dev/null +++ b/report.html @@ -0,0 +1,177 @@ + + + + +HLint Report + + + + + + + + +
+ +

All hints

+ + +

All files

+ + +
+
+

+ Report generated by HLint +v2.1.8 + - a tool to suggest improvements to your Haskell code. +

+ +
+src/Tui.hs:68:1: Error: Parse error
+Found
+
    simpleMain setFieldName
+    fieldName <- getLine 
+> 
+
+ +
+ +
+ + diff --git a/src/ProtoExports.hs b/src/ProtoExports.hs index c64a774..baa43eb 100644 --- a/src/ProtoExports.hs +++ b/src/ProtoExports.hs @@ -1,7 +1,7 @@ module ProtoExports - ( module Proto.Protobuf1 - , module Proto.Protobuf1_Fields + ( module Proto.Protobuf2 + , module Proto.Protobuf2_Fields ) where -import Proto.Protobuf1 -import Proto.Protobuf1_Fields +import Proto.Protobuf2 +import Proto.Protobuf2_Fields diff --git a/src/ProtoRoute/Ghcid.hs b/src/ProtoRoute/Ghcid.hs index 7ad291e..6b424ce 100644 --- a/src/ProtoRoute/Ghcid.hs +++ b/src/ProtoRoute/Ghcid.hs @@ -15,6 +15,7 @@ runGhci stuff = do runCmd ":set -XOverloadedStrings" runCmd "import Data.ProtoLens.Encoding" runCmd ":load src/ProtoExports" + putStrLn stuff runCmd ("let testMsg = " ++ stuff) runCmd "encodeMessage testMsg" stopGhci g diff --git a/src/ProtoRoute/Message.hs b/src/ProtoRoute/Message.hs index 5b4caaf..221c47f 100644 --- a/src/ProtoRoute/Message.hs +++ b/src/ProtoRoute/Message.hs @@ -17,10 +17,9 @@ import Data.Text (Text) newtype MsgName = MN { unMsgName :: String } deriving newtype (Show) newtype FieldName = FN { unFieldName :: String } deriving newtype (Show) -data TValue a = Req a | Opt (Maybe a) | Rep [a] deriving (Show) -- value type +data TValue a = Req a | Opt (Maybe a) | Rep [a] | Error deriving (Show) data FieldValue = FText (TValue Text) | FInt (TValue Int) | FMsg (TValue Message) deriving (Show) --- Typesafe representation of a protobuf mesage data Message = Message { messageName :: MsgName , messageFields :: [(FieldName, FieldValue)] @@ -40,6 +39,7 @@ fromTV :: (Show a) => TValue a -> String fromTV (Req val) = show val fromTV (Opt txt) = show txt fromTV (Rep list) = show list +fromTV Error = "Error" constructProtoMsg :: MsgName -> [(FieldName, FieldValue)] -> String constructProtoMsg msgName namesVals = diff --git a/src/Tui.hs b/src/Tui.hs new file mode 100644 index 0000000..caec5b2 --- /dev/null +++ b/src/Tui.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE OverloadedStrings #-} +module Tui + ( setAttr + , setFieldName + , setMsgName + , setFieldType + , setValue + , processFTV + , main + ) where + +import Brick +import Brick.Widgets.Border +import Brick.Widgets.Border.Style +import Brick.Widgets.Center +import Data.Char (toLower, toUpper) +import ProtoRoute.Ghcid (runGhci) +import ProtoRoute.Message (MsgName (..) + , FieldName (..) + , TValue (..) + , FieldValue (..) + , constructProtoMsg) + +drawKey :: String -> String -> Widget () +drawKey act key = padRight Max (padLeft (Pad 1) $ str act) <+> + padLeft Max (padRight (Pad 1) $ str key) + +setAttr :: String -> [(String, String)] -> Widget () +setAttr s1 opts = withBorderStyle unicodeBold + $ hCenter + $ hLimit 80 + $ vLimit 400 + $ borderWithLabel (str s1) + $ vBox + $ map (uncurry drawKey) opts + +setMsgName :: Widget () +setMsgName = setAttr "Construct a message" [("Enter", "Type msg name")] +onMsgName :: Widget () +onMsgName = setAttr ("**" ++ map toUpper "Construct a message" ++ "**") + [("Enter", "Type msg name")] + +setFieldName :: Widget () +setFieldName = setAttr "Press enter to type field name" + [("Enter", "name of new field")] +onFieldName :: Widget () +onFieldName = + setAttr (">>>>" ++ map toUpper "Press enter to type field name" ++ "<<<<") + [("Enter", "Type msg name")] + +setFieldType :: Widget () +setFieldType = setAttr "Press enter then select new message field type" + [("r", "required"), ("o", "optional"), ("m", "repeated")] +onFieldType :: Widget () +onFieldType = + setAttr (">>>>" ++ map toUpper "Press enter then select field type" ++ "<<<<") + [("r", "required"), ("o", "optional"), ("m", "repeated")] + +setValue :: String -> Widget () +setValue s = case s of + "r" -> setAttr "Press enter key to give value for this new field" + [("Enter", "Type new value in string quotes")] + "o" -> setAttr "Press enter key to give optional value for this new field" + [("Enter", "Type Nothing or Just \"yourValue\" ")] + "m" -> setAttr "Press enter key to give repeated value for this new field" + [("Enter", "Type string values in a string list")] + _ -> setFieldType + +processFTV :: (Read a) => String -> String -> TValue a +processFTV choice value = case choice of + "r" -> Req $ read value + "o" -> Opt $ read value + "m" -> Rep $ read value + _ -> Error + +addFieldName :: IO FieldName +addFieldName = do + simpleMain $ vBox [setMsgName, onFieldName, setFieldType] + field <- getLine + let fn = FN (map toLower field) + return fn + +addFVPair :: IO (FieldName, FieldValue) +addFVPair = do + simpleMain $ vBox [setMsgName, onFieldName, setFieldType] + field <- getLine + let fn = FN (map toLower field) + simpleMain $ vBox [setMsgName, setFieldName, onFieldType] + t <- getLine + simpleMain (setValue t) + val <- getLine + let fv = FText (processFTV t val) + return (fn,fv) + +changeValue :: IO FieldValue +changeValue = do + simpleMain setFieldType + t <- getLine + simpleMain (setValue t) + val <- getLine + let fv = FText (processFTV t val) + return fv + +finishOff :: MsgName ->[(FieldName, FieldValue)] -> IO () +finishOff mn namesVals = do + let msg = constructProtoMsg mn namesVals + putStrLn msg + runGhci msg + +main :: IO () +main = do + simpleMain $ vBox [onMsgName, setFieldName, setFieldType] + msgName <- getLine + let mn = MN msgName + + (fn, fv) <- addFVPair + putStrLn "Change field value? Type y/n to keep editing/stop" + choice <- getLine + if choice == "y" + then do + fv2 <- changeValue + finishOff mn [(fn, fv2), (FN "_unknownFields", FText (Rep []))] + else do + finishOff mn [(fn, fv), (FN "_unknownFields", FText (Rep []))]