{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Language.Bitcoin.Miniscript.Compiler (
CompilerError (..),
compile,
compileOnly,
) where
import Control.Exception (Exception)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (Except, runExcept, throwE)
import Control.Monad.Trans.Reader (
ReaderT,
local,
runReaderT,
)
import Data.Bifunctor (first)
import Data.Functor (void)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Serialize (encode)
import Data.Text (Text)
import Haskoin.Crypto (ripemd160)
import Haskoin.Script (
Script (..),
ScriptOp (..),
opPushData,
)
import Language.Bitcoin.Miniscript.Syntax (
Miniscript (..),
Value (..),
)
import Language.Bitcoin.Miniscript.Types (
MiniscriptTypeError (..),
typeCheckMiniscript,
)
import Language.Bitcoin.Script.Descriptors (KeyDescriptor, keyBytes)
import Language.Bitcoin.Script.Utils (pushNumber)
import Language.Bitcoin.Utils (requiredContextValue)
data CompilerError
= FreeVariable Text
| CompilerError Miniscript
| TypeError MiniscriptTypeError
| NotImplemented Miniscript
| AbstractKey KeyDescriptor
deriving (CompilerError -> CompilerError -> Bool
(CompilerError -> CompilerError -> Bool)
-> (CompilerError -> CompilerError -> Bool) -> Eq CompilerError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CompilerError -> CompilerError -> Bool
$c/= :: CompilerError -> CompilerError -> Bool
== :: CompilerError -> CompilerError -> Bool
$c== :: CompilerError -> CompilerError -> Bool
Eq, Int -> CompilerError -> ShowS
[CompilerError] -> ShowS
CompilerError -> String
(Int -> CompilerError -> ShowS)
-> (CompilerError -> String)
-> ([CompilerError] -> ShowS)
-> Show CompilerError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CompilerError] -> ShowS
$cshowList :: [CompilerError] -> ShowS
show :: CompilerError -> String
$cshow :: CompilerError -> String
showsPrec :: Int -> CompilerError -> ShowS
$cshowsPrec :: Int -> CompilerError -> ShowS
Show)
instance Exception CompilerError
compile :: Miniscript -> Either CompilerError Script
compile :: Miniscript -> Either CompilerError Script
compile script :: Miniscript
script = do
Either CompilerError MiniscriptType -> Either CompilerError ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Either CompilerError MiniscriptType -> Either CompilerError ())
-> (Either MiniscriptTypeError MiniscriptType
-> Either CompilerError MiniscriptType)
-> Either MiniscriptTypeError MiniscriptType
-> Either CompilerError ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MiniscriptTypeError -> CompilerError)
-> Either MiniscriptTypeError MiniscriptType
-> Either CompilerError MiniscriptType
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first MiniscriptTypeError -> CompilerError
TypeError (Either MiniscriptTypeError MiniscriptType
-> Either CompilerError ())
-> Either MiniscriptTypeError MiniscriptType
-> Either CompilerError ()
forall a b. (a -> b) -> a -> b
$ Map Text MiniscriptType
-> Miniscript -> Either MiniscriptTypeError MiniscriptType
typeCheckMiniscript Map Text MiniscriptType
forall a. Monoid a => a
mempty Miniscript
script
Miniscript -> Either CompilerError Script
compileOnly Miniscript
script
compileOnly :: Miniscript -> Either CompilerError Script
compileOnly :: Miniscript -> Either CompilerError Script
compileOnly = ([ScriptOp] -> Script)
-> Either CompilerError [ScriptOp] -> Either CompilerError Script
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [ScriptOp] -> Script
Script (Either CompilerError [ScriptOp] -> Either CompilerError Script)
-> (Miniscript -> Either CompilerError [ScriptOp])
-> Miniscript
-> Either CompilerError Script
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Except CompilerError [ScriptOp] -> Either CompilerError [ScriptOp]
forall e a. Except e a -> Either e a
runExcept (Except CompilerError [ScriptOp]
-> Either CompilerError [ScriptOp])
-> (Miniscript -> Except CompilerError [ScriptOp])
-> Miniscript
-> Either CompilerError [ScriptOp]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReaderT Context (Except CompilerError) [ScriptOp]
-> Context -> Except CompilerError [ScriptOp]
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` Map Text (Context, Miniscript) -> Context
Context Map Text (Context, Miniscript)
forall a. Monoid a => a
mempty) (ReaderT Context (Except CompilerError) [ScriptOp]
-> Except CompilerError [ScriptOp])
-> (Miniscript
-> ReaderT Context (Except CompilerError) [ScriptOp])
-> Miniscript
-> Except CompilerError [ScriptOp]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Miniscript -> ReaderT Context (Except CompilerError) [ScriptOp]
compileOpsInContext
newtype Context = Context {Context -> Map Text (Context, Miniscript)
unContext :: Map Text (Context, Miniscript)}
addClosure :: Text -> Miniscript -> Context -> Context
addClosure :: Text -> Miniscript -> Context -> Context
addClosure n :: Text
n e :: Miniscript
e c :: Context
c = Map Text (Context, Miniscript) -> Context
Context (Map Text (Context, Miniscript) -> Context)
-> (Map Text (Context, Miniscript)
-> Map Text (Context, Miniscript))
-> Map Text (Context, Miniscript)
-> Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text
-> (Context, Miniscript)
-> Map Text (Context, Miniscript)
-> Map Text (Context, Miniscript)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
n (Context
c, Miniscript
e) (Map Text (Context, Miniscript) -> Context)
-> Map Text (Context, Miniscript) -> Context
forall a b. (a -> b) -> a -> b
$ Context -> Map Text (Context, Miniscript)
unContext Context
c
requiredScript :: Text -> ReaderT Context (Except CompilerError) (Context, Miniscript)
requiredScript :: Text
-> ReaderT Context (Except CompilerError) (Context, Miniscript)
requiredScript name :: Text
name = (Context -> Map Text (Context, Miniscript))
-> CompilerError
-> Text
-> ReaderT Context (Except CompilerError) (Context, Miniscript)
forall r c e.
(r -> Map Text c) -> e -> Text -> ReaderT r (Except e) c
requiredContextValue Context -> Map Text (Context, Miniscript)
unContext (Text -> CompilerError
FreeVariable Text
name) Text
name
compileOpsInContext :: Miniscript -> ReaderT Context (Except CompilerError) [ScriptOp]
compileOpsInContext :: Miniscript -> ReaderT Context (Except CompilerError) [ScriptOp]
compileOpsInContext = \case
Boolean x :: Bool
x -> [ScriptOp] -> ReaderT Context (Except CompilerError) [ScriptOp]
forall (m :: * -> *) a. Monad m => a -> m a
return ([ScriptOp] -> ReaderT Context (Except CompilerError) [ScriptOp])
-> [ScriptOp] -> ReaderT Context (Except CompilerError) [ScriptOp]
forall a b. (a -> b) -> a -> b
$ if Bool
x then [ScriptOp
OP_1] else [ScriptOp
OP_0]
Key vk :: Value KeyDescriptor
vk -> Value KeyDescriptor
-> ReaderT Context (Except CompilerError) [ScriptOp]
forall (f :: * -> *).
Applicative f =>
Value KeyDescriptor
-> ReaderT Context (Except CompilerError) (f ScriptOp)
getKeyScript Value KeyDescriptor
vk
KeyH vk :: Value KeyDescriptor
vk -> do
ByteString
k <- KeyDescriptor -> ReaderT Context (Except CompilerError) ByteString
forall (t :: (* -> *) -> * -> *) (m :: * -> *).
(MonadTrans t, Monad m, Monad (t (ExceptT CompilerError m))) =>
KeyDescriptor -> t (ExceptT CompilerError m) ByteString
getKeyBytes (KeyDescriptor
-> ReaderT Context (Except CompilerError) ByteString)
-> ReaderT Context (Except CompilerError) KeyDescriptor
-> ReaderT Context (Except CompilerError) ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Value KeyDescriptor
-> ReaderT Context (Except CompilerError) KeyDescriptor
requiredKey Value KeyDescriptor
vk
[ScriptOp] -> ReaderT Context (Except CompilerError) [ScriptOp]
forall (m :: * -> *) a. Monad m => a -> m a
return [ScriptOp
OP_DUP, ScriptOp
OP_HASH160, ByteString -> ScriptOp
opPushData (Hash160 -> ByteString
forall a. Serialize a => a -> ByteString
encode (Hash160 -> ByteString) -> Hash160 -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Hash160
forall b. ByteArrayAccess b => b -> Hash160
ripemd160 ByteString
k), ScriptOp
OP_EQUALVERIFY]
Older vn :: Value Int
vn -> do
Int
n <- Value Int -> ReaderT Context (Except CompilerError) Int
requiredNumber Value Int
vn
[ScriptOp] -> ReaderT Context (Except CompilerError) [ScriptOp]
forall (m :: * -> *) a. Monad m => a -> m a
return [Int -> ScriptOp
pushNumber Int
n, ScriptOp
OP_CHECKSEQUENCEVERIFY]
After vn :: Value Int
vn -> do
Int
n <- Value Int -> ReaderT Context (Except CompilerError) Int
requiredNumber Value Int
vn
[ScriptOp] -> ReaderT Context (Except CompilerError) [ScriptOp]
forall (m :: * -> *) a. Monad m => a -> m a
return [Int -> ScriptOp
pushNumber Int
n, ScriptOp
OP_CHECKLOCKTIMEVERIFY]
Sha256 vb :: Value ByteString
vb -> do
ByteString
b <- Value ByteString
-> ReaderT Context (Except CompilerError) ByteString
requiredBytes Value ByteString
vb
[ScriptOp] -> ReaderT Context (Except CompilerError) [ScriptOp]
forall (m :: * -> *) a. Monad m => a -> m a
return ([ScriptOp] -> ReaderT Context (Except CompilerError) [ScriptOp])
-> [ScriptOp] -> ReaderT Context (Except CompilerError) [ScriptOp]
forall a b. (a -> b) -> a -> b
$ [ScriptOp]
sizeCheck [ScriptOp] -> [ScriptOp] -> [ScriptOp]
forall a. Semigroup a => a -> a -> a
<> [ScriptOp
OP_SHA256, ByteString -> ScriptOp
opPushData ByteString
b, ScriptOp
OP_EQUAL]
Ripemd160 vb :: Value ByteString
vb -> do
ByteString
b <- Value ByteString
-> ReaderT Context (Except CompilerError) ByteString
requiredBytes Value ByteString
vb
[ScriptOp] -> ReaderT Context (Except CompilerError) [ScriptOp]
forall (m :: * -> *) a. Monad m => a -> m a
return ([ScriptOp] -> ReaderT Context (Except CompilerError) [ScriptOp])
-> [ScriptOp] -> ReaderT Context (Except CompilerError) [ScriptOp]
forall a b. (a -> b) -> a -> b
$ [ScriptOp]
sizeCheck [ScriptOp] -> [ScriptOp] -> [ScriptOp]
forall a. Semigroup a => a -> a -> a
<> [ScriptOp
OP_RIPEMD160, ByteString -> ScriptOp
opPushData ByteString
b, ScriptOp
OP_EQUAL]
Hash256 vb :: Value ByteString
vb -> do
ByteString
b <- Value ByteString
-> ReaderT Context (Except CompilerError) ByteString
requiredBytes Value ByteString
vb
[ScriptOp] -> ReaderT Context (Except CompilerError) [ScriptOp]
forall (m :: * -> *) a. Monad m => a -> m a
return ([ScriptOp] -> ReaderT Context (Except CompilerError) [ScriptOp])
-> [ScriptOp] -> ReaderT Context (Except CompilerError) [ScriptOp]
forall a b. (a -> b) -> a -> b
$ [ScriptOp]
sizeCheck [ScriptOp] -> [ScriptOp] -> [ScriptOp]
forall a. Semigroup a => a -> a -> a
<> [ScriptOp
OP_HASH256, ByteString -> ScriptOp
opPushData ByteString
b, ScriptOp
OP_EQUAL]
Hash160 vb :: Value ByteString
vb -> do
ByteString
b <- Value ByteString
-> ReaderT Context (Except CompilerError) ByteString
requiredBytes Value ByteString
vb
[ScriptOp] -> ReaderT Context (Except CompilerError) [ScriptOp]
forall (m :: * -> *) a. Monad m => a -> m a
return ([ScriptOp] -> ReaderT Context (Except CompilerError) [ScriptOp])
-> [ScriptOp] -> ReaderT Context (Except CompilerError) [ScriptOp]
forall a b. (a -> b) -> a -> b
$ [ScriptOp]
sizeCheck [ScriptOp] -> [ScriptOp] -> [ScriptOp]
forall a. Semigroup a => a -> a -> a
<> [ScriptOp
OP_HASH160, ByteString -> ScriptOp
opPushData ByteString
b, ScriptOp
OP_EQUAL]
AndOr x :: Miniscript
x y :: Miniscript
y z :: Miniscript
z -> do
[ScriptOp]
opsX <- Miniscript -> ReaderT Context (Except CompilerError) [ScriptOp]
compileOpsInContext Miniscript
x
[ScriptOp]
opsY <- Miniscript -> ReaderT Context (Except CompilerError) [ScriptOp]
compileOpsInContext Miniscript
y
[ScriptOp]
opsZ <- Miniscript -> ReaderT Context (Except CompilerError) [ScriptOp]
compileOpsInContext Miniscript
z
[ScriptOp] -> ReaderT Context (Except CompilerError) [ScriptOp]
forall (m :: * -> *) a. Monad m => a -> m a
return ([ScriptOp] -> ReaderT Context (Except CompilerError) [ScriptOp])
-> [ScriptOp] -> ReaderT Context (Except CompilerError) [ScriptOp]
forall a b. (a -> b) -> a -> b
$ [[ScriptOp]] -> [ScriptOp]
forall a. Monoid a => [a] -> a
mconcat [[ScriptOp]
opsX, ScriptOp -> [ScriptOp]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ScriptOp
OP_NOTIF, [ScriptOp]
opsZ, ScriptOp -> [ScriptOp]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ScriptOp
OP_ELSE, [ScriptOp]
opsY, ScriptOp -> [ScriptOp]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ScriptOp
OP_ENDIF]
AndV x :: Miniscript
x z :: Miniscript
z -> do
[ScriptOp]
opsX <- Miniscript -> ReaderT Context (Except CompilerError) [ScriptOp]
compileOpsInContext Miniscript
x
[ScriptOp]
opsZ <- Miniscript -> ReaderT Context (Except CompilerError) [ScriptOp]
compileOpsInContext Miniscript
z
[ScriptOp] -> ReaderT Context (Except CompilerError) [ScriptOp]
forall (m :: * -> *) a. Monad m => a -> m a
return ([ScriptOp] -> ReaderT Context (Except CompilerError) [ScriptOp])
-> [ScriptOp] -> ReaderT Context (Except CompilerError) [ScriptOp]
forall a b. (a -> b) -> a -> b
$ [ScriptOp]
opsX [ScriptOp] -> [ScriptOp] -> [ScriptOp]
forall a. Semigroup a => a -> a -> a
<> [ScriptOp]
opsZ
AndB x :: Miniscript
x z :: Miniscript
z -> do
[ScriptOp]
opsX <- Miniscript -> ReaderT Context (Except CompilerError) [ScriptOp]
compileOpsInContext Miniscript
x
[ScriptOp]
opsZ <- Miniscript -> ReaderT Context (Except CompilerError) [ScriptOp]
compileOpsInContext Miniscript
z
[ScriptOp] -> ReaderT Context (Except CompilerError) [ScriptOp]
forall (m :: * -> *) a. Monad m => a -> m a
return ([ScriptOp] -> ReaderT Context (Except CompilerError) [ScriptOp])
-> [ScriptOp] -> ReaderT Context (Except CompilerError) [ScriptOp]
forall a b. (a -> b) -> a -> b
$ [ScriptOp]
opsX [ScriptOp] -> [ScriptOp] -> [ScriptOp]
forall a. Semigroup a => a -> a -> a
<> [ScriptOp]
opsZ [ScriptOp] -> [ScriptOp] -> [ScriptOp]
forall a. Semigroup a => a -> a -> a
<> [ScriptOp
OP_BOOLAND]
OrB x :: Miniscript
x z :: Miniscript
z -> do
[ScriptOp]
opsX <- Miniscript -> ReaderT Context (Except CompilerError) [ScriptOp]
compileOpsInContext Miniscript
x
[ScriptOp]
opsZ <- Miniscript -> ReaderT Context (Except CompilerError) [ScriptOp]
compileOpsInContext Miniscript
z
[ScriptOp] -> ReaderT Context (Except CompilerError) [ScriptOp]
forall (m :: * -> *) a. Monad m => a -> m a
return ([ScriptOp] -> ReaderT Context (Except CompilerError) [ScriptOp])
-> [ScriptOp] -> ReaderT Context (Except CompilerError) [ScriptOp]
forall a b. (a -> b) -> a -> b
$ [ScriptOp]
opsX [ScriptOp] -> [ScriptOp] -> [ScriptOp]
forall a. Semigroup a => a -> a -> a
<> [ScriptOp]
opsZ [ScriptOp] -> [ScriptOp] -> [ScriptOp]
forall a. Semigroup a => a -> a -> a
<> [ScriptOp
OP_BOOLOR]
OrC x :: Miniscript
x z :: Miniscript
z -> do
[ScriptOp]
opsX <- Miniscript -> ReaderT Context (Except CompilerError) [ScriptOp]
compileOpsInContext Miniscript
x
[ScriptOp]
opsZ <- Miniscript -> ReaderT Context (Except CompilerError) [ScriptOp]
compileOpsInContext Miniscript
z
[ScriptOp] -> ReaderT Context (Except CompilerError) [ScriptOp]
forall (m :: * -> *) a. Monad m => a -> m a
return ([ScriptOp] -> ReaderT Context (Except CompilerError) [ScriptOp])
-> [ScriptOp] -> ReaderT Context (Except CompilerError) [ScriptOp]
forall a b. (a -> b) -> a -> b
$ [[ScriptOp]] -> [ScriptOp]
forall a. Monoid a => [a] -> a
mconcat [[ScriptOp]
opsX, ScriptOp -> [ScriptOp]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ScriptOp
OP_NOTIF, [ScriptOp]
opsZ, ScriptOp -> [ScriptOp]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ScriptOp
OP_ENDIF]
OrD x :: Miniscript
x z :: Miniscript
z -> do
[ScriptOp]
opsX <- Miniscript -> ReaderT Context (Except CompilerError) [ScriptOp]
compileOpsInContext Miniscript
x
[ScriptOp]
opsZ <- Miniscript -> ReaderT Context (Except CompilerError) [ScriptOp]
compileOpsInContext Miniscript
z
[ScriptOp] -> ReaderT Context (Except CompilerError) [ScriptOp]
forall (m :: * -> *) a. Monad m => a -> m a
return ([ScriptOp] -> ReaderT Context (Except CompilerError) [ScriptOp])
-> [ScriptOp] -> ReaderT Context (Except CompilerError) [ScriptOp]
forall a b. (a -> b) -> a -> b
$ [[ScriptOp]] -> [ScriptOp]
forall a. Monoid a => [a] -> a
mconcat [[ScriptOp]
opsX, [ScriptOp
OP_IFDUP, ScriptOp
OP_NOTIF], [ScriptOp]
opsZ, ScriptOp -> [ScriptOp]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ScriptOp
OP_ENDIF]
OrI x :: Miniscript
x z :: Miniscript
z -> do
[ScriptOp]
opsX <- Miniscript -> ReaderT Context (Except CompilerError) [ScriptOp]
compileOpsInContext Miniscript
x
[ScriptOp]
opsZ <- Miniscript -> ReaderT Context (Except CompilerError) [ScriptOp]
compileOpsInContext Miniscript
z
[ScriptOp] -> ReaderT Context (Except CompilerError) [ScriptOp]
forall (m :: * -> *) a. Monad m => a -> m a
return ([ScriptOp] -> ReaderT Context (Except CompilerError) [ScriptOp])
-> [ScriptOp] -> ReaderT Context (Except CompilerError) [ScriptOp]
forall a b. (a -> b) -> a -> b
$ [[ScriptOp]] -> [ScriptOp]
forall a. Monoid a => [a] -> a
mconcat [ScriptOp -> [ScriptOp]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ScriptOp
OP_IF, [ScriptOp]
opsX, ScriptOp -> [ScriptOp]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ScriptOp
OP_ELSE, [ScriptOp]
opsZ, ScriptOp -> [ScriptOp]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ScriptOp
OP_ENDIF]
Thresh vk :: Value Int
vk x :: Miniscript
x xs :: [Miniscript]
xs -> do
Int
k <- Value Int -> ReaderT Context (Except CompilerError) Int
requiredNumber Value Int
vk
[ScriptOp]
opsX <- Miniscript -> ReaderT Context (Except CompilerError) [ScriptOp]
compileOpsInContext Miniscript
x
[[ScriptOp]]
opsXS <- (Miniscript -> ReaderT Context (Except CompilerError) [ScriptOp])
-> [Miniscript]
-> ReaderT Context (Except CompilerError) [[ScriptOp]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Miniscript -> ReaderT Context (Except CompilerError) [ScriptOp]
compileOpsInContext [Miniscript]
xs
[ScriptOp] -> ReaderT Context (Except CompilerError) [ScriptOp]
forall (m :: * -> *) a. Monad m => a -> m a
return ([ScriptOp] -> ReaderT Context (Except CompilerError) [ScriptOp])
-> ([[ScriptOp]] -> [ScriptOp])
-> [[ScriptOp]]
-> ReaderT Context (Except CompilerError) [ScriptOp]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[ScriptOp]] -> [ScriptOp]
forall a. Monoid a => [a] -> a
mconcat ([[ScriptOp]] -> ReaderT Context (Except CompilerError) [ScriptOp])
-> [[ScriptOp]]
-> ReaderT Context (Except CompilerError) [ScriptOp]
forall a b. (a -> b) -> a -> b
$ [ScriptOp] -> [[ScriptOp]]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ScriptOp]
opsX [[ScriptOp]] -> [[ScriptOp]] -> [[ScriptOp]]
forall a. Semigroup a => a -> a -> a
<> ([ScriptOp] -> [[ScriptOp]]) -> [[ScriptOp]] -> [[ScriptOp]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [ScriptOp] -> [[ScriptOp]]
forall (f :: * -> *). Applicative f => f ScriptOp -> [f ScriptOp]
addX [[ScriptOp]]
opsXS [[ScriptOp]] -> [[ScriptOp]] -> [[ScriptOp]]
forall a. Semigroup a => a -> a -> a
<> [[Int -> ScriptOp
pushNumber Int
k, ScriptOp
OP_EQUAL]]
where
addX :: f ScriptOp -> [f ScriptOp]
addX ops :: f ScriptOp
ops = [f ScriptOp
ops, ScriptOp -> f ScriptOp
forall (f :: * -> *) a. Applicative f => a -> f a
pure ScriptOp
OP_ADD]
Multi vk :: Value Int
vk xs :: [Value KeyDescriptor]
xs -> do
Int
k <- Value Int -> ReaderT Context (Except CompilerError) Int
requiredNumber Value Int
vk
[[ScriptOp]]
opsXS <- (Value KeyDescriptor
-> ReaderT Context (Except CompilerError) [ScriptOp])
-> [Value KeyDescriptor]
-> ReaderT Context (Except CompilerError) [[ScriptOp]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Value KeyDescriptor
-> ReaderT Context (Except CompilerError) [ScriptOp]
forall (f :: * -> *).
Applicative f =>
Value KeyDescriptor
-> ReaderT Context (Except CompilerError) (f ScriptOp)
getKeyScript [Value KeyDescriptor]
xs
[ScriptOp] -> ReaderT Context (Except CompilerError) [ScriptOp]
forall (m :: * -> *) a. Monad m => a -> m a
return ([ScriptOp] -> ReaderT Context (Except CompilerError) [ScriptOp])
-> ([[ScriptOp]] -> [ScriptOp])
-> [[ScriptOp]]
-> ReaderT Context (Except CompilerError) [ScriptOp]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[ScriptOp]] -> [ScriptOp]
forall a. Monoid a => [a] -> a
mconcat ([[ScriptOp]] -> ReaderT Context (Except CompilerError) [ScriptOp])
-> [[ScriptOp]]
-> ReaderT Context (Except CompilerError) [ScriptOp]
forall a b. (a -> b) -> a -> b
$ [ScriptOp] -> [[ScriptOp]]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Int -> ScriptOp
pushNumber Int
k] [[ScriptOp]] -> [[ScriptOp]] -> [[ScriptOp]]
forall a. Semigroup a => a -> a -> a
<> [[ScriptOp]]
opsXS [[ScriptOp]] -> [[ScriptOp]] -> [[ScriptOp]]
forall a. Semigroup a => a -> a -> a
<> [ScriptOp] -> [[ScriptOp]]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Int -> ScriptOp
pushNumber ([Value KeyDescriptor] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Value KeyDescriptor]
xs), ScriptOp
OP_CHECKMULTISIG]
AnnA x :: Miniscript
x -> [ScriptOp] -> [ScriptOp]
annA ([ScriptOp] -> [ScriptOp])
-> ReaderT Context (Except CompilerError) [ScriptOp]
-> ReaderT Context (Except CompilerError) [ScriptOp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Miniscript -> ReaderT Context (Except CompilerError) [ScriptOp]
compileOpsInContext Miniscript
x
where
annA :: [ScriptOp] -> [ScriptOp]
annA ops :: [ScriptOp]
ops = ScriptOp
OP_TOALTSTACK ScriptOp -> [ScriptOp] -> [ScriptOp]
forall a. a -> [a] -> [a]
: [ScriptOp]
ops [ScriptOp] -> [ScriptOp] -> [ScriptOp]
forall a. Semigroup a => a -> a -> a
<> [ScriptOp
OP_FROMALTSTACK]
AnnS x :: Miniscript
x -> (ScriptOp
OP_SWAP ScriptOp -> [ScriptOp] -> [ScriptOp]
forall a. a -> [a] -> [a]
:) ([ScriptOp] -> [ScriptOp])
-> ReaderT Context (Except CompilerError) [ScriptOp]
-> ReaderT Context (Except CompilerError) [ScriptOp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Miniscript -> ReaderT Context (Except CompilerError) [ScriptOp]
compileOpsInContext Miniscript
x
AnnC x :: Miniscript
x -> ([ScriptOp] -> [ScriptOp] -> [ScriptOp]
forall a. Semigroup a => a -> a -> a
<> [ScriptOp
OP_CHECKSIG]) ([ScriptOp] -> [ScriptOp])
-> ReaderT Context (Except CompilerError) [ScriptOp]
-> ReaderT Context (Except CompilerError) [ScriptOp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Miniscript -> ReaderT Context (Except CompilerError) [ScriptOp]
compileOpsInContext Miniscript
x
AnnD x :: Miniscript
x -> [ScriptOp] -> [ScriptOp]
annD ([ScriptOp] -> [ScriptOp])
-> ReaderT Context (Except CompilerError) [ScriptOp]
-> ReaderT Context (Except CompilerError) [ScriptOp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Miniscript -> ReaderT Context (Except CompilerError) [ScriptOp]
compileOpsInContext Miniscript
x
where
annD :: [ScriptOp] -> [ScriptOp]
annD ops :: [ScriptOp]
ops = [ScriptOp
OP_DUP, ScriptOp
OP_IF] [ScriptOp] -> [ScriptOp] -> [ScriptOp]
forall a. Semigroup a => a -> a -> a
<> [ScriptOp]
ops [ScriptOp] -> [ScriptOp] -> [ScriptOp]
forall a. Semigroup a => a -> a -> a
<> [ScriptOp
OP_ENDIF]
AnnV x :: Miniscript
x -> [ScriptOp] -> [ScriptOp]
annV ([ScriptOp] -> [ScriptOp])
-> ReaderT Context (Except CompilerError) [ScriptOp]
-> ReaderT Context (Except CompilerError) [ScriptOp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Miniscript -> ReaderT Context (Except CompilerError) [ScriptOp]
compileOpsInContext Miniscript
x
where
annV :: [ScriptOp] -> [ScriptOp]
annV ops :: [ScriptOp]
ops =
let (ops' :: [ScriptOp]
ops', op :: ScriptOp
op) = [ScriptOp] -> ([ScriptOp], ScriptOp)
forall a. [a] -> ([a], a)
unsnoc [ScriptOp]
ops
in case ScriptOp
op of
OP_EQUAL -> [ScriptOp]
ops' [ScriptOp] -> [ScriptOp] -> [ScriptOp]
forall a. Semigroup a => a -> a -> a
<> [ScriptOp
OP_EQUALVERIFY]
OP_NUMEQUAL -> [ScriptOp]
ops' [ScriptOp] -> [ScriptOp] -> [ScriptOp]
forall a. Semigroup a => a -> a -> a
<> [ScriptOp
OP_NUMEQUALVERIFY]
OP_CHECKSIG -> [ScriptOp]
ops' [ScriptOp] -> [ScriptOp] -> [ScriptOp]
forall a. Semigroup a => a -> a -> a
<> [ScriptOp
OP_CHECKSIGVERIFY]
OP_CHECKMULTISIG -> [ScriptOp]
ops' [ScriptOp] -> [ScriptOp] -> [ScriptOp]
forall a. Semigroup a => a -> a -> a
<> [ScriptOp
OP_CHECKMULTISIGVERIFY]
_ -> [ScriptOp]
ops [ScriptOp] -> [ScriptOp] -> [ScriptOp]
forall a. Semigroup a => a -> a -> a
<> [ScriptOp
OP_VERIFY]
AnnJ x :: Miniscript
x -> [ScriptOp] -> [ScriptOp]
annJ ([ScriptOp] -> [ScriptOp])
-> ReaderT Context (Except CompilerError) [ScriptOp]
-> ReaderT Context (Except CompilerError) [ScriptOp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Miniscript -> ReaderT Context (Except CompilerError) [ScriptOp]
compileOpsInContext Miniscript
x
where
annJ :: [ScriptOp] -> [ScriptOp]
annJ ops :: [ScriptOp]
ops = [ScriptOp
OP_SIZE, ScriptOp
OP_0NOTEQUAL, ScriptOp
OP_IF] [ScriptOp] -> [ScriptOp] -> [ScriptOp]
forall a. Semigroup a => a -> a -> a
<> [ScriptOp]
ops [ScriptOp] -> [ScriptOp] -> [ScriptOp]
forall a. Semigroup a => a -> a -> a
<> [ScriptOp
OP_ENDIF]
AnnN x :: Miniscript
x -> ([ScriptOp] -> [ScriptOp] -> [ScriptOp]
forall a. Semigroup a => a -> a -> a
<> [ScriptOp
OP_0NOTEQUAL]) ([ScriptOp] -> [ScriptOp])
-> ReaderT Context (Except CompilerError) [ScriptOp]
-> ReaderT Context (Except CompilerError) [ScriptOp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Miniscript -> ReaderT Context (Except CompilerError) [ScriptOp]
compileOpsInContext Miniscript
x
Var n :: Text
n -> do
(c' :: Context
c', s :: Miniscript
s) <- Text
-> ReaderT Context (Except CompilerError) (Context, Miniscript)
requiredScript Text
n
(Context -> Context)
-> ReaderT Context (Except CompilerError) [ScriptOp]
-> ReaderT Context (Except CompilerError) [ScriptOp]
forall r (m :: * -> *) a.
(r -> r) -> ReaderT r m a -> ReaderT r m a
local (Context -> Context -> Context
forall a b. a -> b -> a
const Context
c') (ReaderT Context (Except CompilerError) [ScriptOp]
-> ReaderT Context (Except CompilerError) [ScriptOp])
-> ReaderT Context (Except CompilerError) [ScriptOp]
-> ReaderT Context (Except CompilerError) [ScriptOp]
forall a b. (a -> b) -> a -> b
$ Miniscript -> ReaderT Context (Except CompilerError) [ScriptOp]
compileOpsInContext Miniscript
s
Let n :: Text
n e :: Miniscript
e b :: Miniscript
b -> (Context -> Context)
-> ReaderT Context (Except CompilerError) [ScriptOp]
-> ReaderT Context (Except CompilerError) [ScriptOp]
forall r (m :: * -> *) a.
(r -> r) -> ReaderT r m a -> ReaderT r m a
local (Text -> Miniscript -> Context -> Context
addClosure Text
n Miniscript
e) (ReaderT Context (Except CompilerError) [ScriptOp]
-> ReaderT Context (Except CompilerError) [ScriptOp])
-> ReaderT Context (Except CompilerError) [ScriptOp]
-> ReaderT Context (Except CompilerError) [ScriptOp]
forall a b. (a -> b) -> a -> b
$ Miniscript -> ReaderT Context (Except CompilerError) [ScriptOp]
compileOpsInContext Miniscript
b
Number x :: Int
x -> [ScriptOp] -> ReaderT Context (Except CompilerError) [ScriptOp]
forall (m :: * -> *) a. Monad m => a -> m a
return [Int -> ScriptOp
pushNumber Int
x]
Bytes b :: ByteString
b -> [ScriptOp] -> ReaderT Context (Except CompilerError) [ScriptOp]
forall (m :: * -> *) a. Monad m => a -> m a
return [ByteString -> ScriptOp
opPushData ByteString
b]
KeyDesc k :: KeyDescriptor
k | Just b :: ByteString
b <- KeyDescriptor -> Maybe ByteString
keyBytes KeyDescriptor
k -> [ScriptOp] -> ReaderT Context (Except CompilerError) [ScriptOp]
forall (m :: * -> *) a. Monad m => a -> m a
return [ByteString -> ScriptOp
opPushData ByteString
b]
e :: Miniscript
e@KeyDesc{} -> Miniscript -> ReaderT Context (Except CompilerError) [ScriptOp]
forall a. Miniscript -> ReaderT Context (Except CompilerError) a
typeError Miniscript
e
where
sizeCheck :: [ScriptOp]
sizeCheck = [ScriptOp
OP_SIZE, Int -> ScriptOp
pushNumber 32, ScriptOp
OP_EQUALVERIFY]
typeError :: Miniscript -> ReaderT Context (Except CompilerError) a
typeError = ExceptT CompilerError Identity a
-> ReaderT Context (Except CompilerError) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT CompilerError Identity a
-> ReaderT Context (Except CompilerError) a)
-> (Miniscript -> ExceptT CompilerError Identity a)
-> Miniscript
-> ReaderT Context (Except CompilerError) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompilerError -> ExceptT CompilerError Identity a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (CompilerError -> ExceptT CompilerError Identity a)
-> (Miniscript -> CompilerError)
-> Miniscript
-> ExceptT CompilerError Identity a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MiniscriptTypeError -> CompilerError
TypeError (MiniscriptTypeError -> CompilerError)
-> (Miniscript -> MiniscriptTypeError)
-> Miniscript
-> CompilerError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Miniscript -> MiniscriptTypeError
MiniscriptTypeError
required :: (Miniscript -> ReaderT Context (Except CompilerError) a)
-> Value a -> ReaderT Context (Except CompilerError) a
required f :: Miniscript -> ReaderT Context (Except CompilerError) a
f = \case
Lit x :: a
x -> a -> ReaderT Context (Except CompilerError) a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
Variable n :: Text
n -> Text
-> ReaderT Context (Except CompilerError) (Context, Miniscript)
requiredScript Text
n ReaderT Context (Except CompilerError) (Context, Miniscript)
-> ((Context, Miniscript)
-> ReaderT Context (Except CompilerError) a)
-> ReaderT Context (Except CompilerError) a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Miniscript -> ReaderT Context (Except CompilerError) a
f (Miniscript -> ReaderT Context (Except CompilerError) a)
-> ((Context, Miniscript) -> Miniscript)
-> (Context, Miniscript)
-> ReaderT Context (Except CompilerError) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Context, Miniscript) -> Miniscript
forall a b. (a, b) -> b
snd
requiredNumber :: Value Int -> ReaderT Context (Except CompilerError) Int
requiredNumber = (Miniscript -> ReaderT Context (Except CompilerError) Int)
-> Value Int -> ReaderT Context (Except CompilerError) Int
forall a.
(Miniscript -> ReaderT Context (Except CompilerError) a)
-> Value a -> ReaderT Context (Except CompilerError) a
required ((Miniscript -> ReaderT Context (Except CompilerError) Int)
-> Value Int -> ReaderT Context (Except CompilerError) Int)
-> (Miniscript -> ReaderT Context (Except CompilerError) Int)
-> Value Int
-> ReaderT Context (Except CompilerError) Int
forall a b. (a -> b) -> a -> b
$ \case
Number x :: Int
x -> Int -> ReaderT Context (Except CompilerError) Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
x
e :: Miniscript
e -> Miniscript -> ReaderT Context (Except CompilerError) Int
forall a. Miniscript -> ReaderT Context (Except CompilerError) a
typeError Miniscript
e
getKeyScript :: Value KeyDescriptor
-> ReaderT Context (Except CompilerError) (f ScriptOp)
getKeyScript vk :: Value KeyDescriptor
vk = (ByteString -> f ScriptOp)
-> ReaderT Context (Except CompilerError) ByteString
-> ReaderT Context (Except CompilerError) (f ScriptOp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ScriptOp -> f ScriptOp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ScriptOp -> f ScriptOp)
-> (ByteString -> ScriptOp) -> ByteString -> f ScriptOp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ScriptOp
opPushData) (ReaderT Context (Except CompilerError) ByteString
-> ReaderT Context (Except CompilerError) (f ScriptOp))
-> ReaderT Context (Except CompilerError) ByteString
-> ReaderT Context (Except CompilerError) (f ScriptOp)
forall a b. (a -> b) -> a -> b
$ Value KeyDescriptor
-> ReaderT Context (Except CompilerError) KeyDescriptor
requiredKey Value KeyDescriptor
vk ReaderT Context (Except CompilerError) KeyDescriptor
-> (KeyDescriptor
-> ReaderT Context (Except CompilerError) ByteString)
-> ReaderT Context (Except CompilerError) ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= KeyDescriptor -> ReaderT Context (Except CompilerError) ByteString
forall (t :: (* -> *) -> * -> *) (m :: * -> *).
(MonadTrans t, Monad m, Monad (t (ExceptT CompilerError m))) =>
KeyDescriptor -> t (ExceptT CompilerError m) ByteString
getKeyBytes
requiredKey :: Value KeyDescriptor
-> ReaderT Context (Except CompilerError) KeyDescriptor
requiredKey = (Miniscript
-> ReaderT Context (Except CompilerError) KeyDescriptor)
-> Value KeyDescriptor
-> ReaderT Context (Except CompilerError) KeyDescriptor
forall a.
(Miniscript -> ReaderT Context (Except CompilerError) a)
-> Value a -> ReaderT Context (Except CompilerError) a
required ((Miniscript
-> ReaderT Context (Except CompilerError) KeyDescriptor)
-> Value KeyDescriptor
-> ReaderT Context (Except CompilerError) KeyDescriptor)
-> (Miniscript
-> ReaderT Context (Except CompilerError) KeyDescriptor)
-> Value KeyDescriptor
-> ReaderT Context (Except CompilerError) KeyDescriptor
forall a b. (a -> b) -> a -> b
$ \case
KeyDesc k :: KeyDescriptor
k -> KeyDescriptor
-> ReaderT Context (Except CompilerError) KeyDescriptor
forall (m :: * -> *) a. Monad m => a -> m a
return KeyDescriptor
k
e :: Miniscript
e -> Miniscript -> ReaderT Context (Except CompilerError) KeyDescriptor
forall a. Miniscript -> ReaderT Context (Except CompilerError) a
typeError Miniscript
e
getKeyBytes :: KeyDescriptor -> t (ExceptT CompilerError m) ByteString
getKeyBytes k :: KeyDescriptor
k
| Just b :: ByteString
b <- KeyDescriptor -> Maybe ByteString
keyBytes KeyDescriptor
k = ByteString -> t (ExceptT CompilerError m) ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
b
| Bool
otherwise = ExceptT CompilerError m ByteString
-> t (ExceptT CompilerError m) ByteString
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT CompilerError m ByteString
-> t (ExceptT CompilerError m) ByteString)
-> (CompilerError -> ExceptT CompilerError m ByteString)
-> CompilerError
-> t (ExceptT CompilerError m) ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompilerError -> ExceptT CompilerError m ByteString
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (CompilerError -> t (ExceptT CompilerError m) ByteString)
-> CompilerError -> t (ExceptT CompilerError m) ByteString
forall a b. (a -> b) -> a -> b
$ KeyDescriptor -> CompilerError
AbstractKey KeyDescriptor
k
requiredBytes :: Value ByteString
-> ReaderT Context (Except CompilerError) ByteString
requiredBytes = (Miniscript -> ReaderT Context (Except CompilerError) ByteString)
-> Value ByteString
-> ReaderT Context (Except CompilerError) ByteString
forall a.
(Miniscript -> ReaderT Context (Except CompilerError) a)
-> Value a -> ReaderT Context (Except CompilerError) a
required ((Miniscript -> ReaderT Context (Except CompilerError) ByteString)
-> Value ByteString
-> ReaderT Context (Except CompilerError) ByteString)
-> (Miniscript
-> ReaderT Context (Except CompilerError) ByteString)
-> Value ByteString
-> ReaderT Context (Except CompilerError) ByteString
forall a b. (a -> b) -> a -> b
$ \case
Bytes b :: ByteString
b -> ByteString -> ReaderT Context (Except CompilerError) ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
b
e :: Miniscript
e -> Miniscript -> ReaderT Context (Except CompilerError) ByteString
forall a. Miniscript -> ReaderT Context (Except CompilerError) a
typeError Miniscript
e
unsnoc :: [a] -> ([a], a)
unsnoc :: [a] -> ([a], a)
unsnoc [] = String -> ([a], a)
forall a. HasCallStack => String -> a
error "unsnoc: empty list"
unsnoc [x :: a
x] = ([], a
x)
unsnoc (x :: a
x : xs :: [a]
xs) = let (zs :: [a]
zs, z :: a
z) = [a] -> ([a], a)
forall a. [a] -> ([a], a)
unsnoc [a]
xs in (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
zs, a
z)