Permalink
Browse files

runghc doing everything and tests passing but still todo

* Compile errors have been hacked into RawError, they need to be parsed
into proper errors with line numbers etc again
* Need to communicate changes to the users, probably by catching
specific errors and re-wording them
  • Loading branch information...
David Smith
David Smith committed Jan 10, 2019
1 parent d99df2f commit a42b0639a98a20518225f82d12fcede8f283296a
@@ -14,28 +14,27 @@

module Playground.API where

import Control.Lens (over, _2)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State (StateT, evalStateT, get, put)
import Control.Newtype.Generics (Newtype, pack, unpack)
import Data.Aeson (FromJSON, ToJSON, Value)
import Data.Bifunctor (second)
import qualified Data.HashMap.Strict.InsOrd as HM
import Data.Maybe (fromMaybe)
import Data.Swagger (ParamSchema (ParamSchema), Referenced (Inline, Ref), Schema (Schema),
SwaggerType (SwaggerInteger, SwaggerObject, SwaggerString))
import qualified Data.Swagger as Swagger
import Data.Text (Text)
import qualified Data.Text as Text
import GHC.Generics (Generic)
import qualified Language.Haskell.Interpreter as Hint
import qualified Language.Haskell.TH.Syntax as TH
import Ledger.Types (Blockchain, PubKey)
import qualified Ledger.Types as Ledger
import Servant.API ((:<|>), (:>), JSON, Post, ReqBody)
import Text.Read (readMaybe)
import Wallet.Emulator.Types (EmulatorEvent, Wallet)
import Wallet.Graph (FlowGraph)
import Control.Lens (over, _2)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State (StateT, evalStateT, get, put)
import Control.Newtype.Generics (Newtype, pack, unpack)
import Data.Aeson (FromJSON, ToJSON, Value)
import Data.Bifunctor (second)
import qualified Data.HashMap.Strict.InsOrd as HM
import Data.Maybe (fromMaybe)
import Data.Swagger (ParamSchema (ParamSchema), Referenced (Inline, Ref), Schema (Schema),
SwaggerType (SwaggerInteger, SwaggerObject, SwaggerString))
import qualified Data.Swagger as Swagger
import Data.Text (Text)
import qualified Data.Text as Text
import GHC.Generics (Generic)
import qualified Language.Haskell.TH.Syntax as TH
import Ledger.Types (Blockchain, PubKey)
import qualified Ledger.Types as Ledger
import Servant.API ((:<|>), (:>), JSON, Post, ReqBody)
import Text.Read (readMaybe)
import Wallet.Emulator.Types (EmulatorEvent, Wallet)
import Wallet.Graph (FlowGraph)

type API
= "contract" :> ReqBody '[ JSON] SourceCode :> Post '[ JSON] (Either [CompilationError] [FunctionSchema SimpleArgumentSchema])
@@ -120,16 +119,17 @@ data CompilationError
, column :: !Int
, text :: ![Text] }
deriving stock (Show, Eq, Generic)
deriving anyclass (ToJSON)
deriving anyclass (ToJSON, FromJSON)

data PlaygroundError
= CompilationErrors [CompilationError]
| InterpreterError Hint.InterpreterError
| InterpreterError [String]
| FunctionSchemaError
| DecodeJsonTypeError String String
| PlaygroundTimeout
| OtherError String
deriving stock (Show, Generic)
deriving anyclass (ToJSON, FromJSON)

parseErrorText :: Text -> CompilationError
parseErrorText input =
@@ -1,58 +1,60 @@
{-# LANGUAGE TemplateHaskell #-}

module Playground.TH
( mkFunction
, mkFunctions
) where
( mkFunction
, mkFunctions
) where

import Data.Proxy (Proxy (Proxy))
import Data.Swagger.Schema (toInlinedSchema)
import Data.Text (pack)
import Language.Haskell.TH (Body (NormalB), Clause (Clause), Dec (FunD, ValD), Exp(ListE, VarE), Pat(VarP), Info (VarI), Name, Q,
Type (AppT, ArrowT, ConT, ForallT, TupleT, VarT), mkName, nameBase, reify)
import Language.Haskell.TH (Body (NormalB), Clause (Clause), Dec (FunD, ValD), Exp (ListE, VarE), Info (VarI),
Name, Pat (VarP), Q, Type (AppT, ArrowT, ConT, ForallT, TupleT, VarT), mkName,
nameBase, reify)
import Playground.API (Fn (Fn), FunctionSchema (FunctionSchema))

mkFunctions :: [Name] -> Q [Dec]
mkFunctions names = do
fns <- traverse mkFunction' names
let newNames = fmap mkNewName names
schemas = ValD (VarP (mkName "schemas")) (NormalB (ListE newNames)) []
pure $ fns <> [schemas]
fns <- traverse mkFunction' names
let newNames = fmap mkNewName names
schemas = ValD (VarP (mkName "schemas")) (NormalB (ListE newNames)) []
pure $ fns <> [schemas]
where
mkNewName name = VarE . mkName $ nameBase name ++ "Schema"

mkFunction :: Name -> Q [Dec]
mkFunction name = do
let newName = mkName $ nameBase name ++ "Schema"
fn = Fn . pack $ nameBase name
expression <- mkFunctionExp name fn
pure [FunD newName [Clause [] (NormalB expression) []]]
let newName = mkName $ nameBase name ++ "Schema"
fn = Fn . pack $ nameBase name
expression <- mkFunctionExp name fn
pure [FunD newName [Clause [] (NormalB expression) []]]

mkFunction' :: Name -> Q Dec
mkFunction' name = do
let newName = mkName $ nameBase name ++ "Schema"
fn = Fn . pack $ nameBase name
expression <- mkFunctionExp name fn
pure $ FunD newName [Clause [] (NormalB expression) []]
let newName = mkName $ nameBase name ++ "Schema"
fn = Fn . pack $ nameBase name
expression <- mkFunctionExp name fn
pure $ FunD newName [Clause [] (NormalB expression) []]

{-# ANN mkFunctionExp ("HLint: ignore" :: String) #-}

mkFunctionExp :: Name -> Fn -> Q Exp
mkFunctionExp name fn = do
r <- reify name
case r of
(VarI _ as _) ->
let ts = args as
in toSchemas fn ts
_ -> error "Incorrect Name type provided to mkFunction"
r <- reify name
case r of
(VarI _ as _) ->
let ts = args as
in toSchemas fn ts
_ -> error "Incorrect Name type provided to mkFunction"

toSchemas :: Fn -> [Type] -> Q Exp
toSchemas fn ts = do
es <-
foldr
(\t e -> [|toInlinedSchema (Proxy :: Proxy $(pure t)) : $e|])
[|[]|]
ts
[|FunctionSchema fn $(pure es)|]
es <-
foldr
(\t e -> [|toInlinedSchema (Proxy :: Proxy $(pure t)) : $e|])
[|[]|]
ts
[|FunctionSchema fn $(pure es)|]

{-# ANN args ("HLint: ignore" :: String) #-}

@@ -70,9 +70,7 @@ loadSource fileName action =
avoidUnsafe :: (MonadError PlaygroundError m) => SourceCode -> m ()
avoidUnsafe s =
unless (null . Text.indices "unsafe" . Newtype.unpack $ s) $
throwError
(InterpreterError
(WontCompile [GhcError "Cannot interpret unsafe functions"]))
throwError $ InterpreterError ["Cannot interpret unsafe functions"]

addGhcOptions :: SourceCode -> SourceCode
addGhcOptions = Newtype.over SourceCode (mappend opts)
@@ -3,25 +3,34 @@

module Playground.Runghc where

import Control.Monad.Catch (MonadCatch, MonadMask, catch, bracket)
import Control.Monad.Error.Class (MonadError, throwError)
import Control.Monad.IO.Class (MonadIO, liftIO)
import qualified Control.Newtype.Generics as Newtype
import qualified Data.Aeson as JSON
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import Data.Swagger (Schema)
import qualified Data.Text as Text
import Playground.API (CompilationError (RawError), FunctionSchema,
PlaygroundError (CompilationErrors, OtherError), SourceCode)
import Playground.Usecases (mainTemplate)
import System.Directory (removeFile)
import System.Environment (lookupEnv)
import System.Exit (ExitCode (ExitSuccess))
import System.IO (Handle, hClose, hFlush)
import System.IO.Temp (getCanonicalTemporaryDirectory, openTempFile)
import System.Process (readProcessWithExitCode)
import Control.Monad (unless)
import Control.Monad.Catch (MonadCatch, MonadMask, bracket, catch)
import Control.Monad.Error.Class (MonadError, throwError)
import Control.Monad.IO.Class (MonadIO, liftIO)
import qualified Control.Newtype.Generics as Newtype
import Data.Aeson (ToJSON)
import qualified Data.Aeson as JSON
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy.Char8 as BSL
import Data.List (intercalate)
import Data.Swagger (Schema)
import qualified Data.Text as Text
import qualified Data.Text.Internal.Search as Text
import Ledger.Types (Blockchain, Value)
import Playground.API (CompilationError (RawError), Evaluation (sourceCode),
Expression (Action, Wait), Fn (Fn), FunctionSchema,
PlaygroundError (CompilationErrors, DecodeJsonTypeError, OtherError),
SourceCode, program, wallets)
import Playground.Usecases (mainTemplate)
import System.Directory (removeFile)
import System.Environment (lookupEnv)
import System.Exit (ExitCode (ExitSuccess))
import System.IO (Handle, hClose, hFlush)
import System.IO.Temp (getCanonicalTemporaryDirectory, openTempFile)
import System.Process (readProcessWithExitCode)
import Wallet.Emulator.Types (EmulatorEvent, Wallet)

run :: (MonadIO m, MonadError PlaygroundError m) => FilePath -> m String
run scriptPath = do
@@ -38,11 +47,17 @@ mkCompileScript script =
"\n\nmain :: IO ()" <>
"\nmain = LBC8.putStrLn . encode $ schemas <> [payToPublicKey_Schema]"

avoidUnsafe :: (MonadError PlaygroundError m) => SourceCode -> m ()
avoidUnsafe s =
unless (null . Text.indices "unsafe" . Newtype.unpack $ s) $
throwError $ OtherError "Cannot interpret unsafe functions"

compile ::
(MonadMask m, MonadIO m, MonadError PlaygroundError m)
=> SourceCode
-> m [FunctionSchema Schema]
compile source =
compile source = do
avoidUnsafe source
withSystemTempFile "Main.hs" $ \file handle -> do
liftIO $
BS.hPutStr handle $
@@ -56,13 +71,52 @@ compile source =
"unable to decode compilation result" <> err
Right schema -> pure schema

runFunction ::
(MonadMask m, MonadIO m, MonadError PlaygroundError m)
=> Evaluation
-> m (Blockchain, [EmulatorEvent], [(Wallet, Value)])
runFunction evaluation = do
let source = sourceCode evaluation
avoidUnsafe source
expr <- mkExpr evaluation
withSystemTempFile "Main.hs" $ \file handle -> do
liftIO $
BS.hPutStr handle $
mkRunScript (BS8.pack . Text.unpack . Newtype.unpack $ source) expr
liftIO $ hFlush handle
liftIO . BS8.putStrLn $
mkRunScript (BS8.pack . Text.unpack . Newtype.unpack $ source) expr
stdout <- run file
let decodeResult =
JSON.eitherDecodeStrict . BS8.pack $ stdout :: Either String (Either PlaygroundError ( Blockchain
, [EmulatorEvent]
, [( Wallet
, Value)]))
case decodeResult of
Left err ->
throwError . OtherError $
"unable to decode compilation result" <> err
Right eResult ->
case eResult of
Left err -> throwError err
Right result -> pure result

mkRunScript :: ByteString -> ByteString -> ByteString
mkRunScript script expr =
mainTemplate <> "\n\n" <> script <> "\n\n$(TH.mkFunction 'payToPublicKey_)" <>
"\n\nmain :: IO ()" <>
"\nmain = LBC8.putStrLn . encode $ " <>
expr

lookupRunghc :: (MonadIO m, MonadError PlaygroundError m) => m String
lookupRunghc = do
mBinDir <- liftIO $ lookupEnv "GHC_BIN_DIR"
mBinDir <- liftIO $ lookupEnv "GHC_BIN_DIR"
case mBinDir of
Nothing -> pure "runghc"
Just val -> pure $ val <> "/runghc"

{-# ANN ignoringIOErrors ("HLint: ignore Evaluate" :: String) #-}

ignoringIOErrors :: MonadCatch m => m () -> m ()
ignoringIOErrors ioe = ioe `catch` (\e -> const (return ()) (e :: IOError))

@@ -79,3 +133,57 @@ withSystemTempFile template action = do
liftIO (hClose handle >> ignoringIOErrors (removeFile name)))
(uncurry action)

jsonToString :: ToJSON a => a -> String
jsonToString = show . JSON.encode

mkExpr :: (MonadError PlaygroundError m) => Evaluation -> m ByteString
mkExpr evaluation = do
let allWallets = fst <$> wallets evaluation
exprs <- traverse (walletActionExpr allWallets) (program evaluation)
pure . BS8.pack $
"runTrace (decode' " <> jsonToString (wallets evaluation) <> ") [" <>
intercalate ", " exprs <>
"]"

{-# ANN getJsonString ("HLint: ignore" :: String) #-}

getJsonString :: (MonadError PlaygroundError m) => JSON.Value -> m String
getJsonString (JSON.String s) = pure $ Text.unpack s
getJsonString v =
throwError . DecodeJsonTypeError "String" . BSL.unpack . JSON.encode $ v

walletActionExpr ::
(MonadError PlaygroundError m) => [Wallet] -> Expression -> m String
walletActionExpr allWallets (Action (Fn f) wallet args) = do
argStrings <- fmap show <$> traverse getJsonString args
pure $
"(runWalletActionAndProcessPending (" <> show allWallets <> ") (" <>
show wallet <>
") <$> (" <>
mkApplyExpr (Text.unpack f) argStrings <>
"))"
-- We return an empty list to fix types as wallets have already been notified
walletActionExpr allWallets (Wait blocks) =
pure $
"pure $ addBlocksAndNotify (" <> show allWallets <> ") " <> show blocks <>
" >> pure []"

{-# ANN mkApplyExpr ("HLint: ignore" :: String) #-}

mkApplyExpr :: String -> [String] -> String
mkApplyExpr functionName [] = "apply" <+> functionName
mkApplyExpr functionName [a] = "apply1" <+> functionName <+> a
mkApplyExpr functionName [a, b] = "apply2" <+> functionName <+> a <+> b
mkApplyExpr functionName [a, b, c] = "apply3" <+> functionName <+> a <+> b <+> c
mkApplyExpr functionName [a, b, c, d] =
"apply4" <+> functionName <+> a <+> b <+> c <+> d
mkApplyExpr functionName [a, b, c, d, e] =
"apply5" <+> functionName <+> a <+> b <+> c <+> d <+> e
mkApplyExpr functionName [a, b, c, d, e, f] =
"apply6" <+> functionName <+> a <+> b <+> c <+> d <+> e <+> f
mkApplyExpr functionName [a, b, c, d, e, f, g] =
"apply7" <+> functionName <+> a <+> b <+> c <+> d <+> e <+> f <+> g
mkApplyExpr _ _ = error "cannot apply more than 7 arguments"

(<+>) :: String -> String -> String
a <+> b = a <> " " <> b
Oops, something went wrong.

0 comments on commit a42b063

Please sign in to comment.