[WIP]: A path to white label friendly play-haskell

.gitignore

@@ -2,3 +2,8 @@ dist-newstyle/
 node_modules/
 .stack-work/
 .ccls-cache/
+
+adminpass.txt
+secretkey.txt
+pubkey.txt
+trustedkeys.txt

play-haskell-server/example-snippets.txt

@@ -1,99 +1,70 @@
-import Data.List (partition)
+module Project where
+import Control.LinearlyVersionedMonad qualified as LVM
+import Prelude.YulDSL
+
+-- | Ethereum contract is a Yul Object in Yolc.
+object = mkYulObject "ERC20" emptyCtor
+  [ staticFn "balanceOf" erc20_balance_of
+  , omniFn   "mint" erc20_mint
+  , omniFn   "transfer" erc20_transfer
+  ]
+
+-- | ERC20 balance storage location for the account.
+--
+-- TODO: this code can be made more palatable in the future versions of Yolc.
+erc20_balance_storage_of = fn @(ADDR -> B32) $locId $
+  \acc -> yulKeccak256 $
+          -- shell$ cast keccak "Yolc.Demo.ERC20.Storage.AccountBalance"
+          (YulEmb (0xc455e3e95e9cd89a306d7619bc5f6406a85b850d31788d0c0fb15e6364be6592 :: U256))
+          `YulFork` acc
+
+balance_ref_of account'p = ver'l $ callFn'lpp erc20_balance_storage_of account'p
+
+balance_of account'p = sget $ balance_ref_of account'p
+
+-- | ERC20 balance of the account.
+erc20_balance_of = lfn $locId $ yulmonad'p @(ADDR -> U256)
+  \account'p -> balance_of account'p
+
+erc20_mint = lfn $locId $ yulmonad'p @(ADDR -> U256 -> ())
+  \account'p mintAmount'p -> LVM.do
+  -- fetch balance of the account
+  (account'p, balanceBefore) <- pass account'p balance_of
+  -- use linear port (naming convention, "*'p") values safely
+  (account'p, mintAmount'p) <- passN_ (account'p, mintAmount'p) \(account'p, mintAmount'p) ->
+    -- update balance
+    sput (balance_ref_of account'p) (balanceBefore + ver'l mintAmount'p)
+  -- call unsafe external contract onTokenMinted
+  externalCall onTokenMinted (ver'l account'p) (ver'l mintAmount'p)
+
+  -- -- fetch balance of the account
+  -- (account'p, balanceBefore) <- pass account'p balance_of
+  -- -- use linear port (naming convention, "*'p") values safely
+  -- (account'p, mintAmount'p) <- passN_ (account'p, mintAmount'p) \(account'p, mintAmount'p) ->
+  --   -- call unsafe external contract onTokenMinted
+  --   externalCall onTokenMinted (ver'l account'p) (ver'l mintAmount'p)
+  -- -- update balance, but using out dated "balanceBefore value" will fail to compile
+  -- sput (balance_ref_of account'p) (balanceBefore + ver'l mintAmount'p)
+
+erc20_transfer = lfn $locId $ yulmonad'p @(ADDR -> ADDR -> U256 -> BOOL)
+  \from'p to'p amount'p -> LVM.do
+  -- get sender balance
+  (from'p, senderBalanceRef) <- pass from'p (ypure . balance_ref_of)
+  -- get receiver balance
+  (to'p, receiverBalanceRef) <- pass to'p (ypure . balance_ref_of)
+  -- calculate new balances
+  (amount, newSenderBalance) <- pass (ver'l amount'p)
+    \amount -> ypure $ callFn'l erc20_balance_of (ver'l from'p) - amount
+  newReceiverBalance <- with amount
+    \amount -> ypure $ callFn'l erc20_balance_of (ver'l to'p) + amount
+  -- update storages
+  sputs $
+    senderBalanceRef   := newSenderBalance   :|
+    receiverBalanceRef := newReceiverBalance : []
+  -- always return true as a silly urban-legendary ERC20 convention
+  embed true
+
+-- TODO: to be abstracted in an interface definition
+--
+onTokenMinted = declareExternalFn @(U256 -> ()) "onTokenMinted"
 
-main :: IO ()
-main = do
-  let unsorted = [10,9..1]
-  putStrLn $ show $ quicksort unsorted
-
-quicksort :: Ord a => [a] -> [a]
-quicksort []     = []
-quicksort (x:xs) = let (lesser, greater) = partition (<= x) xs
-                   in quicksort lesser ++ [x] ++ quicksort greater
-
--- ~~~~ CUT
-
-{-# LANGUAGE OverloadedStrings #-}
-
-import qualified Data.Text as T
-import qualified Data.Time as Time
-
-data Visitor
-  = Member Profile
-  | NonMember (Maybe T.Text)
-  deriving Show
-
-data Profile =
-  Profile
-    { name :: T.Text
-    , birthday :: Time.Day
-    } deriving Show
-
-main :: IO ()
-main = do
-  let haskell = Member Profile
-        { name = "Haskell Curry"
-        , birthday = read "1900-09-12"
-        }
-  greeting <- makeGreeting haskell
-  putStrLn $ T.unpack greeting
-
-makeGreeting :: Visitor -> IO T.Text
-makeGreeting visitor =
-  case visitor of
-    NonMember maybeName ->
-      pure $ case maybeName of
-        Just name -> "Hello, " <> name <> "!"
-        Nothing   -> "Hello, mysterious visitor!"
-    Member profile -> do
-      today <- Time.utctDay <$> Time.getCurrentTime
-      let monthAndDay = (\(_y, m, d) -> (m, d)) . Time.toGregorian
-      if monthAndDay today == monthAndDay (birthday profile)
-      then pure $ "Happy birthday, " <> name profile <> "!"
-      else pure $ "Welcome back, " <> name profile <> "!"
-
--- ~~~~ CUT
-
-import Control.Monad (replicateM)
-import Data.Foldable (foldl')
-import qualified System.Random.Stateful as Rand
-
-data Drone = Drone
-  { xPos :: Int
-  , yPos :: Int
-  , zPos :: Int
-  } deriving Show
-
-data Movement
-  = Forward | Back | ToLeft | ToRight | Up | Down
-  deriving (Show, Enum, Bounded)
-
-main :: IO ()
-main = do
-  let initDrone = Drone { xPos = 0, yPos = 100, zPos = 0 }
-  -- Generate 15 moves randomly
-  randomMoves <- replicateM 15 $ Rand.uniformEnumM Rand.globalStdGen
-  let resultDrone = foldl' moveDrone initDrone randomMoves
-  print resultDrone
-
-moveDrone :: Drone -> Movement -> Drone
-moveDrone drone move =
-  case move of
-    Forward -> drone { zPos = zPos drone + 1 }
-    Back    -> drone { zPos = zPos drone - 1 }
-    ToLeft  -> drone { xPos = xPos drone - 1 }
-    ToRight -> drone { xPos = xPos drone + 1 }
-    Up      -> drone { yPos = yPos drone + 1 }
-    Down    -> drone { yPos = yPos drone - 1 }
-
--- ~~~~ CUT
--- ~~~~ # adapted from @liamzee's https://github.com/haskript/big-book-of-small-haskell-projects/blob/51fd3ac4db30e9df2f14924d66d1469638aed009/35.HexGrid/HexGrid.hs
-
-main :: IO ()
-main = putStr $ unlines $ hexagons 12 17
-
-hexagons :: Int -> Int -> [String]
-hexagons xRepeat yRepeat =
-  yRepeat `times` [xRepeat `times` "/ \\_"
-                  ,xRepeat `times` "\\_/ "]
-  where
-    n `times` l = concat (replicate n l)

play-haskell-server/play.mustache

@@ -3,8 +3,8 @@
 <head>
 <meta charset="utf-8">
 <meta name="viewport" content="width=device-width, initial-scale=1">
-<link rel="icon" type="image/png" href="/haskell-play-logo.png">
-<title>Haskell Playground</title>
+<link rel="icon" type="image/png" href="https://yolc.dev/yolc-logo-256x256.png">
+<title>Yolc Playground</title>
 <style>
 html, body {
 	margin: 0;
@@ -460,11 +460,12 @@ preload_ghcopt = {{&preload_ghcopt}};
 	</dialog>
 
 	<div id="header">
-		<img id="title" src="/haskell-logo-tw.svg">
+		<img id="title" src="https://yolc.dev/yolc-logo-256x256.png">
 		<div id="toolbar">
-			<button id="btn-run" class="pure-button">Run</button>
+			<button id="btn-yolc" class="pure-button">Generate Solidity/Yul</button>
+			<!-- <button id="btn-run" class="pure-button">Run</button>
 			<button id="btn-core" class="pure-button">Core</button>
-			<button id="btn-asm" class="pure-button">Asm</button>
+			<button id="btn-asm" class="pure-button">Asm</button> -->
 			<select id="ghcversionselect"></select>
 			<select id="optselect"></select>
 			<button id="btn-save" class="pure-button">Save &amp; share code</button>

play-haskell-server/static/play-index.ts

@@ -462,15 +462,14 @@ window.addEventListener("load", function() {
 			editor.commands.platform == "mac"
 				? "Press Cmd-Enter to run again"
 				: "Press Ctrl-Enter to run again";
-	document.getElementById("btn-run").setAttribute("title", runTooltip);
-	document.getElementById("btn-core").setAttribute("title", runTooltip);
-	document.getElementById("btn-asm").setAttribute("title", runTooltip);
+	// document.getElementById("btn-run").setAttribute("title", runTooltip);
+	// document.getElementById("btn-core").setAttribute("title", runTooltip);
+	// document.getElementById("btn-asm").setAttribute("title", runTooltip);
 
 	if (editor.commands.platform == "mac") {
 		const l = document.getElementsByClassName("ui-ctrl-cmd");
 		for (let i = 0; i < l.length; i++) l[i].innerHTML = "Cmd";
 	}
-
 	getVersions(function(versions) {
 		const initialGHCver =
 			preload_ghcver == null
@@ -519,9 +518,10 @@ window.addEventListener("load", function() {
 	editor.focus();
 });
 
-document.getElementById("btn-run").addEventListener('click', () => { doRun("run") });
-document.getElementById("btn-core").addEventListener('click', () => { doRun("core") });
-document.getElementById("btn-asm").addEventListener('click', () => { doRun("asm") });
+document.getElementById("btn-yolc").addEventListener('click', () => { doRun("run") });
+// document.getElementById("btn-run").addEventListener('click', () => { doRun("run") });
+// document.getElementById("btn-core").addEventListener('click', () => { doRun("core") });
+// document.getElementById("btn-asm").addEventListener('click', () => { doRun("asm") });
 document.getElementById("btn-save").addEventListener('click', () => { doSave() });
 document.getElementById("btn-close-save-alert").addEventListener('click', () => {
 	(document.getElementById("save-alert") as HTMLDialogElement).close();

play-haskell-types/src/PlayHaskellTypes/Constants.hs

@@ -3,4 +3,4 @@ module PlayHaskellTypes.Constants where
 
 
 runTimeoutMicrosecs :: Int
-runTimeoutMicrosecs = 5_000_000
+runTimeoutMicrosecs = 10_000_000