Merge pull request #99 from kadena-io/rk-all-key-sender

All keys can be senders

deps/pact/github.json

@@ -1,7 +1,7 @@
 {
-  "owner": "eskimor",
+  "owner": "kadena-io",
   "repo": "pact",
-  "branch": "rk-bounded",
-  "rev": "a7b0f5dbb1d8c6858b978d9dbcc6bad700588a70",
-  "sha256": "0g840289ablzi0fpg8vqshh1gnxrkvpgxin9di39fsl4bsl6vacd"
+  "branch": "master",
+  "rev": "e46ecef1a43e37ba2739c1134f66f0999b9bd591",
+  "sha256": "0kc37w3fdpjan78a248wsi9gn3i9vpy3gg2gfy1vzvgnmqqxyl1d"
 }

frontend/sass/common.blocks/_button.scss

@@ -38,6 +38,10 @@
   transform: translate(-50%, -50%);
 }
 
+.button_border_none {
+  border: none;
+}
+
 
 .button:hover:not([disabled]) {
   background: $hover-background;

frontend/src/Frontend/Editor.hs

@@ -54,6 +54,8 @@ import           System.Random              (newStdGen, randoms)
 
 #ifdef  ghcjs_HOST_OS
 import           Data.Map                   (Map)
+import           Data.Bitraversable         (bitraverse)
+import           Control.Monad              (join)
 #endif
 ------------------------------------------------------------------------------
 import           Frontend.Network
@@ -221,23 +223,28 @@ typeCheckVerify m t = mdo
     pure newAnnotations
   where
 -- Line numbers are off on ghcjs:
+-- TODO: Fix this in pact.
 #ifdef  ghcjs_HOST_OS
     parseVerifyOutput :: Map ModuleName Int -> VerifyResult -> [Annotation]
     parseVerifyOutput ms rs =
       let
-        msgsRs :: [(ModuleName, Text)]
-        msgsRs = fmap (fmap $ either id id) . Map.toList $ rs
+        msgsRs :: [(ModuleName, Either Text Text)]
+        msgsRs = Map.toList $ rs
 
-        parsedRs :: Map ModuleName [Annotation]
-        parsedRs = Map.fromList $ fmapMaybe (traverse annoParser) msgsRs
+        parsedRs :: Map ModuleName (Either [Annotation] [Annotation])
+        parsedRs = Map.fromList $ mapMaybe (traverse $ join bitraverse annoParser) msgsRs
 
         fixLineNumber :: Int -> Annotation -> Annotation
         fixLineNumber n a = a { _annotation_line = _annotation_line a + n }
 
         fixLineNumbers :: Int -> [Annotation] -> [Annotation]
         fixLineNumbers n = map (fixLineNumber n)
+
+        fixLineNumbersRight :: Int -> Either [Annotation] [Annotation] -> [Annotation]
+        fixLineNumbersRight n = either id (fixLineNumbers n)
+
       in
-        concat . Map.elems $ Map.intersectionWith fixLineNumbers ms parsedRs
+        normalize . concat . Map.elems $ Map.intersectionWith fixLineNumbersRight ms parsedRs
 #else
     parseVerifyOutput :: VerifyResult -> [Annotation]
     parseVerifyOutput rs =
@@ -248,8 +255,17 @@ typeCheckVerify m t = mdo
         parsedRs :: [(ModuleName, [Annotation])]
         parsedRs = mapMaybe (traverse annoParser) msgsRs
       in
-        concatMap snd parsedRs
+        normalize $ concatMap snd parsedRs
 #endif
+    -- Reason, see: https://github.com/kadena-io/pact/pull/532
+    normalize :: [Annotation] -> [Annotation]
+    normalize = map mkWarning . L.nub
+
+    -- Verification problems should always be displayed as warnings:
+    mkWarning :: Annotation -> Annotation
+    mkWarning anno = anno { _annotation_type = AnnoType_Warning }
+
+
 -- Instances:
 
 instance Reflex t => Semigroup (EditorCfg t) where

frontend/src/Frontend/Editor/Annotation.hs

@@ -42,11 +42,11 @@ import qualified Data.Text            as T
 import           Data.Void            (Void)
 import qualified Text.Megaparsec      as MP
 import qualified Text.Megaparsec.Char as MP
-
 ------------------------------------------------------------------------------
 
 -- | Annotation type.
 data AnnoType = AnnoType_Warning | AnnoType_Error
+  deriving (Eq, Ord)
 
 instance Show AnnoType where
   show = \case
@@ -60,7 +60,7 @@ data Annotation = Annotation
   , _annotation_line   :: Int -- ^ What line to put the annotation to.
   , _annotation_column :: Int -- ^ What column.
   }
-  deriving Show
+  deriving (Show, Eq, Ord)
 
 annoParser :: Text -> Maybe [Annotation]
 annoParser = MP.parseMaybe pactErrorParser
@@ -81,6 +81,7 @@ annoFallbackParser msg =
 
 pactErrorParser :: MP.Parsec Void Text [Annotation]
 pactErrorParser = MP.many $ do
+    dropOptionalQuote
     startErrorParser
     line <- digitsP
     colonP
@@ -91,7 +92,8 @@ pactErrorParser = MP.many $ do
       void $ MP.string' "warning:"
       pure AnnoType_Warning
 
-    msg <- msgParser
+    -- Get rid of trailing quote as well:
+    msg <- T.dropWhileEnd (== '"') <$> msgParser
 
     pure $ Annotation
       { _annotation_type = annoType
@@ -103,6 +105,8 @@ pactErrorParser = MP.many $ do
     digitsP :: MP.Parsec Void Text Int
     digitsP = read <$> MP.some MP.digitChar
 
+    dropOptionalQuote = MP.withRecovery (const $ pure ()) (void $ MP.char '\"')
+
 -- | Parse the actual error message.
 msgParser :: MP.Parsec Void Text Text
 msgParser = linesParser <|> restParser

frontend/src/Frontend/Repl.hs

@@ -213,8 +213,8 @@ makeRepl m cfg = build $ \ ~(_, impl) -> do
                                        , onVerifySt
                                        ]
     let appendHist = flip (|>)
-        onNewOutput = leftmost [ showTerm . _ts_term <$> onNewTransSuccess
-                               , showResult <$> onNewCmdResult
+        onNewOutput = leftmost [ prettyTextPretty . _ts_term <$> onNewTransSuccess
+                               , prettyResult <$> onNewCmdResult
                                ]
 
     output <- foldDyn id S.empty $ mergeWith (.)
@@ -327,7 +327,7 @@ runVerify impl onMod =
 
     verifyModule m = do
       r <- runExceptT . doTypeCheckAndVerify $ m
-      pure (m, bimap T.pack showTerm r)
+      pure (m, bimap T.pack prettyTextPretty r)
 
     doTypeCheckAndVerify m = do
       -- Success output of typecheck is mostly not parseable:
@@ -411,13 +411,9 @@ pactEvalRepl' t = ExceptT $ do
 -- pactEvalPact :: Text -> PactRepl (Term Name)
 -- pactEvalPact = ExceptT . evalPact . T.unpack
 
-showResult :: Show n => Either String (Term n) -> Text
-showResult (Right v) = showTerm v
-showResult (Left e)  = "Error: " <> T.pack e
-
-showTerm :: Show n => Term n -> Text
-showTerm (TLiteral (LString t) _) = t
-showTerm t                        = T.pack $ show t
+prettyResult :: Either String (Term Name) -> Text
+prettyResult (Right v) = prettyTextPretty v
+prettyResult (Left e)  = "Error: " <> T.pack e
 
 -- Instances:
 --

frontend/src/Frontend/UI/Button.hs

@@ -161,7 +161,8 @@ copyButton
   -> RawElement (DomBuilderSpace m)
   -> m (Event t ())
 copyButton cfg e = do
-    onClick <- uiButtonDyn cfg $ text "copy"
+    onClick <- uiButtonDyn (cfg & uiButtonCfg_class %~ (<> "button_border_none")) $
+      elClass "span" "fa fa-lg fa-copy" blank
     performEvent_ $ jsCopy e <$ onClick
     pure onClick
   where
@@ -195,16 +196,14 @@ addButton uCfg =
 deleteButton :: StaticButtonConstraints t m => UiButtonCfg -> m (Event t ())
 deleteButton uCfg =
   let
-    cfg = uCfg & uiButtonCfg_class %~ (<> "button_type_secondary" <> "button_size_tiny")
+    cfg = uCfg
+      & uiButtonCfg_class %~ (<> "button_type_secondary" <> "button_size_tiny" <> "button_border_none")
   in
     uiButton cfg $ imgWithAltCls "button__icon" (static @"img/bin.svg") "Delete" blank
 
 deleteButtonNaked :: StaticButtonConstraints t m => UiButtonCfg -> m (Event t ())
 deleteButtonNaked cfg =
-  {- let -}
-  {-   cfg = uCfg & uiButtonCfg_class %~ (<> "button_type_secondary" <> "button_size_tiny") -}
-  {- in -}
-    uiButton cfg $ imgWithAltCls "button__icon" (static @"img/bin.svg") "Delete" blank
+  uiButton cfg $ imgWithAltCls "button__icon" (static @"img/bin.svg") "Delete" blank
 
 cogButton :: StaticButtonConstraints t m => UiButtonCfg -> m (Event t ())
 cogButton uCfg =

frontend/src/Frontend/UI/DeploymentSettings.hs

@@ -163,7 +163,8 @@ userChainIdSelect m = mkLabeledClsInput (uiChainSelection mNodeInfo) labelText
 
 -- | UI for asking the user about data needed for deployments/function calling.
 uiCfg
-  :: (MonadWidget t m, HasNetwork model t, HasNetworkCfg mConf t, Monoid mConf
+  :: ( MonadWidget t m, HasNetwork model t, HasNetworkCfg mConf t, Monoid mConf
+     , HasWallet model t
      )
   => model
   -> m (Dynamic t (f ChainId))
@@ -198,8 +199,10 @@ uiEndpoint wChainId ep = do
 
 -- | ui for asking the user about meta data needed for the transaction.
 uiMetaData
-  :: (DomBuilder t m, MonadHold t m, MonadFix m, PostBuild t m
-    , HasNetwork model t, HasNetworkCfg mConf t, Monoid mConf
+  :: ( DomBuilder t m, MonadHold t m, MonadFix m, PostBuild t m
+     , HasNetwork model t, HasNetworkCfg mConf t, Monoid mConf
+     , MonadIO (Performable m), PerformEvent t m, TriggerEvent t m
+     , HasWallet model t
      )
   => model -> m mConf
 uiMetaData m  = do
@@ -227,12 +230,15 @@ uiMetaData m  = do
 
       senderDropdown meta uCfg = do
         let itemDom v = elAttr "option" ("value" =: v) $ text v
-        onSet <- tagOnPostBuild $ _pmSender <$> meta
+        -- Delay necessary until we have mount hooks. (SelectElement won't accept
+        -- setting event until its children are properly rendered.)
+        onSet <- delay 0 <=< tagOnPostBuild $ _pmSender <$> meta
         let
           cfg = uCfg
             & selectElementConfig_setValue .~ onSet
         (se, ()) <- uiSelectElement cfg $ do
-          traverse_ itemDom $ Map.keys chainwebDefaultSenders
+          void $ networkView $
+            traverse_ itemDom . Map.keys <$> m ^. wallet_keys
         pure $ _selectElement_change se
 
       readPact wrapper =  fmap wrapper . readMay . T.unpack

static/examples/simplePayments-1.0.pact

@@ -15,46 +15,46 @@
   ; user debit capability
   (defcap USER_DEBIT (user-id)
     "enforces row guard to allow debiting operations"
-    (with-read payments-table user-id { "guard":= guard }
+    (with-read accounts-table user-id { "guard":= guard }
       (enforce-guard guard)))
 
   ; define table schema
-  (defschema payments
+  (defschema accounts
     balance:decimal
     guard:guard)
 
   ; define table
-  (deftable payments-table:{payments})
+  (deftable accounts-table:{accounts})
 
   (defun create-account (id initial-balance keyset)
     "Create a new account for ID with INITIAL-BALANCE funds, must be administrator."
     (with-capability (ACCOUNT_ADMIN)
       (enforce (>= initial-balance 0.0) "Initial balances must be >= 0.")
-      (insert payments-table id
+      (insert accounts-table id
         { "balance": initial-balance,
           "guard": keyset })))
 
   (defun get-balance (id)
     "Read account balance."
-    (at "balance" (read payments-table id)))
+    (at "balance" (read accounts-table id)))
 
   (defun pay (from to amount)
     "Make a payment debiting FROM and crediting TO for AMOUNT."
     (with-capability (USER_DEBIT from)
-      (with-read payments-table from { "balance":= from-bal }
-        (with-read payments-table to { "balance":= to-bal }
+      (with-read accounts-table from { "balance":= from-bal }
+        (with-read accounts-table to { "balance":= to-bal }
           (enforce (> amount 0.0) "Negative Transaction Amount")
           (enforce (>= from-bal amount) "Insufficient Funds")
-          (update payments-table from
+          (update accounts-table from
                   { "balance": (- from-bal amount) })
-          (update payments-table to
+          (update accounts-table to
                   { "balance": (+ to-bal amount) })
           (format "{} paid {} {}" [from to amount])))))
 
 )
 
 ;define table
-(create-table payments-table)
+(create-table accounts-table)
 
 ;;;; create accounts
 ; (env-data { "sarah-keyset": ["sarah"], "james-keyset": ["james"] })
@@ -72,4 +72,4 @@
 ;;;; success Sarah paying James with Sarah's key
 ; (pay "Sarah" "James" 25.0)
 ; (format "Sarah's balance is {}" [(get-balance "Sarah")])
-; (format "James's balance is {}" [(get-balance "James")])
+; (format "James's balance is {}" [(get-balance "James")])