Unify Sigma & SigmaE

`Sigma a` is isomorphic to `SigmaE () (Either Bool a)`. This change simplifies
code quite a bit and allows to specify exactly where boolean literals could be
present and where we want pure sigma expression

hschain-utxo-api/hschain-utxo-api-rest/src/Hschain/Utxo/API/Rest.hs

@@ -82,9 +82,11 @@ data PostTxResponse = PostTxResponse
 
 -- | Result of execution of TX in the current state of blockchain.
 data SigmaTxResponse = SigmaTxResponse
-  { sigmaTxResponse'value :: !(Either Text (Vector BoolExprResult))  -- ^ result of execution
-                                                                     -- (sigma-expression or boolean)
-  , sigmaTxResponse'debug :: !Text }                                 -- ^ Debug info on the process of execution
+  { sigmaTxResponse'value :: !(Either Text (Vector ScriptEvalResult))
+    -- ^ result of execution (sigma-expression or boolean)
+  , sigmaTxResponse'debug :: !Text
+    -- ^ Debug info on the process of execution
+  }
   deriving (Show, Eq)
 
 -- | Useful stats about state of the blockchain

hschain-utxo-compiler/src/Hschain/Utxo/Compiler/Commands.hs

@@ -120,7 +120,7 @@ signSigma secretFile exprFile txFile output = do
       file <- LB.readFile secretFile
       return $ either (const failToReadSecret) id $ S.deserialiseOrFail file
 
-    readExpr :: IO BoolExprResult
+    readExpr :: IO ScriptEvalResult
     readExpr = do
       file <- LB.readFile exprFile
       return $ fromMaybe failToReadExpression $ decode' file

hschain-utxo-lang/src/Hschain/Utxo/Lang/Compile/Hask/Utils.hs

@@ -12,7 +12,6 @@ module Hschain.Utxo.Lang.Compile.Hask.Utils(
 
 import Hex.Common.Text (showt)
 
-import Data.Fix
 import Data.ByteString (ByteString)
 import Data.Text (Text)
 
@@ -47,12 +46,15 @@ toTypedPat :: Loc -> Typed (HM.Type () Name) Name -> H.Pat Loc
 toTypedPat loc (Typed name ty) = H.PatTypeSig loc (H.PVar loc $ toName $ VarName loc name) (toType loc ty)
 
 toSigma :: Loc -> Sigma ProofInput -> H.Exp Loc
-toSigma loc = foldFix $ \case
-  SigmaBool b  -> H.App loc (H.Var loc $ toQName $ VarName loc "toSigma") (toBool loc b)
-  SigmaAnd  as -> sigmaOp "&&" as
-  SigmaOr   as -> sigmaOp "||" as
-  SigmaPk   pk -> fromProofInput pk
+toSigma loc = go
   where
+    go = \case
+      Leaf _ (Left b)   -> H.App loc (H.Var loc $ toQName $ VarName loc "toSigma") (toBool loc b)
+      Leaf _ (Right pk) -> fromProofInput pk
+      AND  _ as         -> sigmaOp "&&" $ go <$> as
+      OR   _ as         -> sigmaOp "||" $ go <$> as
+
+
     sigmaOp op args = L.foldr1 (\a b -> H.InfixApp loc a (toQOp op) b) args
     toQOp op = H.QVarOp loc (toQName $ VarName loc op)
 

hschain-utxo-lang/src/Hschain/Utxo/Lang/Core/Compile/Build.hs

@@ -30,7 +30,6 @@ module Hschain.Utxo.Lang.Core.Compile.Build(
 
 import Data.ByteString (ByteString)
 import Data.Int
-import Data.Fix
 import Data.Text (Text)
 
 import Hschain.Utxo.Lang.Core.Compile.Expr
@@ -63,7 +62,7 @@ bytes :: ByteString -> Core v
 bytes b = EPrim $ PrimBytes b
 
 sigmaBool :: Bool -> Core v
-sigmaBool b = EPrim $ PrimSigma $ Fix $ SigmaBool b
+sigmaBool b = EPrim $ PrimSigma $ Leaf () $ Left b
 
 equals :: TypeCore -> Core v -> Core v -> Core v
 equals t a b = ap (EPrimOp (OpEQ t)) [a, b]

hschain-utxo-lang/src/Hschain/Utxo/Lang/Core/Eval.hs

@@ -5,7 +5,6 @@ module Hschain.Utxo.Lang.Core.Eval(
   , execScriptToSigma
 ) where
 
-import Data.Fix
 import Data.Text
 import Data.Bifunctor
 import Data.Void
@@ -15,7 +14,7 @@ import Hschain.Utxo.Lang.Core.Compile.Expr
 import Hschain.Utxo.Lang.Core.Compile.TypeCheck (typeCheck)
 import Hschain.Utxo.Lang.Core.RefEval           (evalProg)
 import Hschain.Utxo.Lang.Core.Types             (TypeCore(..),Prim(..))
-import Hschain.Utxo.Lang.Expr                   (BoolExprResult(..))
+import Hschain.Utxo.Lang.Expr                   (ScriptEvalResult(..))
 import Hschain.Utxo.Lang.Error
 import Hschain.Utxo.Lang.Pretty
 import Hschain.Utxo.Lang.Sigma
@@ -25,7 +24,7 @@ import qualified Data.Text as T
 
 -- | Executes spend-script in transaction. Spend script should be
 --   well-typed and evaluate to either sigma-expression or boolean.
-execScriptToSigma :: InputEnv -> Core Void -> Either Error (Sigma ProofInput)
+execScriptToSigma :: InputEnv -> Core Void -> Either Error ScriptEvalResult
 execScriptToSigma env prog = do
   -- Type check expression
   ty <- first (CoreScriptError . TypeCoreError)
@@ -36,21 +35,21 @@ execScriptToSigma env prog = do
     _      -> Left $ CoreScriptError ResultIsNotSigma
   -- Evaluate script
   case evalProg env prog of
-    Right (PrimVal (PrimBool  b)) -> Right $ Fix $ SigmaBool b
+    Right (PrimVal (PrimBool  b)) -> pure $ ConstBool b
     Right (PrimVal (PrimSigma s)) -> case eliminateSigmaBool s of
-      Left  b  -> Right $ Fix $ SigmaBool b
-      Right s' -> Right   s'
-    Left _             -> Right $ Fix $ SigmaBool False
+      Left  b  -> pure $ ConstBool   b
+      Right s' -> pure $ SigmaResult s'
+    Left _ -> Right $ ConstBool False
     _ -> error "Internal error:  Left $ E.CoreScriptError E.ResultIsNotSigma"
 
 
-evalToSigma :: TxArg -> Either Error (Vector BoolExprResult)
+evalToSigma :: TxArg -> Either Error (Vector ScriptEvalResult)
 evalToSigma tx = mapM (evalInput . getInputEnv tx) $ txArg'inputs tx
 
-evalInput :: InputEnv -> Either Error BoolExprResult
+evalInput :: InputEnv -> Either Error ScriptEvalResult
 evalInput env =
   case coreProgFromScript $ box'script $ postBox'content $ boxInput'box $ inputEnv'self env of
-    Just prog -> fmap (either ConstBool SigmaResult . eliminateSigmaBool) $ execScriptToSigma env prog
+    Just prog -> execScriptToSigma env prog
     Nothing   -> Left $ ExecError FailedToDecodeScript
 
 verifyInput :: TxArg -> BoxInput -> Either Text ()
@@ -62,16 +61,12 @@ verifyInput txArg input@BoxInput{..} = do
     -- Script evaluated to literal Bool
     ConstBool True  -> pure ()
     ConstBool False -> false
-    SigmaResult sigma -> case sigma of
-      Fix (SigmaBool True)  -> pure ()
-      Fix (SigmaBool False) -> false
-      -- Attempt to prove sigma expression
-      _ | Just proof <- boxInput'proof
-        , equalSigmaProof sigma proof
-        , verifyProof proof boxInput'sigMsg
-          -> pure ()
-      -- Otherwise failure
-      other -> Left $ T.unlines ["Sigma expression proof is not valid:", renderText other]
+    SigmaResult sigma
+      | Just proof <- boxInput'proof
+      , equalSigmaProof sigma proof
+      , verifyProof proof boxInput'sigMsg
+        -> pure ()
+      | otherwise -> Left $ T.unlines ["Sigma expression proof is not valid"]
   where
     false = Left "Script evaluated to False"
 

hschain-utxo-lang/src/Hschain/Utxo/Lang/Core/RefEval.hs

@@ -18,7 +18,6 @@ import Data.ByteString (ByteString)
 import Data.Bool
 import Data.Text       (Text)
 import Data.Typeable
-import Data.Fix
 import Data.Foldable (foldrM)
 import Data.Vector.Generic ((!?))
 import qualified Data.Vector          as V
@@ -183,21 +182,23 @@ evalPrimOp env = \case
       False -> match y
   OpBoolNot -> pure $ lift1 not
   --
-  OpSigBool   -> pure $ lift1 $ Fix . SigmaBool
-  OpSigAnd    -> pure $ lift2 $ \a b -> Fix $ SigmaAnd [a,b]
-  OpSigOr     -> pure $ lift2 $ \a b -> Fix $ SigmaOr  [a,b]
-  OpSigPK     -> pure $ evalLift1 $ \t -> fmap (Fix . SigmaPk . dlogInput) $ parsePublicKey t
-  OpSigDTuple -> pure $ evalLift3 $ \genB keyA keyB -> liftA3 (\gB pkA pkB -> Fix $ SigmaPk $ dtupleInput gB pkA pkB) (parseGenerator genB) (parsePublicKey keyA) (parsePublicKey keyB)
-  OpSigListAnd   -> pure $ lift1 $ Fix . SigmaAnd
-  OpSigListOr    -> pure $ lift1 $ Fix . SigmaOr
+  OpSigBool   -> pure $ lift1 $ Leaf () . Left
+  OpSigAnd    -> pure $ lift2 $ \a b -> AND () [a,b]
+  OpSigOr     -> pure $ lift2 $ \a b -> OR  () [a,b]
+  OpSigPK     -> pure $ evalLift1 $ \t -> fmap (sigmaPk . dlogInput) $ parsePublicKey t
+  OpSigDTuple -> pure $ evalLift3 $ \genB keyA keyB ->
+    liftA3 (\gB pkA pkB -> sigmaPk $ dtupleInput gB pkA pkB)
+           (parseGenerator genB) (parsePublicKey keyA) (parsePublicKey keyB)
+  OpSigListAnd   -> pure $ lift1 $ AND ()
+  OpSigListOr    -> pure $ lift1 $ OR  ()
   OpSigListAll _ -> pure $ Val2F $ \valF valXS -> fmap inj $ do
     f  <- match @(Val -> Eval Val) valF
     xs <- match @[Val]        valXS
-    fmap (Fix . SigmaAnd) $ mapM (match <=< f) xs
+    AND () <$> mapM (match <=< f) xs
   OpSigListAny _ -> pure $ Val2F $ \valF valXS -> fmap inj $ do
     f  <- match @(Val -> Eval Val) valF
     xs <- match @[Val]        valXS
-    fmap (Fix . SigmaOr) $ mapM (match <=< f) xs
+    OR () <$> mapM (match <=< f) xs
   --
   OpCheckSig -> pure $ evalLift2 $ \bs sigIndex -> do
     pk  <- parsePublicKey bs
@@ -382,7 +383,7 @@ instance MatchPrim LB.ByteString where
   match (ValP (PrimBytes a)) = pure $ LB.fromStrict a
   match _                    = throwError "Expecting Bytes"
 
-instance k ~ ProofInput => MatchPrim (Sigma k) where
+instance (k ~ (), a ~ Either Bool ProofInput) => MatchPrim (SigmaE k a) where
   match (ValP (PrimSigma a)) = pure a
   match _                    = throwError "Expecting Sigma"
 
@@ -414,7 +415,7 @@ instance InjPrim ByteString    where inj = ValP . PrimBytes
 instance InjPrim LB.ByteString where inj = inj . LB.toStrict
 instance InjPrim (Hash a)      where inj (Hash h) = inj h
 
-instance k ~ ProofInput => InjPrim (Sigma k) where
+instance (k ~ (), a ~ Either Bool ProofInput) => InjPrim (SigmaE k a) where
   inj = ValP . PrimSigma
 
 instance InjPrim a => InjPrim [a] where

hschain-utxo-lang/src/Hschain/Utxo/Lang/Core/ToHask.hs

@@ -12,7 +12,6 @@ import Hex.Common.Text (showt)
 import qualified Codec.Serialise as CBOR
 import Control.Monad.State.Strict
 import Data.ByteString (ByteString)
-import Data.Fix
 import Data.String
 import Data.Void
 import Data.Text (Text)
@@ -98,14 +97,15 @@ toHaskExprCore = flip evalState (T.pack <$> stringPrettyLetters) . go []
     fromBool b = H.Con () $ if b then toQName "True" else toQName "False"
 
     fromSigma :: Sigma ByteString -> H.Exp ()
-    fromSigma = foldFix rec
+    fromSigma = rec
       where
         rec = \case
-          SigmaPk pkey -> let keyTxt = encodeBase58 pkey
-                          in  ap1 Const.pk $ lit $ H.String src (T.unpack keyTxt) (T.unpack keyTxt)
-          SigmaAnd as  -> foldl1 (ap2 Const.sigmaAnd) as
-          SigmaOr  as  -> foldl1 (ap2 Const.sigmaOr) as
-          SigmaBool b  -> fromBool b
+          Leaf _ (Right pkey) -> let keyTxt = encodeBase58 pkey
+                                 in  ap1 Const.pk $ lit $ H.String src (T.unpack keyTxt) (T.unpack keyTxt)
+          Leaf _ (Left  b)    -> fromBool b
+          AND  _ as  -> foldl1 (ap2 Const.sigmaAnd) $ rec <$> as
+          OR   _ as  -> foldl1 (ap2 Const.sigmaOr)  $ rec <$> as
+
 
         ap1 f a = H.App () (toVar f) a
         ap2 f a b = H.App src (H.App () (toVar f) a) b

hschain-utxo-lang/src/Hschain/Utxo/Lang/Expr.hs

@@ -31,7 +31,7 @@ module Hschain.Utxo.Lang.Expr(
   , bindAlts
   , getBindsNames
   , secretVar
-  , BoolExprResult(..)
+  , ScriptEvalResult(..)
   , mapDeclsM
   , fromParserLoc
   , emptyTypeContext
@@ -278,17 +278,17 @@ secretVar = flip mappend "___"
 
 -- | Result of the script can be boolean constant or sigma-expression
 -- that user have to prove.
-data BoolExprResult
-  = ConstBool Bool
-  | SigmaResult (Sigma ProofInput)
+data ScriptEvalResult
+  = ConstBool   !Bool
+  | SigmaResult !(SigmaE () ProofInput)
   deriving (Show, Eq)
 
-instance ToJSON BoolExprResult where
+instance ToJSON ScriptEvalResult where
   toJSON = \case
     ConstBool b -> object ["bool"  .= b]
     SigmaResult s -> object ["sigma" .= s]
 
-instance FromJSON BoolExprResult where
+instance FromJSON ScriptEvalResult where
   parseJSON = withObject "BoolExprResult" $ \obj ->
         (ConstBool <$> obj .: "bool")
     <|> (SigmaResult <$> obj .: "sigma")

hschain-utxo-lang/src/Hschain/Utxo/Lang/Parser/Hask/ToHask.hs

@@ -82,14 +82,14 @@ toLiteral loc = \case
     lit = H.Lit loc
 
     sigma :: Loc -> Sigma ProofInput -> H.Exp Loc
-    sigma src x = foldFix go x
+    sigma src x = go x
       where
         go = \case
-          SigmaPk pkey -> let keyTxt = encodeBase58 $ BL.toStrict $ CBOR.serialise pkey
-                          in  ap (VarName src "pk") $ lit $ H.String src (T.unpack keyTxt) (T.unpack keyTxt)
-          SigmaAnd as  -> foldl1 (ap2 (VarName src Const.sigmaAnd)) as
-          SigmaOr  as  -> foldl1 (ap2 (VarName src Const.sigmaOr)) as
-          SigmaBool b  -> H.Con src $ bool src b
+          Leaf _ (Right pkey) -> let keyTxt = encodeBase58 $ BL.toStrict $ CBOR.serialise pkey
+                                 in  ap (VarName src "pk") $ lit $ H.String src (T.unpack keyTxt) (T.unpack keyTxt)
+          Leaf _ (Left b) -> H.Con src $ bool src b
+          AND  _ as       -> foldl1 (ap2 (VarName src Const.sigmaAnd)) $ go <$> as
+          OR   _ as       -> foldl1 (ap2 (VarName src Const.sigmaOr))  $ go <$> as
 
         ap f a = H.App (HM.getLoc f) (toVar (HM.getLoc f) f) a
         ap2 f a b = H.App src (H.App src (toVar src f) a) b

hschain-utxo-lang/src/Hschain/Utxo/Lang/Pretty.hs

@@ -11,7 +11,6 @@ import Codec.Serialise (deserialiseOrFail)
 import Hex.Common.Serialise
 
 import Data.Bool
-import Data.Fix
 import Data.Void
 import Data.ByteString.Lazy (fromStrict)
 import Data.Text (Text)
@@ -164,12 +163,12 @@ instance Pretty Env where
 instance Pretty Proof where
   pretty proof = pretty $ P.ppShow proof
 
-instance Pretty a => Pretty (S.Sigma a) where
-  pretty = foldFix $ \case
-      S.SigmaPk k    -> parens $ hsep ["pk", pretty k]
-      S.SigmaAnd as  -> parens $ hsep $ Const.sigmaAnd : as
-      S.SigmaOr  as  -> parens $ hsep $ Const.sigmaOr  : as
-      S.SigmaBool b  -> "Sigma" <> pretty b
+instance Pretty a => Pretty (S.SigmaE () (Either Bool a)) where
+  pretty = \case
+    S.Leaf () (Right k) -> parens $ hsep ["pk", pretty k]
+    S.Leaf () (Left  b) -> "Sigma" <> pretty b
+    S.AND  () as        -> parens $ hsep $ Const.sigmaAnd : fmap pretty as
+    S.OR   () as        -> parens $ hsep $ Const.sigmaOr  : fmap pretty as
 
 instance Pretty S.ProofInput where
   pretty = \case