diff --git a/lib/Language/PureScript/Backend/IR/DCE.hs b/lib/Language/PureScript/Backend/IR/DCE.hs index 7f95c96..0b5239d 100644 --- a/lib/Language/PureScript/Backend/IR/DCE.hs +++ b/lib/Language/PureScript/Backend/IR/DCE.hs @@ -30,6 +30,7 @@ import Language.PureScript.Backend.IR.Types , getAnn , listGrouping , rewriteExpTopDown + , unshift ) data EntryPoint = EntryPoint ModuleName [Name] @@ -122,16 +123,19 @@ eliminateDeadCode uber@UberModule {..} = pure . \case Abs ann param b | not (paramId `member` reachableIds) → - Rewritten Recurse (Abs ann param' b) + Rewritten Recurse (Abs ann param' b') where paramId ∷ Id = case param of ParamUnused (pid, _) → pid ParamNamed (pid, _) _name → pid - param' = + -- Blanking an unused named binder drops a slot from that name's + -- De Bruijn namespace, so references in the body that skipped over it + -- (index ≥ 1) must be lowered, just as in beta reduction (issue #56). + (param', b') = case param of - ParamUnused pann → ParamUnused pann - ParamNamed pann _name → ParamUnused pann + ParamUnused pann → (ParamUnused pann, b) + ParamNamed pann name → (ParamUnused pann, unshift name 0 b) Let ann binds body → Rewritten Recurse case NE.nonEmpty preservedBinds of Nothing → body diff --git a/lib/Language/PureScript/Backend/IR/Optimizer.hs b/lib/Language/PureScript/Backend/IR/Optimizer.hs index cce95af..58fd0ab 100644 --- a/lib/Language/PureScript/Backend/IR/Optimizer.hs +++ b/lib/Language/PureScript/Backend/IR/Optimizer.hs @@ -32,6 +32,7 @@ import Language.PureScript.Backend.IR.Types , substitute , thenRewrite , unIndex + , unshift ) optimizedUberModule ∷ UberModule → UberModule @@ -301,7 +302,11 @@ betaReduce ∷ RewriteRule Ann betaReduce = pure . \case App _ (Abs _ (ParamNamed _ param) body) r → - Rewritten Recurse $ substitute (Local param) 0 r body + -- Removing the λ closes a binder for 'param', so any reference to it + -- that the substitution shifted past the binder must be lowered back + -- with 'unshift'; otherwise it is left pointing one binder too far out + -- and reaches the Lua backend as an unbound local (issue #56). + Rewritten Recurse . unshift param 0 $ substitute (Local param) 0 r body _ → NoChange {- Note [Eta reduction is unsound] diff --git a/lib/Language/PureScript/Backend/IR/Types.hs b/lib/Language/PureScript/Backend/IR/Types.hs index c1c2b8c..b278507 100644 --- a/lib/Language/PureScript/Backend/IR/Types.hs +++ b/lib/Language/PureScript/Backend/IR/Types.hs @@ -736,7 +736,87 @@ substitute name idx replacement = substitute' idx where go = substitute' index --- | Increase the index of all bound variables matching the given variable name +{- | Rewrite the De Bruijn index of every reference to @namespace@ that is free +with respect to @minIndex@, using @adjust minIndex index@. Binders for other +names are transparent; a binder for @namespace@ raises @minIndex@ by one (see +Note [Sequential scoping of Let bindings] for the @Let@ case). This is the +shared traversal behind 'shift' (which makes room for a new binder) and +'unshift' (which closes the gap left by a removed one); keeping both on one +traversal stops them from drifting apart. +-} +overFreeIndex + ∷ (Index → Index → Index) + -- ^ Given the current @minIndex@ and a reference's index, the new index + → Name + -- ^ The variable name to match (a.k.a. the namespace) + → Index + -- ^ The minimum bound at or above which references are considered free + → RawExp ann + → RawExp ann +overFreeIndex adjust namespace = go + where + go minIndex expression = + case expression of + Ref ann (Local name) index + | name == namespace → + Ref ann (Local name) (adjust minIndex index) + Abs ann argument body → + Abs ann argument (go minIndex' body) + where + minIndex' + | paramName argument == Just namespace = minIndex + 1 + | otherwise = minIndex + -- See Note [Sequential scoping of Let bindings] + Let ann binds body → + Let ann binds' body' + where + (bodyMinIndex, binds') = mapAccumL withGrouping minIndex binds + body' = go bodyMinIndex body + withGrouping minIdx grouping = + case grouping of + Standalone (annotation, boundName, expr) → + ( if boundName == namespace then minIdx + 1 else minIdx + , Standalone (annotation, boundName, go minIdx expr) + ) + RecursiveGroup recBinds → + ( minIdx' + , RecursiveGroup $ + recBinds <&> \(nameAnn, boundName, expr) → + (nameAnn, boundName, go minIdx' expr) + ) + where + minIdx' = + minIdx + + fromIntegral + (length (filter (== namespace) (bindingNames grouping))) + App ann argument function → + App ann (go minIndex argument) (go minIndex function) + LiteralArray ann as → + LiteralArray ann (go minIndex <$> as) + LiteralObject ann props → + LiteralObject ann (go minIndex <<$>> props) + ReflectCtor ann a → + ReflectCtor ann (go minIndex a) + DataArgumentByIndex ann idx a → + DataArgumentByIndex ann idx (go minIndex a) + Eq ann a b → + Eq ann (go minIndex a) (go minIndex b) + ArrayLength ann a → + ArrayLength ann (go minIndex a) + ArrayIndex ann a indx → + ArrayIndex ann (go minIndex a) indx + ObjectProp ann a prop → + ObjectProp ann (go minIndex a) prop + ObjectUpdate ann a patches → + ObjectUpdate ann (go minIndex a) (go minIndex <<$>> patches) + IfThenElse ann p th el → + IfThenElse ann (go minIndex p) (go minIndex th) (go minIndex el) + _ → expression + +{- | Increase the index of all references to the given name bound at or above +@minIndex@. Used to make room when a new binder for that name is introduced, +e.g. when substituting a term under a λ that shadows the name. +-} shift ∷ Int -- ^ The amount to shift by @@ -747,72 +827,29 @@ shift → RawExp ann -- ^ The expression to shift → RawExp ann -shift offset namespace minIndex expression = - case expression of - Ref ann (Local name) index → - Ref ann (Local name) $ - index - + if name == namespace && minIndex <= index - then fromIntegral offset - else 0 - Abs ann argument body → - Abs ann argument (shift offset namespace minIndex' body) - where - minIndex' - | paramName argument == Just namespace = minIndex + 1 - | otherwise = minIndex - -- See Note [Sequential scoping of Let bindings] - Let ann binds body → - Let ann binds' body' - where - (bodyMinIndex, binds') = mapAccumL withGrouping minIndex binds - body' = shift offset namespace bodyMinIndex body - withGrouping minIdx grouping = - case grouping of - Standalone (annotation, boundName, expr) → - ( if boundName == namespace then minIdx + 1 else minIdx - , Standalone - ( annotation - , boundName - , shift offset namespace minIdx expr - ) - ) - RecursiveGroup recBinds → - ( minIdx' - , RecursiveGroup $ - recBinds <&> \(nameAnn, boundName, expr) → - (nameAnn, boundName, shift offset namespace minIdx' expr) - ) - where - minIdx' = - minIdx - + fromIntegral - (length (filter (== namespace) (bindingNames grouping))) - App ann argument function → - App ann (go argument) (go function) - LiteralArray ann as → - LiteralArray ann (go <$> as) - LiteralObject ann props → - LiteralObject ann (go <<$>> props) - ReflectCtor ann a → - ReflectCtor ann (go a) - DataArgumentByIndex ann idx a → - DataArgumentByIndex ann idx (go a) - Eq ann a b → - Eq ann (go a) (go b) - ArrayLength ann a → - ArrayLength ann (go a) - ArrayIndex ann a indx → - ArrayIndex ann (go a) indx - ObjectProp ann a prop → - ObjectProp ann (go a) prop - ObjectUpdate ann a patches → - ObjectUpdate ann (go a) (go <<$>> patches) - IfThenElse ann p th el → - IfThenElse ann (go p) (go th) (go el) - _ → expression - where - go = shift offset namespace minIndex +shift offset = + overFreeIndex \minIndex index → + if minIndex <= index then index + fromIntegral offset else index + +{- | Decrease by one the index of references to the given name bound strictly +above @minIndex@: the inverse of @shift 1@, to be applied after a binder for +the name is removed (e.g. by beta reduction) so that references which pointed +past that binder are lowered back into place. References at exactly @minIndex@ +are the removed binder itself and have already been consumed by the +accompanying substitution, so the strict @minIndex < index@ guard both leaves +genuine inner references untouched and keeps the 'Natural' index from +underflowing. +-} +unshift + ∷ Name + -- ^ The variable name to match (a.k.a. the namespace) + → Index + -- ^ References bound strictly above this bound are lowered + → RawExp ann + → RawExp ann +unshift = + overFreeIndex \minIndex index → + if minIndex < index then index - 1 else index $(makePrisms ''AlgebraicType) $(makePrisms ''Parameter) diff --git a/test/Language/PureScript/Backend/IR/Gen.hs b/test/Language/PureScript/Backend/IR/Gen.hs index 2f8bf82..a7e9498 100644 --- a/test/Language/PureScript/Backend/IR/Gen.hs +++ b/test/Language/PureScript/Backend/IR/Gen.hs @@ -1,5 +1,6 @@ module Language.PureScript.Backend.IR.Gen where +import Data.Map.Strict qualified as Map import Data.Text qualified as Text import Hedgehog (MonadGen) import Hedgehog.Corpus qualified as Corpus @@ -57,6 +58,75 @@ exp = ) ] +{- | A generation-time scope: each local name in scope mapped to the number of +enclosing binders for it. Lets 'scopedExp' emit only references that resolve +to a binder (a valid De Bruijn index for that name). +-} +type Scope = Map IR.Name Natural + +{- | Generate a closed, well-scoped expression: every local reference has an +index below the number of enclosing binders of that name. Restricted to +λ / application / if / object / reference / scalar, which is enough to +exercise beta reduction and name shadowing (the surface of issues #37 and +#56) while keeping well-scopedness easy to guarantee by construction. 'Let' +is intentionally left out; its sequential scoping is covered by the +hand-written specs. +-} +scopedExp ∷ ∀ m. MonadGen m ⇒ m IR.Exp +scopedExp = + -- Cap the size hard: beta reduction duplicates substituted arguments, so an + -- unbounded term can blow the optimizer up exponentially in memory. Small + -- terms are plenty to surface scoping bugs (issues #37 / #56 both shrink to + -- a handful of binders). + Gen.scale (min 8) (scopedExpIn mempty) + +scopedExpIn ∷ ∀ m. MonadGen m ⇒ Scope → m IR.Exp +scopedExpIn scope = + Gen.recursiveFrequency + ((4, scalarExp) : [(5, scopedRef) | not (null inScope)]) + [ (6, IR.application <$> scopedExpIn scope <*> scopedExpIn scope) + , + ( 3 + , IR.ifThenElse + <$> scopedExpIn scope + <*> scopedExpIn scope + <*> scopedExpIn scope + ) + , (5, genAbs) + , (4, genRedex) + , + ( 2 + , IR.literalObject + <$> Gen.list + (Range.linear 1 4) + ((,) <$> genPropName <*> scopedExpIn scope) + ) + ] + where + inScope = [(nm, count) | (nm, count) ← Map.toList scope, count > 0] + scopedRef = do + (nm, count) ← Gen.element inScope + index ← Gen.integral (Range.linear 0 (fromIntegral count - 1)) + pure (IR.refLocal nm index) + genAbs = do + (param, body) ← genBinderBody + pure (IR.abstraction param body) + -- An immediately-applied λ: a beta redex. Generating these directly (rather + -- than hoping an application's head happens to be a λ) is what makes the + -- well-scopedness property actually exercise beta reduction, including the + -- shadowing case behind issue #56. + genRedex = do + (param, body) ← genBinderBody + arg ← scopedExpIn scope + pure (IR.application (IR.abstraction param body) arg) + genBinderBody = do + param ← parameter + let scope' = case param of + IR.ParamNamed _ nm → Map.insertWith (+) nm 1 scope + IR.ParamUnused _ → scope + body ← scopedExpIn scope' + pure (param, body) + binding ∷ MonadGen m ⇒ m IR.Binding binding = Gen.frequency [(8, standaloneBinding), (2, recursiveBinding)] diff --git a/test/Language/PureScript/Backend/IR/Optimizer/Spec.hs b/test/Language/PureScript/Backend/IR/Optimizer/Spec.hs index bb98952..3b1d24f 100644 --- a/test/Language/PureScript/Backend/IR/Optimizer/Spec.hs +++ b/test/Language/PureScript/Backend/IR/Optimizer/Spec.hs @@ -1,14 +1,15 @@ module Language.PureScript.Backend.IR.Optimizer.Spec where -import Control.Lens (universeOf) +import Control.Lens (toListOf, universeOf) import Data.Map qualified as Map -import Hedgehog (annotateShow, forAll, (===)) +import Hedgehog (PropertyT, annotateShow, forAll, (===)) import Hedgehog.Gen qualified as Gen import Language.PureScript.Backend.IR.Gen qualified as Gen import Language.PureScript.Backend.IR.Linker (LinkMode (..)) import Language.PureScript.Backend.IR.Linker qualified as Linker import Language.PureScript.Backend.IR.Names ( Name (..) + , PropName (..) , QName (..) , Qualified (Local) , moduleNameFromString @@ -20,7 +21,8 @@ import Language.PureScript.Backend.IR.Optimizer ) import Language.PureScript.Backend.IR.Types ( Exp - , Grouping (Standalone) + , Grouping (..) + , Index , Module (..) , RawExp (..) , abstraction @@ -31,17 +33,59 @@ import Language.PureScript.Backend.IR.Types , lets , literalBool , literalInt + , literalObject , noAnn + , paramName , paramNamed , paramUnused , refImported , refLocal , refLocal0 , subexpressions + , unIndex ) -import Test.Hspec (Spec, describe) +import Test.Hspec (Spec, SpecWith, describe, it) +import Test.Hspec.Hedgehog (hedgehog, modifyMaxShrinks, modifyMaxSuccess) import Test.Hspec.Hedgehog.Extended (test) +-- | Like 'test', but runs the property over many generated inputs. +prop ∷ String → PropertyT IO () → SpecWith () +prop title = + modifyMaxShrinks (const 20) + . modifyMaxSuccess (const 100) + . it title + . hedgehog + +{- | Local references whose De Bruijn index points past every enclosing binder +of that name: unbound locals, which the Lua backend rejects (see +Note [Locals are uniquely named after renameShadowedNames]). An empty result +means the expression is well-scoped. The binder bookkeeping mirrors +'shift'/'unshift'; see Note [Sequential scoping of Let bindings] for 'Let'. +-} +unboundLocals ∷ Exp → [(Name, Index)] +unboundLocals = go Map.empty + where + go ∷ Map Name Natural → Exp → [(Name, Index)] + go scope = \case + Ref _ (Local nm) index + | unIndex index < Map.findWithDefault 0 nm scope → [] + | otherwise → [(nm, index)] + Abs _ param body → go (bindName (paramName param) scope) body + Let _ binds body → + let (bodyScope, errs) = foldl' letGrouping (scope, []) (toList binds) + in errs <> go bodyScope body + other → foldMap (go scope) (toListOf subexpressions other) + where + bindName Nothing sc = sc + bindName (Just nm) sc = Map.insertWith (+) nm 1 sc + letGrouping (sc, errs) = \case + Standalone (_ann, nm, e) → + (Map.insertWith (+) nm 1 sc, errs <> go sc e) + RecursiveGroup recBinds → + let names = (\(_ann, nm, _e) → nm) <$> toList recBinds + sc' = foldr (\nm → Map.insertWith (+) nm 1) sc names + in (sc', errs <> foldMap (\(_ann, _nm, e) → go sc' e) recBinds) + spec ∷ Spec spec = describe "IR Optimizer" do describe "optimizes expressions" do @@ -212,6 +256,103 @@ spec = describe "IR Optimizer" do annotateShow optimized unboundLocalRefs === [] + -- Issue #56: beta reduction removes a binder, so any reference that the + -- substitution shifted past it must be lowered back. Here `b` is bound by + -- an outer λ, while the reduced inner λ is *also* named `b`; reducing it + -- must drop the outer reference from index 1 back to 0 rather than leave it + -- unbound. This is the IR shape `Data.Array.foldRecM` boils down to. + test "beta reduction does not unbind a reference shadowed by the binder" do + let a = Name "a" + b = Name "b" + inner = + abstraction (paramNamed a) $ + abstraction (paramNamed b) $ + literalObject + [ (PropName "p", refLocal a 0) + , (PropName "q", refLocal b 0) + ] + -- (\b -> (\a -> \b -> { p: a, q: b }) b 0) + shadowed = + abstraction (paramNamed b) $ + application + (application inner (refLocal b 0)) + (literalInt 0) + original = + Linker.UberModule + { uberModuleForeigns = [] + , uberModuleBindings = [] + , uberModuleExports = [(Name "foldRecMShape", shadowed)] + } + -- After the redexes are reduced only the outer λ remains, so the + -- surviving reference is `b` at index 0. + expected = + abstraction (paramNamed b) $ + literalObject + [ (PropName "p", refLocal b 0) + , (PropName "q", literalInt 0) + ] + optimized = optimizedUberModule original + offending = + foldMap (unboundLocals . snd) (Linker.uberModuleExports optimized) + annotateShow optimized + offending === [] + Linker.uberModuleExports optimized === [(Name "foldRecMShape", expected)] + + -- Sibling of #56 in the DCE pass (found by the property below). Dead-code + -- elimination blanks an unused named binder to ParamUnused. Here the inner + -- λj is unused, yet the body references the *outer* j (at index 1, skipping + -- the inner one); blanking the inner binder must lower that reference to 0, + -- otherwise it is left unbound. + test "blanking an unused shadowing binder keeps outer references bound" do + let j = Name "j" + k = Name "k" + -- \j -> (\k -> { foo: (\_ -> \j -> k) 0 }) j + shadowed = + abstraction (paramNamed j) $ + application + ( abstraction (paramNamed k) $ + literalObject + [ + ( PropName "foo" + , application + ( abstraction paramUnused $ + abstraction (paramNamed j) (refLocal k 0) + ) + (literalInt 0) + ) + ] + ) + (refLocal j 0) + original = + Linker.UberModule + { uberModuleForeigns = [] + , uberModuleBindings = [] + , uberModuleExports = [(Name "shape", shadowed)] + } + optimized = optimizedUberModule original + offending = + foldMap (unboundLocals . snd) (Linker.uberModuleExports optimized) + annotateShow optimized + offending === [] + + -- The general invariant behind #37 and #56: optimizing a well-scoped + -- expression must never produce an unbound local reference. Runs through the + -- whole 'optimizedUberModule' pipeline (not a single 'optimizedExpression' + -- pass) because the #56 dangling reference only surfaces once an enclosing + -- redex is reduced on a later iteration. + prop "optimization keeps expressions well-scoped" do + e ← forAll Gen.scopedExp + annotateShow e + unboundLocals e === [] -- the generator only emits well-scoped terms + let optimized = + optimizedUberModule + Linker.UberModule + { Linker.uberModuleForeigns = [] + , Linker.uberModuleBindings = [] + , Linker.uberModuleExports = [(Name "root", e)] + } + foldMap (unboundLocals . snd) (Linker.uberModuleExports optimized) === [] + describe "renames shadowed names" do test "nested λ-abstractions" do name ← forAll Gen.name diff --git a/test/Language/PureScript/Backend/IR/Types/Spec.hs b/test/Language/PureScript/Backend/IR/Types/Spec.hs index 01d0f70..54aae3a 100644 --- a/test/Language/PureScript/Backend/IR/Types/Spec.hs +++ b/test/Language/PureScript/Backend/IR/Types/Spec.hs @@ -1,7 +1,10 @@ module Language.PureScript.Backend.IR.Types.Spec where import Data.Map qualified as Map -import Hedgehog ((===)) +import Hedgehog (PropertyT, annotateShow, forAll, (===)) +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range +import Language.PureScript.Backend.IR.Gen qualified as Gen import Language.PureScript.Backend.IR.Names ( ModuleName (..) , Name (..) @@ -10,6 +13,7 @@ import Language.PureScript.Backend.IR.Names import Language.PureScript.Backend.IR.Types ( Exp , Grouping (..) + , Index , abstraction , application , countFreeRef @@ -23,10 +27,23 @@ import Language.PureScript.Backend.IR.Types , refLocal , shift , substitute + , unshift ) -import Test.Hspec (Spec, describe) +import Test.Hspec (Spec, SpecWith, describe, it) +import Test.Hspec.Hedgehog (hedgehog, modifyMaxShrinks, modifyMaxSuccess) import Test.Hspec.Hedgehog.Extended (test) +{- | Like 'test', but runs the property over many generated inputs. The bare +'test' helper pins maxSuccess to 1, which is fine for example-based checks +but too weak for the algebraic laws below. +-} +prop ∷ String → PropertyT IO () → SpecWith () +prop title = + modifyMaxShrinks (const 20) + . modifyMaxSuccess (const 100) + . it title + . hedgehog + spec ∷ Spec spec = describe "Types" do test "countFreeRefs" do @@ -98,6 +115,93 @@ spec = describe "Types" do lets (Standalone (noAnn, x, literalInt 42) :| []) (literalInt 0) substitute (Local x) 0 (literalInt 42) original === expected + describe "shift / unshift (De Bruijn re-indexing)" do + let x = Name "x" + y = Name "y" + + -- 'unshift' is the inverse of 'shift 1': raising every free reference to a + -- name and then lowering it again must return the original expression. + prop "unshift undoes shift 1 (round-trip)" do + e ← forAll Gen.exp + n ← forAll Gen.name + minIndex ← forAll (Gen.integral (Range.linear (0 ∷ Index) 3)) + annotateShow e + unshift n minIndex (shift 1 n minIndex e) === e + + test "unshift: a reference bound above minIndex is lowered" do + unshift x 0 (refLocal x 2) === refLocal x 1 + + test "unshift: the reference at minIndex (removed binder) is left alone" do + unshift x 1 (refLocal x 1) === refLocal x 1 + + test "unshift: a reference to a different name is untouched" do + unshift x 0 (refLocal y 3) === refLocal y 3 + + test "unshift: only references free under a shadowing binder are lowered" do + -- under \x the inner reference x@0 is bound by it (left alone), while the + -- outer reference x@2 is free and must drop to x@1. + unshift x 0 (abstraction (paramNamed x) (refLocal x 0)) + === abstraction (paramNamed x) (refLocal x 0) + unshift x 0 (abstraction (paramNamed x) (refLocal x 2)) + === abstraction (paramNamed x) (refLocal x 1) + + describe "substitute (capture-avoiding)" do + -- Replacing a variable by a reference to itself (at the same index) is the + -- identity: this exercises the capture-avoiding shifting that 'substitute' + -- performs as it descends under same-named binders. + prop "substituting a variable for itself is the identity" do + e ← forAll Gen.exp + n ← forAll Gen.name + index ← forAll (Gen.integral (Range.linear (0 ∷ Index) 3)) + annotateShow e + substitute (Local n) index (refLocal n index) e === e + + -- The classic textbook cases the property above can only sample at random. + let x = Name "x" + y = Name "y" + z = Name "z" + + -- (λy. x)[x ≔ y] must not capture the free y: in De Bruijn terms the + -- replacement's y is shifted to index 1 so it keeps referring to the outer + -- y rather than the λ that now encloses it. + test "a free variable is not captured by a binder of its name" do + substitute + (Local x) + 0 + (refLocal y 0) + (abstraction (paramNamed y) (refLocal x 0)) + === abstraction (paramNamed y) (refLocal y 1) + + -- (λz. x)[x ≔ y]: z shadows neither x nor y, so the result is just (λz. y). + test "substitution passes through an unrelated binder unchanged" do + substitute + (Local x) + 0 + (refLocal y 0) + (abstraction (paramNamed z) (refLocal x 0)) + === abstraction (paramNamed z) (refLocal y 0) + + -- (λx. x)[x ≔ 42]: the inner x is bound by its own λx, not the variable + -- being substituted, so the redex is left untouched. + test "a shadowing binder of the same name stops the substitution" do + substitute + (Local x) + 0 + (literalInt 42) + (abstraction (paramNamed x) (refLocal x 0)) + === abstraction (paramNamed x) (refLocal x 0) + + -- (λx. x⟨outer⟩)[x ≔ y]: here the body's reference points past the binder + -- (index 1), so it is the one being substituted; the replacement y is not + -- captured by λx, so it stays at index 0. + test "a reference reaching past a shadowing binder is substituted" do + substitute + (Local x) + 0 + (refLocal y 0) + (abstraction (paramNamed x) (refLocal x 1)) + === abstraction (paramNamed x) (refLocal y 0) + expr ∷ Exp expr = abstraction diff --git a/test/ps/golden/Golden/TailRecM2Shadow/Test.purs b/test/ps/golden/Golden/TailRecM2Shadow/Test.purs new file mode 100644 index 0000000..bf78834 --- /dev/null +++ b/test/ps/golden/Golden/TailRecM2Shadow/Test.purs @@ -0,0 +1,25 @@ +module Golden.TailRecM2Shadow.Test where + +import Prelude + +import Control.Monad.Rec.Class (class MonadRec, Step(..), tailRecM2) +import Effect (Effect) +import Effect.Console (logShow) + +-- Regression for #56. The outer parameter is named `b`, and `tailRecM2`'s own +-- third parameter is also `b`. `tailRecM2` is a single-use dictionary accessor, +-- so the optimizer inlines and beta-reduces it; reducing under the inner `b` +-- capture-shifts the outer reference to index 1, and removing that binder must +-- lower it back to 0. The optimizer used to skip the lowering, leaving an +-- unbound `Local b index 1` that aborted Lua codegen for `Data.Array.foldRecM`. +sumFrom :: forall m. MonadRec m => Int -> Int -> m Int +sumFrom b n = tailRecM2 go b 0 + where + go acc i + | i >= n = pure (Done acc) + | otherwise = pure (Loop { a: acc + i, b: i + 1 }) + +main :: Effect Unit +main = do + r <- sumFrom 0 5 + logShow r diff --git a/test/ps/output/Golden.TailRecM2Shadow.Test/corefn.json b/test/ps/output/Golden.TailRecM2Shadow.Test/corefn.json new file mode 100644 index 0000000..83854c4 --- /dev/null +++ b/test/ps/output/Golden.TailRecM2Shadow.Test/corefn.json @@ -0,0 +1 @@ +{"builtWith":"0.15.16","comments":[],"decls":[{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"bindType":"NonRec","expression":{"abstraction":{"annotation":{"meta":{"metaType":"IsForeign"},"sourceSpan":{"end":[19,11],"start":[19,9]}},"type":"Var","value":{"identifier":"greaterThanOrEq","moduleName":["Data","Ord"]}},"annotation":{"meta":{"metaType":"IsSyntheticApp"},"sourceSpan":{"end":[19,13],"start":[19,7]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"ordInt","moduleName":["Data","Ord"]}},"type":"App"},"identifier":"greaterThanOrEq"},{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"bindType":"NonRec","expression":{"abstraction":{"annotation":{"meta":{"metaType":"IsForeign"},"sourceSpan":{"end":[20,40],"start":[20,39]}},"type":"Var","value":{"identifier":"add","moduleName":["Data","Semiring"]}},"annotation":{"meta":{"metaType":"IsSyntheticApp"},"sourceSpan":{"end":[20,42],"start":[20,35]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"semiringInt","moduleName":["Data","Semiring"]}},"type":"App"},"identifier":"add"},{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"bindType":"NonRec","expression":{"abstraction":{"annotation":{"meta":{"metaType":"IsForeign"},"sourceSpan":{"end":[25,10],"start":[25,3]}},"type":"Var","value":{"identifier":"logShow","moduleName":["Effect","Console"]}},"annotation":{"meta":{"metaType":"IsSyntheticApp"},"sourceSpan":{"end":[25,12],"start":[25,3]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"showInt","moduleName":["Data","Show"]}},"type":"App"},"identifier":"logShow"},{"annotation":{"meta":null,"sourceSpan":{"end":[15,55],"start":[15,1]}},"bindType":"NonRec","expression":{"annotation":{"meta":null,"sourceSpan":{"end":[15,55],"start":[15,1]}},"argument":"dictMonadRec","body":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"binds":[{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"bindType":"NonRec","expression":{"abstraction":{"annotation":{"meta":{"metaType":"IsForeign"},"sourceSpan":{"end":[19,20],"start":[19,16]}},"type":"Var","value":{"identifier":"pure","moduleName":["Control","Applicative"]}},"annotation":{"meta":{"metaType":"IsSyntheticApp"},"sourceSpan":{"end":[19,31],"start":[19,16]}},"argument":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[19,31],"start":[19,16]}},"expression":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[19,31],"start":[19,16]}},"expression":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"dictMonadRec","sourcePos":[0,0]}},"fieldName":"Monad0","type":"Accessor"},"annotation":{"meta":{"metaType":"IsSyntheticApp"},"sourceSpan":{"end":[19,31],"start":[19,16]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"undefined","moduleName":["Prim"]}},"type":"App"},"fieldName":"Applicative0","type":"Accessor"},"annotation":{"meta":{"metaType":"IsSyntheticApp"},"sourceSpan":{"end":[19,31],"start":[19,16]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"undefined","moduleName":["Prim"]}},"type":"App"},"type":"App"},"identifier":"pure"},{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"bindType":"NonRec","expression":{"abstraction":{"annotation":{"meta":{"metaType":"IsForeign"},"sourceSpan":{"end":[16,24],"start":[16,15]}},"type":"Var","value":{"identifier":"tailRecM2","moduleName":["Control","Monad","Rec","Class"]}},"annotation":{"meta":{"metaType":"IsSyntheticApp"},"sourceSpan":{"end":[16,27],"start":[16,15]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"dictMonadRec","sourcePos":[0,0]}},"type":"App"},"identifier":"tailRecM2"}],"expression":{"annotation":{"meta":null,"sourceSpan":{"end":[15,55],"start":[15,1]}},"argument":"b","body":{"annotation":{"meta":null,"sourceSpan":{"end":[15,55],"start":[15,1]}},"argument":"n","body":{"annotation":{"meta":{"metaType":"IsWhere"},"sourceSpan":{"end":[16,31],"start":[16,15]}},"binds":[{"annotation":{"meta":null,"sourceSpan":{"end":[20,55],"start":[18,3]}},"bindType":"NonRec","expression":{"annotation":{"meta":null,"sourceSpan":{"end":[20,55],"start":[18,3]}},"argument":"acc","body":{"annotation":{"meta":null,"sourceSpan":{"end":[20,55],"start":[18,3]}},"argument":"i","body":{"annotation":{"meta":null,"sourceSpan":{"end":[20,55],"start":[18,3]}},"caseAlternatives":[{"binders":[{"annotation":{"meta":null,"sourceSpan":{"end":[18,9],"start":[18,6]}},"binderType":"VarBinder","identifier":"acc1"},{"annotation":{"meta":null,"sourceSpan":{"end":[18,11],"start":[18,10]}},"binderType":"VarBinder","identifier":"i1"}],"expressions":[{"expression":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"pure","sourcePos":[0,0]}},"annotation":{"meta":null,"sourceSpan":{"end":[19,31],"start":[19,16]}},"argument":{"abstraction":{"annotation":{"meta":{"constructorType":"SumType","identifiers":["value0"],"metaType":"IsConstructor"},"sourceSpan":{"end":[19,26],"start":[19,22]}},"type":"Var","value":{"identifier":"Done","moduleName":["Control","Monad","Rec","Class"]}},"annotation":{"meta":null,"sourceSpan":{"end":[19,30],"start":[19,22]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[19,30],"start":[19,27]}},"type":"Var","value":{"identifier":"acc1","sourcePos":[18,6]}},"type":"App"},"type":"App"},"guard":{"abstraction":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"greaterThanOrEq","moduleName":["Golden","TailRecM2Shadow","Test"]}},"annotation":{"meta":null,"sourceSpan":{"end":[19,13],"start":[19,7]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[19,8],"start":[19,7]}},"type":"Var","value":{"identifier":"i1","sourcePos":[18,10]}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[19,13],"start":[19,7]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[19,13],"start":[19,12]}},"type":"Var","value":{"identifier":"n","sourcePos":[16,1]}},"type":"App"}},{"expression":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"pure","sourcePos":[0,0]}},"annotation":{"meta":null,"sourceSpan":{"end":[20,55],"start":[20,19]}},"argument":{"abstraction":{"annotation":{"meta":{"constructorType":"SumType","identifiers":["value0"],"metaType":"IsConstructor"},"sourceSpan":{"end":[20,29],"start":[20,25]}},"type":"Var","value":{"identifier":"Loop","moduleName":["Control","Monad","Rec","Class"]}},"annotation":{"meta":null,"sourceSpan":{"end":[20,54],"start":[20,25]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[20,54],"start":[20,30]}},"type":"Literal","value":{"literalType":"ObjectLiteral","value":[["a",{"abstraction":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"add","moduleName":["Golden","TailRecM2Shadow","Test"]}},"annotation":{"meta":null,"sourceSpan":{"end":[20,42],"start":[20,35]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[20,38],"start":[20,35]}},"type":"Var","value":{"identifier":"acc1","sourcePos":[18,6]}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[20,42],"start":[20,35]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[20,42],"start":[20,41]}},"type":"Var","value":{"identifier":"i1","sourcePos":[18,10]}},"type":"App"}],["b",{"abstraction":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"add","moduleName":["Golden","TailRecM2Shadow","Test"]}},"annotation":{"meta":null,"sourceSpan":{"end":[20,52],"start":[20,47]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[20,48],"start":[20,47]}},"type":"Var","value":{"identifier":"i1","sourcePos":[18,10]}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[20,52],"start":[20,47]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[20,52],"start":[20,51]}},"type":"Literal","value":{"literalType":"IntLiteral","value":1}},"type":"App"}]]}},"type":"App"},"type":"App"},"guard":{"annotation":{"meta":{"metaType":"IsForeign"},"sourceSpan":{"end":[20,16],"start":[20,7]}},"type":"Var","value":{"identifier":"otherwise","moduleName":["Data","Boolean"]}}}],"isGuarded":true}],"caseExpressions":[{"annotation":{"meta":null,"sourceSpan":{"end":[20,55],"start":[18,3]}},"type":"Var","value":{"identifier":"acc","sourcePos":[18,6]}},{"annotation":{"meta":null,"sourceSpan":{"end":[20,55],"start":[18,3]}},"type":"Var","value":{"identifier":"i","sourcePos":[18,10]}}],"type":"Case"},"type":"Abs"},"type":"Abs"},"identifier":"go"}],"expression":{"abstraction":{"abstraction":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"tailRecM2","sourcePos":[0,0]}},"annotation":{"meta":null,"sourceSpan":{"end":[16,27],"start":[16,15]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[16,27],"start":[16,25]}},"type":"Var","value":{"identifier":"go","sourcePos":[18,3]}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[16,29],"start":[16,15]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[16,29],"start":[16,28]}},"type":"Var","value":{"identifier":"b","sourcePos":[16,1]}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[16,31],"start":[16,15]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[16,31],"start":[16,30]}},"type":"Literal","value":{"literalType":"IntLiteral","value":0}},"type":"App"},"type":"Let"},"type":"Abs"},"type":"Abs"},"type":"Let"},"type":"Abs"},"identifier":"sumFrom"},{"annotation":{"meta":null,"sourceSpan":{"end":[22,20],"start":[22,1]}},"bindType":"NonRec","expression":{"abstraction":{"abstraction":{"abstraction":{"annotation":{"meta":{"metaType":"IsForeign"},"sourceSpan":{"end":[24,19],"start":[24,3]}},"type":"Var","value":{"identifier":"bind","moduleName":["Control","Bind"]}},"annotation":{"meta":{"metaType":"IsSyntheticApp"},"sourceSpan":{"end":[24,19],"start":[24,3]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"bindEffect","moduleName":["Effect"]}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[24,19],"start":[24,3]}},"argument":{"abstraction":{"abstraction":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[24,15],"start":[24,8]}},"type":"Var","value":{"identifier":"sumFrom","moduleName":["Golden","TailRecM2Shadow","Test"]}},"annotation":{"meta":{"metaType":"IsSyntheticApp"},"sourceSpan":{"end":[24,17],"start":[24,8]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"monadRecEffect","moduleName":["Control","Monad","Rec","Class"]}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[24,17],"start":[24,8]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[24,17],"start":[24,16]}},"type":"Literal","value":{"literalType":"IntLiteral","value":0}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[24,19],"start":[24,8]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[24,19],"start":[24,18]}},"type":"Literal","value":{"literalType":"IntLiteral","value":5}},"type":"App"},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[24,19],"start":[24,3]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[24,19],"start":[24,3]}},"argument":"r","body":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"logShow","moduleName":["Golden","TailRecM2Shadow","Test"]}},"annotation":{"meta":null,"sourceSpan":{"end":[25,12],"start":[25,3]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[25,12],"start":[25,11]}},"type":"Var","value":{"identifier":"r","sourcePos":[24,3]}},"type":"App"},"type":"Abs"},"type":"App"},"identifier":"main"}],"exports":["sumFrom","main"],"foreign":[],"imports":[{"annotation":{"meta":null,"sourceSpan":{"end":[25,12],"start":[1,1]}},"moduleName":["Control","Applicative"]},{"annotation":{"meta":null,"sourceSpan":{"end":[25,12],"start":[1,1]}},"moduleName":["Control","Bind"]},{"annotation":{"meta":null,"sourceSpan":{"end":[25,12],"start":[1,1]}},"moduleName":["Control","Monad","Rec","Class"]},{"annotation":{"meta":null,"sourceSpan":{"end":[25,12],"start":[1,1]}},"moduleName":["Data","Boolean"]},{"annotation":{"meta":null,"sourceSpan":{"end":[25,12],"start":[1,1]}},"moduleName":["Data","Ord"]},{"annotation":{"meta":null,"sourceSpan":{"end":[25,12],"start":[1,1]}},"moduleName":["Data","Semiring"]},{"annotation":{"meta":null,"sourceSpan":{"end":[25,12],"start":[1,1]}},"moduleName":["Data","Show"]},{"annotation":{"meta":null,"sourceSpan":{"end":[25,12],"start":[1,1]}},"moduleName":["Effect"]},{"annotation":{"meta":null,"sourceSpan":{"end":[25,12],"start":[1,1]}},"moduleName":["Effect","Console"]},{"annotation":{"meta":null,"sourceSpan":{"end":[25,12],"start":[1,1]}},"moduleName":["Golden","TailRecM2Shadow","Test"]},{"annotation":{"meta":null,"sourceSpan":{"end":[3,15],"start":[3,1]}},"moduleName":["Prelude"]},{"annotation":{"meta":null,"sourceSpan":{"end":[25,12],"start":[1,1]}},"moduleName":["Prim"]}],"moduleName":["Golden","TailRecM2Shadow","Test"],"modulePath":"golden/Golden/TailRecM2Shadow/Test.purs","reExports":{},"sourceSpan":{"end":[25,12],"start":[1,1]}} \ No newline at end of file diff --git a/test/ps/output/Golden.TailRecM2Shadow.Test/eval/.gitignore b/test/ps/output/Golden.TailRecM2Shadow.Test/eval/.gitignore new file mode 100644 index 0000000..d2dc29b --- /dev/null +++ b/test/ps/output/Golden.TailRecM2Shadow.Test/eval/.gitignore @@ -0,0 +1 @@ +actual.txt diff --git a/test/ps/output/Golden.TailRecM2Shadow.Test/eval/golden.txt b/test/ps/output/Golden.TailRecM2Shadow.Test/eval/golden.txt new file mode 100644 index 0000000..f599e28 --- /dev/null +++ b/test/ps/output/Golden.TailRecM2Shadow.Test/eval/golden.txt @@ -0,0 +1 @@ +10 diff --git a/test/ps/output/Golden.TailRecM2Shadow.Test/golden.ir b/test/ps/output/Golden.TailRecM2Shadow.Test/golden.ir new file mode 100644 index 0000000..794ecc5 --- /dev/null +++ b/test/ps/output/Golden.TailRecM2Shadow.Test/golden.ir @@ -0,0 +1,741 @@ +UberModule + { uberModuleBindings = + [ Standalone + ( QName + { qnameModuleName = ModuleName "Data.Semiring", qnameName = Name "foreign" + }, ForeignImport Nothing + ( ModuleName "Data.Semiring" ) ".spago/prelude/v7.2.1/src/Data/Semiring.purs" + [ ( Nothing, Name "intAdd" ), ( Nothing, Name "intMul" ) ] + ), Standalone + ( QName + { qnameModuleName = ModuleName "Effect", qnameName = Name "foreign" + }, ForeignImport Nothing + ( ModuleName "Effect" ) ".spago/effect/v4.1.0/src/Effect.purs" + [ ( Nothing, Name "pureE" ), ( Nothing, Name "bindE" ), ( Nothing, Name "untilE" ) ] + ), Standalone + ( QName + { qnameModuleName = ModuleName "Effect.Ref", qnameName = Name "foreign" + }, ForeignImport Nothing + ( ModuleName "Effect.Ref" ) ".spago/refs/v6.1.0/src/Effect/Ref.purs" + [ ( Nothing, Name "_new" ), ( Nothing, Name "read" ), ( Nothing, Name "write" ) ] + ), Standalone + ( QName + { qnameModuleName = ModuleName "Control.Applicative", qnameName = Name "pure" + }, Abs Nothing + ( ParamNamed Nothing ( Name "dict" ) ) + ( ObjectProp Nothing ( Ref Nothing ( Local ( Name "dict" ) ) 0 ) ( PropName "pure" ) ) + ), Standalone + ( QName + { qnameModuleName = ModuleName "Control.Bind", qnameName = Name "bind" }, Abs Nothing + ( ParamNamed Nothing ( Name "dict" ) ) + ( ObjectProp Nothing ( Ref Nothing ( Local ( Name "dict" ) ) 0 ) ( PropName "bind" ) ) + ), RecursiveGroup + ( + ( QName + { qnameModuleName = ModuleName "Effect", qnameName = Name "monadEffect" + }, LiteralObject Nothing + [ + ( PropName "Applicative0", Abs Nothing ( ParamUnused Nothing ) + ( Ref Nothing ( Imported ( ModuleName "Effect" ) ( Name "applicativeEffect" ) ) 0 ) + ), + ( PropName "Bind1", Abs Nothing ( ParamUnused Nothing ) + ( Ref Nothing ( Imported ( ModuleName "Effect" ) ( Name "bindEffect" ) ) 0 ) + ) + ] + ) :| + [ + ( QName + { qnameModuleName = ModuleName "Effect", qnameName = Name "bindEffect" + }, LiteralObject Nothing + [ + ( PropName "bind", ObjectProp ( Just Always ) + ( Ref Nothing ( Imported ( ModuleName "Effect" ) ( Name "foreign" ) ) 0 ) + ( PropName "bindE" ) + ), + ( PropName "Apply0", Abs Nothing ( ParamUnused Nothing ) + ( App Nothing + ( Ref Nothing + ( Imported ( ModuleName "Effect" ) ( Name "Lazy_applyEffect" ) ) 0 + ) + ( LiteralInt Nothing 0 ) + ) + ) + ] + ), + ( QName + { qnameModuleName = ModuleName "Effect", qnameName = Name "applicativeEffect" + }, LiteralObject Nothing + [ + ( PropName "pure", ObjectProp ( Just Always ) + ( Ref Nothing ( Imported ( ModuleName "Effect" ) ( Name "foreign" ) ) 0 ) + ( PropName "pureE" ) + ), + ( PropName "Apply0", Abs Nothing ( ParamUnused Nothing ) + ( App Nothing + ( Ref Nothing + ( Imported ( ModuleName "Effect" ) ( Name "Lazy_applyEffect" ) ) 0 + ) + ( LiteralInt Nothing 0 ) + ) + ) + ] + ), + ( QName + { qnameModuleName = ModuleName "Effect", qnameName = Name "Lazy_functorEffect" + }, App Nothing + ( App Nothing + ( Ref Nothing ( Local ( Name "PSLUA_runtime_lazy" ) ) 0 ) + ( LiteralString Nothing "functorEffect" ) + ) + ( Abs Nothing ( ParamUnused Nothing ) + ( LiteralObject Nothing + [ + ( PropName "map", Abs Nothing + ( ParamNamed Nothing ( Name "f" ) ) + ( Abs Nothing + ( ParamNamed Nothing ( Name "a" ) ) + ( App Nothing + ( App Nothing + ( ObjectProp Nothing + ( App Nothing + ( ObjectProp Nothing + ( Ref Nothing + ( Imported + ( ModuleName "Effect" ) + ( Name "applicativeEffect" ) + ) 0 + ) + ( PropName "Apply0" ) + ) + ( Ref Nothing + ( Imported ( ModuleName "Prim" ) ( Name "undefined" ) ) 0 + ) + ) + ( PropName "apply" ) + ) + ( App Nothing + ( App Nothing + ( Ref Nothing + ( Imported ( ModuleName "Control.Applicative" ) ( Name "pure" ) ) 0 + ) + ( Ref Nothing + ( Imported ( ModuleName "Effect" ) ( Name "applicativeEffect" ) ) 0 + ) + ) + ( Ref Nothing ( Local ( Name "f" ) ) 0 ) + ) + ) + ( Ref Nothing ( Local ( Name "a" ) ) 0 ) + ) + ) + ) + ] + ) + ) + ), + ( QName + { qnameModuleName = ModuleName "Effect", qnameName = Name "Lazy_applyEffect" + }, App Nothing + ( App Nothing + ( Ref Nothing ( Local ( Name "PSLUA_runtime_lazy" ) ) 0 ) + ( LiteralString Nothing "applyEffect" ) + ) + ( Abs Nothing ( ParamUnused Nothing ) + ( LiteralObject Nothing + [ + ( PropName "apply", Let Nothing + ( Standalone + ( Nothing, Name "bind", App Nothing + ( Ref Nothing + ( Imported ( ModuleName "Control.Bind" ) ( Name "bind" ) ) 0 + ) + ( App Nothing + ( ObjectProp Nothing + ( Ref Nothing + ( Imported ( ModuleName "Effect" ) ( Name "monadEffect" ) ) 0 + ) + ( PropName "Bind1" ) + ) + ( Ref Nothing ( Imported ( ModuleName "Prim" ) ( Name "undefined" ) ) 0 ) + ) + ) :| [] + ) + ( Abs Nothing + ( ParamNamed Nothing ( Name "f" ) ) + ( Abs Nothing + ( ParamNamed Nothing ( Name "a" ) ) + ( App Nothing + ( App Nothing + ( Ref Nothing ( Local ( Name "bind" ) ) 0 ) + ( Ref Nothing ( Local ( Name "f" ) ) 0 ) + ) + ( Abs Nothing + ( ParamNamed Nothing ( Name "f'" ) ) + ( App Nothing + ( App Nothing + ( Ref Nothing ( Local ( Name "bind" ) ) 0 ) + ( Ref Nothing ( Local ( Name "a" ) ) 0 ) + ) + ( Abs Nothing + ( ParamNamed Nothing ( Name "a'" ) ) + ( App Nothing + ( App Nothing + ( Ref Nothing + ( Imported + ( ModuleName "Control.Applicative" ) + ( Name "pure" ) + ) 0 + ) + ( App Nothing + ( ObjectProp Nothing + ( Ref Nothing + ( Imported + ( ModuleName "Effect" ) + ( Name "monadEffect" ) + ) 0 + ) + ( PropName "Applicative0" ) + ) + ( Ref Nothing + ( Imported ( ModuleName "Prim" ) ( Name "undefined" ) ) 0 + ) + ) + ) + ( App Nothing + ( Ref Nothing ( Local ( Name "f'" ) ) 0 ) + ( Ref Nothing ( Local ( Name "a'" ) ) 0 ) + ) + ) + ) + ) + ) + ) + ) + ) + ), + ( PropName "Functor0", Abs Nothing ( ParamUnused Nothing ) + ( App Nothing + ( Ref Nothing + ( Imported ( ModuleName "Effect" ) ( Name "Lazy_functorEffect" ) ) 0 + ) + ( LiteralInt Nothing 0 ) + ) + ) + ] + ) + ) + ), + ( QName + { qnameModuleName = ModuleName "Effect", qnameName = Name "functorEffect" + }, App Nothing + ( Ref Nothing ( Imported ( ModuleName "Effect" ) ( Name "Lazy_functorEffect" ) ) 0 ) + ( LiteralInt Nothing 0 ) + ) + ] + ), Standalone + ( QName + { qnameModuleName = ModuleName "Control.Monad.Rec.Class", qnameName = Name "bind" + }, App Nothing + ( Ref Nothing ( Imported ( ModuleName "Control.Bind" ) ( Name "bind" ) ) 0 ) + ( Ref Nothing ( Imported ( ModuleName "Effect" ) ( Name "bindEffect" ) ) 0 ) + ), Standalone + ( QName + { qnameModuleName = ModuleName "Control.Monad.Rec.Class", qnameName = Name "pure" + }, App Nothing + ( Ref Nothing ( Imported ( ModuleName "Control.Applicative" ) ( Name "pure" ) ) 0 ) + ( Ref Nothing ( Imported ( ModuleName "Effect" ) ( Name "applicativeEffect" ) ) 0 ) + ), Standalone + ( QName + { qnameModuleName = ModuleName "Golden.TailRecM2Shadow.Test", qnameName = Name "add" + }, ObjectProp Nothing + ( LiteralObject Nothing + [ + ( PropName "add", ObjectProp ( Just Always ) + ( Ref Nothing ( Imported ( ModuleName "Data.Semiring" ) ( Name "foreign" ) ) 0 ) + ( PropName "intAdd" ) + ), + ( PropName "zero", LiteralInt Nothing 0 ), + ( PropName "mul", ObjectProp ( Just Always ) + ( Ref Nothing ( Imported ( ModuleName "Data.Semiring" ) ( Name "foreign" ) ) 0 ) + ( PropName "intMul" ) + ), + ( PropName "one", LiteralInt Nothing 1 ) + ] + ) + ( PropName "add" ) + ), Standalone + ( QName + { qnameModuleName = ModuleName "Golden.TailRecM2Shadow.Test", qnameName = Name "sumFrom" + }, Abs Nothing + ( ParamNamed Nothing ( Name "dictMonadRec" ) ) + ( Let Nothing + ( Standalone + ( Nothing, Name "pure", App Nothing + ( Ref Nothing ( Imported ( ModuleName "Control.Applicative" ) ( Name "pure" ) ) 0 ) + ( App Nothing + ( ObjectProp Nothing + ( App Nothing + ( ObjectProp Nothing + ( Ref Nothing ( Local ( Name "dictMonadRec" ) ) 0 ) + ( PropName "Monad0" ) + ) + ( Ref Nothing ( Imported ( ModuleName "Prim" ) ( Name "undefined" ) ) 0 ) + ) + ( PropName "Applicative0" ) + ) + ( Ref Nothing ( Imported ( ModuleName "Prim" ) ( Name "undefined" ) ) 0 ) + ) + ) :| [] + ) + ( Abs Nothing + ( ParamNamed Nothing ( Name "b" ) ) + ( Abs Nothing + ( ParamNamed Nothing ( Name "n" ) ) + ( App Nothing + ( App Nothing + ( ObjectProp Nothing + ( Ref Nothing ( Local ( Name "dictMonadRec" ) ) 0 ) + ( PropName "tailRecM" ) + ) + ( Abs Nothing + ( ParamNamed Nothing ( Name "o" ) ) + ( IfThenElse Nothing + ( IfThenElse Nothing + ( Eq Nothing + ( LiteralString Nothing "Data.Ordering∷Ordering.LT" ) + ( ReflectCtor Nothing + ( App Nothing + ( App Nothing + ( ObjectProp Nothing + ( LiteralObject Nothing + [ + ( PropName "compare", App Nothing + ( App Nothing + ( App Nothing + ( ObjectProp ( Just Always ) + ( ForeignImport Nothing + ( ModuleName "Data.Ord" ) ".spago/prelude/v7.2.1/src/Data/Ord.purs" + [ ( Nothing, Name "ordIntImpl" ) ] + ) + ( PropName "ordIntImpl" ) + ) + ( Ctor Nothing SumType + ( ModuleName "Data.Ordering" ) + ( TyName "Ordering" ) + ( CtorName "LT" ) [] + ) + ) + ( Ctor Nothing SumType + ( ModuleName "Data.Ordering" ) + ( TyName "Ordering" ) + ( CtorName "EQ" ) [] + ) + ) + ( Ctor Nothing SumType + ( ModuleName "Data.Ordering" ) + ( TyName "Ordering" ) + ( CtorName "GT" ) [] + ) + ), + ( PropName "Eq0", Abs Nothing ( ParamUnused Nothing ) + ( LiteralObject Nothing + [ + ( PropName "eq", ObjectProp ( Just Always ) + ( ForeignImport Nothing + ( ModuleName "Data.Eq" ) ".spago/prelude/v7.2.1/src/Data/Eq.purs" + [ ( Nothing, Name "eqIntImpl" ) ] + ) + ( PropName "eqIntImpl" ) + ) + ] + ) + ) + ] + ) + ( PropName "compare" ) + ) + ( ObjectProp Nothing + ( Ref Nothing ( Local ( Name "o" ) ) 0 ) + ( PropName "b" ) + ) + ) + ( Ref Nothing ( Local ( Name "n" ) ) 0 ) + ) + ) + ) ( LiteralBool Nothing False ) ( LiteralBool Nothing True ) + ) + ( App Nothing + ( Ref Nothing ( Local ( Name "pure" ) ) 0 ) + ( App Nothing + ( Ctor Nothing SumType + ( ModuleName "Control.Monad.Rec.Class" ) + ( TyName "Step" ) + ( CtorName "Done" ) + [ FieldName "value0" ] + ) + ( ObjectProp Nothing + ( Ref Nothing ( Local ( Name "o" ) ) 0 ) + ( PropName "a" ) + ) + ) + ) + ( App Nothing + ( Ref Nothing ( Local ( Name "pure" ) ) 0 ) + ( App Nothing + ( Ctor Nothing SumType + ( ModuleName "Control.Monad.Rec.Class" ) + ( TyName "Step" ) + ( CtorName "Loop" ) + [ FieldName "value0" ] + ) + ( LiteralObject Nothing + [ + ( PropName "a", App Nothing + ( App Nothing + ( Ref Nothing + ( Imported + ( ModuleName "Golden.TailRecM2Shadow.Test" ) + ( Name "add" ) + ) 0 + ) + ( ObjectProp Nothing + ( Ref Nothing ( Local ( Name "o" ) ) 0 ) + ( PropName "a" ) + ) + ) + ( ObjectProp Nothing + ( Ref Nothing ( Local ( Name "o" ) ) 0 ) + ( PropName "b" ) + ) + ), + ( PropName "b", App Nothing + ( App Nothing + ( Ref Nothing + ( Imported + ( ModuleName "Golden.TailRecM2Shadow.Test" ) + ( Name "add" ) + ) 0 + ) + ( ObjectProp Nothing + ( Ref Nothing ( Local ( Name "o" ) ) 0 ) + ( PropName "b" ) + ) + ) + ( LiteralInt Nothing 1 ) + ) + ] + ) + ) + ) + ) + ) + ) + ( LiteralObject Nothing + [ + ( PropName "a", Ref Nothing ( Local ( Name "b" ) ) 0 ), + ( PropName "b", LiteralInt Nothing 0 ) + ] + ) + ) + ) + ) + ) + ) + ], uberModuleForeigns = [], uberModuleExports = + [ + ( Name "sumFrom", Ref Nothing + ( Imported ( ModuleName "Golden.TailRecM2Shadow.Test" ) ( Name "sumFrom" ) ) 0 + ), + ( Name "main", App Nothing + ( App Nothing + ( App Nothing + ( Ref Nothing ( Imported ( ModuleName "Control.Bind" ) ( Name "bind" ) ) 0 ) + ( Ref Nothing ( Imported ( ModuleName "Effect" ) ( Name "bindEffect" ) ) 0 ) + ) + ( App Nothing + ( App Nothing + ( App Nothing + ( Ref Nothing + ( Imported ( ModuleName "Golden.TailRecM2Shadow.Test" ) ( Name "sumFrom" ) ) 0 + ) + ( LiteralObject Nothing + [ + ( PropName "tailRecM", Abs Nothing + ( ParamNamed Nothing ( Name "f" ) ) + ( Abs Nothing + ( ParamNamed Nothing ( Name "a" ) ) + ( App Nothing + ( App Nothing + ( Ref Nothing + ( Imported + ( ModuleName "Control.Monad.Rec.Class" ) + ( Name "bind" ) + ) 0 + ) + ( App Nothing + ( App Nothing + ( App Nothing + ( Ref Nothing + ( Imported ( ModuleName "Control.Bind" ) ( Name "bind" ) ) 0 + ) + ( Ref Nothing + ( Imported ( ModuleName "Effect" ) ( Name "bindEffect" ) ) 0 + ) + ) + ( App Nothing + ( Ref Nothing ( Local ( Name "f" ) ) 0 ) + ( Ref Nothing ( Local ( Name "a" ) ) 0 ) + ) + ) + ( ObjectProp ( Just Always ) + ( Ref Nothing + ( Imported ( ModuleName "Effect.Ref" ) ( Name "foreign" ) ) 0 + ) + ( PropName "_new" ) + ) + ) + ) + ( Abs Nothing + ( ParamNamed Nothing ( Name "r" ) ) + ( App Nothing + ( App Nothing + ( App Nothing + ( ObjectProp Nothing + ( LiteralObject Nothing + [ + ( PropName "discard", Abs Nothing + ( ParamNamed Nothing ( Name "dictBind" ) ) + ( App Nothing + ( Ref Nothing + ( Imported + ( ModuleName "Control.Bind" ) + ( Name "bind" ) + ) 0 + ) + ( Ref Nothing ( Local ( Name "dictBind" ) ) 0 ) + ) + ) + ] + ) + ( PropName "discard" ) + ) + ( Ref Nothing + ( Imported ( ModuleName "Effect" ) ( Name "bindEffect" ) ) 0 + ) + ) + ( App Nothing + ( ObjectProp ( Just Always ) + ( Ref Nothing + ( Imported ( ModuleName "Effect" ) ( Name "foreign" ) ) 0 + ) + ( PropName "untilE" ) + ) + ( App Nothing + ( App Nothing + ( Ref Nothing + ( Imported + ( ModuleName "Control.Monad.Rec.Class" ) + ( Name "bind" ) + ) 0 + ) + ( App Nothing + ( ObjectProp ( Just Always ) + ( Ref Nothing + ( Imported + ( ModuleName "Effect.Ref" ) + ( Name "foreign" ) + ) 0 + ) + ( PropName "read" ) + ) + ( Ref Nothing ( Local ( Name "r" ) ) 0 ) + ) + ) + ( Abs Nothing + ( ParamNamed Nothing ( Name "v" ) ) + ( IfThenElse Nothing + ( Eq Nothing + ( LiteralString Nothing "Control.Monad.Rec.Class∷Step.Loop" ) + ( ReflectCtor Nothing + ( Ref Nothing ( Local ( Name "v" ) ) 0 ) + ) + ) + ( App Nothing + ( App Nothing + ( Ref Nothing + ( Imported + ( ModuleName "Control.Monad.Rec.Class" ) + ( Name "bind" ) + ) 0 + ) + ( App Nothing + ( Ref Nothing ( Local ( Name "f" ) ) 0 ) + ( ObjectProp Nothing + ( Ref Nothing ( Local ( Name "v" ) ) 0 ) + ( PropName "value0" ) + ) + ) + ) + ( Abs Nothing + ( ParamNamed Nothing ( Name "e" ) ) + ( App Nothing + ( App Nothing + ( Ref Nothing + ( Imported + ( ModuleName "Control.Monad.Rec.Class" ) + ( Name "bind" ) + ) 0 + ) + ( App Nothing + ( App Nothing + ( ObjectProp ( Just Always ) + ( Ref Nothing + ( Imported + ( ModuleName "Effect.Ref" ) + ( Name "foreign" ) + ) 0 + ) + ( PropName "write" ) + ) + ( Ref Nothing ( Local ( Name "e" ) ) 0 ) + ) + ( Ref Nothing ( Local ( Name "r" ) ) 0 ) + ) + ) + ( Abs Nothing ( ParamUnused Nothing ) + ( App Nothing + ( Ref Nothing + ( Imported + ( ModuleName "Control.Monad.Rec.Class" ) + ( Name "pure" ) + ) 0 + ) ( LiteralBool Nothing False ) + ) + ) + ) + ) + ) + ( IfThenElse Nothing + ( Eq Nothing + ( LiteralString Nothing "Control.Monad.Rec.Class∷Step.Done" ) + ( ReflectCtor Nothing + ( Ref Nothing ( Local ( Name "v" ) ) 0 ) + ) + ) + ( App Nothing + ( Ref Nothing + ( Imported + ( ModuleName "Control.Monad.Rec.Class" ) + ( Name "pure" ) + ) 0 + ) ( LiteralBool Nothing True ) + ) + ( Exception Nothing "No patterns matched" ) + ) + ) + ) + ) + ) + ) + ( Abs Nothing ( ParamUnused Nothing ) + ( App Nothing + ( App Nothing + ( ObjectProp Nothing + ( Ref Nothing + ( Imported + ( ModuleName "Effect" ) + ( Name "functorEffect" ) + ) 0 + ) + ( PropName "map" ) + ) + ( App Nothing + ( ObjectProp ( Just Always ) + ( ForeignImport Nothing + ( ModuleName "Partial.Unsafe" ) ".spago/partial/v4.1.0/src/Partial/Unsafe.purs" + [ ( Nothing, Name "_unsafePartial" ) ] + ) + ( PropName "_unsafePartial" ) + ) + ( Abs Nothing ( ParamUnused Nothing ) + ( Abs Nothing + ( ParamNamed Nothing ( Name "v" ) ) + ( IfThenElse Nothing + ( Eq Nothing + ( LiteralString Nothing "Control.Monad.Rec.Class∷Step.Done" ) + ( ReflectCtor Nothing + ( Ref Nothing ( Local ( Name "v" ) ) 0 ) + ) + ) + ( ObjectProp Nothing + ( Ref Nothing ( Local ( Name "v" ) ) 0 ) + ( PropName "value0" ) + ) + ( Exception Nothing "No patterns matched" ) + ) + ) + ) + ) + ) + ( App Nothing + ( ObjectProp ( Just Always ) + ( Ref Nothing + ( Imported + ( ModuleName "Effect.Ref" ) + ( Name "foreign" ) + ) 0 + ) + ( PropName "read" ) + ) + ( Ref Nothing ( Local ( Name "r" ) ) 0 ) + ) + ) + ) + ) + ) + ) + ) + ), + ( PropName "Monad0", Abs Nothing ( ParamUnused Nothing ) + ( Ref Nothing ( Imported ( ModuleName "Effect" ) ( Name "monadEffect" ) ) 0 ) + ) + ] + ) + ) + ( LiteralInt Nothing 0 ) + ) + ( LiteralInt Nothing 5 ) + ) + ) + ( Abs Nothing + ( ParamNamed Nothing ( Name "r" ) ) + ( App Nothing + ( ObjectProp ( Just Always ) + ( ForeignImport Nothing + ( ModuleName "Effect.Console" ) ".spago/console/v6.1.0/src/Effect/Console.purs" + [ ( Nothing, Name "log" ) ] + ) + ( PropName "log" ) + ) + ( App Nothing + ( ObjectProp Nothing + ( LiteralObject Nothing + [ + ( PropName "show", ObjectProp ( Just Always ) + ( ForeignImport Nothing + ( ModuleName "Data.Show" ) ".spago/prelude/v7.2.1/src/Data/Show.purs" + [ ( Nothing, Name "showIntImpl" ) ] + ) + ( PropName "showIntImpl" ) + ) + ] + ) + ( PropName "show" ) + ) + ( Ref Nothing ( Local ( Name "r" ) ) 0 ) + ) + ) + ) + ) + ] + } \ No newline at end of file diff --git a/test/ps/output/Golden.TailRecM2Shadow.Test/golden.lua b/test/ps/output/Golden.TailRecM2Shadow.Test/golden.lua new file mode 100644 index 0000000..2b9e127 --- /dev/null +++ b/test/ps/output/Golden.TailRecM2Shadow.Test/golden.lua @@ -0,0 +1,188 @@ +local function PSLUA_runtime_lazy(name) + return function(init) + return function() + local state = 0 + local val = nil + if state == 2 then + return val + else + if state == 1 then + return error(name .. " was needed before it finished initializing") + else + state = 1 + val = init() + state = 2 + return val + end + end + end + end +end +local M = {} +M.Data_Semiring_foreign = { + intAdd = function(x) return function(y) return x + y end end, + intMul = function(x) return function(y) return x * y end end +} +M.Effect_foreign = { + pureE = function(a) + return function() + return a + end + end, + bindE = function(a) + return function(f) + return function() + return f(a())() + end + end + end, + untilE = function(f) + return function() + while not f() do + end + end + end +} +M.Effect_Ref_foreign = { + _new = function(val) return function() return {value = val} end end, + read = function(ref) return function() return ref.value end end, + write = function(val) + return function(ref) return function() ref.value = val end end + end +} +M.Control_Applicative_pure = function(dict) return dict.pure end +M.Control_Bind_bind = function(dict) return dict.bind end +M.Effect_monadEffect = { + Applicative0 = function() return M.Effect_applicativeEffect end, + Bind1 = function() return M.Effect_bindEffect end +} +M.Effect_bindEffect = { + bind = M.Effect_foreign.bindE, + Apply0 = function() return M.Effect_Lazy_applyEffect(0) end +} +M.Effect_applicativeEffect = { + pure = M.Effect_foreign.pureE, + Apply0 = function() return M.Effect_Lazy_applyEffect(0) end +} +M.Effect_Lazy_functorEffect = PSLUA_runtime_lazy("functorEffect")(function() + return { + map = function(f) + return function(a) + return (M.Effect_applicativeEffect.Apply0()).apply(M.Control_Applicative_pure(M.Effect_applicativeEffect)(f))(a) + end + end + } +end) +M.Effect_Lazy_applyEffect = PSLUA_runtime_lazy("applyEffect")(function() + return { + apply = (function() + return function(f) + local bind = M.Control_Bind_bind(M.Effect_monadEffect.Bind1()) + return function(a) + return bind(f)(function(fPrime) + return bind(a)(function(aPrime) + return M.Control_Applicative_pure(M.Effect_monadEffect.Applicative0())(fPrime(aPrime)) + end) + end) + end + end + end)(), + Functor0 = function() return M.Effect_Lazy_functorEffect(0) end + } +end) +M.Effect_functorEffect = M.Effect_Lazy_functorEffect(0) +M.Control_Monad_Rec_Class_bind = M.Control_Bind_bind(M.Effect_bindEffect) +M.Control_Monad_Rec_Class_pure = M.Control_Applicative_pure(M.Effect_applicativeEffect) +M.Golden_TailRecM2Shadow_Test_add = M.Data_Semiring_foreign.intAdd +M.Golden_TailRecM2Shadow_Test_sumFrom = function(dictMonadRec) + return function(b) + local pure = M.Control_Applicative_pure((dictMonadRec.Monad0()).Applicative0()) + return function(n) + return dictMonadRec.tailRecM(function(o) + if (function() + if "Data.Ordering∷Ordering.LT" == (((function() + local unsafeCoerceImpl = function(lt) + return function(eq) + return function(gt) + return function(x) + return function(y) + if x < y then + return lt + elseif x == y then + return eq + else + return gt + end + end + end + end + end + end + return { ordIntImpl = unsafeCoerceImpl } + end)()).ordIntImpl({ ["$ctor"] = "Data.Ordering∷Ordering.LT" })({ + ["$ctor"] = "Data.Ordering∷Ordering.EQ" + })({ ["$ctor"] = "Data.Ordering∷Ordering.GT" })(o.b)(n))["$ctor"] then + return false + else + return true + end + end)() then + return pure((function(value0) + return { + ["$ctor"] = "Control.Monad.Rec.Class∷Step.Done", + value0 = value0 + } + end)(o.a)) + else + return pure((function(value0) + return { + ["$ctor"] = "Control.Monad.Rec.Class∷Step.Loop", + value0 = value0 + } + end)({ + a = M.Golden_TailRecM2Shadow_Test_add(o.a)(o.b), + b = M.Golden_TailRecM2Shadow_Test_add(o.b)(1) + })) + end + end)({ a = b, b = 0 }) + end + end +end +return M.Control_Bind_bind(M.Effect_bindEffect)(M.Golden_TailRecM2Shadow_Test_sumFrom({ + tailRecM = function(f) + return function(a) + return M.Control_Monad_Rec_Class_bind(M.Control_Bind_bind(M.Effect_bindEffect)(f(a))(M.Effect_Ref_foreign._new))(function( r ) + return (function(dictBind) + return M.Control_Bind_bind(dictBind) + end)(M.Effect_bindEffect)(M.Effect_foreign.untilE(M.Control_Monad_Rec_Class_bind(M.Effect_Ref_foreign.read(r))(function( v ) + if "Control.Monad.Rec.Class∷Step.Loop" == v["$ctor"] then + return M.Control_Monad_Rec_Class_bind(f(v.value0))(function(e) + return M.Control_Monad_Rec_Class_bind(M.Effect_Ref_foreign.write(e)(r))(function( ) + return M.Control_Monad_Rec_Class_pure(false) + end) + end) + else + if "Control.Monad.Rec.Class∷Step.Done" == v["$ctor"] then + return M.Control_Monad_Rec_Class_pure(true) + else + return error("No patterns matched") + end + end + end)))(function() + return M.Effect_functorEffect.map((function(f) return f(); end)(function( ) + return function(v) + if "Control.Monad.Rec.Class∷Step.Done" == v["$ctor"] then + return v.value0 + else + return error("No patterns matched") + end + end + end))(M.Effect_Ref_foreign.read(r)) + end) + end) + end + end, + Monad0 = function() return M.Effect_monadEffect end +})(0)(5))(function(r) + return (function(s) return function() print(s) end end)((function(n) return tostring(n) end)(r)) +end)() diff --git a/test/ps/spago.dhall b/test/ps/spago.dhall index e2214cb..abaca65 100644 --- a/test/ps/spago.dhall +++ b/test/ps/spago.dhall @@ -10,6 +10,7 @@ , "prelude" , "profunctor" , "strings" + , "tailrec" ] , packages = ./packages.dhall , sources = [ "golden/**/*.purs" ]