diff --git a/lib/Language/PureScript/Backend/IR/DCE.hs b/lib/Language/PureScript/Backend/IR/DCE.hs index 6bca7a8..7f95c96 100644 --- a/lib/Language/PureScript/Backend/IR/DCE.hs +++ b/lib/Language/PureScript/Backend/IR/DCE.hs @@ -309,6 +309,7 @@ eliminateDeadCode uber@UberModule {..} = addToScope ((nameId, _ann), name, _expr) = addLocalToScope nameId name 0 where + -- See Note [Sequential scoping of Let bindings] adjacencyListForGrouping ∷ (Scope, DList Node) → Grouping ((Id, Ann), Name, AExp) diff --git a/lib/Language/PureScript/Backend/IR/Linker.hs b/lib/Language/PureScript/Backend/IR/Linker.hs index c4d5210..ee8b825 100644 --- a/lib/Language/PureScript/Backend/IR/Linker.hs +++ b/lib/Language/PureScript/Backend/IR/Linker.hs @@ -106,23 +106,27 @@ qualifyTopRefs moduleName = go case parameter of ParamNamed _ann argName → Map.adjust (+ 1) argName topNames ParamUnused _ann → topNames + -- See Note [Sequential scoping of Let bindings] Let ann groupings body → - Let ann (qualifyGroupings groupings) (qualifyBody body) + Let ann groupings' (go topNamesAfterBinds body) where - qualifyGroupings ∷ NonEmpty Binding → NonEmpty Binding - qualifyGroupings = fmap \case - Standalone (a, name, expr) → - Standalone (a, name, go (Map.adjust (+ 1) name topNames) expr) - RecursiveGroup recBinds → - RecursiveGroup do - (a, name, expr) ← recBinds - pure (a, name, go indexedNames expr) - where - boundNames = toList recBinds <&> \(_, n, _) → n - indexedNames = foldr (Map.adjust (+ 1)) topNames boundNames - qualifyBody = - let boundNames = toList groupings >>= bindingNames - in go (foldr (Map.adjust (+ 1)) topNames boundNames) + (topNamesAfterBinds, groupings') = + mapAccumL qualifyGrouping topNames groupings + qualifyGrouping ∷ Map Name Index → Binding → (Map Name Index, Binding) + qualifyGrouping names grouping = + case grouping of + Standalone (a, name, expr) → + ( Map.adjust (+ 1) name names + , Standalone (a, name, go names expr) + ) + RecursiveGroup recBinds → + ( names' + , RecursiveGroup $ + recBinds <&> \(a, name, expr) → (a, name, go names' expr) + ) + where + names' = + foldr (Map.adjust (+ 1)) names (bindingNames grouping) App ann argument function → App ann (go' argument) (go' function) LiteralArray ann as → diff --git a/lib/Language/PureScript/Backend/IR/Optimizer.hs b/lib/Language/PureScript/Backend/IR/Optimizer.hs index bf56d22..905ad74 100644 --- a/lib/Language/PureScript/Backend/IR/Optimizer.hs +++ b/lib/Language/PureScript/Backend/IR/Optimizer.hs @@ -41,6 +41,8 @@ optimizedUberModule = -- unblock even more optimizations, e.g. inline foreign bindings. >>> mergeForeignsIntoBindings >>> idempotently (eliminateDeadCode . optimizeModule) + -- Must run last: + -- see Note [Locals are uniquely named after renameShadowedNames] >>> renameShadowedNames mergeForeignsIntoBindings ∷ UberModule → UberModule @@ -51,6 +53,30 @@ mergeForeignsIntoBindings uberModule@UberModule {..} = map Standalone uberModuleForeigns <> uberModuleBindings } +{- Note [Locals are uniquely named after renameShadowedNames] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +'renameShadowedNames' gives every shadowing local binder a fresh name +and rewrites all references to it with index 0, so afterwards a local +reference resolves to its binder by name alone. The Lua code generator +relies on this: Lua has no notion of "the second enclosing local named +x", so the Ref case of 'fromIR' emits a plain variable name and throws +'UnexpectedRefBound' if it ever meets a local reference with a non-zero +index. Such a reference is unbound: rendering it by name would silently +capture a different binder, and inventing a name produces an undefined +Lua variable (issue #37). + +Two consequences: + + * this pass must run LAST in 'optimizedUberModule' — passes like + inlining and DCE may introduce or remove shadowing and rely on + indices being meaningful, so running anything after the renaming + would invalidate it; + + * (name, index) references must be resolved according to + Note [Sequential scoping of Let bindings], which this pass and the + rest of the pipeline implement. +-} + renameShadowedNames ∷ UberModule → UberModule renameShadowedNames uberModule = uberModule @@ -60,6 +86,7 @@ renameShadowedNames uberModule = type RenamesInScope = Map Name [Name] +-- | See Note [Sequential scoping of Let bindings] renameShadowedNamesInExpr ∷ RenamesInScope → Exp → Exp renameShadowedNamesInExpr scope = go where @@ -284,7 +311,8 @@ etaReduce = _ → NoChange betaReduceUnusedParams ∷ RewriteRule Ann -betaReduceUnusedParams = pure . \case +betaReduceUnusedParams = + pure . \case App _ (Abs _ (ParamUnused _) body) _arg → Rewritten Recurse body _ → NoChange diff --git a/lib/Language/PureScript/Backend/IR/Types.hs b/lib/Language/PureScript/Backend/IR/Types.hs index 7783e7c..c1c2b8c 100644 --- a/lib/Language/PureScript/Backend/IR/Types.hs +++ b/lib/Language/PureScript/Backend/IR/Types.hs @@ -98,6 +98,64 @@ data RawExp ann | Exception ann Text | ForeignImport ann ModuleName FilePath [(ann, Name)] +{- Note [Sequential scoping of Let bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A local variable is referenced by name plus a De Bruijn-style index +('Ref _ (Local name) index'): the index selects among the binders of +that same name that are in scope, counting from the innermost binder +outwards, starting at 0. The index is per-name, so introducing a binder +for one name does not disturb references to other names. + +Which binders of a 'Let' are in scope where? The convention is +sequential, like Scheme's let*: + + * the RHS of a Standalone binding sees the *earlier* siblings of the + same Let; the binding's own name is NOT in scope there, so a + reference to it from its own RHS points at an outer binder + (Standalone bindings are non-recursive); + + * the RHS of a RecursiveGroup member sees the earlier groupings of + the same Let and every member of its own group, itself included; + + * the body sees all the bindings. + +For example (indices in brackets): + + let a = ... -- sees only the enclosing scope + b = f a[0] -- a[0] is the sibling directly above + a = g a[0] b[0] -- a[0] is the FIRST binding, not itself + in h a[0] a[1] b[0] -- a[0] is the second binding, a[1] the first + +Every traversal that walks under Let binders must implement this +convention, and they must all agree: + + * 'countFreeRefs', 'substitute' and 'shift' thread the scope through + the groupings left to right; + + * 'qualifyTopRefs' decides whether a local reference escapes to a + top-level binding by threading per-name depths the same way; + + * 'renameShadowedNamesInExpr' resolves (name, index) pairs to fresh + unique names the same way (see also + Note [Locals are uniquely named after renameShadowedNames]); + + * dead code elimination resolves references against the same + sequential scope ('adjacencyListForGrouping'); + + * the Lua code generator emits Standalone bindings of a Let as a + sequence of 'local' statements, which is exactly let* scoping on + the Lua side (the Let case of 'fromIR'). + +Getting one of the walkers wrong miscompiles. Issue #37 was caused by +shift/substitute/countFreeRefs implementing the opposite convention +(own name bound in its own RHS, siblings ignored): inlining shifted a +sibling-bound reference past its binder, DCE deleted the "unused" +binder, and codegen rendered the dangling 'Ref (Local Bind1) 1' as an +undefined Lua variable 'Bind11'. The golden test +test/ps/golden/Golden/Issue37/Test.purs and the "Let sequential (let*) +scoping" tests pin the convention. +-} + deriving stock instance Show ann ⇒ Show (RawExp ann) deriving stock instance Eq ann ⇒ Eq (RawExp ann) deriving stock instance Ord ann ⇒ Ord (RawExp ann) @@ -507,28 +565,38 @@ countFreeRefs = fmap getSum . MMap.toMap . countFreeRefs' mempty where minIndexes' = Map.insertWith (+) (Local name) 1 minIndexes ParamUnused _paramAnn → countFreeRefs' minIndexes body + -- See Note [Sequential scoping of Let bindings] Let _ann binds body → fold (countsInBody : countsInBinds) where - countsInBody = countFreeRefs' minIndexes' body - where - minIndexes' = - foldr (\name → Map.insertWith (+) name 1) minIndexes $ - toList binds >>= fmap Local . bindingNames - countsInBinds = - toList binds >>= \case - Standalone (_nameAnn, boundName, expr) → - [countFreeRefs' minIndexes' expr] - where - minIndexes' = Map.insertWith (+) (Local boundName) 1 minIndexes - RecursiveGroup recBinds → - toList recBinds <&> \(_nameAnn, _boundName, expr) → - countFreeRefs' minIndexes' expr - where - minIndexes' = - foldr - (\(_nameAnn, qName, _expr) → Map.insertWith (+) (Local qName) 1) - minIndexes - recBinds + countsInBody = countFreeRefs' minIndexesAfterBinds body + (minIndexesAfterBinds, countsInBinds) = + foldl' withGrouping (minIndexes, []) (toList binds) + withGrouping + ∷ ( Map (Qualified Name) Index + , [MonoidMap (Qualified Name) (Sum Natural)] + ) + → Grouping (ann, Name, RawExp ann) + → ( Map (Qualified Name) Index + , [MonoidMap (Qualified Name) (Sum Natural)] + ) + withGrouping (mins, counts) = \case + Standalone (_nameAnn, boundName, expr) → + ( Map.insertWith (+) (Local boundName) 1 mins + , countFreeRefs' mins expr : counts + ) + RecursiveGroup recBinds → + ( minsAfterGroup + , ( toList recBinds <&> \(_nameAnn, _boundName, expr) → + countFreeRefs' minsAfterGroup expr + ) + <> counts + ) + where + minsAfterGroup = + foldr + (\(_nameAnn, qName, _expr) → Map.insertWith (+) (Local qName) 1) + mins + recBinds App _ann argument function → go argument <> go function LiteralArray _ann as → @@ -604,39 +672,36 @@ substitute name idx replacement = substitute' idx where index' = if name == Local pName then index + 1 else index replacement' = shift 1 pName 0 replacement + -- See Note [Sequential scoping of Let bindings] Let ann binds body → Let ann binds' body' where - binds' = - binds <&> \grouping → - case grouping of - Standalone (nameAnn, boundName, expr) → - Standalone - ( nameAnn - , boundName - , substitute name index' replacement' expr - ) - where - index' - | name == Local boundName = index + 1 - | otherwise = index - replacement' = shift 1 boundName 0 replacement - RecursiveGroup recBinds → - RecursiveGroup $ - substitute name index' replacement' <<$>> recBinds - where - index' - | name `elem` fmap Local boundNames = index + 1 - | otherwise = index - replacement' = - foldr (\n r → shift 1 n 0 r) replacement boundNames - boundNames = bindingNames grouping - body' = substitute name index' replacement' body - where - boundNames = toList binds >>= bindingNames - index' = - index - & if name `elem` (Local <$> boundNames) then (+ 1) else id - replacement' = foldr (\n r → shift 1 n 0 r) replacement boundNames + ((bodyIndex, bodyReplacement), binds') = + mapAccumL withGrouping (index, replacement) binds + body' = substitute name bodyIndex bodyReplacement body + withGrouping + ∷ (Index, RawExp ann) + → Grouping (ann, Name, RawExp ann) + → ((Index, RawExp ann), Grouping (ann, Name, RawExp ann)) + withGrouping (i, repl) grouping = + case grouping of + Standalone (nameAnn, boundName, expr) → + ( + ( if name == Local boundName then i + 1 else i + , shift 1 boundName 0 repl + ) + , Standalone (nameAnn, boundName, substitute name i repl expr) + ) + RecursiveGroup recBinds → + ( (i', repl') + , RecursiveGroup $ substitute name i' repl' <<$>> recBinds + ) + where + boundNames = bindingNames grouping + i' = + i + + fromIntegral + (length (filter ((name ==) . Local) boundNames)) + repl' = foldr (\n r → shift 1 n 0 r) repl boundNames App ann argument function → App ann (go argument) (go function) LiteralArray ann as → @@ -696,36 +761,33 @@ shift offset namespace minIndex expression = 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 - binds' = - binds <&> \grouping → - case grouping of - Standalone (annotation, boundName, expr) → - Standalone + (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 minIndex' expr + , shift offset namespace minIdx expr ) - where - minIndex' - | namespace == boundName = minIndex + 1 - | otherwise = minIndex - RecursiveGroup recBinds → - RecursiveGroup $ + ) + RecursiveGroup recBinds → + ( minIdx' + , RecursiveGroup $ recBinds <&> \(nameAnn, boundName, expr) → - (nameAnn, boundName, shift offset namespace minIndex' expr) - where - minIndex' - | namespace `elem` bindingNames grouping = minIndex + 1 - | otherwise = minIndex - body' = shift offset namespace minIndex' body - where - boundNames' = toList binds >>= bindingNames - minIndex' - | namespace `elem` boundNames' = minIndex + 1 - | otherwise = minIndex + (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 → diff --git a/lib/Language/PureScript/Backend/Lua.hs b/lib/Language/PureScript/Backend/Lua.hs index fff3710..eaf7d24 100644 --- a/lib/Language/PureScript/Backend/Lua.hs +++ b/lib/Language/PureScript/Backend/Lua.hs @@ -127,12 +127,6 @@ asExpression = \case fromName ∷ HasCallStack ⇒ IR.Name → Lua.Name fromName = Name.makeSafe . IR.nameToText -fromNameWithIndex ∷ HasCallStack ⇒ IR.Name → IR.Index → Lua.Name -fromNameWithIndex name (IR.unIndex → index) = - if index == 0 - then fromName name - else Name.makeSafe $ IR.nameToText name <> show index - fromModuleName ∷ ModuleName → Lua.Name fromModuleName = Name.makeSafe . runModuleName @@ -207,17 +201,23 @@ fromIR foreigns topLevelNames modname ir = case ir of pure [] _ → goExp arg <&> \a → [a] IR.Ref _ann qualifiedName index → - pure . Right $ case qualifiedName of + case qualifiedName of IR.Local name | topLevelName ← qualifyName modname (fromName name) , Set.member topLevelName topLevelNames → - Lua.varField (Lua.varName Fixture.moduleName) topLevelName - IR.Local name → - Lua.varName (fromNameWithIndex name index) + pure . Right $ + Lua.varField (Lua.varName Fixture.moduleName) topLevelName + IR.Local name + -- See Note [Locals are uniquely named after renameShadowedNames] + | index == 0 → pure . Right $ Lua.varName (fromName name) + | otherwise → Oops.throw $ UnexpectedRefBound modname ir IR.Imported modname' name → - Lua.varField - (Lua.varName Fixture.moduleName) - (qualifyName modname' (fromName name)) + pure . Right $ + Lua.varField + (Lua.varName Fixture.moduleName) + (qualifyName modname' (fromName name)) + -- Standalone bindings become a sequence of 'local' statements, which + -- matches Note [Sequential scoping of Let bindings] IR.Let _ann bindings bodyExp → do body ← go bodyExp recs ← diff --git a/pslua.cabal b/pslua.cabal index 70f957e..d8dad70 100644 --- a/pslua.cabal +++ b/pslua.cabal @@ -162,6 +162,7 @@ test-suite spec Language.PureScript.Backend.IR.DCE.Spec Language.PureScript.Backend.IR.Gen Language.PureScript.Backend.IR.Inliner.Spec + Language.PureScript.Backend.IR.Linker.Spec Language.PureScript.Backend.IR.Optimizer.Spec Language.PureScript.Backend.IR.Spec Language.PureScript.Backend.IR.Types.Spec diff --git a/test/Language/PureScript/Backend/IR/Linker/Spec.hs b/test/Language/PureScript/Backend/IR/Linker/Spec.hs new file mode 100644 index 0000000..fffd513 --- /dev/null +++ b/test/Language/PureScript/Backend/IR/Linker/Spec.hs @@ -0,0 +1,60 @@ +module Language.PureScript.Backend.IR.Linker.Spec where + +import Data.Map qualified as Map +import Hedgehog ((===)) +import Language.PureScript.Backend.IR.Linker (qualifyTopRefs) +import Language.PureScript.Backend.IR.Names + ( ModuleName (..) + , Name (..) + ) +import Language.PureScript.Backend.IR.Types + ( Grouping (..) + , lets + , literalInt + , noAnn + , refImported + , refLocal + ) +import Test.Hspec (Spec, describe) +import Test.Hspec.Hedgehog.Extended (test) + +spec ∷ Spec +spec = describe "IR Linker" do + -- See Note [Sequential scoping of Let bindings] + describe "qualifyTopRefs" do + let modname = ModuleName "Main" + x = Name "x" + y = Name "y" + topX = Map.fromList [(x, 0)] + qualify = qualifyTopRefs modname topX + + test "ref bound by an earlier sibling is not qualified" do + let e = + lets + ( Standalone (noAnn, x, literalInt 1) + :| [Standalone (noAnn, y, refLocal x 0)] + ) + (literalInt 0) + qualify e === e + + test "ref to a top-level name in own RHS is qualified" do + let original = + lets (Standalone (noAnn, x, refLocal x 0) :| []) (literalInt 0) + expected = + lets + (Standalone (noAnn, x, refImported modname x 0) :| []) + (literalInt 0) + qualify original === expected + + test "ref in the body pointing past the binder is qualified" do + let original = + lets (Standalone (noAnn, x, literalInt 1) :| []) (refLocal x 1) + expected = + lets + (Standalone (noAnn, x, literalInt 1) :| []) + (refImported modname x 1) + qualify original === expected + + test "ref in the body bound by the let is not qualified" do + let e = lets (Standalone (noAnn, x, literalInt 1) :| []) (refLocal x 0) + qualify e === e diff --git a/test/Language/PureScript/Backend/IR/Optimizer/Spec.hs b/test/Language/PureScript/Backend/IR/Optimizer/Spec.hs index 56d119c..3f6a47a 100644 --- a/test/Language/PureScript/Backend/IR/Optimizer/Spec.hs +++ b/test/Language/PureScript/Backend/IR/Optimizer/Spec.hs @@ -1,5 +1,6 @@ module Language.PureScript.Backend.IR.Optimizer.Spec where +import Control.Lens (universeOf) import Data.Map qualified as Map import Hedgehog (annotateShow, forAll, (===)) import Hedgehog.Gen qualified as Gen @@ -8,6 +9,8 @@ import Language.PureScript.Backend.IR.Linker (LinkMode (..)) import Language.PureScript.Backend.IR.Linker qualified as Linker import Language.PureScript.Backend.IR.Names ( Name (..) + , QName (..) + , Qualified (Local) , moduleNameFromString ) import Language.PureScript.Backend.IR.Optimizer @@ -31,8 +34,10 @@ import Language.PureScript.Backend.IR.Types , noAnn , paramNamed , paramUnused + , refImported , refLocal , refLocal0 + , subexpressions ) import Test.Hspec (Spec, describe) import Test.Hspec.Hedgehog.Extended (test) @@ -117,6 +122,85 @@ spec = describe "IR Optimizer" do annotateShow expected optimizedUberModule original === expected + describe "scoping invariants" do + -- Mimics issue #37: an inlined binding contains a let with a + -- reference bound by an earlier sibling; inlining it under a binder + -- with the same name must not leave the reference unbound. + -- See Note [Sequential scoping of Let bindings] + test "inlining bindings does not unbind let-bound references" do + let mainModule = moduleNameFromString "Main" + dict = moduleNameFromString "Dict" + fooExp = + abstraction (paramNamed (Name "fn1")) $ + lets + ( Standalone + ( noAnn + , Name "Bind1" + , application + (refImported dict (Name "bind") 0) + (refLocal (Name "fn1") 0) + ) + :| [ Standalone + ( noAnn + , Name "discard1" + , application + (refImported dict (Name "discard") 0) + (refLocal (Name "Bind1") 0) + ) + ] + ) + ( application + (refLocal (Name "discard1") 0) + (refLocal (Name "discard1") 0) + ) + barExp = + abstraction (paramNamed (Name "f")) $ + lets + ( Standalone + ( noAnn + , Name "Bind1" + , application + (refImported dict (Name "bind") 0) + (refLocal (Name "f") 0) + ) + :| [] + ) + ( application + ( application + (refImported mainModule (Name "foo") 0) + (refLocal (Name "f") 0) + ) + ( application + (refLocal (Name "Bind1") 0) + (refLocal (Name "Bind1") 0) + ) + ) + original = + Linker.UberModule + { uberModuleForeigns = [] + , uberModuleBindings = + [ Standalone (QName mainModule (Name "foo"), fooExp) + , Standalone (QName mainModule (Name "bar"), barExp) + ] + , uberModuleExports = + [ + ( Name "baz" + , application + (refImported mainModule (Name "bar") 0) + (literalInt 7) + ) + ] + } + optimized = optimizedUberModule original + unboundLocalRefs = + [ (name, index) + | (_exportedName, expr) ← Linker.uberModuleExports optimized + , Ref _ann (Local name) index ← universeOf subexpressions expr + , index /= 0 + ] + annotateShow optimized + unboundLocalRefs === [] + 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 88d7393..01d0f70 100644 --- a/test/Language/PureScript/Backend/IR/Types/Spec.hs +++ b/test/Language/PureScript/Backend/IR/Types/Spec.hs @@ -5,13 +5,14 @@ import Hedgehog ((===)) import Language.PureScript.Backend.IR.Names ( ModuleName (..) , Name (..) - , Qualified (Imported) + , Qualified (Imported, Local) ) import Language.PureScript.Backend.IR.Types ( Exp , Grouping (..) , abstraction , application + , countFreeRef , countFreeRefs , lets , literalInt @@ -20,6 +21,8 @@ import Language.PureScript.Backend.IR.Types , paramUnused , refImported , refLocal + , shift + , substitute ) import Test.Hspec (Spec, describe) import Test.Hspec.Hedgehog.Extended (test) @@ -39,6 +42,62 @@ spec = describe "Types" do , (Imported (ModuleName "Partial.Unsafe") (Name "unsafePartial"), 1) ] + -- See Note [Sequential scoping of Let bindings] + describe "Let sequential (let*) scoping" do + let x = Name "x" + y = Name "y" + + test "shift: ref bound by an earlier sibling is not shifted" do + let e = + lets + ( Standalone (noAnn, x, literalInt 1) + :| [Standalone (noAnn, y, refLocal x 0)] + ) + (literalInt 0) + shift 1 x 0 e === e + + test "shift: ref to an outer name in own RHS is shifted" do + let original = + lets (Standalone (noAnn, x, refLocal x 0) :| []) (literalInt 0) + shifted = + lets (Standalone (noAnn, x, refLocal x 1) :| []) (literalInt 0) + shift 1 x 0 original === shifted + + test "shift: ref in the body bound by the let is not shifted" do + let e = + lets (Standalone (noAnn, x, literalInt 1) :| []) (refLocal x 0) + shift 1 x 0 e === e + + test "countFreeRefs: ref bound by an earlier sibling is not free" do + let e = + lets + ( Standalone (noAnn, x, literalInt 1) + :| [Standalone (noAnn, y, refLocal x 0)] + ) + (literalInt 0) + countFreeRef (Local x) e === 0 + + test "countFreeRefs: ref to an outer name in own RHS is free" do + let e = + lets (Standalone (noAnn, x, refLocal x 0) :| []) (literalInt 0) + countFreeRef (Local x) e === 1 + + test "substitute: ref bound by an earlier sibling is not substituted" do + let e = + lets + ( Standalone (noAnn, x, literalInt 1) + :| [Standalone (noAnn, y, refLocal x 0)] + ) + (literalInt 0) + substitute (Local x) 0 (literalInt 42) e === e + + test "substitute: ref to an outer name in own RHS is substituted" do + let original = + lets (Standalone (noAnn, x, refLocal x 0) :| []) (literalInt 0) + expected = + lets (Standalone (noAnn, x, literalInt 42) :| []) (literalInt 0) + substitute (Local x) 0 (literalInt 42) original === expected + expr ∷ Exp expr = abstraction diff --git a/test/Language/PureScript/Backend/Lua/Golden/Spec.hs b/test/Language/PureScript/Backend/Lua/Golden/Spec.hs index e712f35..50ba4a7 100644 --- a/test/Language/PureScript/Backend/Lua/Golden/Spec.hs +++ b/test/Language/PureScript/Backend/Lua/Golden/Spec.hs @@ -75,7 +75,7 @@ spec ∷ Spec spec = do describe "Goldens: *.purs -> *.lua" do let compilePs = do - putText "Comipling PureScript sources" + putText "Compiling PureScript sources" exitCode ← runProcess . setWorkingDir "test/ps" . shell $ String.unwords ["spago", "build", "-u", "'-g corefn'"] diff --git a/test/Main.hs b/test/Main.hs index 75c4202..6d27b1d 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -2,6 +2,7 @@ module Main where import Language.PureScript.Backend.IR.DCE.Spec qualified as IrDce import Language.PureScript.Backend.IR.Inliner.Spec qualified as Inliner +import Language.PureScript.Backend.IR.Linker.Spec qualified as IRLinker import Language.PureScript.Backend.IR.Optimizer.Spec qualified as IROptimizer import Language.PureScript.Backend.IR.Spec qualified as IR import Language.PureScript.Backend.IR.Types.Spec qualified as Types @@ -20,6 +21,7 @@ main = hspec do IrDce.spec LuaDce.spec Types.spec + IRLinker.spec IROptimizer.spec LuaOptimizer.spec Printer.spec diff --git a/test/ps/golden/Golden/Issue37/Test.purs b/test/ps/golden/Golden/Issue37/Test.purs new file mode 100644 index 0000000..4dd75da --- /dev/null +++ b/test/ps/golden/Golden/Issue37/Test.purs @@ -0,0 +1,20 @@ +module Golden.Issue37.Test (baz) where + +import Prelude +import Effect (Effect) + +baz :: Effect Unit +baz = bar (pure unit) + +bar :: forall f. Monad f => f Unit -> f Unit +bar f = do + f + _ <- pure [ foo f ] + pure unit + +foo :: forall f. Monad f => f Unit -> f Unit +foo fn1 = do + _ <- fn1 + fn1 + fn1 + fn1 diff --git a/test/ps/output/Golden.Issue37.Test/corefn.json b/test/ps/output/Golden.Issue37.Test/corefn.json new file mode 100644 index 0000000..7005a9c --- /dev/null +++ b/test/ps/output/Golden.Issue37.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":[18,6],"start":[18,3]}},"type":"Var","value":{"identifier":"discard","moduleName":["Control","Bind"]}},"annotation":{"meta":{"metaType":"IsSyntheticApp"},"sourceSpan":{"end":[18,6],"start":[18,3]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"discardUnit","moduleName":["Control","Bind"]}},"type":"App"},"identifier":"discard"},{"annotation":{"meta":null,"sourceSpan":{"end":[15,45],"start":[15,1]}},"bindType":"NonRec","expression":{"annotation":{"meta":null,"sourceSpan":{"end":[15,45],"start":[15,1]}},"argument":"dictMonad","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":null,"sourceSpan":{"end":[17,11],"start":[17,3]}},"expression":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"dictMonad","sourcePos":[0,0]}},"fieldName":"Bind1","type":"Accessor"},"annotation":{"meta":{"metaType":"IsSyntheticApp"},"sourceSpan":{"end":[17,11],"start":[17,3]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"undefined","moduleName":["Prim"]}},"type":"App"},"identifier":"Bind1"},{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"bindType":"NonRec","expression":{"abstraction":{"annotation":{"meta":{"metaType":"IsForeign"},"sourceSpan":{"end":[17,11],"start":[17,3]}},"type":"Var","value":{"identifier":"bind","moduleName":["Control","Bind"]}},"annotation":{"meta":{"metaType":"IsSyntheticApp"},"sourceSpan":{"end":[17,11],"start":[17,3]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"Bind1","sourcePos":[0,0]}},"type":"App"},"identifier":"bind"},{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"bindType":"NonRec","expression":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"discard","moduleName":["Golden","Issue37","Test"]}},"annotation":{"meta":{"metaType":"IsSyntheticApp"},"sourceSpan":{"end":[18,6],"start":[18,3]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"Bind1","sourcePos":[0,0]}},"type":"App"},"identifier":"discard1"}],"expression":{"annotation":{"meta":null,"sourceSpan":{"end":[15,45],"start":[15,1]}},"argument":"fn1","body":{"abstraction":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"bind","sourcePos":[0,0]}},"annotation":{"meta":null,"sourceSpan":{"end":[17,11],"start":[17,3]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[17,11],"start":[17,8]}},"type":"Var","value":{"identifier":"fn1","sourcePos":[16,1]}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[17,11],"start":[17,3]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[17,11],"start":[17,3]}},"argument":"$__unused","body":{"abstraction":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"discard1","sourcePos":[0,0]}},"annotation":{"meta":null,"sourceSpan":{"end":[18,6],"start":[18,3]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[18,6],"start":[18,3]}},"type":"Var","value":{"identifier":"fn1","sourcePos":[16,1]}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[18,6],"start":[18,3]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[18,6],"start":[18,3]}},"argument":"$__unused","body":{"abstraction":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"discard1","sourcePos":[0,0]}},"annotation":{"meta":null,"sourceSpan":{"end":[19,6],"start":[19,3]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[19,6],"start":[19,3]}},"type":"Var","value":{"identifier":"fn1","sourcePos":[16,1]}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[19,6],"start":[19,3]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[19,6],"start":[19,3]}},"argument":"$__unused","body":{"annotation":{"meta":null,"sourceSpan":{"end":[20,6],"start":[20,3]}},"type":"Var","value":{"identifier":"fn1","sourcePos":[16,1]}},"type":"Abs"},"type":"App"},"type":"Abs"},"type":"App"},"type":"Abs"},"type":"App"},"type":"Abs"},"type":"Let"},"type":"Abs"},"identifier":"foo"},{"annotation":{"meta":null,"sourceSpan":{"end":[9,45],"start":[9,1]}},"bindType":"NonRec","expression":{"annotation":{"meta":null,"sourceSpan":{"end":[9,45],"start":[9,1]}},"argument":"dictMonad","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":null,"sourceSpan":{"end":[11,4],"start":[11,3]}},"expression":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"dictMonad","sourcePos":[0,0]}},"fieldName":"Bind1","type":"Accessor"},"annotation":{"meta":{"metaType":"IsSyntheticApp"},"sourceSpan":{"end":[11,4],"start":[11,3]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"undefined","moduleName":["Prim"]}},"type":"App"},"identifier":"Bind1"},{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"bindType":"NonRec","expression":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"discard","moduleName":["Golden","Issue37","Test"]}},"annotation":{"meta":{"metaType":"IsSyntheticApp"},"sourceSpan":{"end":[11,4],"start":[11,3]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"Bind1","sourcePos":[0,0]}},"type":"App"},"identifier":"discard1"},{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"bindType":"NonRec","expression":{"abstraction":{"annotation":{"meta":{"metaType":"IsForeign"},"sourceSpan":{"end":[12,22],"start":[12,3]}},"type":"Var","value":{"identifier":"bind","moduleName":["Control","Bind"]}},"annotation":{"meta":{"metaType":"IsSyntheticApp"},"sourceSpan":{"end":[12,22],"start":[12,3]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"Bind1","sourcePos":[0,0]}},"type":"App"},"identifier":"bind"},{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"bindType":"NonRec","expression":{"abstraction":{"annotation":{"meta":{"metaType":"IsForeign"},"sourceSpan":{"end":[12,12],"start":[12,8]}},"type":"Var","value":{"identifier":"pure","moduleName":["Control","Applicative"]}},"annotation":{"meta":{"metaType":"IsSyntheticApp"},"sourceSpan":{"end":[12,22],"start":[12,8]}},"argument":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[12,22],"start":[12,8]}},"expression":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"dictMonad","sourcePos":[0,0]}},"fieldName":"Applicative0","type":"Accessor"},"annotation":{"meta":{"metaType":"IsSyntheticApp"},"sourceSpan":{"end":[12,22],"start":[12,8]}},"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":null,"sourceSpan":{"end":[12,18],"start":[12,15]}},"type":"Var","value":{"identifier":"foo","moduleName":["Golden","Issue37","Test"]}},"annotation":{"meta":{"metaType":"IsSyntheticApp"},"sourceSpan":{"end":[12,20],"start":[12,15]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"dictMonad","sourcePos":[0,0]}},"type":"App"},"identifier":"foo1"}],"expression":{"annotation":{"meta":null,"sourceSpan":{"end":[9,45],"start":[9,1]}},"argument":"f","body":{"abstraction":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"discard1","sourcePos":[0,0]}},"annotation":{"meta":null,"sourceSpan":{"end":[11,4],"start":[11,3]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[11,4],"start":[11,3]}},"type":"Var","value":{"identifier":"f","sourcePos":[10,1]}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[11,4],"start":[11,3]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[11,4],"start":[11,3]}},"argument":"$__unused","body":{"abstraction":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"bind","sourcePos":[0,0]}},"annotation":{"meta":null,"sourceSpan":{"end":[12,22],"start":[12,3]}},"argument":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"pure","sourcePos":[0,0]}},"annotation":{"meta":null,"sourceSpan":{"end":[12,22],"start":[12,8]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[12,22],"start":[12,13]}},"type":"Literal","value":{"literalType":"ArrayLiteral","value":[{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"foo1","sourcePos":[0,0]}},"annotation":{"meta":null,"sourceSpan":{"end":[12,20],"start":[12,15]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[12,20],"start":[12,19]}},"type":"Var","value":{"identifier":"f","sourcePos":[10,1]}},"type":"App"}]}},"type":"App"},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[12,22],"start":[12,3]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[12,22],"start":[12,3]}},"argument":"$__unused","body":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"pure","sourcePos":[0,0]}},"annotation":{"meta":null,"sourceSpan":{"end":[13,12],"start":[13,3]}},"argument":{"annotation":{"meta":{"metaType":"IsForeign"},"sourceSpan":{"end":[13,12],"start":[13,8]}},"type":"Var","value":{"identifier":"unit","moduleName":["Data","Unit"]}},"type":"App"},"type":"Abs"},"type":"App"},"type":"Abs"},"type":"App"},"type":"Abs"},"type":"Let"},"type":"Abs"},"identifier":"bar"},{"annotation":{"meta":null,"sourceSpan":{"end":[6,19],"start":[6,1]}},"bindType":"NonRec","expression":{"abstraction":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[7,10],"start":[7,7]}},"type":"Var","value":{"identifier":"bar","moduleName":["Golden","Issue37","Test"]}},"annotation":{"meta":{"metaType":"IsSyntheticApp"},"sourceSpan":{"end":[7,22],"start":[7,7]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"monadEffect","moduleName":["Effect"]}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[7,22],"start":[7,7]}},"argument":{"abstraction":{"abstraction":{"annotation":{"meta":{"metaType":"IsForeign"},"sourceSpan":{"end":[7,16],"start":[7,12]}},"type":"Var","value":{"identifier":"pure","moduleName":["Control","Applicative"]}},"annotation":{"meta":{"metaType":"IsSyntheticApp"},"sourceSpan":{"end":[7,21],"start":[7,12]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[0,0],"start":[0,0]}},"type":"Var","value":{"identifier":"applicativeEffect","moduleName":["Effect"]}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[7,21],"start":[7,12]}},"argument":{"annotation":{"meta":{"metaType":"IsForeign"},"sourceSpan":{"end":[7,21],"start":[7,17]}},"type":"Var","value":{"identifier":"unit","moduleName":["Data","Unit"]}},"type":"App"},"type":"App"},"identifier":"baz"}],"exports":["baz"],"foreign":[],"imports":[{"annotation":{"meta":null,"sourceSpan":{"end":[20,6],"start":[1,1]}},"moduleName":["Control","Applicative"]},{"annotation":{"meta":null,"sourceSpan":{"end":[20,6],"start":[1,1]}},"moduleName":["Control","Bind"]},{"annotation":{"meta":null,"sourceSpan":{"end":[20,6],"start":[1,1]}},"moduleName":["Data","Unit"]},{"annotation":{"meta":null,"sourceSpan":{"end":[20,6],"start":[1,1]}},"moduleName":["Effect"]},{"annotation":{"meta":null,"sourceSpan":{"end":[20,6],"start":[1,1]}},"moduleName":["Golden","Issue37","Test"]},{"annotation":{"meta":null,"sourceSpan":{"end":[3,15],"start":[3,1]}},"moduleName":["Prelude"]},{"annotation":{"meta":null,"sourceSpan":{"end":[20,6],"start":[1,1]}},"moduleName":["Prim"]}],"moduleName":["Golden","Issue37","Test"],"modulePath":"golden/Golden/Issue37/Test.purs","reExports":{},"sourceSpan":{"end":[20,6],"start":[1,1]}} \ No newline at end of file diff --git a/test/ps/output/Golden.Issue37.Test/golden.ir b/test/ps/output/Golden.Issue37.Test/golden.ir new file mode 100644 index 0000000..1019739 --- /dev/null +++ b/test/ps/output/Golden.Issue37.Test/golden.ir @@ -0,0 +1,378 @@ +UberModule + { uberModuleBindings = + [ Standalone + ( QName + { qnameModuleName = ModuleName "Data.Unit", qnameName = Name "foreign" + }, ForeignImport Nothing + ( ModuleName "Data.Unit" ) ".spago/prelude/v7.2.0/src/Data/Unit.purs" + [ ( Just Always, Name "unit" ) ] + ), 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" ) ] + ), 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" ) ) + ( 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 ) + ) + ) + ) + ] + ) + ) + ), + ( 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 ) + ) + ) + ] + ) + ) + ) + ] + ), Standalone + ( QName + { qnameModuleName = ModuleName "Golden.Issue37.Test", qnameName = Name "discard" + }, ObjectProp Nothing + ( LiteralObject Nothing + [ + ( PropName "discard", Ref Nothing + ( Imported ( ModuleName "Control.Bind" ) ( Name "bind" ) ) 0 + ) + ] + ) + ( PropName "discard" ) + ) + ], uberModuleForeigns = [], uberModuleExports = + [ + ( Name "baz", App Nothing + ( Let Nothing + ( Standalone + ( Nothing, Name "Bind1", App Nothing + ( ObjectProp Nothing + ( Ref Nothing ( Imported ( ModuleName "Effect" ) ( Name "monadEffect" ) ) 0 ) + ( PropName "Bind1" ) + ) + ( Ref Nothing ( Imported ( ModuleName "Prim" ) ( Name "undefined" ) ) 0 ) + ) :| + [ Standalone + ( Nothing, Name "pure", 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 ) + ) + ) + ] + ) + ( Abs Nothing + ( ParamNamed Nothing ( Name "f" ) ) + ( App Nothing + ( App Nothing + ( App Nothing + ( Ref Nothing + ( Imported ( ModuleName "Golden.Issue37.Test" ) ( Name "discard" ) ) 0 + ) + ( Ref Nothing ( Local ( Name "Bind1" ) ) 0 ) + ) + ( Ref Nothing ( Local ( Name "f" ) ) 0 ) + ) + ( Abs Nothing ( ParamUnused Nothing ) + ( App Nothing + ( App Nothing + ( App Nothing + ( Ref Nothing ( Imported ( ModuleName "Control.Bind" ) ( Name "bind" ) ) 0 ) + ( Ref Nothing ( Local ( Name "Bind1" ) ) 0 ) + ) + ( App Nothing + ( Ref Nothing ( Local ( Name "pure" ) ) 0 ) + ( LiteralArray Nothing + [ App Nothing + ( Let Nothing + ( Standalone + ( Nothing, Name "Bind11", App Nothing + ( ObjectProp Nothing + ( Ref Nothing + ( Imported ( ModuleName "Effect" ) ( Name "monadEffect" ) ) 0 + ) + ( PropName "Bind1" ) + ) + ( Ref Nothing + ( Imported ( ModuleName "Prim" ) ( Name "undefined" ) ) 0 + ) + ) :| + [ Standalone + ( Nothing, Name "discard1", App Nothing + ( Ref Nothing + ( Imported + ( ModuleName "Golden.Issue37.Test" ) + ( Name "discard" ) + ) 0 + ) + ( Ref Nothing ( Local ( Name "Bind11" ) ) 0 ) + ) + ] + ) + ( Abs Nothing + ( ParamNamed Nothing ( Name "fn1" ) ) + ( App Nothing + ( App Nothing + ( 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 + ) + ) + ) + ( Ref Nothing ( Local ( Name "fn1" ) ) 0 ) + ) + ( Abs Nothing ( ParamUnused Nothing ) + ( App Nothing + ( App Nothing + ( Ref Nothing ( Local ( Name "discard1" ) ) 0 ) + ( Ref Nothing ( Local ( Name "fn1" ) ) 0 ) + ) + ( Abs Nothing ( ParamUnused Nothing ) + ( App Nothing + ( App Nothing + ( Ref Nothing ( Local ( Name "discard1" ) ) 0 ) + ( Ref Nothing ( Local ( Name "fn1" ) ) 0 ) + ) + ( Abs Nothing ( ParamUnused Nothing ) + ( Ref Nothing ( Local ( Name "fn1" ) ) 0 ) + ) + ) + ) + ) + ) + ) + ) + ) + ( Ref Nothing ( Local ( Name "f" ) ) 0 ) + ] + ) + ) + ) + ( Abs Nothing ( ParamUnused Nothing ) + ( App Nothing + ( Ref Nothing ( Local ( Name "pure" ) ) 0 ) + ( ObjectProp ( Just Always ) + ( Ref Nothing + ( Imported ( ModuleName "Data.Unit" ) ( Name "foreign" ) ) 0 + ) + ( PropName "unit" ) + ) + ) + ) + ) + ) + ) + ) + ) + ( App Nothing + ( App Nothing + ( Ref Nothing ( Imported ( ModuleName "Control.Applicative" ) ( Name "pure" ) ) 0 ) + ( Ref Nothing ( Imported ( ModuleName "Effect" ) ( Name "applicativeEffect" ) ) 0 ) + ) + ( ObjectProp ( Just Always ) + ( Ref Nothing ( Imported ( ModuleName "Data.Unit" ) ( Name "foreign" ) ) 0 ) + ( PropName "unit" ) + ) + ) + ) + ] + } \ No newline at end of file diff --git a/test/ps/output/Golden.Issue37.Test/golden.lua b/test/ps/output/Golden.Issue37.Test/golden.lua new file mode 100644 index 0000000..fe39af7 --- /dev/null +++ b/test/ps/output/Golden.Issue37.Test/golden.lua @@ -0,0 +1,98 @@ +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_Unit_foreign = { unit = {} } +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 +} +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 (M.Effect_applicativeEffect.Apply0()).apply(M.Control_Applicative_pure(M.Effect_applicativeEffect)(f)) + 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.Golden_Issue37_Test_discard = M.Control_Bind_bind +return { + baz = (function() + return function(f) + local Bind1 = M.Effect_monadEffect.Bind1() + local pure = M.Control_Applicative_pure(M.Effect_monadEffect.Applicative0()) + return M.Golden_Issue37_Test_discard(Bind1)(f)(function() + return M.Control_Bind_bind(Bind1)(pure({ + [1] = (function() + return function(fn1) + local Bind11 = M.Effect_monadEffect.Bind1() + local discard1 = M.Golden_Issue37_Test_discard(Bind11) + return M.Control_Bind_bind(M.Effect_monadEffect.Bind1())(fn1)(function( ) + return discard1(fn1)(function() + return discard1(fn1)(function() return fn1 end) + end) + end) + end + end)()(f) + }))(function() return pure(M.Data_Unit_foreign.unit) end) + end) + end + end)()(M.Control_Applicative_pure(M.Effect_applicativeEffect)(M.Data_Unit_foreign.unit)) +}