Permalink
Browse files

Merge branch 'master' into playground-extras

  • Loading branch information...
michaelpj committed Dec 6, 2018
2 parents 0c38fdc + b49791d commit c156ea609a19da763f6c460351254db309782570
Showing with 548 additions and 415 deletions.
  1. +1 −1 .hlint.yaml
  2. +1 −1 default.nix
  3. +21 −6 pkgs/default.nix
  4. +22 −0 plutus-playground/plutus-playground-lib/plutus-playground-lib.cabal
  5. +2 −2 plutus-playground/plutus-playground-lib/src/Playground/API.hs
  6. +1 −0 plutus-playground/plutus-playground-lib/src/Playground/TH.hs
  7. +60 −0 plutus-playground/plutus-playground-lib/tests/Spec.hs
  8. +1 −1 plutus-tx-plugin/plutus-tx-plugin.cabal
  9. +18 −23 plutus-tx-plugin/src/Language/PlutusTx/Lift.hs
  10. +25 −25 plutus-tx-plugin/src/Language/PlutusTx/Lift/{LiftPir.hs → Class.hs}
  11. +17 −17 plutus-tx-plugin/src/Language/PlutusTx/Lift/Instances.hs
  12. +2 −2 plutus-tx-plugin/src/Language/PlutusTx/Plugin.hs
  13. +11 −11 plutus-tx-plugin/test/Lift/Spec.hs
  14. +1 −1 plutus-tx-plugin/test/Plugin/Spec.hs
  15. +87 −13 plutus-tx/src/Language/PlutusTx/Prelude.hs
  16. +3 −3 plutus-tx/tutorial/Tutorial.md
  17. +1 −1 plutus-tx/tutorial/tutorial-doctests.hs
  18. +0 −4 plutus-use-cases/README.md
  19. +0 −20 plutus-use-cases/plutus-use-cases.cabal
  20. +16 −0 plutus-use-cases/src/Language/PlutusTx/Coordination/Contracts.hs
  21. +4 −4 plutus-use-cases/src/Language/PlutusTx/Coordination/Contracts/CrowdFunding.hs
  22. +8 −8 plutus-use-cases/src/Language/PlutusTx/Coordination/Contracts/Future.hs
  23. +8 −8 plutus-use-cases/src/Language/PlutusTx/Coordination/Contracts/Swap.hs
  24. +5 −6 plutus-use-cases/src/Language/PlutusTx/Coordination/Contracts/Vesting.hs
  25. +0 −80 plutus-use-cases/src/Language/PlutusTx/Validation.hs
  26. +0 −94 plutus-use-cases/src/Language/PlutusTx/Validation/TH.hs
  27. +0 −2 plutus-use-cases/tutorial/tutorial-doctests.hs
  28. +4 −0 wallet-api/README.md
  29. +4 −3 wallet-api/src/Ledger/Types.hs
  30. +190 −72 wallet-api/src/Ledger/Validation.hs
  31. +1 −3 wallet-api/src/Wallet/Emulator.hs
  32. 0 {plutus-use-cases → wallet-api}/tutorial/Tutorial.lhs
  33. +4 −4 {plutus-use-cases → wallet-api}/tutorial/Tutorial.md
  34. +12 −0 wallet-api/tutorial/tutorial-doctests.hs
  35. +18 −0 wallet-api/wallet-api.cabal
@@ -2,7 +2,7 @@
- functions:
- {name: unsafePerformIO, within: [PlutusPrelude, Language.PlutusCore.Generators.Internal.Entity, Language.PlutusCore.Constant.Dynamic.Call, Language.PlutusCore.Constant.Dynamic.Emit, Language.PlutusCore.Constant.Dynamic.Instances, Language.PlutusTx.Plugin, Language.PlutusTx.Evaluation]}
- {name: error, within: [Main, PlutusPrelude, Language.PlutusCore.StdLib.Meta, Evaluation.Constant.Success, Language.PlutusCore.Constant.Apply, Language.PlutusCore.Constant.Typed, Language.PlutusCore.Evaluation.CkMachine, Language.PlutusCore.TypeSynthesis, Language.PlutusCore.Generators.Internal.Entity, Language.PlutusCore.Generators.Internal.Utils, Language.PlutusCore.Constant.Make, Language.PlutusCore.TH, Language.PlutusTx.Utils, Language.PlutusIR.Compiler.Datatype]}
- {name: undefined, within: [Language.PlutusCore.Constant.Apply, Language.PlutusTx.Lift.LiftPir, Language.PlutusTx.Lift.Instances]}
- {name: undefined, within: [Language.PlutusCore.Constant.Apply, Language.PlutusTx.Lift.Class, Language.PlutusTx.Lift.Instances]}
- {name: fromJust, within: [Language.PlutusTx.Lift]}
- {name: foldl, within: []}
- {name: traceShowId, within: []} # for debugging only, should not be merged to master
@@ -87,7 +87,7 @@ let
splitCheck = let
dontSplit = [
# Broken for things with test tool dependencies
"plutus-use-cases"
"wallet-api"
"plutus-tx"
# Broken for things which pick up other files at test runtime
"plutus-playground-server"

Some generated files are not rendered by default. Learn more.

Oops, something went wrong.
@@ -56,3 +56,25 @@ library
, text
, wallet-api
default-language: Haskell2010
test-suite playground-lib-test
default-language: Haskell2010
hs-source-dirs: tests
type: exitcode-stdio-1.0
main-is: Spec.hs
build-depends:
base >=4.9 && <5,
containers -any,
hedgehog -any,
swagger2 -any,
tasty -any,
tasty-hunit -any,
text -any,
template-haskell -any,
plutus-playground-lib -any,
wallet-api -any,
aeson -any
ghc-options:
-Wall -Wnoncanonical-monad-instances
-Wincomplete-uni-patterns -Wincomplete-record-updates
-Wredundant-constraints -Widentities
@@ -47,7 +47,7 @@ newtype SourceCode = SourceCode Text
deriving anyclass (Newtype)
newtype Fn = Fn Text
deriving stock (Show, Generic, TH.Lift)
deriving stock (Eq, Show, Generic, TH.Lift)
deriving newtype (ToJSON, FromJSON)
data Expression
@@ -83,7 +83,7 @@ data EvaluationResult = EvaluationResult
data FunctionSchema a = FunctionSchema
{ functionName :: Fn
, argumentSchema :: [a]
} deriving (Show, Generic, ToJSON, Functor)
} deriving (Eq, Show, Generic, ToJSON, Functor)
data SimpleArgumentSchema
= SimpleIntArgument
@@ -42,6 +42,7 @@ toSchemas fn ts = do
args :: Type -> [Type]
args (AppT (AppT ArrowT t1) as) = t1 : args as
args (AppT (ConT _) _) = []
args (ForallT _ _ as) = args as
args (ConT _) = []
args (TupleT _) = []
@@ -0,0 +1,60 @@
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
module Main where
import Data.Aeson (FromJSON (..), ToJSON (..))
import Data.Proxy (Proxy (..))
import Data.Swagger (Schema, ToSchema (..), toSchema)
import Data.Text (Text)
import GHC.Generics (Generic)
import Test.Tasty
import Test.Tasty.HUnit
import Playground.API
import Playground.TH
import Wallet.Emulator.Types (MockWallet)
-- f1..fn are functions that we should be able to generate schemas
-- for, using `mkFunction`. The schemas will be called f1Schema etc.
f1 :: MockWallet ()
f1 = pure ()
f2 :: String -> MockWallet ()
f2 _ = pure ()
f3 :: String -> Value -> MockWallet ()
f3 _ _ = pure ()
f4 :: Text -> Text -> (Int, Int) -> [Text] -> MockWallet ()
f4 _ _ _ _ = pure ()
data Value = Value Int Int
deriving (Generic, FromJSON, ToJSON, ToSchema)
$(mkFunction 'f1)
$(mkFunction 'f2)
$(mkFunction 'f3)
$(mkFunction 'f4)
main :: IO ()
main = defaultMain tests
tests :: TestTree
tests = testGroup "TH" [
testCase "f1" (f1Schema @?= FunctionSchema @Schema (Fn "f1") []),
testCase "f2" (f2Schema @?= FunctionSchema (Fn "f2") [
toSchema (Proxy @String)]),
testCase "f3" (f3Schema @?= FunctionSchema (Fn "f3") [
toSchema (Proxy @String),
toSchema (Proxy @Value)]),
testCase "f4" (f4Schema @?= FunctionSchema (Fn "f4") [
toSchema (Proxy @Text),
toSchema (Proxy @Text),
toSchema (Proxy @(Int, Int)),
toSchema (Proxy @[Text]) ])
]
@@ -26,6 +26,7 @@ flag development
library
exposed-modules:
Language.PlutusTx.Lift
Language.PlutusTx.Lift.Class
Language.PlutusTx.Plugin
Language.PlutusTx.Builtins
Language.PlutusTx.Compiler.Error
@@ -34,7 +35,6 @@ library
Language.PlutusTx.PLCTypes
Language.PlutusTx.PIRTypes
Language.PlutusTx.Utils
Language.PlutusTx.Lift.LiftPir
Language.PlutusTx.Lift.THUtils
Language.PlutusTx.Lift.Instances
Language.PlutusTx.Compiler.Binders
@@ -1,14 +1,15 @@
{-# LANGUAGE FlexibleContexts #-}
-- Note that we don't export the Lift class itself, most consumers shouldn't need that.
module Language.PlutusTx.Lift (
module Lift,
makeLift,
liftPlc,
liftPlcProgram,
unsafeLiftPlc,
unsafeLiftPlcProgram) where
lift,
liftProgram,
unsafeLift,
unsafeLiftProgram) where
import Language.PlutusTx.Lift.Class (makeLift)
import qualified Language.PlutusTx.Lift.Class as Lift
import Language.PlutusTx.Lift.Instances ()
import Language.PlutusTx.Lift.LiftPir as Lift
import Language.PlutusIR
import Language.PlutusIR.Compiler
@@ -18,34 +19,28 @@ import qualified Language.PlutusCore as PLC
import Language.PlutusCore.Quote
import Control.Exception
import Control.Monad.Except
import Control.Monad.Reader
import qualified Language.Haskell.TH as TH
import Control.Monad.Except hiding (lift)
import Control.Monad.Reader hiding (lift)
-- | Get a Plutus Core term corresponding to the given value.
liftPlc :: (LiftPir a, AsError e (Provenance ()), MonadError e m, MonadQuote m) => a -> m (PLC.Term TyName Name ())
liftPlc x = do
lift :: (Lift.Lift a, AsError e (Provenance ()), MonadError e m, MonadQuote m) => a -> m (PLC.Term TyName Name ())
lift x = do
lifted <- runDefT () $ Lift.lift x
compiled <- flip runReaderT NoProvenance $ compileTerm lifted
pure $ void compiled
-- | Get a Plutus Core program corresponding to the given value.
liftPlcProgram :: (LiftPir a, AsError e (Provenance ()), MonadError e m, MonadQuote m) => a -> m (PLC.Program TyName Name ())
liftPlcProgram x = PLC.Program () (PLC.defaultVersion ()) <$> liftPlc x
liftProgram :: (Lift.Lift a, AsError e (Provenance ()), MonadError e m, MonadQuote m) => a -> m (PLC.Program TyName Name ())
liftProgram x = PLC.Program () (PLC.defaultVersion ()) <$> lift x
-- | Get a Plutus Core term corresponding to the given value, throwing any errors that occur as exceptions and ignoring fresh names.
unsafeLiftPlc :: LiftPir a => a -> PLC.Term TyName Name ()
unsafeLiftPlc a = runQuote $ do
run <- runExceptT $ liftPlc a
unsafeLift :: Lift.Lift a => a -> PLC.Term TyName Name ()
unsafeLift a = runQuote $ do
run <- runExceptT $ lift a
case run of
Left (e::Error (Provenance ())) -> throw e
Right t -> pure t
-- | Get a Plutus Core program corresponding to the given value, throwing any errors that occur as exceptions and ignoring fresh names.
unsafeLiftPlcProgram :: LiftPir a => a -> PLC.Program TyName Name ()
unsafeLiftPlcProgram x = PLC.Program () (PLC.defaultVersion ()) $ unsafeLiftPlc x
-- | Make lift typeclass instances for the given type constructor name.
makeLift :: TH.Name -> TH.Q [TH.Dec]
makeLift = makeLiftPir
unsafeLiftProgram :: Lift.Lift a => a -> PLC.Program TyName Name ()
unsafeLiftProgram x = PLC.Program () (PLC.defaultVersion ()) $ unsafeLift x
Oops, something went wrong.

0 comments on commit c156ea6

Please sign in to comment.