diff --git a/src-tool/Pact/Analyze/Translate.hs b/src-tool/Pact/Analyze/Translate.hs index 5a9d62c17..d01d7556e 100644 --- a/src-tool/Pact/Analyze/Translate.hs +++ b/src-tool/Pact/Analyze/Translate.hs @@ -44,8 +44,7 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Traversable (for) import Data.Type.Equality ((:~:) (Refl)) -import Numeric.Natural (Natural) -import GHC.TypeLits (SomeSymbol(..), someSymbolVal, symbolVal) +import GHC.TypeLits hiding (SSymbol) import qualified Pact.Types.Info as P import Pact.Types.Lang @@ -1604,10 +1603,10 @@ translateNode astNode = withAstContext astNode $ case astNode of tsFoundVars .= [] Some tyb f' <- translateNode f - (avid, _, _) <- captureOneFreeVar + (avid, _, _) <- captureFreeVar Some tyc g' <- translateNode g - (bvid, _, _) <- captureOneFreeVar + (bvid, _, _) <- captureFreeVar -- important: we captured a, so we need to leave it free (by restoring -- tsFoundVars) @@ -1617,9 +1616,8 @@ translateNode astNode = withAstContext astNode $ case astNode of Compose tya tyb tyc a' (Open avid "a" f') (Open bvid "b" g') AST_NFun node SMap [ fun, l ] -> do - expectNoFreeVars Some bTy fun' <- translateNode fun - captureOneFreeVar >>= \case + captureFreeVar >>= \case (vid, varName, EType aType) -> translateNode l >>= \case Some (SList listTy) l' -> do Refl <- singEq listTy aType ?? TypeError node @@ -1628,9 +1626,8 @@ translateNode astNode = withAstContext astNode $ case astNode of _ -> unexpectedNode astNode AST_NFun node SFilter [ fun, l ] -> do - expectNoFreeVars translateNode fun >>= \case - Some SBool fun' -> captureOneFreeVar >>= \case + Some SBool fun' -> captureFreeVar >>= \case (vid, varName, EType aType) -> translateNode l >>= \case Some (SList listTy) l' -> do Refl <- singEq listTy aType ?? TypeError node @@ -1640,7 +1637,6 @@ translateNode astNode = withAstContext astNode $ case astNode of _ -> unexpectedNode astNode AST_NFun node SFold [ fun, a, l ] -> do - expectNoFreeVars Some funTy fun' <- translateNode fun -- Note: The order of these variables is important. `a` should be the first @@ -1651,8 +1647,8 @@ translateNode astNode = withAstContext astNode $ case astNode of -- -- `a` encountered first, `b` will be consed on top of it, resulting in the -- variables coming out backwards. - captureTwoFreeVars >>= \case - [ (vidb, varNameb, EType tyb), (vida, varNamea, EType tya) ] -> do + liftM2 (,) captureFreeVar captureFreeVar >>= \case + ((vidb, varNameb, EType tyb), (vida, varNamea, EType tya)) -> do Some aTy' a' <- translateNode a translateNode l >>= \case Some (SList listTy) l' -> do @@ -1662,17 +1658,15 @@ translateNode astNode = withAstContext astNode $ case astNode of pure $ Some tya $ CoreTerm $ ListFold tya tyb (Open vida varNamea (Open vidb varNameb fun')) a' l' _ -> unexpectedNode astNode - _ -> unexpectedNode astNode AST_NFun _ name [ f, g, a ] | name == SAndQ || name == SOrQ -> do - expectNoFreeVars translateNode f >>= \case Some SBool f' -> do - (fvid, fvarName, _) <- captureOneFreeVar + (fvid, fvarName, _) <- captureFreeVar translateNode g >>= \case Some SBool g' -> do - (gvid, gvarName, _) <- captureOneFreeVar + (gvid, gvarName, _) <- captureFreeVar Some aTy' a' <- translateNode a pure $ Some SBool $ CoreTerm $ (if name == "and?" then AndQ else OrQ) aTy' (Open fvid fvarName f') (Open gvid gvarName g') a' @@ -1681,9 +1675,8 @@ translateNode astNode = withAstContext astNode $ case astNode of AST_NFun _ SWhere [ field, fun, obj ] -> translateNode field >>= \case Some SStr field' -> do - expectNoFreeVars translateNode fun >>= \case - Some SBool fun' -> captureOneFreeVar >>= \case + Some SBool fun' -> captureFreeVar >>= \case (vid, varName, EType freeTy) -> translateNode obj >>= \case Some objTy@SObject{} obj' -> pure $ Some SBool $ CoreTerm $ Where objTy freeTy field' (Open vid varName fun') obj' @@ -1848,23 +1841,14 @@ trackCapScope capName act = do tsStaticCapsInScope .= current return r -captureOneFreeVar :: TranslateM (VarId, Text, EType) -captureOneFreeVar = do - vs <- use tsFoundVars - tsFoundVars .= [] - case vs of - [v] -> pure v - _ -> throwError' $ FreeVarInvariantViolation $ - "unexpected vars found: " <> tShow vs - -captureTwoFreeVars :: TranslateM [(VarId, Text, EType)] -captureTwoFreeVars = do +captureFreeVar :: TranslateM (VarId, Text, EType) +captureFreeVar = do vs <- use tsFoundVars - tsFoundVars .= [] case vs of - [_, _] -> pure vs - _ -> throwError' $ FreeVarInvariantViolation $ - "unexpected vars found: " <> tShow vs + v:vs' -> do + tsFoundVars .= vs' + pure v + _ -> throwError' $ FreeVarInvariantViolation "expected var" expectNoFreeVars :: TranslateM () expectNoFreeVars = do @@ -1938,6 +1922,7 @@ runTranslation modName funName info caps pactArgs body checkType = do CheckDefconst -> error "invariant violation: this cannot be a constant" _ <- extendPath -- form final edge for any remaining events + expectNoFreeVars pure res handleState translateState = diff --git a/tests/AnalyzeSpec.hs b/tests/AnalyzeSpec.hs index a04902ddb..2469351b8 100644 --- a/tests/AnalyzeSpec.hs +++ b/tests/AnalyzeSpec.hs @@ -4198,6 +4198,24 @@ spec = describe "analyze" $ do (typeof "foo")) |] + describe "nested application of higher-order functions (regression #1250)" $ do + expectVerified [text| + (defun child: bool (accParent: bool l: [integer]) + (fold (lambda (acc:bool x:integer) (and (= x 0) acc)) accParent l)) + + (defun parent: bool () + @model[(property (= result false))] + (fold (child) true [[1]])) + |] + + expectVerified [text| + (defun child: [bool] (l : [integer]) + (map (= 0) l)) + + (defun parent: [[bool]] () + (map (child) [[1]])) + |] + -- TODO: pending sbv unicode fix -- describe "unicode strings" $ -- let code = [text|