{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Compile miniscript into bitcoin script
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

-- | Type check and compile a miniscript
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

-- | Compile a miniscript without type checking
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)