diff --git a/.gitignore b/.gitignore index f45c27f..ae43ec4 100644 --- a/.gitignore +++ b/.gitignore @@ -9,3 +9,4 @@ result-* /output/ .vscode/settings.json .envrc.local +.hspec-failures diff --git a/exe/Cli.hs b/exe/Cli.hs index 839f586..486f5ed 100644 --- a/exe/Cli.hs +++ b/exe/Cli.hs @@ -7,7 +7,7 @@ import Data.List.NonEmpty qualified as NE import Data.Tagged (Tagged (..)) import Data.Text (splitOn) import Data.Text qualified as Text -import Language.PureScript.Backend.Types (AppOrModule (..)) +import Language.PureScript.Backend.AppOrModule (AppOrModule (..)) import Language.PureScript.Names qualified as PS import Options.Applicative ( Parser diff --git a/flake.lock b/flake.lock index 7e7d4f9..3029717 100644 --- a/flake.lock +++ b/flake.lock @@ -174,11 +174,11 @@ "ghc910X": { "flake": false, "locked": { - "lastModified": 1711543129, - "narHash": "sha256-MUI07CxYOng7ZwHnMCw0ugY3HmWo2p/f4r07CGV7OAM=", + "lastModified": 1714520650, + "narHash": "sha256-4uz6RA1hRr0RheGNDM49a/B3jszqNNU8iHIow4mSyso=", "ref": "ghc-9.10", - "rev": "6ecd5f2ff97af53c7334f2d8581651203a2c6b7d", - "revCount": 62607, + "rev": "2c6375b9a804ac7fca1e82eb6fcfc8594c67c5f5", + "revCount": 62663, "submodules": true, "type": "git", "url": "https://gitlab.haskell.org/ghc/ghc" @@ -193,11 +193,11 @@ "ghc911": { "flake": false, "locked": { - "lastModified": 1711538967, - "narHash": "sha256-KSdOJ8seP3g30FaC2du8QjU9vumMnmzPR5wfkVRXQMk=", + "lastModified": 1714817013, + "narHash": "sha256-m2je4UvWfkgepMeUIiXHMwE6W+iVfUY38VDGkMzjCcc=", "ref": "refs/heads/master", - "rev": "0acfe391583d77a72051d505f05fab0ada056c49", - "revCount": 62632, + "rev": "fc24c5cf6c62ca9e3c8d236656e139676df65034", + "revCount": 62816, "submodules": true, "type": "git", "url": "https://gitlab.haskell.org/ghc/ghc" @@ -211,11 +211,11 @@ "hackage": { "flake": false, "locked": { - "lastModified": 1713659097, - "narHash": "sha256-HLnaRb/Q6hOnNj/5Unz7xsmO5b2gcrFr3nKdUQgMchQ=", + "lastModified": 1715474112, + "narHash": "sha256-nJKMnJ+HVD2xcdtF3Pl1pmU2Bent6yEoC6Dg6NevHlw=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "515f09ec65043eee03970616f389c379258d2c53", + "rev": "25618a5293d11ef32e37bc10070783c3f720fa3a", "type": "github" }, "original": { @@ -263,11 +263,11 @@ "stackage": "stackage" }, "locked": { - "lastModified": 1713660611, - "narHash": "sha256-v1234hmQ4kdOkWf+STY1tdeZM8V8hgU7tHqhgmoC1Bw=", + "lastModified": 1715475035, + "narHash": "sha256-PSY9tTGImNB2glCnwNRg1g0HhL17gqnTkLzhsiRtFaE=", "owner": "input-output-hk", "repo": "haskell.nix", - "rev": "f5b0f70e987cba6944121856973cbd1507053a20", + "rev": "c65b5a202520ccdf2cb435351d9e10545881cae4", "type": "github" }, "original": { @@ -696,11 +696,11 @@ "stackage": { "flake": false, "locked": { - "lastModified": 1713658249, - "narHash": "sha256-+fjl407ii7vN2GazvewniOmriimgV4uRJussDJB7Ssg=", + "lastModified": 1715473225, + "narHash": "sha256-uAD2qephrnRmMdLiLNqbGXfgc0BGHveiHbRhm19cNs0=", "owner": "input-output-hk", "repo": "stackage.nix", - "rev": "8387248af9b576dd2f4057690e79e533d42fa6ca", + "rev": "207b7104d536df29d264047c37500a224dde97bc", "type": "github" }, "original": { diff --git a/lib/Language/PureScript/Backend.hs b/lib/Language/PureScript/Backend.hs index bd020d5..53913f6 100644 --- a/lib/Language/PureScript/Backend.hs +++ b/lib/Language/PureScript/Backend.hs @@ -10,7 +10,7 @@ import Language.PureScript.Backend.IR.Optimizer (optimizedUberModule) import Language.PureScript.Backend.Lua qualified as Lua import Language.PureScript.Backend.Lua.Optimizer (optimizeChunk) import Language.PureScript.Backend.Lua.Types qualified as Lua -import Language.PureScript.Backend.Types (AppOrModule (..), entryPointModule) +import Language.PureScript.Backend.AppOrModule (AppOrModule (..), entryPointModule) import Language.PureScript.CoreFn.Reader qualified as CoreFn import Path (Abs, Dir, Path, SomeBase) import Prelude hiding (show) diff --git a/lib/Language/PureScript/Backend/Types.hs b/lib/Language/PureScript/Backend/AppOrModule.hs similarity index 85% rename from lib/Language/PureScript/Backend/Types.hs rename to lib/Language/PureScript/Backend/AppOrModule.hs index 470896a..3f02215 100644 --- a/lib/Language/PureScript/Backend/Types.hs +++ b/lib/Language/PureScript/Backend/AppOrModule.hs @@ -1,4 +1,4 @@ -module Language.PureScript.Backend.Types where +module Language.PureScript.Backend.AppOrModule where import Language.PureScript.Names qualified as PS diff --git a/lib/Language/PureScript/Backend/IR/Optimizer.hs b/lib/Language/PureScript/Backend/IR/Optimizer.hs index 14891f0..e3de414 100644 --- a/lib/Language/PureScript/Backend/IR/Optimizer.hs +++ b/lib/Language/PureScript/Backend/IR/Optimizer.hs @@ -12,7 +12,11 @@ import Language.PureScript.Backend.IR.Names , Qualified (Local) , qualifiedQName ) -import Language.PureScript.Backend.IR.Query (collectBoundNames) +import Language.PureScript.Backend.IR.Query + ( collectBoundNames + , countFreeRef + , countFreeRefs + ) import Language.PureScript.Backend.IR.Types ( Ann , Exp @@ -23,8 +27,6 @@ import Language.PureScript.Backend.IR.Types , RewriteRule , Rewritten (..) , bindingExprs - , countFreeRef - , countFreeRefs , getAnn , isNonRecursiveLiteral , literalBool @@ -171,12 +173,12 @@ idempotently = fix $ \i f a → let a' = f a in if a' == a then a else i f a' --- if a' == a --- then tr "FIXPOINT" a a --- else tr "RETRYING" a' (i f a') +-- if a' == a +-- then tr "FIXPOINT" a a +-- else tr "RETRYING" a' (i f a') -- where -- tr ∷ Show x ⇒ String → x → y → y --- tr l x y = trace ("\n\n" <> l <> "\n" <> (toString . pShow) x <> "\n") y +-- tr l x = trace ("\n\n" <> l <> "\n" <> (toString . pShow) x <> "\n") optimizeModule ∷ UberModule → UberModule optimizeModule UberModule {..} = @@ -279,7 +281,7 @@ etaReduce ∷ RewriteRule Ann etaReduce = pure . \case Abs _ (ParamNamed _ param) (App _ m (Ref _ (Local param') 0)) - | param == param' → + | param == param' && countFreeRef (Local param) m == 0 → Rewritten Recurse m _ → NoChange diff --git a/lib/Language/PureScript/Backend/IR/Query.hs b/lib/Language/PureScript/Backend/IR/Query.hs index 08ff8c6..1ebe895 100644 --- a/lib/Language/PureScript/Backend/IR/Query.hs +++ b/lib/Language/PureScript/Backend/IR/Query.hs @@ -3,6 +3,8 @@ module Language.PureScript.Backend.IR.Query where import Control.Lens.Plated (transformMOf) import Control.Monad.Trans.Accum (add, execAccum) import Data.Map qualified as Map +import Data.MonoidMap (MonoidMap) +import Data.MonoidMap qualified as MMap import Data.Set qualified as Set import Language.PureScript.Backend.IR.Linker (UberModule (..)) import Language.PureScript.Backend.IR.Names @@ -12,15 +14,94 @@ import Language.PureScript.Backend.IR.Names ) import Language.PureScript.Backend.IR.Types ( Exp + , Grouping (..) + , Index + , Parameter (..) + , RawExp (..) , bindingNames - , countFreeRef - , countFreeRefs , listGrouping , subexpressions ) import Language.PureScript.Backend.IR.Types qualified as IR import Language.PureScript.Names (runtimeLazyName) +countFreeRefs ∷ RawExp ann → Map (Qualified Name) Natural +countFreeRefs = fmap getSum . MMap.toMap . countFreeRefs' mempty + where + countFreeRefs' + ∷ Map (Qualified Name) Index + → RawExp ann + → MonoidMap (Qualified Name) (Sum Natural) + countFreeRefs' minIndexes = \case + Ref _ann qname index → + if Map.findWithDefault 0 qname minIndexes <= index + then MMap.singleton qname (Sum 1) + else mempty + Abs _ann param body → + case param of + ParamNamed _paramAnn name → countFreeRefs' minIndexes' body + where + minIndexes' = Map.insertWith (+) (Local name) 1 minIndexes + ParamUnused _paramAnn → countFreeRefs' minIndexes body + 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 + App _ann argument function → + go argument <> go function + LiteralArray _ann as → + foldMap go as + LiteralObject _ann props → + foldMap (go . snd) props + ReflectCtor _ann a → + go a + DataArgumentByIndex _ann _idx a → + go a + Eq _ann a b → + go a <> go b + ArrayLength _ann a → + go a + ArrayIndex _ann a _indx → + go a + ObjectProp _ann a _prop → + go a + ObjectUpdate _ann a patches → + go a <> foldMap (go . snd) patches + IfThenElse _ann p th el → + go p <> go th <> go el + -- Terminals: + LiteralInt {} → mempty + LiteralBool {} → mempty + LiteralFloat {} → mempty + LiteralString {} → mempty + LiteralChar {} → mempty + Ctor {} → mempty + Exception {} → mempty + ForeignImport {} → mempty + where + go = countFreeRefs' minIndexes + +countFreeRef ∷ Qualified Name → RawExp ann → Natural +countFreeRef name = Map.findWithDefault 0 name . countFreeRefs + usesRuntimeLazy ∷ UberModule → Bool usesRuntimeLazy UberModule {uberModuleBindings, uberModuleExports} = getAny $ diff --git a/lib/Language/PureScript/Backend/IR/Types.hs b/lib/Language/PureScript/Backend/IR/Types.hs index 7783e7c..a77bc3c 100644 --- a/lib/Language/PureScript/Backend/IR/Types.hs +++ b/lib/Language/PureScript/Backend/IR/Types.hs @@ -5,8 +5,6 @@ module Language.PureScript.Backend.IR.Types where import Control.Lens (Prism', Traversal', makePrisms, prism') import Data.Deriving (deriveEq1, deriveOrd1) import Data.Map qualified as Map -import Data.MonoidMap (MonoidMap) -import Data.MonoidMap qualified as MMap import Language.PureScript.Backend.IR.Inliner qualified as Inliner import Language.PureScript.Backend.IR.Names ( CtorName (renderCtorName) @@ -489,82 +487,7 @@ rewriteExpTopDownM rewrite = visit IfThenElse ann <$> visit p <*> visit th <*> visit el _ → pure e -countFreeRefs ∷ RawExp ann → Map (Qualified Name) Natural -countFreeRefs = fmap getSum . MMap.toMap . countFreeRefs' mempty - where - countFreeRefs' - ∷ Map (Qualified Name) Index - → RawExp ann - → MonoidMap (Qualified Name) (Sum Natural) - countFreeRefs' minIndexes = \case - Ref _ann qname index → - if Map.findWithDefault 0 qname minIndexes <= index - then MMap.singleton qname (Sum 1) - else mempty - Abs _ann param body → - case param of - ParamNamed _paramAnn name → countFreeRefs' minIndexes' body - where - minIndexes' = Map.insertWith (+) (Local name) 1 minIndexes - ParamUnused _paramAnn → countFreeRefs' minIndexes body - 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 - App _ann argument function → - go argument <> go function - LiteralArray _ann as → - foldMap go as - LiteralObject _ann props → - foldMap (go . snd) props - ReflectCtor _ann a → - go a - DataArgumentByIndex _ann _idx a → - go a - Eq _ann a b → - go a <> go b - ArrayLength _ann a → - go a - ArrayIndex _ann a _indx → - go a - ObjectProp _ann a _prop → - go a - ObjectUpdate _ann a patches → - go a <> foldMap (go . snd) patches - IfThenElse _ann p th el → - go p <> go th <> go el - -- Terminals: - LiteralInt {} → mempty - LiteralBool {} → mempty - LiteralFloat {} → mempty - LiteralString {} → mempty - LiteralChar {} → mempty - Ctor {} → mempty - Exception {} → mempty - ForeignImport {} → mempty - where - go = countFreeRefs' minIndexes -countFreeRef ∷ Qualified Name → RawExp ann → Natural -countFreeRef name = Map.findWithDefault 0 name . countFreeRefs -- | Substitute the given variable name and index with an expression substitute diff --git a/lib/Language/PureScript/Backend/Lua.hs b/lib/Language/PureScript/Backend/Lua.hs index fff3710..ef1699d 100644 --- a/lib/Language/PureScript/Backend/Lua.hs +++ b/lib/Language/PureScript/Backend/Lua.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE QuasiQuotes #-} - module Language.PureScript.Backend.Lua ( fromUberModule , fromIR @@ -19,6 +17,7 @@ import Data.Set qualified as Set import Data.Tagged (Tagged (..), untag) import Data.Text qualified as Text import Data.Traversable (for) +import Language.PureScript.Backend.AppOrModule (AppOrModule (..)) import Language.PureScript.Backend.IR qualified as IR import Language.PureScript.Backend.IR.Linker (UberModule (..)) import Language.PureScript.Backend.IR.Linker qualified as Linker @@ -28,9 +27,7 @@ import Language.PureScript.Backend.Lua.Key qualified as Key import Language.PureScript.Backend.Lua.Linker.Foreign qualified as Foreign import Language.PureScript.Backend.Lua.Name qualified as Lua import Language.PureScript.Backend.Lua.Name qualified as Name -import Language.PureScript.Backend.Lua.Types (ParamF (..)) import Language.PureScript.Backend.Lua.Types qualified as Lua -import Language.PureScript.Backend.Types (AppOrModule (..)) import Language.PureScript.Names (ModuleName (..), runModuleName) import Language.PureScript.Names qualified as PS import Path (Abs, Dir, Path) @@ -102,21 +99,30 @@ fromUberModule foreigns needsRuntimeLazy appOrModule uber = (`evalStateT` 0) do pure ( DList.fromList foreignBindings <> bindings - , Lua.Return (Lua.ann returnExp) + , Lua.return returnExp ) - pure . mconcat $ - [ [Fixture.runtimeLazy | untag needsRuntimeLazy && usesRuntimeLazy uber] - , [Fixture.objectUpdate | UsesObjectUpdate ← [usesObjectUpdate]] - , [Lua.local1 Fixture.moduleName (Lua.table []) | not (null bindings)] - , toList (DList.snoc bindings returnStat) - ] + pure $ + DList.fromList + [ Fixture.runtimeLazy + | untag needsRuntimeLazy && usesRuntimeLazy uber + ] + <> DList.fromList + [ Fixture.objectUpdate + | UsesObjectUpdate ← [usesObjectUpdate] + ] + <> DList.fromList + [ Lua.local1 Fixture.moduleName (Lua.table []) + | not (null bindings) + ] + <> DList.snoc bindings returnStat mkBinding ∷ ModuleName → Lua.Name → Lua.Exp → Lua.Statement mkBinding modname name = Lua.assign $ Lua.VarField - (Lua.ann (Lua.varName Fixture.moduleName)) + Lua.newAnn + (Lua.var (Lua.varName Fixture.moduleName)) (qualifyName modname name) asExpression ∷ Either Lua.Chunk Lua.Exp → Lua.Exp @@ -149,42 +155,45 @@ fromIR → LuaM e (Either Lua.Chunk Lua.Exp) fromIR foreigns topLevelNames modname ir = case ir of IR.LiteralInt _ann i → - pure . Right $ Lua.Integer i + pure . Right $ Lua.integer i IR.LiteralFloat _ann d → - pure . Right $ Lua.Float d + pure . Right $ Lua.float d IR.LiteralString _ann s → - pure . Right $ Lua.String s + pure . Right $ Lua.string s IR.LiteralChar _ann c → - pure . Right $ Lua.String $ Text.singleton c + pure . Right $ Lua.string $ Text.singleton c IR.LiteralBool _ann b → - pure . Right $ Lua.Boolean b + pure . Right $ Lua.boolean b IR.LiteralArray _ann exprs → Right . Lua.table <$> forM (zip [1 ..] exprs) \(i, e) → - Lua.tableRowKV (Lua.Integer i) <$> goExp e + Lua.tableRowKV (Lua.integer i) <$> goExp e IR.LiteralObject _ann kvs → Right . Lua.table <$> for kvs \(prop, exp) → Lua.tableRowNV (fromPropName prop) <$> goExp exp IR.ReflectCtor _ann e → - Right . (`Lua.varIndex` keyCtor) <$> goExp e + Right . Lua.var . (`Lua.varIndex` keyCtor) <$> goExp e IR.DataArgumentByIndex _ann i e → - Right . (`Lua.varField` Lua.unsafeName ("value" <> show i)) <$> goExp e + Right . Lua.var . (`Lua.varField` Lua.unsafeName ("value" <> show i)) + <$> goExp e IR.Eq _ann l r → Right <$> liftA2 Lua.equalTo (goExp l) (goExp r) IR.Ctor _ann _algebraicTy ctorModName ctorTyName ctorName fieldNames → pure . Right $ foldr wrap value args where - wrap name expr = Lua.functionDef [ParamNamed name] [Lua.return expr] + wrap name expr = Lua.functionDef [Lua.paramNamed name] [Lua.return expr] value = Lua.table $ ctorRow : attributes ctorId = IR.ctorId ctorModName ctorTyName ctorName - ctorRow = Lua.tableRowKV keyCtor (Lua.String ctorId) + ctorRow = Lua.tableRowKV keyCtor (Lua.string ctorId) args = Name.unsafeName . IR.renderFieldName <$> fieldNames - attributes = args <&> ap Lua.tableRowNV Lua.varName + attributes = args <&> ap Lua.tableRowNV (Lua.var . Lua.varName) IR.ArrayLength _ann e → Right . Lua.hash <$> goExp e IR.ArrayIndex _ann expr index → - Right . flip Lua.varIndex (Lua.Integer (fromIntegral index)) <$> goExp expr + Right . Lua.var . (`Lua.varIndex` Lua.integer (fromIntegral index)) + <$> goExp expr IR.ObjectProp _ann expr propName → - Right . flip Lua.varField (fromPropName propName) <$> goExp expr + Right . Lua.var . (`Lua.varField` fromPropName propName) + <$> goExp expr IR.ObjectUpdate _ann expr propValues → do add UsesObjectUpdate obj ← goExp expr @@ -192,12 +201,14 @@ fromIR foreigns topLevelNames modname ir = case ir of Lua.table <$> for (toList propValues) \(propName, e) → Lua.tableRowNV (fromPropName propName) <$> goExp e pure . Right $ - Lua.functionCall (Lua.varName Fixture.objectUpdateName) [obj, vals] + Lua.functionCall + (Lua.var (Lua.varName Fixture.objectUpdateName)) + [obj, vals] IR.Abs _ann param expr → do e ← goExp expr let luaParams = case param of IR.ParamUnused _ann → [] - IR.ParamNamed _ann name → [ParamNamed (fromName name)] + IR.ParamNamed _ann name → [Lua.paramNamed (fromName name)] pure . Right $ Lua.functionDef luaParams [Lua.return e] IR.App _ann expr arg → do e ← goExp expr @@ -205,19 +216,23 @@ fromIR foreigns topLevelNames modname ir = case ir of -- PS sometimes inserts syntetic unused argument "Prim.undefined" IR.Ref _ann (IR.Imported (IR.ModuleName "Prim") (IR.Name "undefined")) _ → pure [] - _ → goExp arg <&> \a → [a] + _ → goExp arg <&> (: []) IR.Ref _ann qualifiedName index → pure . Right $ case qualifiedName of IR.Local name | topLevelName ← qualifyName modname (fromName name) , Set.member topLevelName topLevelNames → - Lua.varField (Lua.varName Fixture.moduleName) topLevelName + Lua.var $ + Lua.varField + (Lua.var (Lua.varName Fixture.moduleName)) + topLevelName IR.Local name → - Lua.varName (fromNameWithIndex name index) + Lua.var (Lua.varName (fromNameWithIndex name index)) IR.Imported modname' name → - Lua.varField - (Lua.varName Fixture.moduleName) - (qualifyName modname' (fromName name)) + Lua.var $ + Lua.varField + (Lua.var (Lua.varName Fixture.moduleName)) + (qualifyName modname' (fromName name)) IR.Let _ann bindings bodyExp → do body ← go bodyExp recs ← @@ -227,7 +242,7 @@ fromIR foreigns topLevelNames modname ir = case ir of IR.RecursiveGroup grp → do let binds = toList grp <&> \(_ann, fromName → name, _) → - Lua.Local + Lua.local ( if Set.member (qualifyName modname name) topLevelNames then qualifyName modname name else name @@ -237,14 +252,15 @@ fromIR foreigns topLevelNames modname ir = case ir of goExp expr <&> Lua.assign ( Lua.VarName + Lua.newAnn ( if Set.member (qualifyName modname name) topLevelNames then qualifyName modname name else name ) ) pure $ DList.fromList binds <> DList.fromList assignments - pure . Left . DList.toList $ - recs <> either DList.fromList (DList.singleton . Lua.return) body + pure . Left $ + recs <> either id (DList.singleton . Lua.return) body IR.IfThenElse _ann cond th el → do thenExp ← go th elseExp ← go el @@ -252,7 +268,10 @@ fromIR foreigns topLevelNames modname ir = case ir of let thenBranch = either id (pure . Lua.return) thenExp elseBranch = either id (pure . Lua.return) elseExp - pure $ Left [Lua.ifThenElse condExp thenBranch elseBranch] + pure $ + Left $ + DList.singleton $ + Lua.ifThenElse condExp (toList thenBranch) (toList elseBranch) IR.Exception _ann msg → pure . Right $ Lua.error msg IR.ForeignImport _ann _moduleName path annotatedNames → do @@ -263,7 +282,7 @@ fromIR foreigns topLevelNames modname ir = case ir of <$> Foreign.parseForeignSource (untag foreigns) path let foreignExports ∷ Lua.Exp = Lua.table - [ Lua.tableRowNV name (Lua.ForeignSourceExp src) + [ Lua.tableRowNV name (Lua.foreignExpression src) | (key, src) ← toList exports , -- Export tables can contain Lua-reserved words as keys -- for example: `{ ["for"] = 42 }` @@ -272,7 +291,12 @@ fromIR foreigns topLevelNames modname ir = case ir of ] pure case header of Nothing → Right foreignExports - Just fh → Left $ Lua.ForeignSourceStat fh : [Lua.return foreignExports] + Just fh → + Left $ + DList.fromList + [ Lua.foreignStatement fh + , Lua.return foreignExports + ] where go ∷ IR.Exp → LuaM e (Either Lua.Chunk Lua.Exp) go = fromIR foreigns topLevelNames modname @@ -281,7 +305,7 @@ fromIR foreigns topLevelNames modname ir = case ir of goExp = asExpression <<$>> go keyCtor ∷ Lua.Exp -keyCtor = Lua.String "$ctor" +keyCtor = Lua.string "$ctor" -------------------------------------------------------------------------------- -- Helpers --------------------------------------------------------------------- diff --git a/lib/Language/PureScript/Backend/Lua/DCE.hs b/lib/Language/PureScript/Backend/Lua/DCE.hs index 7cc8b88..275a15b 100644 --- a/lib/Language/PureScript/Backend/Lua/DCE.hs +++ b/lib/Language/PureScript/Backend/Lua/DCE.hs @@ -1,6 +1,7 @@ module Language.PureScript.Backend.Lua.DCE where -import Control.Monad.Trans.Accum (add, execAccum) +import Control.Lens ((%~)) +import Control.Lens.Plated qualified as Plated import Data.DList (DList) import Data.DList qualified as DList import Data.Graph (Graph, Vertex, graphFromEdges, reachable) @@ -11,279 +12,288 @@ import Language.PureScript.Backend.Lua.Name (Name) import Language.PureScript.Backend.Lua.Name qualified as Name import Language.PureScript.Backend.Lua.Traversal ( Annotator (..) - , Visitor (..) + , Rewrites (..) , annotateStatementInsideOutM - , makeVisitor - , unAnnotateStatement - , visitStatementM + , makeRewrites + , rewriteStatementM + ) +import Language.PureScript.Backend.Lua.Types + ( Ann + , HasAnn (..) + , annL + , annOf ) import Language.PureScript.Backend.Lua.Types qualified as Lua import Prelude hiding (exp) data DceMode = PreserveTopLevel | PreserveReturned -type Label = Text type Key = Int +type NodeEdges = (Text, Key, [Key]) -eliminateDeadCode ∷ DceMode → Lua.Chunk → Lua.Chunk -eliminateDeadCode dceMode chunk = do - unNodesStatement <$> dceChunk statementWithNodes +eliminateDeadCode ∷ DceMode → [Lua.Statement] → [Lua.Statement] +eliminateDeadCode dceMode stats = dceChunk annotatedStatements where - statementWithNodes ∷ [ANode Lua.StatementF] - statementWithNodes = makeNodesStatement chunk + annotatedStatements = dceAnnotatedStatements stats ( graph ∷ Graph - , _nodeFromVertex ∷ Vertex → (Label, Key, [Key]) + , _nodeFromVertex ∷ Vertex → NodeEdges , keyToVertex ∷ Key → Maybe Vertex - ) = graphFromEdges (DList.toList (adjacencyList statementWithNodes)) + ) = graphFromEdges nodesEdges - dceChunk ∷ [ANode Lua.StatementF] → [ANode Lua.StatementF] - dceChunk = foldMap $ toList . dceStatement + nodesEdges ∷ [NodeEdges] + nodesEdges = DList.toList (adjacencyList annotatedStatements) - dceStatement ∷ ANode Lua.StatementF → Maybe (ANode Lua.StatementF) - dceStatement vstat@(Node key scopes, statement) = + dceChunk = foldMap $ toList . dceStatement + dceStatement statement = case statement of - Lua.Local name value → + Lua.Local dceAnn name value → ifKeyIsReachable $ - node (Lua.Local name (dceExpression <$> value)) - Lua.Assign variable value → + Lua.Local (unDceAnn dceAnn) name (dceExpression <$> value) + Lua.Assign dceAnn variable value → ifKeyIsReachable $ - node (Lua.Assign (dceVar variable) (dceExpression value)) - Lua.IfThenElse i t e → + Lua.Assign (unDceAnn dceAnn) (dceVar variable) (dceExpression value) + Lua.IfThenElse dceAnn i t e → ifKeyIsReachable $ - node (Lua.IfThenElse (dceExpression i) (dceChunk t) (dceChunk e)) - Lua.Return exp → - Just $ node (Lua.Return (dceExpression exp)) - Lua.ForeignSourceStat {} → - Just vstat + Lua.IfThenElse + (unDceAnn dceAnn) + (dceExpression i) + (dceChunk t) + (dceChunk e) + Lua.Return dceAnn exp → + Just $ Lua.Return (unDceAnn dceAnn) (dceExpression exp) + Lua.ForeignSourceStat dceAnn s → + Just $ Lua.ForeignSourceStat (unDceAnn dceAnn) s where - node = (Node key scopes,) + key = keyOf statement ifKeyIsReachable preserved = do vertex ← keyToVertex key guard (Set.member vertex reachableVertices) $> preserved - dceExpression ∷ ANode Lua.ExpF → ANode Lua.ExpF - dceExpression originalExpr@(Node key scope, expr) = - case expr of - Lua.Nil → originalExpr - Lua.Boolean _bool → originalExpr - Lua.Integer _int → originalExpr - Lua.Float _double → originalExpr - Lua.String _text → originalExpr - Lua.Function params body → - dce (Lua.Function (dceParams params) (dceChunk body)) - Lua.TableCtor rows → - dce (Lua.TableCtor (dceTableRow <$> rows)) - Lua.UnOp op e → - dce (Lua.UnOp op (dceExpression e)) - Lua.BinOp op e1 e2 → - dce (Lua.BinOp op (dceExpression e1) (dceExpression e2)) - Lua.Var v → - dce (Lua.Var (dceVar v)) - Lua.FunctionCall e es → - dce (Lua.FunctionCall (dceExpression e) (dceExpression <$> es)) - Lua.ForeignSourceExp _src → - originalExpr - where - dce = (Node key scope,) - - dceParams ∷ [ANode Lua.ParamF] → [ANode Lua.ParamF] - dceParams paramNodes = do - node@(Node key scopes, param) ← paramNodes - case param of - Lua.ParamUnused → [node] - Lua.ParamNamed _ → do - vertex ← maybeToList $ keyToVertex key + dceExpression ∷ Lua.ExpF DceAnn → Lua.Exp + dceExpression expr = case expr of + Lua.Nil dceAnn → + Lua.Nil (unDceAnn dceAnn) + Lua.Boolean dceAnn b → + Lua.Boolean (unDceAnn dceAnn) b + Lua.Integer dceAnn int → + Lua.Integer (unDceAnn dceAnn) int + Lua.Float dceAnn double → + Lua.Float (unDceAnn dceAnn) double + Lua.String dceAnn text → + Lua.String (unDceAnn dceAnn) text + Lua.Function dceAnn params body → + Lua.Function (unDceAnn dceAnn) (dceParams params) (dceChunk body) + Lua.TableCtor dceAnn rows → + Lua.TableCtor (unDceAnn dceAnn) (dceTableRow <$> rows) + Lua.UnOp dceAnn op e → + Lua.UnOp (unDceAnn dceAnn) op (dceExpression e) + Lua.BinOp dceAnn op e1 e2 → + Lua.BinOp (unDceAnn dceAnn) op (dceExpression e1) (dceExpression e2) + Lua.Var dceAnn v → + Lua.Var (unDceAnn dceAnn) (dceVar v) + Lua.FunctionCall dceAnn e es → + Lua.FunctionCall + (unDceAnn dceAnn) + (dceExpression e) + (dceExpression <$> es) + Lua.ForeignSourceExp dceAnn src → + Lua.ForeignSourceExp (unDceAnn dceAnn) src + + dceParams ∷ [Lua.ParamF DceAnn] → [Lua.Param] + dceParams paramNodes = + paramNodes >>= \case + Lua.ParamUnused dceAnn → [Lua.ParamUnused (unDceAnn dceAnn)] + p@(Lua.ParamNamed dceAnn name) → do + vertex ← maybeToList $ keyToVertex $ keyOf p if Set.member vertex reachableVertices - then [node] - else [(Node key scopes, Lua.ParamUnused)] - - dceTableRow ∷ ANode Lua.TableRowF → ANode Lua.TableRowF - dceTableRow (Node key scope, row) = - case row of - Lua.TableRowKV k v → - dce (Lua.TableRowKV (dceExpression k) (dceExpression v)) - Lua.TableRowNV n e → - dce (Lua.TableRowNV n (dceExpression e)) - where - dce = (Node key scope,) - - dceVar ∷ ANode Lua.VarF → ANode Lua.VarF - dceVar node@(Node key scope, variable) = - case variable of - Lua.VarName _qname → - node - Lua.VarIndex e1 e2 → - (Node key scope, Lua.VarIndex (dceExpression e1) (dceExpression e2)) - Lua.VarField e _name → - (Node key scope, Lua.VarField (dceExpression e) _name) + then [Lua.ParamNamed (unDceAnn dceAnn) name] + else [Lua.ParamUnused (unDceAnn dceAnn)] + + dceTableRow ∷ Lua.TableRowF DceAnn → Lua.TableRow + dceTableRow = \case + Lua.TableRowKV dceAnn k v → + Lua.TableRowKV (unDceAnn dceAnn) (dceExpression k) (dceExpression v) + Lua.TableRowNV dceAnn n e → + Lua.TableRowNV (unDceAnn dceAnn) n (dceExpression e) + + dceVar ∷ Lua.VarF DceAnn → Lua.Var + dceVar = \case + Lua.VarName dceAnn name → + Lua.VarName (unDceAnn dceAnn) name + Lua.VarIndex dceAnn e1 e2 → + Lua.VarIndex (unDceAnn dceAnn) (dceExpression e1) (dceExpression e2) + Lua.VarField dceAnn e name → + Lua.VarField (unDceAnn dceAnn) (dceExpression e) name reachableVertices ∷ Set Vertex - reachableVertices = Set.fromList $ reachable graph =<< dceEntryVertices + reachableVertices = + let reachables = reachable graph + in Set.fromList (dceEntryVertices >>= reachables) dceEntryVertices ∷ [Vertex] dceEntryVertices = case dceMode of - PreserveReturned → - case viaNonEmpty last statementWithNodes of - Just (Node k0 _scope0, Lua.Return (Node k1 _scope1, _stat)) → - mapMaybe keyToVertex [k0, k1] - _ → [] - PreserveTopLevel → - mapMaybe (keyToVertex . keyOf . nodeOf) statementWithNodes + PreserveTopLevel → mapMaybe (keyToVertex . keyOf) annotatedStatements + PreserveReturned → case viaNonEmpty last annotatedStatements of + Just (Lua.Return (DceAnn _ann k _scopes) exp) → + mapMaybe keyToVertex [k, keyOf exp] + _ → [] -------------------------------------------------------------------------------- -- Building graph from adjacency list ------------------------------------------ -adjacencyList ∷ [ANode Lua.StatementF] → DList (Label, Key, [Key]) +adjacencyList ∷ [Lua.StatementF DceAnn] → DList NodeEdges adjacencyList = (`go` mempty) where go - ∷ [ANode Lua.StatementF] - → DList (Label, Key, [Key]) - → DList (Label, Key, [Key]) + ∷ [Lua.StatementF DceAnn] + → DList NodeEdges + → DList NodeEdges go [] acc = acc - go ((Node key _scope, statement) : nextStatements) acc = go nextStatements do - acc <> case statement of - Lua.Local name value → - DList.cons - ( "Local(" <> Name.toText name <> ")" - , key - , case value of - Nothing → findAssignments name nextStatements - Just (n, _) → keyOf n : findAssignments name nextStatements - ) - (maybe mempty expressionAdjacencyList value) - Lua.Assign variable value → - DList.cons - ("Assign", key, [keyOf (nodeOf variable), keyOf (nodeOf value)]) - (varAdjacencyList variable <> expressionAdjacencyList value) - Lua.IfThenElse cond th el → - DList.cons - ( "IfThenElse" - , key - , keyOf (nodeOf cond) - : DList.toList (findReturns th <> findReturns el) - ) - (expressionAdjacencyList cond) - <> go th mempty - <> go el mempty - Lua.Return e → - DList.cons - ("Return", key, [keyOf (nodeOf e)]) - (expressionAdjacencyList e) - _ → mempty - -expressionAdjacencyList ∷ ANode Lua.ExpF → DList (Label, Key, [Key]) -expressionAdjacencyList (Node key _scope, expr) = + go (statement : nextStatements) acc = + go nextStatements $ + acc <> case statement of + Lua.Local _ann name value → + DList.cons + ( "Local(" <> Name.toText name <> ")" + , keyOf statement + , toList + let keys = findAssignments name nextStatements + in maybe keys (\expr → DList.cons (keyOf expr) keys) value + ) + (maybe mempty expressionAdjacencyList value) + Lua.Assign _ann variable value → + DList.cons + ("Assign", keyOf statement, [keyOf variable, keyOf value]) + (varAdjacencyList variable <> expressionAdjacencyList value) + Lua.IfThenElse _ann cond th el → + DList.cons + ( "IfThenElse" + , keyOf statement + , keyOf cond : DList.toList (findReturns th <> findReturns el) + ) + (expressionAdjacencyList cond) + <> go th DList.empty + <> go el DList.empty + Lua.Return _ann e → + DList.cons + ("Return", keyOf statement, [keyOf e]) + (expressionAdjacencyList e) + Lua.ForeignSourceStat {} → + pure ("ForeignSourceStat", keyOf statement, []) + +expressionAdjacencyList ∷ Lua.ExpF DceAnn → DList NodeEdges +expressionAdjacencyList expr = case expr of - Lua.Nil → pure ("Nil", key, []) - Lua.Boolean _bool → pure ("Boolean", key, []) - Lua.Integer _integer → pure ("Integer", key, []) - Lua.Float _double → pure ("Float", key, []) - Lua.String _text → pure ("String", key, []) - Lua.Function params body → + Lua.Nil _ann → pure ("Nil", keyOf expr, []) + Lua.Boolean _ann _bool → pure ("Boolean", keyOf expr, []) + Lua.Integer _ann _integer → pure ("Integer", keyOf expr, []) + Lua.Float _ann _double → pure ("Float", keyOf expr, []) + Lua.String _ann _text → pure ("String", keyOf expr, []) + Lua.Function _ann params body → DList.cons - ("Function", key, DList.toList (findReturns body)) - (foldMap (paramsAdjacencyList key) params <> adjacencyList body) - Lua.TableCtor rows → + ("Function", keyOf expr, DList.toList (findReturns body)) + (foldMap (paramsAdjacencyList (keyOf expr)) params <> adjacencyList body) + Lua.TableCtor _ann rows → DList.cons - ("TableCtor", key, keyOf . nodeOf <$> rows) + ("TableCtor", keyOf expr, keyOf <$> rows) (foldMap rowAdjacencyList rows) - Lua.UnOp _op e → - DList.cons ("UnOp", key, [keyOf (nodeOf e)]) (expressionAdjacencyList e) - Lua.BinOp _op e1 e2 → + Lua.UnOp _ann _op e → + DList.cons ("UnOp", keyOf expr, [keyOf e]) (expressionAdjacencyList e) + Lua.BinOp _ann _op e1 e2 → DList.cons - ("BinOp", key, [keyOf (nodeOf e1), keyOf (nodeOf e2)]) + ("BinOp", keyOf expr, [keyOf e1, keyOf e2]) (expressionAdjacencyList e1 <> expressionAdjacencyList e2) - Lua.Var variable → + Lua.Var _ann variable → DList.cons - ("Var", key, [keyOf (nodeOf variable)]) + ("Var", keyOf expr, [keyOf variable]) (varAdjacencyList variable) - Lua.FunctionCall e params → + Lua.FunctionCall _ann e params → DList.cons - ("FunctionCall", key, keyOf (nodeOf e) : map (keyOf . nodeOf) params) + ("FunctionCall", keyOf expr, keyOf e : map keyOf params) (expressionAdjacencyList e <> foldMap expressionAdjacencyList params) - Lua.ForeignSourceExp _src → - pure ("ForeignSourceExp", key, []) + Lua.ForeignSourceExp _ann _src → + pure ("ForeignSourceExp", keyOf expr, []) -paramsAdjacencyList ∷ Key → ANode Lua.ParamF → DList (Label, Key, [Key]) -paramsAdjacencyList fnKey (Node key _scopes, param) = +paramsAdjacencyList ∷ Key → Lua.ParamF DceAnn → DList NodeEdges +paramsAdjacencyList fnKey param = case param of - Lua.ParamUnused → + Lua.ParamUnused _ann → DList.empty - Lua.ParamNamed name → - DList.singleton ("ParamNamed(" <> Name.toText name <> ")", key, [fnKey]) + Lua.ParamNamed _ann name → + DList.singleton + ( "ParamNamed(" <> Name.toText name <> ")" + , keyOf param + , [fnKey] + ) -varAdjacencyList ∷ ANode Lua.VarF → DList (Label, Key, [Key]) -varAdjacencyList (Node key scopes, variable) = +varAdjacencyList ∷ Lua.VarF DceAnn → DList NodeEdges +varAdjacencyList variable = case variable of - Lua.VarName name → + Lua.VarName _ann name → DList.singleton ( "VarName(Local " <> Name.toText name <> ")" - , key - , toList (Map.lookup name (flatten scopes)) + , keyOf variable + , toList (Map.lookup name (flatten (scopesOf variable))) ) - Lua.VarIndex e1 e2 → + Lua.VarIndex _ann e1 e2 → DList.cons - ("VarIndex", key, [keyOf (nodeOf e1), keyOf (nodeOf e2)]) + ("VarIndex", keyOf variable, [keyOf e1, keyOf e2]) (expressionAdjacencyList e1 <> expressionAdjacencyList e2) - Lua.VarField e name → + Lua.VarField _ann e name → DList.cons - ("VarField(" <> Name.toText name <> ")", key, [keyOf (nodeOf e)]) + ( "VarField(" <> Name.toText name <> ")" + , keyOf variable + , [keyOf e] + ) (expressionAdjacencyList e) -rowAdjacencyList ∷ ANode Lua.TableRowF → DList (Label, Key, [Key]) -rowAdjacencyList (Node key _scope, row) = +rowAdjacencyList ∷ Lua.TableRowF DceAnn → DList NodeEdges +rowAdjacencyList row = case row of - Lua.TableRowKV e1@(n1, _) e2@(n2, _) → + Lua.TableRowKV _ann e1 e2 → DList.cons - ("Lua.TableRowKV", key, [keyOf n1, keyOf n2]) + ("Lua.TableRowKV", keyOf row, [keyOf e1, keyOf e2]) (expressionAdjacencyList e1 <> expressionAdjacencyList e2) - Lua.TableRowNV _name e@(n, _) → + Lua.TableRowNV _ann _name e → DList.cons - ("Lua.TableRowNV", key, [keyOf n]) + ("Lua.TableRowNV", keyOf row, [keyOf e]) (expressionAdjacencyList e) -------------------------------------------------------------------------------- -- Queries --------------------------------------------------------------------- -findReturns ∷ [ANode Lua.StatementF] → DList Key -findReturns = (keyOf . nodeOf <$>) . findReturnStatements +findReturns ∷ [Lua.StatementF DceAnn] → DList Key +findReturns = fmap keyOf . findReturnStatements -findReturnStatements ∷ [ANode Lua.StatementF] → DList (ANode Lua.StatementF) -findReturnStatements = foldMap \node@(_node, statement) → +findReturnStatements ∷ [Lua.StatementF DceAnn] → DList (Lua.StatementF DceAnn) +findReturnStatements = foldMap \statement → case statement of - Lua.Return _ → DList.singleton node - Lua.IfThenElse _cond th el → - DList.cons node (findReturnStatements th <> findReturnStatements el) + Lua.Return _ann _expr → DList.singleton statement + Lua.IfThenElse _ann _cond th el → + DList.cons statement (findReturnStatements th <> findReturnStatements el) _ → DList.empty -findAssignments ∷ Name → [ANode Lua.StatementF] → [Key] +findAssignments ∷ Name → [Lua.StatementF DceAnn] → DList Key findAssignments name = - toList . foldMap do - (`execAccum` DList.empty) - . visitStatementM - makeVisitor - { beforeStat = \node@(Node key _scope, statement) → - case statement of - Lua.Assign (Lua.Ann (Lua.VarName name')) _val - | name' == name → add (DList.singleton key) $> node - _ → pure node - } - -findVars ∷ Name → [ANode Lua.StatementF] → DList Key -findVars name = foldMap do (`execAccum` DList.empty) . visitStatementM visitor - where - visitor = - makeVisitor - { beforeExp = \node@(Node key _scope, expr) → - case expr of - Lua.Var (Lua.Ann (Lua.VarName name')) - | name' == name → - add (DList.singleton key) $> node - _ → pure node - } + foldMap $ + Lua.S >>> Plated.para \term rs → + case term of + Lua.S (Lua.Assign ann (Lua.VarName _ name') _val) + | name' == name → + DList.cons (annKey ann) (fold rs) + _ → fold rs + +findVars ∷ Name → [Lua.StatementF DceAnn] → DList Key +findVars name = + foldMap $ + Lua.S >>> Plated.para \term rs → + case term of + Lua.E (Lua.Var ann (Lua.VarName _ name')) + | name' == name → + DList.cons (annKey ann) (fold rs) + _ → fold rs -------------------------------------------------------------------------------- -- Annotating statements with graph keys --------------------------------------- @@ -298,85 +308,86 @@ flatten = ) Map.empty -data Node = Node Key [Scope] +data DceAnn = DceAnn Ann Key [Scope] deriving stock (Eq, Show) -type ANode f = Lua.Annotated Node f +unDceAnn ∷ DceAnn → Ann +unDceAnn (DceAnn a _key _scope) = a + +keyOf ∷ HasAnn f ⇒ f DceAnn → Key +keyOf = annKey . annOf -keyOf ∷ Node → Key -keyOf (Node key _scope) = key +annKey ∷ DceAnn → Key +annKey (DceAnn _ key _) = key -nodeOf ∷ ANode f → Node -nodeOf = fst +scopesOf ∷ HasAnn f ⇒ f DceAnn → [Scope] +scopesOf f = let DceAnn _ann _key scopes = annOf f in scopes -makeNodesStatement ∷ [Lua.Statement] → [ANode Lua.StatementF] -makeNodesStatement chunk = - evalState (forM chunk assignKeys) 0 & \keyedChunk → - evalState @[Scope] (assignScopes keyedChunk) [] +dceAnnotatedStatements ∷ [Lua.Statement] → [Lua.StatementF DceAnn] +dceAnnotatedStatements statements = + evalState (forM statements assignKeys) 0 & \keyedStatements → + evalState @[Scope] (assignScopes keyedStatements) [] -assignKeys ∷ Lua.Statement → State Key (ANode Lua.StatementF) +assignKeys ∷ Lua.Statement → State Key (Lua.StatementF DceAnn) assignKeys = annotateStatementInsideOutM Annotator - { unAnnotate = Lua.unAnn - , annotateStat = mkNodeWithKey - , annotateExp = mkNodeWithKey - , annotateRow = mkNodeWithKey - , annotateVar = mkNodeWithKey - , annotateParam = mkNodeWithKey + { withAnn = \a → state \key → (DceAnn a key mempty, key + 1) + , annotateStat = pure + , annotateExp = pure + , annotateVar = pure + , annotateParam = pure + , annotateRow = pure } - . Lua.ann - where - mkNodeWithKey ∷ f Node → State Key (ANode f) - mkNodeWithKey f = state \key → ((Node key mempty, f), key + 1) assignScopes - ∷ ∀ m. MonadScopes m ⇒ [ANode Lua.StatementF] → m [ANode Lua.StatementF] + ∷ ∀ m. MonadScopes m ⇒ [Lua.StatementF DceAnn] → m [Lua.StatementF DceAnn] assignScopes = traverse do - visitStatementM - makeVisitor + rewriteStatementM + makeRewrites { beforeStat = beforeStat + , beforeExpr = beforeExpr + , beforeVar = updateScopes + , beforeRow = updateScopes , afterStat = afterStat - , beforeExp = beforeExp - , beforeVar = mkNodeWithScopes - , beforeRow = mkNodeWithScopes } where - beforeStat ∷ ANode Lua.StatementF → m (ANode Lua.StatementF) - beforeStat node@(Node key _scopes, stat) = + beforeStat ∷ Lua.StatementF DceAnn → m (Lua.StatementF DceAnn) + beforeStat stat = case stat of - Lua.Local name _value → do + Lua.Local (DceAnn a key _scopes) name value → do scopes ← addName name key - pure (Node key (toList scopes), stat) - Lua.IfThenElse p t e → do + pure $ Lua.Local (DceAnn a key (toList scopes)) name value + Lua.IfThenElse (DceAnn a key _scopes) p t e → do t' ← addScope $> t e' ← addScope $> e scopes ← getScopes - pure (Node key (toList scopes), Lua.IfThenElse p t' e') - _ → pure node + pure $ Lua.IfThenElse (DceAnn a key (toList scopes)) p t' e' + _ → pure stat - afterStat ∷ Lua.StatementF Node → m (Lua.StatementF Node) - afterStat = \case - stat@Lua.Return {} → dropScope $> stat - other → pure other + afterStat ∷ Lua.StatementF DceAnn → m (Lua.StatementF DceAnn) + afterStat statement = + case statement of + Lua.Return {} → dropScope $> statement + _ → pure statement - beforeExp ∷ ANode Lua.ExpF → m (ANode Lua.ExpF) - beforeExp node@(Node key _scopes, expr) = + beforeExpr ∷ Lua.ExpF DceAnn → m (Lua.ExpF DceAnn) + beforeExpr expr = case expr of - Lua.Function argNodes _body → do + Lua.Function (DceAnn ann key _scopes) argNodes body → do _ ← addScope - for_ argNodes \(Node argKey _scopes, param) → + for_ argNodes \param → case param of - Lua.ParamUnused → pass - Lua.ParamNamed name → void $ addName name argKey - getScopes <&> \scopes → (Node key (toList scopes), expr) - _ → mkNodeWithScopes node - - mkNodeWithScopes ∷ (Node, t) → m (Node, t) - mkNodeWithScopes (Node key _scopes, t) = getScopes <&> ((,t) . Node key) - -unNodesStatement ∷ ANode Lua.StatementF → Lua.Statement -unNodesStatement = unAnnotateStatement Lua.unAnn + Lua.ParamUnused _ann → pass + Lua.ParamNamed _ann name → void $ addName name (keyOf param) + getScopes <&> \scopes → + Lua.Function (DceAnn ann key (toList scopes)) argNodes body + _ → pure expr + + updateScopes ∷ HasAnn f ⇒ f DceAnn → m (f DceAnn) + updateScopes f = do + scopes ← getScopes + pure $ f & annL %~ \(DceAnn a k _scopes) → DceAnn a k scopes class Monad m ⇒ MonadScopes m where addName ∷ Name → Key → m (NonEmpty Scope) diff --git a/lib/Language/PureScript/Backend/Lua/Fixture.hs b/lib/Language/PureScript/Backend/Lua/Fixture.hs index c341a20..0354626 100644 --- a/lib/Language/PureScript/Backend/Lua/Fixture.hs +++ b/lib/Language/PureScript/Backend/Lua/Fixture.hs @@ -27,7 +27,7 @@ runtimeLazyName = psluaName [name|runtime_lazy|] runtimeLazy ∷ Statement runtimeLazy = - ForeignSourceStat + foreignStatement [__i| local function #{Name.toText runtimeLazyName}(name) return function(init) @@ -56,7 +56,7 @@ objectUpdateName = psluaName [name|object_update|] objectUpdate ∷ Statement objectUpdate = - ForeignSourceStat + foreignStatement [__i| local function #{Name.toText objectUpdateName}(o, patches) local o_copy = {} diff --git a/lib/Language/PureScript/Backend/Lua/Name.hs b/lib/Language/PureScript/Backend/Lua/Name.hs index bf2e5cb..4c8e3a7 100644 --- a/lib/Language/PureScript/Backend/Lua/Name.hs +++ b/lib/Language/PureScript/Backend/Lua/Name.hs @@ -15,6 +15,7 @@ module Language.PureScript.Backend.Lua.Name ) where import Data.Char qualified as Char +import Data.Data (Data) import Data.Set qualified as Set import Data.Text qualified as Text import Language.Haskell.TH.Quote (QuasiQuoter (..)) @@ -24,6 +25,7 @@ import Text.Megaparsec.Char qualified as M import Prelude hiding (toText) newtype Name = Name {toText ∷ Text} + deriving stock (Data) deriving newtype (Eq, Ord, Show, Pretty) name ∷ QuasiQuoter diff --git a/lib/Language/PureScript/Backend/Lua/Optimizer.hs b/lib/Language/PureScript/Backend/Lua/Optimizer.hs index bb815e9..6952264 100644 --- a/lib/Language/PureScript/Backend/Lua/Optimizer.hs +++ b/lib/Language/PureScript/Backend/Lua/Optimizer.hs @@ -1,55 +1,306 @@ module Language.PureScript.Backend.Lua.Optimizer where +import Control.Lens ((^?)) +import Control.Lens.Plated (children) +import Control.Lens.Plated qualified as Plated import Control.Monad.Trans.Accum (Accum, add, execAccum) +import Data.DList (DList) +import Data.DList qualified as DL import Data.List qualified as List import Data.Map qualified as Map +import Data.Tree (Tree (..), foldTree) import Language.PureScript.Backend.Lua.Name qualified as Lua import Language.PureScript.Backend.Lua.Traversal - ( everywhereExp - , everywhereInChunkM + ( everywhereInChunkM , everywhereStat , everywhereStatM ) -import Language.PureScript.Backend.Lua.Types - ( Chunk - , Exp - , ExpF (..) - , Statement - , StatementF (Local, Return) - , TableRowF (..) - , VarF (..) - , functionDef - , return - , unAnn - , pattern Ann - ) import Language.PureScript.Backend.Lua.Types qualified as Lua import Prelude hiding (return) -optimizeChunk ∷ Chunk → Chunk -optimizeChunk = fmap optimizeStatement +optimizeChunk ∷ Lua.Chunk → Lua.Chunk +optimizeChunk = idempotently optimizeChunkOnce -substituteVarForValue ∷ Lua.Name → Exp → Chunk → Chunk -substituteVarForValue name inlinee = - runIdentity . everywhereInChunkM (pure . subst) pure +idempotently ∷ Eq a ⇒ (a → a) → a → a +idempotently = fix $ \i f a → + let a' = f a + in if a' == a then a else i f a' + +{- | Given a function @f@ and an initial value @t@, applies @f@ to @t@ once, +and in case of Nothing it terminates, otherwise repeatedly applies @f@ +to the result of the previous application until it no longer changes. +-} +everywhere ∷ (t → Maybe t) → t → Maybe t +everywhere f t = + case f t of + Nothing → Nothing + Just t' → everywhereUntilNothing f t' where - subst = \case - Lua.Var (Lua.unAnn → Lua.VarName varName) | varName == name → inlinee - expr → expr + everywhereUntilNothing ∷ (t → Maybe t) → t → Maybe t + everywhereUntilNothing g s = maybe (Just s) (everywhereUntilNothing g) (g s) -countRefs ∷ Statement → Map Lua.Name (Sum Natural) -countRefs = everywhereStatM pure countRefsInExpression >>> (`execAccum` mempty) +optimizeChunkOnce ∷ Lua.Chunk → Lua.Chunk +optimizeChunkOnce = go DL.empty . toList where - countRefsInExpression ∷ Exp → Accum (Map Lua.Name (Sum Natural)) Exp - countRefsInExpression = \case - expr@(Lua.Var (Lua.unAnn → Lua.VarName name)) → - add (Map.singleton name (Sum 1)) $> expr - expr → pure expr + go ∷ Lua.Chunk → [Lua.Statement] → Lua.Chunk + go optimizedStats remainingStats = + case remainingStats of + [] → optimizedStats + stat : stats → + let (optimizedStat, remainingStats') = optimizeStatement stat stats + in go (DL.snoc optimizedStats optimizedStat) remainingStats' + +optimizeStatement + ∷ Lua.Statement → [Lua.Statement] → (Lua.Statement, [Lua.Statement]) +optimizeStatement currentStat nextStats = + case currentStat of + Lua.Assign + ann + var + (Lua.Function _ args [Lua.Return _ (Lua.Function _ innerArgs innerBody)]) + | Just nextStats' ← everywhere (rewriteCurried var) nextStats → + ( go $ + Lua.Assign + ann + var + (Lua.functionDef (args ++ innerArgs) innerBody) + , go <$> nextStats' + ) + _stat → (go currentStat, go <$> nextStats) + where + go = everywhereStat identity optimizeExpression + +data AppliedHow = Unknown | NotApplied | AppliedOnce | AppliedAtLeastTwice + deriving stock (Eq, Show, Enum, Bounded) + +instance Semigroup AppliedHow where + Unknown <> b = b + a <> Unknown = a + a <> b = if fromEnum a < fromEnum b then a else b + +instance Monoid AppliedHow where + mempty = Unknown + +pattern NestedCall + ∷ Lua.VarF ann + -- ^ The var inside the inner function call + → ann + -- ^ The annotation of the outer function call + → [Lua.ExpF ann] + -- ^ The arguments of the outer function call + → [Lua.ExpF ann] + -- ^ The arguments of the inner function call + → Lua.ExpF ann + -- ^ The body of the inner function call + → Lua.TermF ann + -- ^ The outer function call +pattern NestedCall innerVar outerAnn outerArgs innerArgs innerCall ← + Lua.E + ( Lua.FunctionCall + outerAnn + innerCall@( Lua.FunctionCall + _innerAnn + (Lua.Var _varAnn innerVar) + innerArgs + ) + outerArgs + ) + +rewriteCurried ∷ Lua.Var → [Lua.Statement] → Maybe [Lua.Statement] +rewriteCurried var (map Lua.S → statTerms) = + case appliedHow var statTerms of + Unknown → Nothing + NotApplied → Nothing + AppliedOnce → Nothing + AppliedAtLeastTwice → + Just $ mapMaybe ((^? Lua._S) . rewriteCurriedTerm var 2) statTerms + +appliedHow ∷ Lua.Var → [Lua.Term] → AppliedHow +appliedHow var = foldMap appliedHowInTerm + where + appliedHowInTerm = + foldTree (\x xs → fold (x : xs)) . Plated.para \term subterms → + case term of + NestedCall var' _outerAnn _outerArgs _innerArgs _innerCall + | var == var' → Node AppliedAtLeastTwice (drop 1 subterms) + Lua.E (Lua.FunctionCall _ (Lua.Var _ var') _args) + | var == var' → Node AppliedOnce (drop 1 subterms) + Lua.V var' + | var == var' → Node NotApplied [] + _ → Node Unknown subterms + +rewriteCurriedTerm ∷ Lua.Var → Int → Lua.Term → Lua.Term +rewriteCurriedTerm var numApplications term0 = + case go term0 of Pass {resTerm} → resTerm + where + go ∷ Lua.Term → Res + go term = rewriteTerm (go <$> children term) + where + passTerm = flip Pass Nothing + + rewriteTerm ∷ [Res] → Res + rewriteTerm results = + case term of + Lua.E (Lua.Function ann params _body) → + let body' = [s | Pass (Lua.S s) _ ← results] + in passTerm (Lua.E (Lua.Function ann params body')) + Lua.E (Lua.FunctionCall ann appliedExpr _args) → + case results of + Pass (Lua.E (Lua.Var _ var')) Nothing : passes + | var == var' → + Pass + ( Lua.E + ( Lua.FunctionCall + ann + appliedExpr + [a | Pass (Lua.E a) _ ← passes] + ) + ) + (Just (1, numApplications)) + Pass (Lua.E subTerm) (Just (n, maxApplications)) : passes + | succ n == maxApplications → + Pass + ( collapseFunCalls + (succ n) + ( Lua.FunctionCall + ann + subTerm + [a | Pass (Lua.E a) _ ← passes] + ) + ) + Nothing + Pass _subTerm (Just (n, maxApplications)) : passes + | n < maxApplications → + Pass + ( Lua.E + ( Lua.FunctionCall + ann + appliedExpr + [a | Pass (Lua.E a) _ ← passes] + ) + ) + (Just (succ n, maxApplications)) + Pass (Lua.E fun) _ : passes → + passTerm . Lua.E $ + Lua.functionCall fun [a | Pass (Lua.E a) _ ← passes] + _ → + passTerm term + Lua.S (Lua.Assign ann name _expr) → + case results of + [Pass Lua.V {} _, Pass (Lua.E expr') _] → + passTerm (Lua.S (Lua.Assign ann name expr')) + _ → error "Impossible subexpressions: Assign" + Lua.S (Lua.Local ann name (Just _expr)) → + case results of + [Pass (Lua.E expr') _info] → + passTerm (Lua.S (Lua.Local ann name (Just expr'))) + _ → error "Impossible subexpression: Local" + Lua.S (Lua.IfThenElse ann _expr th el) → + case results of + [Pass (Lua.E expr') _info] → + passTerm (Lua.S (Lua.IfThenElse ann expr' th el)) + _ → error "Impossible subexpressions: IfThenElse" + Lua.S (Lua.Return ann _expr) → + case results of + [Pass (Lua.E expr') _info] → + passTerm (Lua.S (Lua.Return ann expr')) + _ → error "Impossible subexpressions: Return" + Lua.E (Lua.UnOp ann op _expr) → + case results of + [Pass (Lua.E expr') _info] → + passTerm (Lua.E (Lua.UnOp ann op expr')) + _ → error "Impossible subexpressions: UnOp" + Lua.E (Lua.BinOp ann op _lhs _rhs) → + case results of + [Pass (Lua.E lhs') _, Pass (Lua.E rhs') _] → + passTerm (Lua.E (Lua.BinOp ann op lhs' rhs')) + _ → error "Impossible subexpressions: BinOp" + Lua.E (Lua.TableCtor ann _rows) → + passTerm + (Lua.E (Lua.TableCtor ann [r | Pass (Lua.R r) _ ← results])) + Lua.V (Lua.VarIndex ann _lhs _rhs) → + case results of + [Pass (Lua.E lhs') _, Pass (Lua.E rhs') _] → + passTerm (Lua.V (Lua.VarIndex ann lhs' rhs')) + _ → error "Impossible subexpressions: VarIndex" + Lua.V (Lua.VarField ann _expr field) → + case results of + [Pass (Lua.E expr') _] → + passTerm (Lua.V (Lua.VarField ann expr' field)) + _ → error "Impossible subexpressions: VarField" + Lua.R (Lua.TableRowKV ann _k _v) → + case results of + [Pass (Lua.E k') _, Pass (Lua.E v') _] → + passTerm (Lua.R (Lua.TableRowKV ann k' v')) + _ → error "Impossible subexpressions: TableRowKV" + Lua.R (Lua.TableRowNV ann name _v) → + case results of + [Pass (Lua.E expr') _] → + passTerm (Lua.R (Lua.TableRowNV ann name expr')) + _ → error "Impossible subexpressions: TableRowNV" + _ → passTerm term + +data St = St + { appliedExpr ∷ Maybe Lua.Exp + , args ∷ DList Lua.Exp + , remainingApps ∷ Int + } + deriving stock (Show) + +collapseFunCalls ∷ Int → Lua.Exp → Lua.Term +collapseFunCalls n e + | n < 2 = Lua.E e + | otherwise = + go St {appliedExpr = Nothing, args = DL.empty, remainingApps = n} e + & \case + St {appliedExpr = Nothing} → error "collapseFunCalls: impossible" + St {appliedExpr = Just functionCall} → Lua.E functionCall + where + go ∷ St → Lua.Exp → St + go st = \case + Lua.FunctionCall ann expr args → + go st expr & \st' → + case st' of + St {appliedExpr, remainingApps, args = args'} + | remainingApps == 1 → + st' + { remainingApps = 0 + , appliedExpr = + Lua.FunctionCall ann + <$> appliedExpr + <*> pure (toList args' ++ normalizeArgs args) + , args = DL.empty + } + St {remainingApps, args = args'} + | remainingApps > 0 → + st' + { remainingApps = pred remainingApps + , args = args' <> normalizeArgs (DL.fromList args) + } + St {appliedExpr} → + st' + { appliedExpr = + Lua.FunctionCall ann + <$> appliedExpr + <*> pure args + } + expr → st {appliedExpr = Just expr} -optimizeStatement ∷ Statement → Statement -optimizeStatement = everywhereStat identity optimizeExpression + normalizeArgs ∷ (Foldable f, Applicative f) ⇒ f Lua.Exp → f Lua.Exp + normalizeArgs xs = if null xs then pure Lua.nil else xs -optimizeExpression ∷ Exp → Exp +data Res = Pass + { resTerm ∷ Lua.Term + , resInfo ∷ Maybe (Int, Int) + } + deriving stock (Show) + +{- +t1 ∷ ∀ {a}. Show a ⇒ [Char] → a → a +t1 x a = trace ("\n------------<" ++ x ++ ">----------\n" ++ toString (pShow a)) a +-} + +optimizeExpression ∷ Lua.Exp → Lua.Exp optimizeExpression = foldr (>>>) identity rewriteRulesInOrder rewriteRulesInOrder ∷ [RewriteRule] @@ -59,52 +310,64 @@ rewriteRulesInOrder = , reduceTableDefinitionAccessor ] -type RewriteRule = Exp → Exp - -rewriteExpWithRule ∷ RewriteRule → Exp → Exp -rewriteExpWithRule rule = everywhereExp rule identity +type RewriteRule = Lua.Exp → Lua.Exp -------------------------------------------------------------------------------- -- Rewrite rules for expressions ----------------------------------------------- pushDeclarationsDownTheInnerScope ∷ RewriteRule pushDeclarationsDownTheInnerScope = \case - Function outerArgs outerBody + Lua.Function _ outerArgs outerBody | Just lastStatement ← viaNonEmpty last outerBody - , Ann (Return (Ann (Function innerArgs innerBody))) ← lastStatement - , declarations ← unAnn <$> List.init outerBody + , Lua.Return _ (Lua.Function _ innerArgs innerBody) ← lastStatement + , declarations ← List.init outerBody , not (null declarations) , all isDeclaration declarations → - functionDef - (fmap unAnn outerArgs) - [ return $ - functionDef - (fmap unAnn innerArgs) - (declarations <> fmap unAnn innerBody) - ] + Lua.functionDef + outerArgs + [Lua.return $ Lua.functionDef innerArgs (declarations <> innerBody)] e → e where - isDeclaration ∷ Statement → Bool + isDeclaration ∷ Lua.Statement → Bool isDeclaration = \case - Local _ _ → True + Lua.Local {} → True + Lua.Assign {} → True _ → False removeScopeWhenInsideEmptyFunction ∷ RewriteRule removeScopeWhenInsideEmptyFunction = \case - Function + Lua.Function + _ outerArgs - [Ann (Return (Ann (FunctionCall (Ann (Function [] body)) [])))] → - Function outerArgs body + [Lua.Return _ (Lua.FunctionCall _ (Lua.Function _ [] body) [])] → + Lua.functionDef outerArgs body e → e -- | Rewrites '{ foo = 1, bar = 2 }.foo' to '1' reduceTableDefinitionAccessor ∷ RewriteRule reduceTableDefinitionAccessor = \case - Var (Ann (VarField (Ann (TableCtor rows)) accessedField)) → - fromMaybe Nil $ + Lua.Var _ (Lua.VarField _ (Lua.TableCtor _ rows) accessedField) → + fromMaybe Lua.nil $ listToMaybe [ fieldValue - | (_ann, TableRowNV tableField (Ann fieldValue)) ← rows + | Lua.TableRowNV _ tableField fieldValue ← rows , tableField == accessedField ] e → e + +substituteVarForValue ∷ Lua.Name → Lua.Exp → Lua.Chunk → Lua.Chunk +substituteVarForValue name inlinee = + runIdentity . everywhereInChunkM (pure . subst) pure + where + subst = \case + Lua.Var _ (Lua.VarName _ varName) | varName == name → inlinee + expr → expr + +countRefs ∷ Lua.Statement → Map Lua.Name (Sum Natural) +countRefs = everywhereStatM pure countRefsInExpression >>> (`execAccum` mempty) + where + countRefsInExpression ∷ Lua.Exp → Accum (Map Lua.Name (Sum Natural)) Lua.Exp + countRefsInExpression = \case + expr@(Lua.Var _ (Lua.VarName _ name)) → + add (Map.singleton name (Sum 1)) $> expr + expr → pure expr diff --git a/lib/Language/PureScript/Backend/Lua/Printer.hs b/lib/Language/PureScript/Backend/Lua/Printer.hs index 5e8b419..438e3d3 100644 --- a/lib/Language/PureScript/Backend/Lua/Printer.hs +++ b/lib/Language/PureScript/Backend/Lua/Printer.hs @@ -31,19 +31,19 @@ type ADoc = Doc () type PADoc = (Precedence, ADoc) printLuaChunk ∷ Lua.Chunk → ADoc -printLuaChunk = vsep . fmap printStatement +printLuaChunk = vsep . fmap printStatement . toList printStatement ∷ Lua.Statement → ADoc printStatement = \case - Lua.Assign (Ann variable) (Ann expr) → + Lua.Assign _ann variable expr → printAssign variable expr - Lua.Local name value → - printLocal name (printedExp . unAnn <$> value) - Lua.IfThenElse (Ann predicate) thenBlock elseBlock → - printIfThenElse predicate (unAnn <$> thenBlock) (unAnn <$> elseBlock) - Lua.Return (Ann expr) → + Lua.Local _ann name value → + printLocal name (printedExp <$> value) + Lua.IfThenElse _ann predicate thenBlock elseBlock → + printIfThenElse predicate thenBlock elseBlock + Lua.Return _ann expr → "return" <+> printedExp expr - Lua.ForeignSourceStat code → + Lua.ForeignSourceStat _ann code → pretty code printAssign ∷ Lua.Var → Lua.Exp → ADoc @@ -55,28 +55,34 @@ printedExp = snd . printExp printExp ∷ Lua.Exp → PADoc printExp = \case - Lua.Nil → (PrecAtom, "nil") - Lua.Boolean b → (PrecAtom, if b then "true" else "false") - Lua.Float f → (PrecAtom, pretty f) - Lua.Integer i → (PrecAtom, pretty i) - Lua.String t → (PrecAtom, dquotes (pretty t)) - Lua.Function args body → + Lua.Nil _ann → + (PrecAtom, "nil") + Lua.Boolean _ann b → + (PrecAtom, if b then "true" else "false") + Lua.Float _ann f → + (PrecAtom, pretty f) + Lua.Integer _ann i → + (PrecAtom, pretty i) + Lua.String _ann t → + (PrecAtom, dquotes (pretty t)) + Lua.Function _ann args body → let argNames = args >>= \case - Ann (ParamNamed n) → [n] - Ann ParamUnused → [] - in (PrecFunction, printFunction argNames (unAnn <$> body)) - Lua.TableCtor rows → (PrecTable, printTableCtor (unAnn <$> rows)) - Lua.UnOp op (Ann a) → printUnaryOp op (printExp a) - Lua.BinOp op (Ann l) (Ann r) → printBinaryOp op (printExp l) (printExp r) - Lua.Var (Ann v) → (PrecAtom, printVar v) - Lua.FunctionCall (Ann prefix) args → - ( PrecPrefix - , printFunctionCall - (printExp prefix) - (printExp . unAnn <$> args) - ) - Lua.ForeignSourceExp code → (PrecFunction, pretty code) + Lua.ParamNamed _ann n → [n] + Lua.ParamUnused _ann → [] + in (PrecFunction, printFunction argNames body) + Lua.TableCtor _ann rows → + (PrecTable, printTableCtor rows) + Lua.UnOp _ann op a → + printUnaryOp op (printExp a) + Lua.BinOp _ann op l r → + printBinaryOp op (printExp l) (printExp r) + Lua.Var _ann v → + (PrecAtom, printVar v) + Lua.FunctionCall _ann prefix args → + (PrecPrefix, printFunctionCall (printExp prefix) (printExp <$> args)) + Lua.ForeignSourceExp _ann code → + (PrecFunction, pretty code) printUnaryOp ∷ Lua.UnaryOp → PADoc → PADoc printUnaryOp op (_, a) = (prec op, pretty (sym op) <> parens a) @@ -100,16 +106,16 @@ printTableCtor tableRows = sep [lbrace, flex rows, rbrace] printRow ∷ Lua.TableRow → ADoc printRow = \case - Lua.TableRowKV (Ann kexp) (Ann vexp) → + Lua.TableRowKV _ann kexp vexp → brackets (printedExp kexp) <+> "=" <+> printedExp vexp - Lua.TableRowNV name (Ann vexp) → + Lua.TableRowNV _ann name vexp → printName name <+> "=" <+> printedExp vexp printVar ∷ Lua.Var → ADoc printVar = \case - Lua.VarName name → printName name - Lua.VarIndex (Ann e) (Ann i) → printedExp e <> brackets (printedExp i) - Lua.VarField (Ann e) n → wrapPrec PrecAtom (printExp e) <> "." <> printName n + Lua.VarName _ann name → printName name + Lua.VarIndex _ann e i → printedExp e <> brackets (printedExp i) + Lua.VarField _ann e n → wrapPrec PrecAtom (printExp e) <> "." <> printName n printFunctionCall ∷ PADoc → [PADoc] → ADoc printFunctionCall prefix args = diff --git a/lib/Language/PureScript/Backend/Lua/Traversal.hs b/lib/Language/PureScript/Backend/Lua/Traversal.hs index ff10980..5ef1638 100644 --- a/lib/Language/PureScript/Backend/Lua/Traversal.hs +++ b/lib/Language/PureScript/Backend/Lua/Traversal.hs @@ -14,10 +14,10 @@ everywhereStat everywhereStat f g = runIdentity . everywhereStatM (pure . f) (pure . g) everywhereInChunkM - ∷ Monad m + ∷ (Monad m, Traversable t) ⇒ (Exp → m Exp) → (Statement → m Statement) - → (Chunk → m Chunk) + → (t Statement → m (t Statement)) everywhereInChunkM f g = traverse (everywhereStatM g f) everywhereExpM @@ -29,23 +29,23 @@ everywhereExpM everywhereExpM f g = goe where goe = \case - Var (Ann v) → case v of - VarIndex (Ann e1) (Ann e2) → f =<< varIndex <$> goe e1 <*> goe e2 - VarField (Ann e) n → f . (`varField` n) =<< goe e - VarName n → f (varName n) - Function names statements → - f . functionDef (snd <$> names) - =<< forM statements (everywhereStatM g f . unAnn) - TableCtor (fmap unAnn → rows) → do + Var _ann v → case v of + VarIndex _ann e1 e2 → f . var =<< varIndex <$> goe e1 <*> goe e2 + VarField _ann e n → f . var . (`varField` n) =<< goe e + VarName _ann n → f (var (varName n)) + Function _ann names statements → + f . functionDef names + =<< forM statements (everywhereStatM g f) + TableCtor _ann rows → do tableRows ← forM rows \case - TableRowKV (Ann k) (Ann v) → tableRowKV <$> goe k <*> goe v - TableRowNV n (Ann e) → tableRowNV n <$> goe e + TableRowKV _ann k v → tableRowKV <$> goe k <*> goe v + TableRowNV _ann n e → tableRowNV n <$> goe e f $ table tableRows - UnOp op (Ann e) → + UnOp _ann op e → f . unOp op =<< goe e - BinOp op (Ann e1) (Ann e2) → + BinOp _ann op e1 e2 → f =<< binOp op <$> goe e1 <*> goe e2 - FunctionCall (Ann fn) (fmap unAnn → args) → + FunctionCall _ann fn args → f =<< functionCall <$> goe fn <*> forM args goe other → f other @@ -59,210 +59,255 @@ everywhereStatM f g = go where goe = everywhereExpM g f go = \case - Assign (Ann variable) (Ann value) → f . assign variable =<< goe value - Local name val → f . local name =<< forM val (goe . unAnn) - IfThenElse (Ann p) tb eb → do + Assign ann variable value → f . Assign ann variable =<< goe value + Local ann name val → f . Local ann name =<< forM val goe + IfThenElse ann p tb eb → do predicate ← goe p - thenBranch ← forM tb (go . unAnn) - elseBranch ← forM eb (go . unAnn) - f $ ifThenElse predicate thenBranch elseBranch - Return (Ann e) → f . Return . ann =<< goe e - ForeignSourceStat src → f $ ForeignSourceStat src + thenBranch ← forM tb go + elseBranch ← forM eb go + f $ IfThenElse ann predicate thenBranch elseBranch + Return ann e → f . Return ann =<< goe e + ForeignSourceStat ann src → f $ ForeignSourceStat ann src -------------------------------------------------------------------------------- -- Annotating ------------------------------------------------------------------ data Annotator m f f' = Annotator - { unAnnotate ∷ ∀ g. Annotated f g → g f - -- ^ How to remove an annotation - , annotateStat ∷ StatementF f' → m (Annotated f' StatementF) + { withAnn ∷ f → m f' + -- ^ How to update the annotation + , annotateStat ∷ StatementF f' → m (StatementF f') -- ^ How to annotate a statement - , annotateExp ∷ ExpF f' → m (Annotated f' ExpF) + , annotateExp ∷ ExpF f' → m (ExpF f') -- ^ How to annotate an expression - , annotateParam ∷ ParamF f' → m (Annotated f' ParamF) + , annotateParam ∷ ParamF f' → m (ParamF f') -- ^ How to annotate a function parameter - , annotateVar ∷ VarF f' → m (Annotated f' VarF) + , annotateVar ∷ VarF f' → m (VarF f') -- ^ How to annotate a variable - , annotateRow ∷ TableRowF f' → m (Annotated f' TableRowF) + , annotateRow ∷ TableRowF f' → m (TableRowF f') -- ^ How to annotate a table row } -unAnnotateStatement - ∷ (∀ g. Annotated f g → g f) → Annotated f StatementF → Statement -unAnnotateStatement unAnnotate = - unAnn - . runIdentity - . annotateStatementInsideOutM - Annotator - { unAnnotate - , annotateStat = pure . ann - , annotateExp = pure . ann - , annotateParam = pure . ann - , annotateVar = pure . ann - , annotateRow = pure . ann - } - -------------------------------------------------------------------------------- -- Inside-out ------------------------------------------------------------------ annotateStatementInsideOutM - ∷ ∀ m f f' - . Monad m - ⇒ Annotator m f f' - → (Annotated f StatementF → m (Annotated f' StatementF)) -annotateStatementInsideOutM annotator@Annotator {..} stat = - case unAnnotate stat of - Assign variable value → do - indexedVars ← goV variable - indexedVals ← goE value - annotateStat $ Assign indexedVars indexedVals - Local names vals → annotateStat . Local names =<< forM vals goE - IfThenElse p tb eb → do - iPred ← goE p - iThen ← traverse goS tb - iElse ← traverse goS eb - annotateStat $ IfThenElse iPred iThen iElse - Return e → annotateStat . Return =<< goE e - ForeignSourceStat src → annotateStat $ ForeignSourceStat src + ∷ ∀ m f f'. Monad m ⇒ Annotator m f f' → StatementF f → m (StatementF f') +annotateStatementInsideOutM annotator@Annotator {..} = \case + Assign ann variable value → do + visitedVar ← goV variable + visitedVal ← goE value + ann' ← withAnn ann + annotateStat $ Assign ann' visitedVar visitedVal + Local ann names vals → do + ann' ← withAnn ann + annotateStat . Local ann' names =<< forM vals goE + IfThenElse ann p tb eb → do + ann' ← withAnn ann + iPred ← goE p + iThen ← traverse goS tb + iElse ← traverse goS eb + annotateStat $ IfThenElse ann' iPred iThen iElse + Return ann e → do + ann' ← withAnn ann + e' ← goE e + annotateStat $ Return ann' e' + ForeignSourceStat ann src → do + ann' ← withAnn ann + annotateStat $ ForeignSourceStat ann' src where goS = annotateStatementInsideOutM annotator goE = annotateExpInsideOutM annotator goV = annotateVarInsideOutM annotator annotateExpInsideOutM - ∷ ∀ m f f' - . Monad m - ⇒ Annotator m f f' - → (Annotated f ExpF → m (Annotated f' ExpF)) -annotateExpInsideOutM annotator@Annotator {..} expf = - case unAnnotate expf of - Var v → annotateExp . Var =<< goV v - Function params stats → do - paramNames ← forM params \case - (_, ParamNamed n) → annotateParam (ParamNamed n) - (_, ParamUnused) → annotateParam ParamUnused - aStats ← forM stats goS - annotateExp $ Function paramNames aStats - TableCtor rows → - annotateExp . TableCtor =<< forM rows \row → - case unAnnotate row of - TableRowKV k v → annotateRow =<< TableRowKV <$> goE k <*> goE v - TableRowNV n e → annotateRow . TableRowNV n =<< goE e - UnOp op e → annotateExp . UnOp op =<< goE e - BinOp op e1 e2 → annotateExp =<< BinOp op <$> goE e1 <*> goE e2 - FunctionCall fn args → - annotateExp =<< FunctionCall <$> goE fn <*> forM args goE - Nil → annotateExp Nil - Boolean b → annotateExp $ Boolean b - Integer i → annotateExp $ Integer i - Float f → annotateExp $ Float f - String s → annotateExp $ String s - ForeignSourceExp src → annotateExp $ ForeignSourceExp src + ∷ ∀ m f f'. Monad m ⇒ Annotator m f f' → (ExpF f → m (ExpF f')) +annotateExpInsideOutM annotator@Annotator {..} = \case + Var ann v → do + ann' ← withAnn ann + v' ← goV v + annotateExp $ Var ann' v' + Function ann params stats → do + paramNames ← forM params \case + ParamNamed pann n → do + pann' ← withAnn pann + annotateParam (ParamNamed pann' n) + ParamUnused pann → do + pann' ← withAnn pann + annotateParam (ParamUnused pann') + ann' ← withAnn ann + stats' ← forM stats goS + annotateExp $ Function ann' paramNames stats' + TableCtor ann rows → do + ann' ← withAnn ann + rows' ← forM rows \case + TableRowKV tann k v → do + tann' ← withAnn tann + k' ← goE k + v' ← goE v + annotateRow $ TableRowKV tann' k' v' + TableRowNV tann n e → do + tann' ← withAnn tann + e' ← goE e + annotateRow $ TableRowNV tann' n e' + annotateExp $ TableCtor ann' rows' + UnOp ann op e → do + ann' ← withAnn ann + e' ← goE e + annotateExp $ UnOp ann' op e' + BinOp ann op e1 e2 → do + ann' ← withAnn ann + e1' ← goE e1 + e2' ← goE e2 + annotateExp $ BinOp ann' op e1' e2' + FunctionCall ann fn args → do + ann' ← withAnn ann + fn' ← goE fn + args' ← forM args goE + annotateExp $ FunctionCall ann' fn' args' + Nil ann → do + ann' ← withAnn ann + annotateExp (Nil ann') + Boolean ann b → do + ann' ← withAnn ann + annotateExp $ Boolean ann' b + Integer ann i → do + ann' ← withAnn ann + annotateExp $ Integer ann' i + Float ann f → do + ann' ← withAnn ann + annotateExp $ Float ann' f + String ann s → do + ann' ← withAnn ann + annotateExp $ String ann' s + ForeignSourceExp ann src → do + ann' ← withAnn ann + annotateExp $ ForeignSourceExp ann' src where goS = annotateStatementInsideOutM annotator goE = annotateExpInsideOutM annotator goV = annotateVarInsideOutM annotator annotateVarInsideOutM - ∷ ∀ m f f' - . Monad m - ⇒ Annotator m f f' - → (Annotated f VarF → m (Annotated f' VarF)) -annotateVarInsideOutM annotator@Annotator {..} = - unAnnotate >>> \case - VarName qualifiedName → annotateVar $ VarName qualifiedName - VarIndex e1 e2 → annotateVar =<< VarIndex <$> goE e1 <*> goE e2 - VarField e name → annotateVar . (`VarField` name) =<< goE e + ∷ ∀ m f f'. Monad m ⇒ Annotator m f f' → (VarF f → m (VarF f')) +annotateVarInsideOutM annotator@Annotator {..} = \case + VarName ann qualifiedName → do + ann' ← withAnn ann + annotateVar $ VarName ann' qualifiedName + VarIndex ann e1 e2 → do + ann' ← withAnn ann + e1' ← goE e1 + e2' ← goE e2 + annotateVar $ VarIndex ann' e1' e2' + VarField ann e name → do + ann' ← withAnn ann + e' ← goE e + annotateVar $ VarField ann' e' name where goE = annotateExpInsideOutM annotator -------------------------------------------------------------------------------- --- Outside-in ------------------------------------------------------------------ +-- Visiting (for effect) outside-in -------------------------------------------- + +visitTermM + ∷ ∀ m ann + . Monad m + ⇒ TermF ann + -- ^ The term to visit + → (TermF ann → m [TermF ann]) + -- ^ How to get the subterms of a term + → m () +visitTermM term subterms = subterms term >>= traverse_ (`visitTermM` subterms) + +-------------------------------------------------------------------------------- +-- Rewriting ------------------------------------------------------------------- -data Visitor m a = Visitor - { aroundChunk ∷ [Annotated a StatementF] → m [Annotated a StatementF] - , beforeStat ∷ Annotated a StatementF → m (Annotated a StatementF) +data Rewrites m a = Rewrites + { beforeStat ∷ StatementF a → m (StatementF a) + , beforeExpr ∷ ExpF a → m (ExpF a) + , beforeVar ∷ VarF a → m (VarF a) + , beforeRow ∷ TableRowF a → m (TableRowF a) , afterStat ∷ StatementF a → m (StatementF a) - , beforeExp ∷ Annotated a ExpF → m (Annotated a ExpF) , afterExp ∷ ExpF a → m (ExpF a) - , beforeVar ∷ Annotated a VarF → m (Annotated a VarF) , afterVar ∷ VarF a → m (VarF a) - , beforeRow ∷ Annotated a TableRowF → m (Annotated a TableRowF) , afterRow ∷ TableRowF a → m (TableRowF a) } -makeVisitor ∷ Applicative m ⇒ Visitor m a -makeVisitor = - Visitor - { aroundChunk = pure - , beforeStat = pure +makeRewrites ∷ ∀ m a. Monad m ⇒ Rewrites m a +makeRewrites = + Rewrites + { beforeStat = pure + , beforeExpr = pure + , beforeVar = pure + , beforeRow = pure , afterStat = pure - , beforeExp = pure , afterExp = pure - , beforeVar = pure , afterVar = pure - , beforeRow = pure , afterRow = pure } -visitStatementM - ∷ Monad m - ⇒ Visitor m a - → (Annotated a StatementF → m (Annotated a StatementF)) -visitStatementM visitor@Visitor {..} stat = do - let goS = visitStatementM visitor - goE = visitExpM visitor - goV = visitVarM visitor - beforeStat stat >>= traverse \case - Assign variable value → do - indexedVars ← goV variable - indexedVals ← goE value - afterStat $ Assign indexedVars indexedVals - Local names vals → - afterStat . Local names =<< forM vals goE - IfThenElse p tb eb → do - iPred ← goE p - iThen ← traverse goS tb - iElse ← traverse goS eb - afterStat $ IfThenElse iPred iThen iElse - Return e → afterStat . Return =<< goE e - other → afterStat other +rewriteChunkM ∷ Monad m ⇒ Rewrites m a → [StatementF a] → m [StatementF a] +rewriteChunkM rewrites = traverse (rewriteStatementM rewrites) -visitExpM - ∷ ∀ m a - . Monad m - ⇒ Visitor m a - → (Annotated a ExpF → m (Annotated a ExpF)) -visitExpM visitor@Visitor {..} expf = do - let goS = visitStatementM visitor - goE = visitExpM visitor - goV = visitVarM visitor - beforeExp expf >>= traverse \case - Var v → - afterExp . Var =<< goV v - Function names stats → - afterExp . Function names =<< forM stats goS - TableCtor rows → - TableCtor <$> forM rows do - beforeRow >=> traverse \case - TableRowKV k v → afterRow =<< TableRowKV <$> goE k <*> goE v - TableRowNV n e → afterRow . TableRowNV n =<< goE e - UnOp op e → - afterExp . UnOp op =<< goE e - BinOp op e1 e2 → - afterExp =<< BinOp op <$> goE e1 <*> goE e2 - FunctionCall fn args → - afterExp =<< FunctionCall <$> goE fn <*> forM args goE - other → afterExp other +rewriteStatementM ∷ Monad m ⇒ Rewrites m a → (StatementF a → m (StatementF a)) +rewriteStatementM rewrites@Rewrites {..} = + beforeStat >=> \case + Assign ann variable value → do + rewriteedVar ← rewriteVarM rewrites variable + rewriteedVal ← rewriteExpM rewrites value + afterStat $ Assign ann rewriteedVar rewriteedVal + Local ann names vals → + afterStat . Local ann names =<< forM vals (rewriteExpM rewrites) + IfThenElse ann p tb eb → do + iPred ← rewriteExpM rewrites p + iThen ← traverse (rewriteStatementM rewrites) tb + iElse ← traverse (rewriteStatementM rewrites) eb + afterStat $ IfThenElse ann iPred iThen iElse + Return ann e → + afterStat . Return ann =<< rewriteExpM rewrites e + ForeignSourceStat ann src → + afterStat $ ForeignSourceStat ann src -visitVarM - ∷ ∀ m a - . Monad m - ⇒ Visitor m a - → (Annotated a VarF → m (Annotated a VarF)) -visitVarM visitor@Visitor {..} variable = do - let goE = visitExpM visitor - beforeVar variable >>= traverse \case - VarName qualifiedName → afterVar $ VarName qualifiedName - VarIndex e1 e2 → afterVar =<< VarIndex <$> goE e1 <*> goE e2 - VarField e name → afterVar . (`VarField` name) =<< goE e +rewriteExpM ∷ ∀ m a. Monad m ⇒ Rewrites m a → (ExpF a → m (ExpF a)) +rewriteExpM rewrites@Rewrites {..} expf = do + beforeExpr expf >>= \case + ex → case ex of + Var ann v → + afterExp . Var ann =<< rewriteVarM rewrites v + Function ann names stats → + afterExp . Function ann names =<< forM stats (rewriteStatementM rewrites) + TableCtor ann rows → + TableCtor ann <$> forM rows do + beforeRow >=> \case + TableRowKV ann' k v → + afterRow + =<< TableRowKV ann' + <$> rewriteExpM rewrites k + <*> rewriteExpM rewrites v + TableRowNV ann' n e → + afterRow . TableRowNV ann' n =<< rewriteExpM rewrites e + UnOp ann op e → + afterExp . UnOp ann op =<< rewriteExpM rewrites e + BinOp ann op e1 e2 → + afterExp + =<< BinOp ann op + <$> rewriteExpM rewrites e1 + <*> rewriteExpM rewrites e2 + FunctionCall ann fn args → + afterExp + =<< FunctionCall ann + <$> rewriteExpM rewrites fn + <*> forM args (rewriteExpM rewrites) + other → afterExp other + +rewriteVarM ∷ ∀ m a. Monad m ⇒ Rewrites m a → (VarF a → m (VarF a)) +rewriteVarM rewrites@Rewrites {..} = + beforeVar >=> \case + VarName ann qualifiedName → + afterVar $ VarName ann qualifiedName + VarIndex ann e1 e2 → + afterVar + =<< VarIndex ann + <$> rewriteExpM rewrites e1 + <*> rewriteExpM rewrites e2 + VarField ann e name → + afterVar . (\x → VarField ann x name) =<< rewriteExpM rewrites e diff --git a/lib/Language/PureScript/Backend/Lua/Types.hs b/lib/Language/PureScript/Backend/Lua/Types.hs index b3c6488..3ea25b2 100644 --- a/lib/Language/PureScript/Backend/Lua/Types.hs +++ b/lib/Language/PureScript/Backend/Lua/Types.hs @@ -1,7 +1,11 @@ {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} module Language.PureScript.Backend.Lua.Types where +import Control.Lens (Lens', Plated (plate), lens) +import Control.Lens.TH (makePrisms) +import Data.DList (DList) import Language.PureScript.Backend.Lua.Name (Name) import Language.PureScript.Backend.Lua.Name qualified as Lua import Prettyprinter (Pretty) @@ -16,44 +20,38 @@ import Prelude hiding , return ) -type Chunk = [Statement] +type Chunk = DList Statement newtype ChunkName = ChunkName Text deriving stock (Show) deriving newtype (Pretty) -type Annotated (a ∷ Type) (f ∷ Type → Type) = (a, f a) +data ParamF ann + = ParamNamed ann Name + | ParamUnused ann -pattern Ann ∷ b → (a, b) -pattern Ann fa ← (_ann, fa) -{-# COMPLETE Ann #-} - -data ParamF a - = ParamNamed Name - | ParamUnused - -type Param = ParamF () +type Param = ParamF Ann deriving stock instance Eq a ⇒ Eq (ParamF a) deriving stock instance Ord a ⇒ Ord (ParamF a) deriving stock instance Show a ⇒ Show (ParamF a) -data VarF a - = VarName Name - | VarIndex (Annotated a ExpF) (Annotated a ExpF) - | VarField (Annotated a ExpF) Name +data VarF ann + = VarName ann Name + | VarIndex ann (ExpF ann) (ExpF ann) + | VarField ann (ExpF ann) Name -type Var = VarF () +type Var = VarF Ann deriving stock instance Eq a ⇒ Eq (VarF a) deriving stock instance Ord a ⇒ Ord (VarF a) deriving stock instance Show a ⇒ Show (VarF a) data TableRowF ann - = TableRowKV (Annotated ann ExpF) (Annotated ann ExpF) - | TableRowNV Name (Annotated ann ExpF) + = TableRowKV ann (ExpF ann) (ExpF ann) + | TableRowNV ann Name (ExpF ann) -type TableRow = TableRowF () +type TableRow = TableRowF Ann deriving stock instance Eq a ⇒ Eq (TableRowF a) deriving stock instance Ord a ⇒ Ord (TableRowF a) @@ -94,6 +92,87 @@ instance HasSymbol UnaryOp where LogicalNot → "not" BitwiseNot → "~" +newtype Ann = Ann () + deriving stock (Eq, Ord, Show) + +newAnn ∷ Ann +newAnn = Ann () + +annL ∷ ∀ f a. HasAnn f ⇒ Lens' (f a) a +annL = lens annOf setAnn + +class HasAnn f where + annOf ∷ f a → a + setAnn ∷ f a → a → f a + +instance HasAnn VarF where + annOf = \case + VarName a _ → a + VarIndex a _ _ → a + VarField a _ _ → a + setAnn f a = case f of + VarName _ n → VarName a n + VarIndex _ e1 e2 → VarIndex a e1 e2 + VarField _ e n → VarField a e n + +instance HasAnn ParamF where + annOf = \case + ParamNamed a _ → a + ParamUnused a → a + setAnn f a = case f of + ParamNamed _ n → ParamNamed a n + ParamUnused _ → ParamUnused a + +instance HasAnn TableRowF where + annOf = \case + TableRowKV a _ _ → a + TableRowNV a _ _ → a + setAnn f a = case f of + TableRowKV _ k v → TableRowKV a k v + TableRowNV _ n e → TableRowNV a n e + +instance HasAnn ExpF where + annOf = \case + Nil a → a + Boolean a _ → a + Integer a _ → a + Float a _ → a + String a _ → a + Function a _ _ → a + TableCtor a _ → a + UnOp a _ _ → a + BinOp a _ _ _ → a + Var a _ → a + FunctionCall a _ _ → a + ForeignSourceExp a _ → a + setAnn expr a = case expr of + Nil _ → Nil a + Boolean _ b → Boolean a b + Integer _ i → Integer a i + Float _ f → Float a f + String _ s → String a s + Function _ p s → Function a p s + TableCtor _ r → TableCtor a r + UnOp _ o e → UnOp a o e + BinOp _ o e1 e2 → BinOp a o e1 e2 + Var _ v → Var a v + FunctionCall _ f args → FunctionCall a f args + ForeignSourceExp _ src → ForeignSourceExp a src + +instance HasAnn StatementF where + annOf = \case + Assign a _ _ → a + Local a _ _ → a + IfThenElse a _ _ _ → a + Return a _ → a + ForeignSourceStat a _ → a + setAnn f a = case f of + Assign _ v e → Assign a v e + Local _ n e → Local a n e + IfThenElse _ p t e → IfThenElse a p t e + Return _ e → Return a e + ForeignSourceStat _ src → ForeignSourceStat a src + data BinaryOp = Or | And @@ -182,201 +261,364 @@ instance HasSymbol BinaryOp where Exp → "^" data ExpF ann - = Nil - | Boolean Bool - | Integer Integer - | Float Double - | String Text - | Function [Annotated ann ParamF] [Annotated ann StatementF] - | TableCtor [Annotated ann TableRowF] - | UnOp UnaryOp (Annotated ann ExpF) - | BinOp BinaryOp (Annotated ann ExpF) (Annotated ann ExpF) - | Var (Annotated ann VarF) - | FunctionCall (Annotated ann ExpF) [Annotated ann ExpF] - | ForeignSourceExp Text - -type Exp = ExpF () + = Nil ann + | Boolean ann Bool + | Integer ann Integer + | Float ann Double + | String ann Text + | Function ann [ParamF ann] [StatementF ann] + | TableCtor ann [TableRowF ann] + | UnOp ann UnaryOp (ExpF ann) + | BinOp ann BinaryOp (ExpF ann) (ExpF ann) + | Var ann (VarF ann) + | FunctionCall ann (ExpF ann) [ExpF ann] + | ForeignSourceExp ann Text + +type Exp = ExpF Ann deriving stock instance Eq a ⇒ Eq (ExpF a) deriving stock instance Ord a ⇒ Ord (ExpF a) deriving stock instance Show a ⇒ Show (ExpF a) data StatementF ann - = Assign (Annotated ann VarF) (Annotated ann ExpF) - | Local Name (Maybe (Annotated ann ExpF)) + = Assign ann (VarF ann) (ExpF ann) + | Local ann Name (Maybe (ExpF ann)) | IfThenElse - (Annotated ann ExpF) + ann + (ExpF ann) -- ^ predicate - [Annotated ann StatementF] + [StatementF ann] -- ^ then block - [Annotated ann StatementF] + [StatementF ann] -- ^ else block - | Return (Annotated ann ExpF) - | ForeignSourceStat Text + | Return ann (ExpF ann) + | ForeignSourceStat ann Text -type Statement = StatementF () +type Statement = StatementF Ann deriving stock instance Eq a ⇒ Eq (StatementF a) deriving stock instance Ord a ⇒ Ord (StatementF a) deriving stock instance Show a ⇒ Show (StatementF a) +-------------------------------------------------------------------------------- +-- Terms ----------------------------------------------------------------------- + +data TermF a + = E (ExpF a) + | S (StatementF a) + | V (VarF a) + | R (TableRowF a) + deriving stock (Eq, Ord, Show) + +$(makePrisms ''TermF) + +type Term = TermF Ann + +instance Plated (TermF a) where + plate f t = case t of + E e → + case e of + Nil {} → + pure t + Boolean {} → + pure t + Integer {} → + pure t + Float {} → + pure t + String {} → + pure t + ForeignSourceExp {} → + pure t + Var ann v → + E . Var ann <$> mapV f v + Function ann params body → + E . Function ann params <$> traverse (mapS f) body + TableCtor ann rows → + E . TableCtor ann <$> traverse (mapR f) rows + UnOp ann op e1 → + E . UnOp ann op <$> mapE f e1 + BinOp ann op e1 e2 → + E <$> liftA2 (BinOp ann op) (mapE f e1) (mapE f e2) + FunctionCall ann expr args → + E <$> liftA2 (FunctionCall ann) (mapE f expr) (traverse (mapE f) args) + S s → + case s of + Assign ann v e → + S <$> liftA2 (Assign ann) (mapV f v) (mapE f e) + Local ann name expr → + S . Local ann name <$> traverse (mapE f) expr + Return ann e → + S . Return ann <$> mapE f e + ForeignSourceStat {} → + pure t + IfThenElse ann p tb eb → + S + <$> liftA3 + (IfThenElse ann) + (mapE f p) + (traverse (mapS f) tb) + (traverse (mapS f) eb) + V v → + case v of + VarName {} → + pure t + VarIndex ann e1 e2 → + V <$> liftA2 (VarIndex ann) (mapE f e1) (mapE f e2) + VarField ann e name → + V <$> liftA2 (VarField ann) (mapE f e) (pure name) + R r → + case r of + TableRowKV ann k v → + R <$> liftA2 (TableRowKV ann) (mapE f k) (mapE f v) + TableRowNV ann name e → + R <$> liftA2 (TableRowNV ann) (pure name) (mapE f e) + +mapS ∷ Functor f ⇒ (TermF a → f (TermF a)) → StatementF a → f (StatementF a) +mapS tf s = tf (S s) <&> \case S s' → s'; _ → s + +mapE ∷ Functor f ⇒ (TermF a → f (TermF a)) → ExpF a → f (ExpF a) +mapE tf e = tf (E e) <&> \case E e' → e'; _ → e + +mapV ∷ Functor f ⇒ (TermF a → f (TermF a)) → VarF a → f (VarF a) +mapV tf v = tf (V v) <&> \case V v' → v'; _ → v + +mapR ∷ Functor f ⇒ (TermF a → f (TermF a)) → TableRowF a → f (TableRowF a) +mapR tf r = tf (R r) <&> \case R r' → r'; _ → r + +termSubterms ∷ TermF a → [TermF a] +termSubterms = \case + E e → exprSubterms e + S s → statementSubterms s + V v → varSubterms v + R r → rowSubterms r + +exprSubterms ∷ ExpF a → [TermF a] +exprSubterms = \case + Nil _ → [] + Boolean _ _ → [] + Integer _ _ → [] + Float _ _ → [] + String _ _ → [] + ForeignSourceExp _ _ → [] + Var _ v → [V v] + Function _ _params body → map S body + TableCtor _ rs → map R rs + UnOp _ _ e → [E e] + BinOp _ _ e1 e2 → [E e1, E e2] + FunctionCall _ f args → E f : map E args + +statementSubterms ∷ StatementF a → [TermF a] +statementSubterms = \case + Assign _ v e → [V v, E e] + Local _ _name es → map E (maybeToList es) + Return _ e → [E e] + ForeignSourceStat _ _ → [] + IfThenElse _ p tb eb → + E p : concatMap statementSubterms tb ++ concatMap statementSubterms eb + +varSubterms ∷ VarF a → [TermF a] +varSubterms = \case + VarName _ _ → [] + VarIndex _ e1 e2 → [E e1, E e2] + VarField _ e _ → [E e] + +rowSubterms ∷ TableRowF a → [TermF a] +rowSubterms = \case + TableRowKV _ k v → [E k, E v] + TableRowNV _ _ e → [E e] + -------------------------------------------------------------------------------- -- Smarter constructors -------------------------------------------------------- -ann ∷ f () → Annotated () f -ann f = ((), f) +var ∷ Var → Exp +var = Var newAnn -unAnn ∷ Annotated a f → f a -unAnn = snd +varNameExp ∷ Name → Exp +varNameExp = var . varName -var ∷ Var → Exp -var = Var . ann +varFieldExp ∷ Exp → Name → Exp +varFieldExp n = var . varField n + +varIndexExp ∷ Exp → Exp → Exp +varIndexExp n = var . varIndex n assign ∷ Var → Exp → Statement -assign v e = Assign (ann v) (ann e) +assign = Assign newAnn -assignVar :: Name -> Exp -> Statement -assignVar name = assign (VarName name) +assignVar ∷ Name → Exp → Statement +assignVar name = assign (VarName newAnn name) local ∷ Name → Maybe Exp → Statement -local name expr = Local name (ann <$> expr) +local = Local newAnn local1 ∷ Name → Exp → Statement -local1 name expr = Local name (Just (ann expr)) +local1 name expr = Local newAnn name (Just expr) local0 ∷ Name → Statement -local0 name = Local name Nothing +local0 name = Local newAnn name Nothing -ifThenElse ∷ Exp → Chunk → Chunk → Statement -ifThenElse i t e = IfThenElse (ann i) (ann <$> t) (ann <$> e) +ifThenElse ∷ Exp → [Statement] → [Statement] → Statement +ifThenElse = IfThenElse newAnn return ∷ Exp → Statement -return = Return . ann +return = Return newAnn + +foreignStatement ∷ Text → Statement +foreignStatement = ForeignSourceStat newAnn chunkToExpression ∷ Chunk → Exp -chunkToExpression ss = functionCall (Function [] (ann <$> ss)) [] +chunkToExpression = scope . toList -- Expressions ----------------------------------------------------------------- -table ∷ [TableRow] → Exp -table = TableCtor . fmap ann +nil ∷ Exp +nil = Nil newAnn -varName ∷ Name → Exp -varName = Var . ann . VarName +boolean ∷ Bool → Exp +boolean = Boolean newAnn -varIndex ∷ Exp → Exp → Exp -varIndex e1 e2 = Var (ann (VarIndex (ann e1) (ann e2))) +integer ∷ Integer → Exp +integer = Integer newAnn -varField ∷ Exp → Name → Exp -varField e n = Var (ann (VarField (ann e) n)) +float ∷ Double → Exp +float = Float newAnn -functionDef ∷ [Param] → Chunk → Exp -functionDef params body = Function (ann <$> params) (ann <$> body) +string ∷ Text → Exp +string = String newAnn + +table ∷ [TableRow] → Exp +table = TableCtor newAnn + +functionDef ∷ [Param] → [Statement] → Exp +functionDef = Function newAnn functionCall ∷ Exp → [Exp] → Exp -functionCall f args = FunctionCall (ann f) (ann <$> args) +functionCall = FunctionCall newAnn + +foreignExpression ∷ Text → Exp +foreignExpression = ForeignSourceExp newAnn unOp ∷ UnaryOp → Exp → Exp -unOp op e = UnOp op (ann e) +unOp = UnOp newAnn binOp ∷ BinaryOp → Exp → Exp → Exp -binOp op e1 e2 = BinOp op (ann e1) (ann e2) +binOp = BinOp newAnn error ∷ Text → Exp -error msg = functionCall (varName [Lua.name|error|]) [String msg] +error msg = functionCall (var (varName [Lua.name|error|])) [String newAnn msg] pun ∷ Name → TableRow -pun n = TableRowNV n (ann (varName n)) +pun n = TableRowNV newAnn n (var (varName n)) thunk ∷ Exp → Exp -thunk e = scope [Return (ann e)] +thunk e = scope [return e] -scope ∷ Chunk → Exp -scope body = functionCall (Function [] (ann <$> body)) [] +scope ∷ [Statement] → Exp +scope body = functionCall (functionDef [] body) [] -- Unary operators ------------------------------------------------------------- hash ∷ Exp → Exp -hash = UnOp HashOp . ann +hash = UnOp newAnn HashOp negate ∷ Exp → Exp -negate = UnOp Negate . ann +negate = UnOp newAnn Negate logicalNot ∷ Exp → Exp -logicalNot = UnOp LogicalNot . ann +logicalNot = UnOp newAnn LogicalNot bitwiseNot ∷ Exp → Exp -bitwiseNot = UnOp BitwiseNot . ann +bitwiseNot = UnOp newAnn BitwiseNot -- Binary operators ------------------------------------------------------------ or ∷ Exp → Exp → Exp -or e1 e2 = BinOp Or (ann e1) (ann e2) +or = BinOp newAnn Or and ∷ Exp → Exp → Exp -and e1 e2 = BinOp And (ann e1) (ann e2) +and = BinOp newAnn And lessThan ∷ Exp → Exp → Exp -lessThan e1 e2 = BinOp LessThan (ann e1) (ann e2) +lessThan = BinOp newAnn LessThan greaterThan ∷ Exp → Exp → Exp -greaterThan e1 e2 = BinOp GreaterThan (ann e1) (ann e2) +greaterThan = BinOp newAnn GreaterThan lessThanOrEqualTo ∷ Exp → Exp → Exp -lessThanOrEqualTo e1 e2 = BinOp LessThanOrEqualTo (ann e1) (ann e2) +lessThanOrEqualTo = BinOp newAnn LessThanOrEqualTo greaterThanOrEqualTo ∷ Exp → Exp → Exp -greaterThanOrEqualTo e1 e2 = BinOp GreaterThanOrEqualTo (ann e1) (ann e2) +greaterThanOrEqualTo = BinOp newAnn GreaterThanOrEqualTo notEqualTo ∷ Exp → Exp → Exp -notEqualTo e1 e2 = BinOp NotEqualTo (ann e1) (ann e2) +notEqualTo = BinOp newAnn NotEqualTo equalTo ∷ Exp → Exp → Exp -equalTo e1 e2 = BinOp EqualTo (ann e1) (ann e2) +equalTo = BinOp newAnn EqualTo bitOr ∷ Exp → Exp → Exp -bitOr e1 e2 = BinOp BitOr (ann e1) (ann e2) +bitOr = BinOp newAnn BitOr bitXor ∷ Exp → Exp → Exp -bitXor e1 e2 = BinOp BitXor (ann e1) (ann e2) +bitXor = BinOp newAnn BitXor bitAnd ∷ Exp → Exp → Exp -bitAnd e1 e2 = BinOp BitAnd (ann e1) (ann e2) +bitAnd = BinOp newAnn BitAnd bitShiftRight ∷ Exp → Exp → Exp -bitShiftRight e1 e2 = BinOp BitShiftRight (ann e1) (ann e2) +bitShiftRight = BinOp newAnn BitShiftRight bitShiftLeft ∷ Exp → Exp → Exp -bitShiftLeft e1 e2 = BinOp BitShiftLeft (ann e1) (ann e2) +bitShiftLeft = BinOp newAnn BitShiftLeft concat ∷ Exp → Exp → Exp -concat e1 e2 = BinOp Concat (ann e1) (ann e2) +concat = BinOp newAnn Concat add ∷ Exp → Exp → Exp -add e1 e2 = BinOp Add (ann e1) (ann e2) +add = BinOp newAnn Add sub ∷ Exp → Exp → Exp -sub e1 e2 = BinOp Sub (ann e1) (ann e2) +sub = BinOp newAnn Sub mul ∷ Exp → Exp → Exp -mul e1 e2 = BinOp Mul (ann e1) (ann e2) +mul = BinOp newAnn Mul floatDiv ∷ Exp → Exp → Exp -floatDiv e1 e2 = BinOp FloatDiv (ann e1) (ann e2) +floatDiv = BinOp newAnn FloatDiv floorDiv ∷ Exp → Exp → Exp -floorDiv e1 e2 = BinOp FloorDiv (ann e1) (ann e2) +floorDiv = BinOp newAnn FloorDiv mod ∷ Exp → Exp → Exp -mod e1 e2 = BinOp Mod (ann e1) (ann e2) +mod = BinOp newAnn Mod exponent ∷ Exp → Exp → Exp -exponent e1 e2 = BinOp Exp (ann e1) (ann e2) +exponent = BinOp newAnn Exp -- Table Rows ------------------------------------------------------------------ tableRowKV ∷ Exp → Exp → TableRow -tableRowKV k v = TableRowKV (ann k) (ann v) +tableRowKV = TableRowKV newAnn tableRowNV ∷ Name → Exp → TableRow -tableRowNV n v = TableRowNV n (ann v) +tableRowNV = TableRowNV newAnn + +-- Params ---------------------------------------------------------------------- + +paramNamed ∷ Name → Param +paramNamed = ParamNamed newAnn + +paramUnused ∷ Param +paramUnused = ParamUnused newAnn + +-- Variables ------------------------------------------------------------------- + +varName ∷ Name → Var +varName = VarName newAnn + +varField ∷ Exp → Name → Var +varField = VarField newAnn + +varIndex ∷ Exp → Exp → Var +varIndex = VarIndex newAnn diff --git a/pslua.cabal b/pslua.cabal index 70f957e..0e28fe8 100644 --- a/pslua.cabal +++ b/pslua.cabal @@ -140,7 +140,7 @@ library Language.PureScript.Backend.Lua.Printer Language.PureScript.Backend.Lua.Traversal Language.PureScript.Backend.Lua.Types - Language.PureScript.Backend.Types + Language.PureScript.Backend.AppOrModule Language.PureScript.Comments Language.PureScript.CoreFn Language.PureScript.CoreFn.Expr @@ -171,6 +171,7 @@ test-suite spec Language.PureScript.Backend.Lua.Linker.Foreign.Spec Language.PureScript.Backend.Lua.Optimizer.Spec Language.PureScript.Backend.Lua.Printer.Spec + Language.PureScript.Backend.Lua.Traversal.Spec Test.Hspec.Expectations.Pretty Test.Hspec.Extra Test.Hspec.Golden diff --git a/scripts/watch_test b/scripts/watch_test new file mode 100755 index 0000000..4b8aabb --- /dev/null +++ b/scripts/watch_test @@ -0,0 +1,12 @@ +#!/usr/bin/env bash + +set -euo pipefail + + +args='' +for arg in "$@" +do + args="$args '$arg'" +done + +watchman-make -p '**/*.hs' -r "clear && cabal test $args" diff --git a/test/Language/PureScript/Backend/IR/DCE/Spec.hs b/test/Language/PureScript/Backend/IR/DCE/Spec.hs index e6e9af0..c24fb5f 100644 --- a/test/Language/PureScript/Backend/IR/DCE/Spec.hs +++ b/test/Language/PureScript/Backend/IR/DCE/Spec.hs @@ -14,13 +14,13 @@ import Language.PureScript.Backend.IR.Names , Qualified (Local) , moduleNameFromString ) +import Language.PureScript.Backend.IR.Query (countFreeRefs) import Language.PureScript.Backend.IR.Types ( Ann , Exp , Grouping (..) , abstraction , application - , countFreeRefs , exception , lets , noAnn diff --git a/test/Language/PureScript/Backend/IR/Optimizer/Spec.hs b/test/Language/PureScript/Backend/IR/Optimizer/Spec.hs index 56d119c..6b296bb 100644 --- a/test/Language/PureScript/Backend/IR/Optimizer/Spec.hs +++ b/test/Language/PureScript/Backend/IR/Optimizer/Spec.hs @@ -11,7 +11,8 @@ import Language.PureScript.Backend.IR.Names , moduleNameFromString ) import Language.PureScript.Backend.IR.Optimizer - ( optimizedExpression + ( etaReduce + , optimizedExpression , optimizedUberModule , renameShadowedNamesInExpr ) @@ -33,6 +34,7 @@ import Language.PureScript.Backend.IR.Types , paramUnused , refLocal , refLocal0 + , rewriteExpTopDown ) import Test.Hspec (Spec, describe) import Test.Hspec.Hedgehog.Extended (test) @@ -60,6 +62,23 @@ spec = describe "IR Optimizer" do let f = abstraction paramUnused body body === optimizedExpression (application f arg) + test "does eta reduction" do + n ← forAll Gen.name + e ← forAll Gen.exp + let p = paramNamed n + r = refLocal n 0 + a = abstraction p (application e r) + rewriteExpTopDown etaReduce a === e + + test "does not do eta reduction when r is free in e" do + n ← forAll Gen.name + let p = paramNamed n + r = refLocal n 0 + a = + abstraction p $ + application (ifThenElse (literalBool True) r (literalInt 2)) r + rewriteExpTopDown etaReduce a === a + describe "inlines expressions" do test "inlines literals" 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..6321e09 100644 --- a/test/Language/PureScript/Backend/IR/Types/Spec.hs +++ b/test/Language/PureScript/Backend/IR/Types/Spec.hs @@ -7,12 +7,12 @@ import Language.PureScript.Backend.IR.Names , Name (..) , Qualified (Imported) ) +import Language.PureScript.Backend.IR.Query (countFreeRefs) import Language.PureScript.Backend.IR.Types ( Exp , Grouping (..) , abstraction , application - , countFreeRefs , lets , literalInt , noAnn diff --git a/test/Language/PureScript/Backend/Lua/DCE/Spec.hs b/test/Language/PureScript/Backend/Lua/DCE/Spec.hs index e6e68e6..7410738 100644 --- a/test/Language/PureScript/Backend/Lua/DCE/Spec.hs +++ b/test/Language/PureScript/Backend/Lua/DCE/Spec.hs @@ -8,14 +8,14 @@ import Hedgehog (annotateShow, forAll, (===)) import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range import Language.PureScript.Backend.Lua.DCE - ( DceMode (PreserveReturned) + ( DceAnn (..) + , DceMode (PreserveReturned) , MonadScopes (..) ) import Language.PureScript.Backend.Lua.DCE qualified as DCE import Language.PureScript.Backend.Lua.Fixture qualified as Fixture import Language.PureScript.Backend.Lua.Gen qualified as Gen import Language.PureScript.Backend.Lua.Name qualified as Lua -import Language.PureScript.Backend.Lua.Types (ParamF (..)) import Language.PureScript.Backend.Lua.Types qualified as Lua import Test.Hspec (Spec, describe) import Test.Hspec.Hedgehog.Extended (test) @@ -30,58 +30,58 @@ spec = describe "Lua Dead Code Elimination" do let chunk = [ Lua.local name1 . Just $ - Lua.functionDef [ParamNamed name2] [Lua.return expr1] - , Lua.return $ Lua.functionCall (Lua.varName name1) [expr2] + Lua.functionDef [Lua.paramNamed name2] [Lua.return expr1] + , Lua.return $ Lua.functionCall (Lua.varNameExp name1) [expr2] ] let chunk' = [ Lua.local name1 . Just $ - Lua.functionDef [ParamUnused] [Lua.return expr1] - , Lua.return $ Lua.functionCall (Lua.varName name1) [expr2] + Lua.functionDef [Lua.paramUnused] [Lua.return expr1] + , Lua.return $ Lua.functionCall (Lua.varNameExp name1) [expr2] ] DCE.eliminateDeadCode PreserveReturned chunk === chunk' test "Eliminates unused local binding" do - [usedLocal@(Lua.Local name _val), unusedLocal1, unusedLocal2] ← + [usedLocal@(Lua.Local _ann name _val), unusedLocal1, unusedLocal2] ← forAll . fmap toList $ Gen.set (Range.singleton 3) Gen.local - let fnCall ∷ Lua.Exp = Lua.functionCall (Lua.varName name) [] + let fnCall ∷ Lua.Exp = Lua.functionCall (Lua.varNameExp name) [] let chunk = [unusedLocal1, usedLocal, unusedLocal2, Lua.return fnCall] annotateShow chunk DCE.eliminateDeadCode PreserveReturned chunk === [usedLocal, Lua.return fnCall] test "Eliminates unused local binding inside a function" do - [usedLocal@(Lua.Local name _val), unusedLocal1, unusedLocal2] ← + [usedLocal@(Lua.Local _ann name _val), unusedLocal1, unusedLocal2] ← forAll . fmap toList $ Gen.set (Range.singleton 3) Gen.local - let fnCall ∷ Lua.Exp = Lua.functionCall (Lua.varName name) [] + let fnCall ∷ Lua.Exp = Lua.functionCall (Lua.varNameExp name) [] let body = [unusedLocal1, usedLocal, unusedLocal2, Lua.return fnCall] body' = [usedLocal, Lua.return fnCall] let chunk = - [Lua.return $ Lua.functionDef [ParamNamed [Lua.name|unusedArg|]] body] - chunk' = [Lua.return $ Lua.functionDef [ParamUnused] body'] + [Lua.return $ Lua.functionDef [Lua.paramNamed [Lua.name|unusedArg|]] body] + chunk' = [Lua.return $ Lua.functionDef [Lua.paramUnused] body'] annotateShow chunk DCE.eliminateDeadCode PreserveReturned chunk === chunk' test "Doesn't eliminate local binding used transitively" do name0 ← forAll Gen.name - localDef@(Lua.Local name1 _val) ← forAll Gen.local - let retCall = Lua.return (Lua.functionCall (Lua.varName name0) []) + localDef@(Lua.Local _ann name1 _val) ← forAll Gen.local + let retCall = Lua.return (Lua.functionCall (Lua.varNameExp name0) []) chunk = [ localDef - , Lua.local name0 (Just (Lua.varName name1)) + , Lua.local name0 (Just (Lua.varNameExp name1)) , retCall ] annotateShow chunk DCE.eliminateDeadCode PreserveReturned chunk === chunk test "Eliminates unused assign statement" do - localDef@(Lua.Local name _val) ← forAll Gen.local + localDef@(Lua.Local _ann name _val) ← forAll Gen.local name_ ← forAll $ mfilter (/= name) Gen.name value_ ← forAll Gen.expression - let retCall = Lua.return (Lua.functionCall (Lua.varName name) []) + let retCall = Lua.return (Lua.functionCall (Lua.varNameExp name) []) let chunk = [ localDef , Lua.local name_ Nothing - , Lua.assign (Lua.VarName name_) value_ + , Lua.assignVar name_ value_ , retCall ] annotateShow chunk @@ -90,10 +90,10 @@ spec = describe "Lua Dead Code Elimination" do test "Doesn't eliminate used assign statement" do name ← forAll Gen.name value_ ← forAll Gen.expression - let retCall = Lua.return (Lua.functionCall (Lua.varName name) []) + let retCall = Lua.return (Lua.functionCall (Lua.varNameExp name) []) let chunk = - [ Lua.Local name Nothing - , Lua.assign (Lua.VarName name) value_ + [ Lua.local name Nothing + , Lua.assignVar name value_ , retCall ] annotateShow chunk @@ -103,50 +103,70 @@ spec = describe "Lua Dead Code Elimination" do let name = Fixture.runtimeLazyName let chunk = [ Fixture.runtimeLazy - , Lua.return (Lua.functionCall (Lua.varName name) []) + , Lua.return (Lua.functionCall (Lua.varNameExp name) []) ] DCE.eliminateDeadCode PreserveReturned chunk === chunk + test "findAssignments" do + let name = [Lua.name|a|] + let chunk = + [ Lua.Local + (DceAnn Lua.newAnn 1 []) + name + (Just (Lua.Integer (DceAnn Lua.newAnn 11 []) 11)) + , Lua.Assign + (DceAnn Lua.newAnn 2 []) + (Lua.VarName (DceAnn Lua.newAnn 20 []) name) + (Lua.Integer (DceAnn Lua.newAnn 21 []) 2) + , Lua.Return (DceAnn Lua.newAnn 3 []) $ + Lua.FunctionCall + (DceAnn Lua.newAnn 3 []) + ( Lua.Var + (DceAnn Lua.newAnn 31 []) + (Lua.VarName (DceAnn Lua.newAnn 32 []) name) + ) + [] + ] + DCE.findAssignments name chunk === pure 2 + test "scopes" do - let name = Fixture.runtimeLazyName + name ← forAll Gen.name let chunk = [ Lua.local1 name $ - Lua.Function + Lua.functionDef [] - [ Lua.ann $ - Lua.ifThenElse - (Lua.Integer 100 `Lua.equalTo` Lua.Integer 0) - [Lua.Return ((), Lua.Integer 1)] - [Lua.Return ((), Lua.Integer 2)] + [ Lua.ifThenElse + (Lua.integer 100 `Lua.equalTo` Lua.integer 0) + [Lua.return (Lua.integer 1)] + [Lua.return (Lua.integer 2)] ] - , Lua.return (Lua.functionCall (Lua.varName name) []) + , Lua.return (Lua.functionCall (Lua.varNameExp name) []) ] + annotateShow $ scopeAssignmentTraces chunk DCE.eliminateDeadCode PreserveReturned chunk === chunk test "Adds/removes scopes correctly" do let n1 = [Lua.name|a|] - chunk ∷ [Lua.Statement] - chunk = + chunk ∷ [Lua.Statement] = [ Lua.local1 n1 $ - Lua.Function + Lua.functionDef [] - [ Lua.ann $ - Lua.ifThenElse - (Lua.Integer 100 `Lua.equalTo` Lua.Integer 0) - [Lua.Return ((), Lua.Integer 1)] - [Lua.Return ((), Lua.Integer 2)] + [ Lua.ifThenElse + (Lua.integer 100 `Lua.equalTo` Lua.integer 0) + [Lua.return (Lua.integer 1)] + [Lua.return (Lua.integer 2)] ] - , Lua.return (Lua.functionCall (Lua.varName n1) []) + , Lua.return (Lua.functionCall (Lua.varNameExp n1) []) ] scopeAssignmentTraces chunk - === [ AddName n1 9 (fromList [(n1, 9)] :| []) - , AddScope (mempty :| [fromList [(n1, 9)]]) - , AddScope (mempty :| [mempty, fromList [(n1, 9)]]) - , AddScope (mempty :| [mempty, mempty, fromList [(n1, 9)]]) - , DropScope [mempty, mempty, fromList [(n1, 9)]] - , DropScope [mempty, fromList [(n1, 9)]] - , DropScope [fromList [(n1, 9)]] + === [ AddName n1 0 (fromList [(n1, 0)] :| []) + , AddScope (mempty :| [fromList [(n1, 0)]]) + , AddScope (mempty :| [mempty, fromList [(n1, 0)]]) + , AddScope (mempty :| [mempty, mempty, fromList [(n1, 0)]]) + , DropScope [mempty, mempty, fromList [(n1, 0)]] + , DropScope [mempty, fromList [(n1, 0)]] + , DropScope [fromList [(n1, 0)]] ] scopeAssignmentTraces ∷ [Lua.Statement] → [Trace] diff --git a/test/Language/PureScript/Backend/Lua/Gen.hs b/test/Language/PureScript/Backend/Lua/Gen.hs index 6a41fa7..65a7fce 100644 --- a/test/Language/PureScript/Backend/Lua/Gen.hs +++ b/test/Language/PureScript/Backend/Lua/Gen.hs @@ -5,16 +5,25 @@ import Hedgehog (Gen, Range) import Hedgehog.Gen.Extended qualified as Gen import Hedgehog.Range qualified as Range import Language.PureScript.Backend.Lua.Name (Name, unsafeName) +import Language.PureScript.Backend.Lua.Optimizer (AppliedHow (..)) import Language.PureScript.Backend.Lua.Printer (printStatement) -import Language.PureScript.Backend.Lua.Types (ParamF (..)) import Language.PureScript.Backend.Lua.Types qualified as Lua import Prettyprinter (defaultLayoutOptions, layoutPretty) import Prettyprinter.Render.Text (renderStrict) import Prelude hiding (local, return) -chunk ∷ Gen Lua.Chunk +chunk ∷ Gen [Lua.Statement] chunk = Gen.list (Range.linear 1 16) statement +term ∷ Gen Lua.Term +term = + Gen.frequency + [ (6, Lua.S <$> statement) + , (7, Lua.E <$> expression) + , (1, Lua.V <$> nonRecursiveVar) + , (1, Lua.R <$> tableRow) + ] + statement ∷ Gen Lua.Statement statement = Gen.recursiveFrequency nonRecursiveStatements recursiveStatements @@ -47,7 +56,7 @@ recursiveStatements = [(2, ifThenElse)] foreignSourceCode ∷ Gen Lua.Statement foreignSourceCode = - Lua.ForeignSourceStat + Lua.foreignStatement . renderStrict . layoutPretty defaultLayoutOptions . printStatement @@ -85,27 +94,27 @@ nonRecursiveExpressions = ] nil ∷ Gen Lua.Exp -nil = Gen.constant Lua.Nil +nil = Gen.constant Lua.nil literalBool ∷ Gen Lua.Exp -literalBool = Lua.Boolean <$> Gen.bool +literalBool = Lua.boolean <$> Gen.bool literalInt ∷ Gen Lua.Exp -literalInt = Lua.Integer <$> Gen.integral integerRange +literalInt = Lua.integer <$> Gen.integral integerRange where integerRange ∷ Range Integer integerRange = fromIntegral <$> (Range.exponentialBounded ∷ Range Int64) literalFloat ∷ Gen Lua.Exp literalFloat = - Lua.Float + Lua.float <$> Gen.double (Range.exponentialFloatFrom 0 (-1234567890.0) 1234567890) literalString ∷ Gen Lua.Exp -literalString = Lua.String <$> Gen.text (Range.linear 1 16) Gen.unicode +literalString = Lua.string <$> Gen.text (Range.linear 1 16) Gen.unicode nonRecursiveVar ∷ Gen Lua.Var -nonRecursiveVar = Gen.frequency [(1, Lua.VarName <$> name)] +nonRecursiveVar = Gen.frequency [(1, Lua.VarName Lua.newAnn <$> name)] recursiveExpressions ∷ [(Int, Gen Lua.Exp)] recursiveExpressions = @@ -122,7 +131,7 @@ function = Lua.functionDef <$> Gen.list (Range.linear 0 5) - (maybe ParamUnused ParamNamed <$> Gen.maybe name) + (maybe Lua.paramUnused Lua.paramNamed <$> Gen.maybe name) <*> chunk unOp ∷ Gen Lua.Exp @@ -137,10 +146,16 @@ table = Lua.table <$> Gen.list (Range.linear 0 5) tableRow recursiveVar ∷ Gen Lua.Exp recursiveVar = do Gen.choice - [ Lua.varIndex <$> expression <*> expression - , Lua.varField <$> expression <*> name + [ fmap Lua.var . Lua.varIndex <$> expression <*> expression + , fmap Lua.var . Lua.varField <$> expression <*> name ] functionCall ∷ Gen Lua.Exp functionCall = Lua.functionCall <$> expression <*> Gen.list (Range.linear 0 5) expression + +appliedHow ∷ Gen AppliedHow +appliedHow = Gen.enumBounded + +knownAppliedHow ∷ Gen AppliedHow +knownAppliedHow = Gen.filter (/= Unknown) appliedHow diff --git a/test/Language/PureScript/Backend/Lua/Golden/Spec.hs b/test/Language/PureScript/Backend/Lua/Golden/Spec.hs index e712f35..c7a5dc1 100644 --- a/test/Language/PureScript/Backend/Lua/Golden/Spec.hs +++ b/test/Language/PureScript/Backend/Lua/Golden/Spec.hs @@ -9,6 +9,7 @@ import Data.List qualified as List import Data.String qualified as String import Data.Tagged (Tagged (..)) import Data.Text qualified as Text +import Language.PureScript.Backend.AppOrModule (AppOrModule (..)) import Language.PureScript.Backend.IR qualified as IR import Language.PureScript.Backend.IR.Linker (LinkMode (..)) import Language.PureScript.Backend.IR.Linker qualified as IR @@ -17,7 +18,6 @@ import Language.PureScript.Backend.IR.Optimizer (optimizedUberModule) import Language.PureScript.Backend.Lua qualified as Lua import Language.PureScript.Backend.Lua.Optimizer (optimizeChunk) import Language.PureScript.Backend.Lua.Printer qualified as Printer -import Language.PureScript.Backend.Types (AppOrModule (..)) import Language.PureScript.CoreFn.Reader qualified as CoreFn import Language.PureScript.Names qualified as PS import Path @@ -120,7 +120,7 @@ spec = do it luaTestName do defaultGolden luaGolden (Just luaActual) do appOrModule ← - (doesFileExist evalGolden) <&> \case + doesFileExist evalGolden <&> \case True → AsApplication moduleName (PS.Ident "main") False → AsModule moduleName cfn ← compileCorefn (Tagged (Rel psOutputPath)) moduleName diff --git a/test/Language/PureScript/Backend/Lua/Optimizer/Spec.hs b/test/Language/PureScript/Backend/Lua/Optimizer/Spec.hs index 9910a2a..9e30531 100644 --- a/test/Language/PureScript/Backend/Lua/Optimizer/Spec.hs +++ b/test/Language/PureScript/Backend/Lua/Optimizer/Spec.hs @@ -2,16 +2,31 @@ module Language.PureScript.Backend.Lua.Optimizer.Spec where +import Hedgehog (annotate, forAll, (===)) +import Language.PureScript.Backend.Lua.Gen qualified as Gen import Language.PureScript.Backend.Lua.Name (name) import Language.PureScript.Backend.Lua.Optimizer - ( pushDeclarationsDownTheInnerScope + ( AppliedHow (..) + , RewriteRule + , appliedHow + , collapseFunCalls + , pushDeclarationsDownTheInnerScope , removeScopeWhenInsideEmptyFunction - , rewriteExpWithRule + , rewriteCurried ) -import Language.PureScript.Backend.Lua.Types (ParamF (..)) +import Language.PureScript.Backend.Lua.Printer (printLuaChunk) +import Language.PureScript.Backend.Lua.Traversal (everywhereExp) import Language.PureScript.Backend.Lua.Types qualified as Lua +import Prettyprinter (defaultLayoutOptions, layoutPretty) +import Prettyprinter.Render.Text (renderStrict) import Test.Hspec (Spec, describe, it) -import Test.Hspec.Expectations.Pretty (assertEqual) +import Test.Hspec.Expectations.Pretty + ( assertEqualPretty + , assertEqualShowing + , shouldBe + ) +import Test.Hspec.Hedgehog (hedgehog) +import Test.Hspec.Hedgehog.Extended (test) import Text.Pretty.Simple (pShow) spec ∷ Spec @@ -20,48 +35,338 @@ spec = describe "Lua AST Optimizer" do it "removes scope when inside an empty function" do let original ∷ Lua.Exp = Lua.functionDef - [ParamNamed [name|a|]] + [Lua.paramNamed [name|a|]] [ Lua.return ( Lua.functionDef - [ParamNamed [name|b|]] - [Lua.return (Lua.scope [Lua.return (Lua.varName [name|c|])])] + [Lua.paramNamed [name|b|]] + [ Lua.return + ( Lua.scope + [Lua.return $ Lua.var (Lua.varName [name|c|])] + ) + ] ) ] expected ∷ Lua.Exp = Lua.functionDef - [ParamNamed [name|a|]] + [Lua.paramNamed [name|a|]] [ Lua.return ( Lua.functionDef - [ParamNamed [name|b|]] - [Lua.return (Lua.varName [name|c|])] + [Lua.paramNamed [name|b|]] + [Lua.return $ Lua.var (Lua.varName [name|c|])] ) ] - assertEqual (toString $ pShow original) expected $ + assertEqualPretty (toString $ pShow original) expected $ rewriteExpWithRule removeScopeWhenInsideEmptyFunction original it "pushes declarations down into an inner scope" do let original ∷ Lua.Exp = Lua.functionDef - [ParamNamed [name|a|], ParamNamed [name|b|]] - [ Lua.local1 [name|i|] (Lua.Integer 42) - , Lua.local1 [name|j|] (Lua.Integer 43) + [Lua.paramNamed [name|a|], Lua.paramNamed [name|b|]] + [ Lua.local1 [name|i|] (Lua.integer 42) + , Lua.local1 [name|j|] (Lua.integer 43) , Lua.return ( Lua.functionDef - [ParamNamed [name|d|]] - [Lua.return (Lua.varName [name|c|])] + [Lua.paramNamed [name|d|]] + [Lua.return $ Lua.var (Lua.varName [name|c|])] ) ] expected ∷ Lua.Exp = Lua.functionDef - [ParamNamed [name|a|], ParamNamed [name|b|]] + [Lua.paramNamed [name|a|], Lua.paramNamed [name|b|]] [ Lua.return ( Lua.functionDef - [ParamNamed [name|d|]] - [ Lua.local1 [name|i|] (Lua.Integer 42) - , Lua.local1 [name|j|] (Lua.Integer 43) - , Lua.return (Lua.varName [name|c|]) + [Lua.paramNamed [name|d|]] + [ Lua.local1 [name|i|] (Lua.integer 42) + , Lua.local1 [name|j|] (Lua.integer 43) + , Lua.return $ Lua.var (Lua.varName [name|c|]) ] ) ] - assertEqual (toString $ pShow @Lua.Exp original) expected $ + assertEqualPretty (toString $ pShow @Lua.Exp original) expected $ rewriteExpWithRule pushDeclarationsDownTheInnerScope original + + describe "Determines how a variable is applied" do + it "Unknown always loses" $ hedgehog do + how ← forAll Gen.appliedHow + Unknown <> how === how + + it "AppliedAtLeastTwice always loses" $ hedgehog do + how ← forAll $ Gen.knownAppliedHow + AppliedAtLeastTwice <> how === how + + it "NotApplied always wins" $ hedgehog do + how ← forAll $ Gen.knownAppliedHow + NotApplied <> how === NotApplied + + it "is not applied" do + let var ∷ Lua.Var = Lua.varName [name|v|] + let terms = [Lua.S . Lua.return $ Lua.var var] + appliedHow var terms `shouldBe` NotApplied + + it "is applied once" do + let var ∷ Lua.Var = Lua.varName [name|v|] + let terms = + [ Lua.S . Lua.return $ + Lua.functionCall + (Lua.var var) + [Lua.functionCall (Lua.var var) [Lua.string "x"]] + , Lua.S . Lua.return $ + Lua.functionCall + ( Lua.functionCall + (Lua.var var) + [Lua.string "y"] + ) + [Lua.functionCall (Lua.var var) [Lua.string "z"]] + ] + appliedHow var terms `shouldBe` AppliedOnce + + it "is applied at least twice" do + let var ∷ Lua.Var = Lua.varName [name|v|] + let terms = + [ Lua.S . Lua.return $ + Lua.functionCall (Lua.functionCall (Lua.var var) []) [] + ] + appliedHow var terms `shouldBe` AppliedAtLeastTwice + + it "is applied twice but with different vars" do + let var1 ∷ Lua.Var = Lua.varName [name|v1|] + let var2 ∷ Lua.Var = Lua.varName [name|v2|] + let terms = + [ Lua.S . Lua.return $ + Lua.functionCall (Lua.functionCall (Lua.var var1) []) [] + ] + appliedHow var2 terms `shouldBe` Unknown + + describe "Uncurries functions" do + let var ∷ Lua.Var = Lua.varName [name|v|] + let printedChunk s = + toString . unlines $ + [ renderStrict . layoutPretty defaultLayoutOptions $ + printLuaChunk (fromList s) + ] + let assertRewriteCurried + ∷ HasCallStack + ⇒ Lua.Var + → [Lua.Statement] + → Maybe [Lua.Statement] + → IO () + assertRewriteCurried variable stats expected = + assertEqualShowing showRewriteCurried "" expected actual + where + actual = rewriteCurried variable stats + -- actual = rewriteTillFixpoint (rewriteCurried variable) stats + showRewriteCurried = \case + Nothing → "Nothing" + Just s → printedChunk s + + it "No uncurrying if function is never referred to by name" do + assertRewriteCurried var [] Nothing + + it "No uncurrying if function is never applied" do + let stats = [Lua.return $ Lua.var var] + assertRewriteCurried var stats Nothing + + it "No uncurrying if a function is applied once" do + let call1 = Lua.functionCall (Lua.var var) [Lua.integer 1] + let call2 = Lua.functionCall call1 [Lua.integer 2] + let stats = [Lua.assignVar [name|r|] call1, Lua.return call2] + assertRewriteCurried var stats Nothing + + it "No uncurrying if a function is applied to one argument at least once" do + let varEx = Lua.var var + call1 = Lua.functionCall varEx [] + call2 = Lua.functionCall call1 [Lua.integer 1] + call3 = Lua.functionCall call2 [Lua.integer 2] + stats = + [ Lua.assignVar [name|tmp1|] call2 + , Lua.assignVar [name|tmp2|] call1 + , Lua.return call3 + ] + assertRewriteCurried var stats Nothing + + it "No uncurrying if a variable is reassigned" do + let var0 = Lua.varName [name|v0|] + var1 = Lua.varName [name|v1|] + call1 = Lua.functionCall (Lua.var var1) [Lua.integer 1] + stats = + [ Lua.assign var1 (Lua.var var0) + , Lua.return $ Lua.functionCall call1 [Lua.integer 2] + ] + assertRewriteCurried var stats Nothing + + it "Uncurried: up to min number of applications (2)" do + let varEx = Lua.var var + call1 = Lua.functionCall varEx [] + call2 = Lua.functionCall call1 [Lua.nil, Lua.integer 1] + call3 = Lua.functionCall call2 [Lua.integer 2] + call2' = + Lua.functionCall varEx [Lua.nil, Lua.nil, Lua.integer 1] + call3' = + Lua.functionCall + ( Lua.functionCall + varEx + [Lua.nil, Lua.nil, Lua.integer 1] + ) + [Lua.integer 2] + stats = + [ Lua.assignVar [name|tmp1|] call2 + , Lua.assignVar [name|tmp2|] call3 + , Lua.return call3 + ] + stats' = + [ Lua.assignVar [name|tmp1|] call2' + , Lua.assignVar [name|tmp2|] call3' + , Lua.return call3' + ] + assertRewriteCurried var stats $ Just stats' + + test "Uncurried: rewrite 3 times" do + let varEx = Lua.var var + call3 = + Lua.functionCall + ( Lua.functionCall + (Lua.functionCall varEx []) + [Lua.nil, Lua.integer 1] + ) + [Lua.integer 2] + + let rewrittenOnce = rewriteCurried var [Lua.return call3] + + annotate $ toString $ pShow rewrittenOnce + + let rewrittenTwice = rewriteCurried var =<< rewrittenOnce + + annotate $ toString $ pShow rewrittenTwice + + let rewrittenThrice = rewriteCurried var =<< rewrittenTwice + + annotate $ toString $ pShow rewrittenThrice + + rewrittenOnce + === Just + [ Lua.return $ + Lua.functionCall + (Lua.functionCall varEx [Lua.nil, Lua.nil, Lua.integer 1]) + [Lua.integer 2] + ] + + rewrittenTwice + === Just + [ Lua.return $ + Lua.functionCall + varEx + [ Lua.nil + , Lua.nil + , Lua.integer 1 + , Lua.integer 2 + ] + ] + + rewrittenThrice === Nothing + + {- + + (fun ((fun 1) 2)) ((fun 3) 4) + + ==> + + fun (fun (1, 2), fun (3, 4)) + + -} + test "rewrite 2 + 2" do + let fun = Lua.var var + terms = + [ Lua.return $ + Lua.functionCall + ( Lua.functionCall + fun + [ Lua.functionCall + (Lua.functionCall fun [Lua.string "1"]) + [Lua.string "2"] + ] + ) + [ Lua.functionCall + (Lua.functionCall fun [Lua.string "3"]) + [Lua.string "4"] + ] + ] + + actual = rewriteTillFixpoint (rewriteCurried var) terms + + annotate $ toString $ pShow actual + + actual + === Just + [ Lua.return $ + Lua.functionCall + fun + [ Lua.functionCall fun [Lua.string "1", Lua.string "2"] + , Lua.functionCall fun [Lua.string "3", Lua.string "4"] + ] + ] + + let subterms = + Lua.functionCall -- 5 + ( Lua.functionCall -- 4 + ( Lua.functionCall -- 3 + ( Lua.functionCall -- 2 + ( Lua.functionCall -- 1 + (Lua.varNameExp [name|v|]) + [] -- 1 + ) + [Lua.string "a"] -- 2 + ) + [Lua.string "b", Lua.integer 1] -- 3 + ) + [Lua.integer 2] -- 4 + ) + [Lua.integer 3] -- 5 + -- + test "collapseFunCalls 0" do + collapseFunCalls 0 subterms === Lua.E subterms + + test "collapseFunCalls 1" do + collapseFunCalls 1 subterms === Lua.E subterms + + test "collapseFunCalls 2" do + collapseFunCalls 2 subterms + === Lua.E + ( Lua.functionCall -- 5 + ( Lua.functionCall -- 4 + ( Lua.functionCall -- 3 + ( Lua.functionCall -- (1 + 2) + (Lua.varNameExp [name|v|]) + [Lua.nil, Lua.string "a"] + ) + [Lua.string "b", Lua.integer 1] -- 3 + ) + [Lua.integer 2] -- 4 + ) + [Lua.integer 3] -- 5 + ) + + test "collapseFunCalls 4" do + collapseFunCalls 4 subterms + === Lua.E + ( Lua.functionCall -- 5 + ( Lua.functionCall + (Lua.varNameExp [name|v|]) + [ Lua.nil -- 1 + , Lua.string "a" -- 2 + , Lua.string "b" -- 3 + , Lua.integer 1 -- 3 + , Lua.integer 2 -- 4 + ] + ) + [Lua.integer 3] -- 5 + ) + +rewriteExpWithRule ∷ RewriteRule → Lua.Exp → Lua.Exp +rewriteExpWithRule rule = everywhereExp rule identity + +rewriteTillFixpoint ∷ (t → Maybe t) → t → Maybe t +rewriteTillFixpoint f ss = + let r = f ss + in case r of + Nothing → Just ss + Just ss' → rewriteTillFixpoint f ss' diff --git a/test/Language/PureScript/Backend/Lua/Printer/Spec.hs b/test/Language/PureScript/Backend/Lua/Printer/Spec.hs index f1f4857..f9626cf 100644 --- a/test/Language/PureScript/Backend/Lua/Printer/Spec.hs +++ b/test/Language/PureScript/Backend/Lua/Printer/Spec.hs @@ -6,7 +6,6 @@ module Language.PureScript.Backend.Lua.Printer.Spec where import Data.Text qualified as Text import Language.PureScript.Backend.Lua.Name qualified as Lua import Language.PureScript.Backend.Lua.Printer qualified as Printer -import Language.PureScript.Backend.Lua.Types (ParamF (..)) import Language.PureScript.Backend.Lua.Types qualified as Lua import Prettyprinter (Doc, defaultLayoutOptions, layoutPretty) import Prettyprinter.Render.Text (renderStrict) @@ -18,48 +17,48 @@ spec = do (rendered . Printer.printName) [Lua.name|foo|] `shouldBe` "foo" it "VarName" do - renderedExpression (Lua.varName [Lua.name|foo|]) `shouldBe` "foo" + renderedExpression (Lua.varNameExp [Lua.name|foo|]) `shouldBe` "foo" describe "VarField" do it "var.field" do - let e = Lua.varName [Lua.name|expr|] + let e = Lua.varNameExp [Lua.name|expr|] f = [Lua.name|foo|] - renderedExpression (Lua.varField e f) `shouldBe` "expr.foo" + renderedExpression (Lua.varFieldExp e f) `shouldBe` "expr.foo" it "({field = 1}).field" do - let e = Lua.table [Lua.tableRowNV f (Lua.Integer 1)] + let e = Lua.table [Lua.tableRowNV f (Lua.integer 1)] f = [Lua.name|foo|] - renderedExpression (Lua.varField e f) `shouldBe` "({ foo = 1 }).foo" + renderedExpression (Lua.varFieldExp e f) `shouldBe` "({ foo = 1 }).foo" it "Assignment" do - let s = Lua.assign (Lua.VarName [Lua.name|foo|]) (Lua.Boolean True) + let s = Lua.assignVar [Lua.name|foo|] (Lua.boolean True) renderedStatement s `shouldBe` "foo = true" describe "Local declaration" do it "without a value" do - let s = Lua.Local [Lua.name|foo|] Nothing + let s = Lua.local [Lua.name|foo|] Nothing renderedStatement s `shouldBe` "local foo" it "with value" do - let s = Lua.local [Lua.name|foo|] (Just (Lua.Boolean True)) + let s = Lua.local [Lua.name|foo|] (Just (Lua.boolean True)) renderedStatement s `shouldBe` "local foo = true" describe "If Then Else" do it "if / then" do - let p = Lua.Boolean True - let t = pure $ Lua.return $ Lua.Integer 1 + let p = Lua.boolean True + let t = pure $ Lua.return $ Lua.integer 1 let s = Lua.ifThenElse p t [] renderedStatement s `shouldBe` "if true then return 1 end" it "if / then / else" do - let p = Lua.Boolean True - let t = pure $ Lua.return $ Lua.Integer 1 - let e = pure $ Lua.return $ Lua.Integer 0 + let p = Lua.boolean True + let t = pure $ Lua.return $ Lua.integer 1 + let e = pure $ Lua.return $ Lua.integer 0 let s = Lua.ifThenElse p t e renderedStatement s `shouldBe` "if true then return 1 else return 0 end" describe "Return" do it "statement" do - let s = Lua.return $ Lua.Boolean True + let s = Lua.return $ Lua.boolean True renderedStatement s `shouldBe` "return true" describe "Table" do @@ -69,18 +68,18 @@ spec = do it "small table constructor in one line" do let e = Lua.table - [ Lua.tableRowKV (Lua.Integer 42) (Lua.Boolean True) - , Lua.tableRowNV [Lua.name|foo|] (Lua.String "ok") + [ Lua.tableRowKV (Lua.integer 42) (Lua.boolean True) + , Lua.tableRowNV [Lua.name|foo|] (Lua.string "ok") ] renderedExpression e `shouldBe` "{ [42] = true, foo = \"ok\" }" it "large table constructor on muliple lines" do let e = Lua.table - [ Lua.tableRowKV (Lua.Integer 42) (Lua.Boolean True) - , Lua.tableRowNV [Lua.name|foo|] (Lua.String "bar") - , Lua.tableRowNV [Lua.name|loooooooooooong1|] (Lua.String "value") - , Lua.tableRowNV [Lua.name|loooooooooooong2|] (Lua.String "value") + [ Lua.tableRowKV (Lua.integer 42) (Lua.boolean True) + , Lua.tableRowNV [Lua.name|foo|] (Lua.string "bar") + , Lua.tableRowNV [Lua.name|loooooooooooong1|] (Lua.string "value") + , Lua.tableRowNV [Lua.name|loooooooooooong2|] (Lua.string "value") ] renderedExpression e `shouldBe` multiline @@ -94,18 +93,18 @@ spec = do describe "function" do it "one-liner" do - let params = ParamNamed <$> [[Lua.name|a|], [Lua.name|b|]] - let result = Lua.Integer 1 - let stats = [Lua.assign (Lua.VarName [Lua.name|x|]) Lua.Nil] + let params = Lua.paramNamed <$> [[Lua.name|a|], [Lua.name|b|]] + let result = Lua.integer 1 + let stats = [Lua.assignVar [Lua.name|x|] Lua.nil] let expr = Lua.functionDef params (stats <> [Lua.return result]) renderedExpression expr `shouldBe` "function(a, b) x = nil return 1 end" it "multi-liner" do - let params = ParamNamed <$> [[Lua.name|aaa|], [Lua.name|bbb|]] + let params = Lua.paramNamed <$> [[Lua.name|aaa|], [Lua.name|bbb|]] let result = - Lua.varName + Lua.varNameExp [Lua.name|aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa|] - let stats = [Lua.assign (Lua.VarName [Lua.name|x|]) Lua.Nil] + let stats = [Lua.assignVar [Lua.name|x|] Lua.nil] let expr = Lua.functionDef params (stats <> [Lua.return result]) renderedExpression expr `shouldBe` multiline @@ -118,40 +117,40 @@ spec = do let expr = Lua.functionCall ( Lua.functionDef - [ParamNamed [Lua.name|a|], ParamNamed [Lua.name|b|]] - [Lua.return (Lua.varName [Lua.name|a|])] + [Lua.paramNamed [Lua.name|a|], Lua.paramNamed [Lua.name|b|]] + [Lua.return (Lua.varNameExp [Lua.name|a|])] ) - [Lua.Integer 1, Lua.Integer 2] + [Lua.integer 1, Lua.integer 2] renderedExpression expr `shouldBe` "(function(a, b) return a end)(1, 2)" describe "expression" do describe "unary" do it "hash" do - renderedExpression (Lua.hash (Lua.varName [Lua.name|foo|])) + renderedExpression (Lua.hash (Lua.varNameExp [Lua.name|foo|])) `shouldBe` "#(foo)" it "negate" do - renderedExpression (Lua.negate (Lua.varName [Lua.name|foo|])) + renderedExpression (Lua.negate (Lua.varNameExp [Lua.name|foo|])) `shouldBe` "-(foo)" it "logicalNot" do - renderedExpression (Lua.logicalNot (Lua.varName [Lua.name|foo|])) + renderedExpression (Lua.logicalNot (Lua.varNameExp [Lua.name|foo|])) `shouldBe` "not(foo)" it "bitwiseNot" do - renderedExpression (Lua.bitwiseNot (Lua.varName [Lua.name|foo|])) + renderedExpression (Lua.bitwiseNot (Lua.varNameExp [Lua.name|foo|])) `shouldBe` "~(foo)" describe "binary" do it "Op with lower precedence is braced" do renderedExpression - ((Lua.Integer 2 `Lua.add` Lua.Integer 3) `Lua.mul` Lua.Integer 4) + ((Lua.integer 2 `Lua.add` Lua.integer 3) `Lua.mul` Lua.integer 4) `shouldBe` "(2 + 3) * 4" it "Op with higher precedence is not braced" do renderedExpression - (Lua.Integer 2 `Lua.add` (Lua.Integer 3 `Lua.mul` Lua.Integer 4)) + (Lua.integer 2 `Lua.add` (Lua.integer 3 `Lua.mul` Lua.integer 4)) `shouldBe` "2 + 3 * 4" -------------------------------------------------------------------------------- diff --git a/test/Language/PureScript/Backend/Lua/Traversal/Spec.hs b/test/Language/PureScript/Backend/Lua/Traversal/Spec.hs new file mode 100644 index 0000000..fac9a67 --- /dev/null +++ b/test/Language/PureScript/Backend/Lua/Traversal/Spec.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Language.PureScript.Backend.Lua.Traversal.Spec where + +import Control.Lens.Plated qualified as Plated +import Control.Monad.Trans.Accum (Accum, add, execAccum) +import Data.Set qualified as Set +import Hedgehog (annotate, forAll, (===)) +import Language.PureScript.Backend.Lua.Gen qualified as Gen +import Language.PureScript.Backend.Lua.Name qualified as Lua +import Language.PureScript.Backend.Lua.Types qualified as Lua +import Test.Hspec (Spec, describe, it) +import Test.Hspec.Hedgehog (hedgehog) +import Test.Hspec.Hedgehog.Extended (test) +import Text.Pretty.Simple (pShow) + +spec ∷ Spec +spec = do + describe "Plated-based traversals" do + test "Not rewriting a single term is identity" do + name ← forAll Gen.name + let term = Lua.S (Lua.assignVar name (Lua.boolean True)) + annotate $ toString $ pShow term + Plated.rewrite (const Nothing) term === term + + it "Not rewriting a single term visits every term once" $ hedgehog do + term ← forAll Gen.term + annotate $ toString $ pShow term + let visit ∷ Lua.Term → Accum [Lua.Term] (Maybe (Lua.Term)) + visit t = do + add [t] + pure Nothing + Set.fromList (execAccum (Plated.rewriteM visit term) []) + === Set.fromList (Plated.universe term) + + it "Rewrites all named variables to fields" do + term ← forAll Gen.term + name ← forAll Gen.name + annotate $ toString $ pShow term + let term' = + term & Plated.rewrite \case + Lua.V (Lua.VarName ann n) + | n /= name → + Just $ Lua.V (Lua.VarField ann (Lua.varNameExp name) n) + _ → Nothing + [n | Lua.V (Lua.VarName _ann n) ← Plated.universe term', n /= name] === [] + + test "Rewrites terms bottom-up" do + let term = + Lua.E + ( Lua.functionCall + ( Lua.functionCall + ( Lua.functionCall + (Lua.varNameExp [Lua.name|innermost|]) + [Lua.string "inner"] + ) + [Lua.string "outer"] + ) + [Lua.string "outermost"] + ) + annotate $ toString $ pShow term + execAccum (Plated.transformM (\t → add [t] $> t) term) [] + === [ Lua.V (Lua.varName [Lua.name|innermost|]) + , Lua.E (Lua.varNameExp [Lua.name|innermost|]) + , Lua.E (Lua.string "inner") + , Lua.E + ( Lua.functionCall + (Lua.varNameExp [Lua.name|innermost|]) + [Lua.string "inner"] + ) + , Lua.E (Lua.string "outer") + , Lua.E + ( Lua.functionCall + ( Lua.functionCall + (Lua.varNameExp [Lua.name|innermost|]) + [Lua.string "inner"] + ) + [Lua.string "outer"] + ) + , Lua.E (Lua.string "outermost") + , Lua.E + ( Lua.functionCall + ( Lua.functionCall + ( Lua.functionCall + (Lua.varNameExp [Lua.name|innermost|]) + [Lua.string "inner"] + ) + [Lua.string "outer"] + ) + [Lua.string "outermost"] + ) + ] diff --git a/test/Main.hs b/test/Main.hs index 75c4202..7e4d086 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -10,6 +10,7 @@ import Language.PureScript.Backend.Lua.Golden.Spec qualified as Golden import Language.PureScript.Backend.Lua.Linker.Foreign.Spec qualified as LuaLinkerForeign import Language.PureScript.Backend.Lua.Optimizer.Spec qualified as LuaOptimizer import Language.PureScript.Backend.Lua.Printer.Spec qualified as Printer +import Language.PureScript.Backend.Lua.Traversal.Spec qualified as LuaTraversal import Test.Hspec (hspec) main ∷ IO () @@ -18,6 +19,7 @@ main = hspec do Inliner.spec Golden.spec IrDce.spec + LuaTraversal.spec LuaDce.spec Types.spec IROptimizer.spec diff --git a/test/Test/Hspec/Expectations/Pretty.hs b/test/Test/Hspec/Expectations/Pretty.hs index 46f2805..48eb9fa 100644 --- a/test/Test/Hspec/Expectations/Pretty.hs +++ b/test/Test/Hspec/Expectations/Pretty.hs @@ -10,7 +10,10 @@ import Test.HUnit.Lang import Text.Pretty.Simple (pShow) shouldBe ∷ (HasCallStack, Eq a, Show a) ⇒ a → a → Assertion -shouldBe expected actual = assertEqual "" actual expected +shouldBe expected actual = assertEqualPretty "" actual expected + +assertEqualPretty ∷ (HasCallStack, Eq a, Show a) ⇒ String → a → a → Assertion +assertEqualPretty = assertEqualShowing (toString . pShow) {- | Asserts that the specified actual value is equal to the expected value. The output message will contain the prefix, the expected value, and the @@ -19,16 +22,18 @@ shouldBe expected actual = assertEqual "" actual expected If the prefix is the empty string (i.e., @\"\"@), then the prefix is omitted and only the expected and actual values are output. -} -assertEqual - ∷ (HasCallStack, Eq a, Show a) - ⇒ String +assertEqualShowing + ∷ (HasCallStack, Eq a) + ⇒ (a → String) + -- ^ A function to convert the expected value to a string + → String -- ^ The message prefix → a -- ^ The expected value → a -- ^ The actual value → Assertion -assertEqual preface expected actual = +assertEqualShowing shower preface expected actual = unless (actual == expected) do prefaceMsg `deepseq` expectedMsg @@ -41,8 +46,8 @@ assertEqual preface expected actual = prefaceMsg | null preface = Nothing | otherwise = Just preface - expectedMsg = toString $ pShow expected - actualMsg = toString $ pShow actual + expectedMsg = shower expected + actualMsg = shower actual location ∷ HasCallStack ⇒ Maybe SrcLoc location = case reverse Data.CallStack.callStack of diff --git a/test/Test/Hspec/Golden.hs b/test/Test/Hspec/Golden.hs index 381ac97..d6a220b 100644 --- a/test/Test/Hspec/Golden.hs +++ b/test/Test/Hspec/Golden.hs @@ -10,6 +10,7 @@ where import Path (Abs, File, Path, parent, toFilePath) import Path.IO (createDirIfMissing, doesFileExist) +import System.Environment.Blank (getEnv) import Test.Hspec.Core.Spec ( Example (..) , FailureReason (..) @@ -78,6 +79,8 @@ fromGoldenResult = \case Result "Golden and Actual output hasn't changed" Success FirstExecutionSucceed → Result "First time execution. Golden file created." Success + GoldenFileOverwritten → + Result "Golden file overwritten" Success FirstExecutionFail → Result "First time execution. Golden file created." @@ -107,6 +110,7 @@ defaultGolden goldenFile actualFile produceOutput = data GoldenResult = MissmatchOutput String String | SameOutput + | GoldenFileOverwritten | FirstExecutionSucceed | FirstExecutionFail @@ -134,10 +138,15 @@ runGolden Golden {..} = do else FirstExecutionSucceed else do contentGolden ← readFromFile goldenFile - pure - if contentGolden == output - then SameOutput - else - MissmatchOutput - (encodePretty contentGolden) - (encodePretty output) + overwriteGolden ← isJust <$> getEnv "UPDATE_GOLDEN" + if contentGolden == output + then pure SameOutput + else + if overwriteGolden + then + GoldenFileOverwritten <$ writeToFile goldenFile output + else + pure $ + MissmatchOutput + (encodePretty contentGolden) + (encodePretty output) diff --git a/test/ps/golden/Golden/Inline/Test.purs b/test/ps/golden/Golden/Inline/Test.purs index 447ac04..f4902ff 100644 --- a/test/ps/golden/Golden/Inline/Test.purs +++ b/test/ps/golden/Golden/Inline/Test.purs @@ -1,4 +1,9 @@ -module Golden.Inline.Test where +module Golden.Inline.Test + ( main + , Mu + , runMu + , iMu + ) where main :: Int main = @@ -7,3 +12,11 @@ main = in let y :: forall b. b -> Int y _ = 2 in x y + +newtype Mu a = MkMu (Mu a -> a) + +runMu :: forall a. Mu a -> a +runMu mu@(MkMu f) = f mu + +iMu :: Mu Int +iMu = MkMu runMu diff --git a/test/ps/golden/Golden/Uncurrying/Test.purs b/test/ps/golden/Golden/Uncurrying/Test.purs new file mode 100644 index 0000000..a0a89dd --- /dev/null +++ b/test/ps/golden/Golden/Uncurrying/Test.purs @@ -0,0 +1,25 @@ +module Golden.Uncurrying.Test (call2, call3, call4, call5) where + +uncurryFirst2Args :: Int -> Boolean -> Char -> Int +uncurryFirst2Args i _b _c = i + +call2 :: Char -> Int +call2 = uncurryFirst2Args 1 true + +call3 :: Int +call3 = uncurryFirst2Args 2 false 'a' + +uncurryFirst4Args :: Int -> Int -> Int -> Int -> Int -> Int +uncurryFirst4Args i _j _k _l _m = i + +call4 :: Int -> Int +call4 = uncurryFirst4Args 1 2 3 (synonym 4 5 6) + +uncurryFirst3Args :: Int -> Int -> Int -> Int +uncurryFirst3Args _i _j k = k + +synonym :: Int -> Int -> Int -> Int +synonym = uncurryFirst3Args + +call5 :: Int -> Int +call5 i = synonym 1 i 3 diff --git a/test/ps/output/Golden.ArrayOfUnits.Test/golden.lua b/test/ps/output/Golden.ArrayOfUnits.Test/golden.lua index b02e938..35d5a15 100644 --- a/test/ps/output/Golden.ArrayOfUnits.Test/golden.lua +++ b/test/ps/output/Golden.ArrayOfUnits.Test/golden.lua @@ -109,8 +109,8 @@ 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) + local bind = M.Control_Bind_bind(M.Effect_monadEffect.Bind1()) return bind(f)(function(fPrime) return bind(a)(function(aPrime) return M.Control_Applicative_pure(M.Effect_monadEffect.Applicative0())(fPrime(aPrime)) diff --git a/test/ps/output/Golden.HelloPrelude.Test/golden.lua b/test/ps/output/Golden.HelloPrelude.Test/golden.lua index 16977dd..bb5d4af 100644 --- a/test/ps/output/Golden.HelloPrelude.Test/golden.lua +++ b/test/ps/output/Golden.HelloPrelude.Test/golden.lua @@ -57,8 +57,8 @@ M.Effect_Lazy_applyEffect = PSLUA_runtime_lazy("applyEffect")(function() return { apply = (function() return function(f) - local bind = (M.Effect_monadEffect.Bind1()).bind return function(a) + local bind = (M.Effect_monadEffect.Bind1()).bind return bind(f)(function(fPrime) return bind(a)(function(aPrime) return M.Control_Applicative_pure(M.Effect_monadEffect.Applicative0())(fPrime(aPrime)) diff --git a/test/ps/output/Golden.Inline.Test/corefn.json b/test/ps/output/Golden.Inline.Test/corefn.json index 36ae11a..3105748 100644 --- a/test/ps/output/Golden.Inline.Test/corefn.json +++ b/test/ps/output/Golden.Inline.Test/corefn.json @@ -1 +1 @@ -{"builtWith":"0.15.15","comments":[],"decls":[{"annotation":{"meta":null,"sourceSpan":{"end":[3,12],"start":[3,1]}},"bindType":"NonRec","expression":{"annotation":{"meta":null,"sourceSpan":{"end":[9,13],"start":[5,3]}},"binds":[{"annotation":{"meta":null,"sourceSpan":{"end":[5,30],"start":[5,7]}},"bindType":"NonRec","expression":{"annotation":{"meta":null,"sourceSpan":{"end":[5,30],"start":[5,7]}},"argument":"v","body":{"annotation":{"meta":null,"sourceSpan":{"end":[6,14],"start":[6,13]}},"type":"Literal","value":{"literalType":"IntLiteral","value":1}},"type":"Abs"},"identifier":"x"}],"expression":{"annotation":{"meta":null,"sourceSpan":{"end":[9,13],"start":[7,6]}},"binds":[{"annotation":{"meta":null,"sourceSpan":{"end":[7,34],"start":[7,11]}},"bindType":"NonRec","expression":{"annotation":{"meta":null,"sourceSpan":{"end":[7,34],"start":[7,11]}},"argument":"v","body":{"annotation":{"meta":null,"sourceSpan":{"end":[8,18],"start":[8,17]}},"type":"Literal","value":{"literalType":"IntLiteral","value":2}},"type":"Abs"},"identifier":"y"}],"expression":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[9,11],"start":[9,10]}},"type":"Var","value":{"identifier":"x","sourcePos":[5,7]}},"annotation":{"meta":null,"sourceSpan":{"end":[9,13],"start":[9,10]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[9,13],"start":[9,12]}},"type":"Var","value":{"identifier":"y","sourcePos":[7,11]}},"type":"App"},"type":"Let"},"type":"Let"},"identifier":"main"}],"exports":["main"],"foreign":[],"imports":[{"annotation":{"meta":null,"sourceSpan":{"end":[9,13],"start":[1,1]}},"moduleName":["Prim"]}],"moduleName":["Golden","Inline","Test"],"modulePath":"golden/Golden/Inline/Test.purs","reExports":{},"sourceSpan":{"end":[9,13],"start":[1,1]}} \ No newline at end of file +{"builtWith":"0.15.15","comments":[],"decls":[{"annotation":{"meta":null,"sourceSpan":{"end":[16,32],"start":[16,1]}},"bindType":"NonRec","expression":{"annotation":{"meta":{"metaType":"IsNewtype"},"sourceSpan":{"end":[16,32],"start":[16,1]}},"argument":"x","body":{"annotation":{"meta":null,"sourceSpan":{"end":[16,32],"start":[16,1]}},"type":"Var","value":{"identifier":"x","sourcePos":[0,0]}},"type":"Abs"},"identifier":"MkMu"},{"annotation":{"meta":null,"sourceSpan":{"end":[18,29],"start":[18,1]}},"bindType":"NonRec","expression":{"annotation":{"meta":null,"sourceSpan":{"end":[18,29],"start":[18,1]}},"argument":"v","body":{"annotation":{"meta":null,"sourceSpan":{"end":[18,29],"start":[18,1]}},"caseAlternatives":[{"binders":[{"annotation":{"meta":null,"sourceSpan":{"end":[19,18],"start":[19,7]}},"binder":{"annotation":{"meta":{"metaType":"IsNewtype"},"sourceSpan":{"end":[19,17],"start":[19,11]}},"binderType":"ConstructorBinder","binders":[{"annotation":{"meta":null,"sourceSpan":{"end":[19,17],"start":[19,16]}},"binderType":"VarBinder","identifier":"f"}],"constructorName":{"identifier":"MkMu","moduleName":["Golden","Inline","Test"]},"typeName":{"identifier":"Mu","moduleName":["Golden","Inline","Test"]}},"binderType":"NamedBinder","identifier":"mu"}],"expression":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[19,22],"start":[19,21]}},"type":"Var","value":{"identifier":"f","sourcePos":[19,16]}},"annotation":{"meta":null,"sourceSpan":{"end":[19,25],"start":[19,21]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[19,25],"start":[19,23]}},"type":"Var","value":{"identifier":"mu","sourcePos":[19,7]}},"type":"App"},"isGuarded":false}],"caseExpressions":[{"annotation":{"meta":null,"sourceSpan":{"end":[19,25],"start":[19,1]}},"type":"Var","value":{"identifier":"v","sourcePos":[0,0]}}],"type":"Case"},"type":"Abs"},"identifier":"runMu"},{"annotation":{"meta":null,"sourceSpan":{"end":[8,12],"start":[8,1]}},"bindType":"NonRec","expression":{"annotation":{"meta":null,"sourceSpan":{"end":[14,13],"start":[10,3]}},"binds":[{"annotation":{"meta":null,"sourceSpan":{"end":[10,30],"start":[10,7]}},"bindType":"NonRec","expression":{"annotation":{"meta":null,"sourceSpan":{"end":[10,30],"start":[10,7]}},"argument":"v","body":{"annotation":{"meta":null,"sourceSpan":{"end":[11,14],"start":[11,13]}},"type":"Literal","value":{"literalType":"IntLiteral","value":1}},"type":"Abs"},"identifier":"x"}],"expression":{"annotation":{"meta":null,"sourceSpan":{"end":[14,13],"start":[12,6]}},"binds":[{"annotation":{"meta":null,"sourceSpan":{"end":[12,34],"start":[12,11]}},"bindType":"NonRec","expression":{"annotation":{"meta":null,"sourceSpan":{"end":[12,34],"start":[12,11]}},"argument":"v","body":{"annotation":{"meta":null,"sourceSpan":{"end":[13,18],"start":[13,17]}},"type":"Literal","value":{"literalType":"IntLiteral","value":2}},"type":"Abs"},"identifier":"y"}],"expression":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[14,11],"start":[14,10]}},"type":"Var","value":{"identifier":"x","sourcePos":[10,7]}},"annotation":{"meta":null,"sourceSpan":{"end":[14,13],"start":[14,10]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[14,13],"start":[14,12]}},"type":"Var","value":{"identifier":"y","sourcePos":[12,11]}},"type":"App"},"type":"Let"},"type":"Let"},"identifier":"main"},{"annotation":{"meta":null,"sourceSpan":{"end":[21,14],"start":[21,1]}},"bindType":"NonRec","expression":{"abstraction":{"annotation":{"meta":{"metaType":"IsNewtype"},"sourceSpan":{"end":[22,11],"start":[22,7]}},"type":"Var","value":{"identifier":"MkMu","moduleName":["Golden","Inline","Test"]}},"annotation":{"meta":null,"sourceSpan":{"end":[22,17],"start":[22,7]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[22,17],"start":[22,12]}},"type":"Var","value":{"identifier":"runMu","moduleName":["Golden","Inline","Test"]}},"type":"App"},"identifier":"iMu"}],"exports":["main","runMu","iMu"],"foreign":[],"imports":[{"annotation":{"meta":null,"sourceSpan":{"end":[22,17],"start":[1,1]}},"moduleName":["Golden","Inline","Test"]},{"annotation":{"meta":null,"sourceSpan":{"end":[22,17],"start":[1,1]}},"moduleName":["Prim"]}],"moduleName":["Golden","Inline","Test"],"modulePath":"golden/Golden/Inline/Test.purs","reExports":{},"sourceSpan":{"end":[22,17],"start":[1,1]}} \ No newline at end of file diff --git a/test/ps/output/Golden.Inline.Test/golden.ir b/test/ps/output/Golden.Inline.Test/golden.ir index 7547681..648a313 100644 --- a/test/ps/output/Golden.Inline.Test/golden.ir +++ b/test/ps/output/Golden.Inline.Test/golden.ir @@ -1,4 +1,23 @@ UberModule - { uberModuleBindings = [], uberModuleForeigns = [], uberModuleExports = - [ ( Name "main", LiteralInt Nothing 1 ) ] + { uberModuleBindings = + [ Standalone + ( QName + { qnameModuleName = ModuleName "Golden.Inline.Test", qnameName = Name "runMu" + }, Abs Nothing + ( ParamNamed Nothing ( Name "v" ) ) + ( App Nothing + ( Ref Nothing ( Local ( Name "v" ) ) 0 ) + ( Ref Nothing ( Local ( Name "v" ) ) 0 ) + ) + ) + ], uberModuleForeigns = [], uberModuleExports = + [ + ( Name "main", LiteralInt Nothing 1 ), + ( Name "runMu", Ref Nothing + ( Imported ( ModuleName "Golden.Inline.Test" ) ( Name "runMu" ) ) 0 + ), + ( Name "iMu", Ref Nothing + ( Imported ( ModuleName "Golden.Inline.Test" ) ( Name "runMu" ) ) 0 + ) + ] } \ No newline at end of file diff --git a/test/ps/output/Golden.Inline.Test/golden.lua b/test/ps/output/Golden.Inline.Test/golden.lua index 2764a01..9e0c091 100644 --- a/test/ps/output/Golden.Inline.Test/golden.lua +++ b/test/ps/output/Golden.Inline.Test/golden.lua @@ -1 +1,7 @@ -return { main = 1 } +local M = {} +M.Golden_Inline_Test_runMu = function(v) return v(v) end +return { + main = 1, + runMu = M.Golden_Inline_Test_runMu, + iMu = M.Golden_Inline_Test_runMu +} diff --git a/test/ps/output/Golden.NameShadowing.Test/golden.lua b/test/ps/output/Golden.NameShadowing.Test/golden.lua index 272f73a..ab048ba 100644 --- a/test/ps/output/Golden.NameShadowing.Test/golden.lua +++ b/test/ps/output/Golden.NameShadowing.Test/golden.lua @@ -1,16 +1,14 @@ local M = {} -M.Golden_NameShadowing_Test_f = function(v) - return function(v1) - if 1 == v then return 1 else if 1 == v1 then return 2 else return 3 end end - end +M.Golden_NameShadowing_Test_f = function(v, v1) + if 1 == v then return 1 else if 1 == v1 then return 2 else return 3 end end end return { b = function(x) return function(x1) - return M.Golden_NameShadowing_Test_f(M.Golden_NameShadowing_Test_f(x)(x1))(M.Golden_NameShadowing_Test_f(42)(1)) + return M.Golden_NameShadowing_Test_f(M.Golden_NameShadowing_Test_f(x, x1), M.Golden_NameShadowing_Test_f(42, 1)) end end, c = function(y) - return function(x1) return M.Golden_NameShadowing_Test_f(x1)(y) end + return function(x1) return M.Golden_NameShadowing_Test_f(x1, y) end end } diff --git a/test/ps/output/Golden.Uncurrying.Test/corefn.json b/test/ps/output/Golden.Uncurrying.Test/corefn.json new file mode 100644 index 0000000..cdc0c57 --- /dev/null +++ b/test/ps/output/Golden.Uncurrying.Test/corefn.json @@ -0,0 +1 @@ +{"builtWith":"0.15.15","comments":[],"decls":[{"annotation":{"meta":null,"sourceSpan":{"end":[12,60],"start":[12,1]}},"bindType":"NonRec","expression":{"annotation":{"meta":null,"sourceSpan":{"end":[12,60],"start":[12,1]}},"argument":"i","body":{"annotation":{"meta":null,"sourceSpan":{"end":[12,60],"start":[12,1]}},"argument":"_j","body":{"annotation":{"meta":null,"sourceSpan":{"end":[12,60],"start":[12,1]}},"argument":"_k","body":{"annotation":{"meta":null,"sourceSpan":{"end":[12,60],"start":[12,1]}},"argument":"_l","body":{"annotation":{"meta":null,"sourceSpan":{"end":[12,60],"start":[12,1]}},"argument":"_m","body":{"annotation":{"meta":null,"sourceSpan":{"end":[13,36],"start":[13,35]}},"type":"Var","value":{"identifier":"i","sourcePos":[13,1]}},"type":"Abs"},"type":"Abs"},"type":"Abs"},"type":"Abs"},"type":"Abs"},"identifier":"uncurryFirst4Args"},{"annotation":{"meta":null,"sourceSpan":{"end":[18,46],"start":[18,1]}},"bindType":"NonRec","expression":{"annotation":{"meta":null,"sourceSpan":{"end":[18,46],"start":[18,1]}},"argument":"_i","body":{"annotation":{"meta":null,"sourceSpan":{"end":[18,46],"start":[18,1]}},"argument":"_j","body":{"annotation":{"meta":null,"sourceSpan":{"end":[18,46],"start":[18,1]}},"argument":"k","body":{"annotation":{"meta":null,"sourceSpan":{"end":[19,30],"start":[19,29]}},"type":"Var","value":{"identifier":"k","sourcePos":[19,1]}},"type":"Abs"},"type":"Abs"},"type":"Abs"},"identifier":"uncurryFirst3Args"},{"annotation":{"meta":null,"sourceSpan":{"end":[3,51],"start":[3,1]}},"bindType":"NonRec","expression":{"annotation":{"meta":null,"sourceSpan":{"end":[3,51],"start":[3,1]}},"argument":"i","body":{"annotation":{"meta":null,"sourceSpan":{"end":[3,51],"start":[3,1]}},"argument":"_b","body":{"annotation":{"meta":null,"sourceSpan":{"end":[3,51],"start":[3,1]}},"argument":"_c","body":{"annotation":{"meta":null,"sourceSpan":{"end":[4,30],"start":[4,29]}},"type":"Var","value":{"identifier":"i","sourcePos":[4,1]}},"type":"Abs"},"type":"Abs"},"type":"Abs"},"identifier":"uncurryFirst2Args"},{"annotation":{"meta":null,"sourceSpan":{"end":[21,36],"start":[21,1]}},"bindType":"NonRec","expression":{"annotation":{"meta":null,"sourceSpan":{"end":[22,28],"start":[22,11]}},"type":"Var","value":{"identifier":"uncurryFirst3Args","moduleName":["Golden","Uncurrying","Test"]}},"identifier":"synonym"},{"annotation":{"meta":null,"sourceSpan":{"end":[24,20],"start":[24,1]}},"bindType":"NonRec","expression":{"annotation":{"meta":null,"sourceSpan":{"end":[24,20],"start":[24,1]}},"argument":"i","body":{"abstraction":{"abstraction":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[25,18],"start":[25,11]}},"type":"Var","value":{"identifier":"synonym","moduleName":["Golden","Uncurrying","Test"]}},"annotation":{"meta":null,"sourceSpan":{"end":[25,20],"start":[25,11]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[25,20],"start":[25,19]}},"type":"Literal","value":{"literalType":"IntLiteral","value":1}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[25,22],"start":[25,11]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[25,22],"start":[25,21]}},"type":"Var","value":{"identifier":"i","sourcePos":[25,1]}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[25,24],"start":[25,11]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[25,24],"start":[25,23]}},"type":"Literal","value":{"literalType":"IntLiteral","value":3}},"type":"App"},"type":"Abs"},"identifier":"call5"},{"annotation":{"meta":null,"sourceSpan":{"end":[15,20],"start":[15,1]}},"bindType":"NonRec","expression":{"abstraction":{"abstraction":{"abstraction":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[16,26],"start":[16,9]}},"type":"Var","value":{"identifier":"uncurryFirst4Args","moduleName":["Golden","Uncurrying","Test"]}},"annotation":{"meta":null,"sourceSpan":{"end":[16,28],"start":[16,9]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[16,28],"start":[16,27]}},"type":"Literal","value":{"literalType":"IntLiteral","value":1}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[16,30],"start":[16,9]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[16,30],"start":[16,29]}},"type":"Literal","value":{"literalType":"IntLiteral","value":2}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[16,32],"start":[16,9]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[16,32],"start":[16,31]}},"type":"Literal","value":{"literalType":"IntLiteral","value":3}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[16,48],"start":[16,9]}},"argument":{"abstraction":{"abstraction":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[16,41],"start":[16,34]}},"type":"Var","value":{"identifier":"synonym","moduleName":["Golden","Uncurrying","Test"]}},"annotation":{"meta":null,"sourceSpan":{"end":[16,43],"start":[16,34]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[16,43],"start":[16,42]}},"type":"Literal","value":{"literalType":"IntLiteral","value":4}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[16,45],"start":[16,34]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[16,45],"start":[16,44]}},"type":"Literal","value":{"literalType":"IntLiteral","value":5}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[16,47],"start":[16,34]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[16,47],"start":[16,46]}},"type":"Literal","value":{"literalType":"IntLiteral","value":6}},"type":"App"},"type":"App"},"identifier":"call4"},{"annotation":{"meta":null,"sourceSpan":{"end":[9,13],"start":[9,1]}},"bindType":"NonRec","expression":{"abstraction":{"abstraction":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[10,26],"start":[10,9]}},"type":"Var","value":{"identifier":"uncurryFirst2Args","moduleName":["Golden","Uncurrying","Test"]}},"annotation":{"meta":null,"sourceSpan":{"end":[10,28],"start":[10,9]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[10,28],"start":[10,27]}},"type":"Literal","value":{"literalType":"IntLiteral","value":2}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[10,34],"start":[10,9]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[10,34],"start":[10,29]}},"type":"Literal","value":{"literalType":"BooleanLiteral","value":false}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[10,38],"start":[10,9]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[10,38],"start":[10,35]}},"type":"Literal","value":{"literalType":"CharLiteral","value":"a"}},"type":"App"},"identifier":"call3"},{"annotation":{"meta":null,"sourceSpan":{"end":[6,21],"start":[6,1]}},"bindType":"NonRec","expression":{"abstraction":{"abstraction":{"annotation":{"meta":null,"sourceSpan":{"end":[7,26],"start":[7,9]}},"type":"Var","value":{"identifier":"uncurryFirst2Args","moduleName":["Golden","Uncurrying","Test"]}},"annotation":{"meta":null,"sourceSpan":{"end":[7,28],"start":[7,9]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[7,28],"start":[7,27]}},"type":"Literal","value":{"literalType":"IntLiteral","value":1}},"type":"App"},"annotation":{"meta":null,"sourceSpan":{"end":[7,33],"start":[7,9]}},"argument":{"annotation":{"meta":null,"sourceSpan":{"end":[7,33],"start":[7,29]}},"type":"Literal","value":{"literalType":"BooleanLiteral","value":true}},"type":"App"},"identifier":"call2"}],"exports":["call2","call3","call4","call5"],"foreign":[],"imports":[{"annotation":{"meta":null,"sourceSpan":{"end":[25,24],"start":[1,1]}},"moduleName":["Golden","Uncurrying","Test"]},{"annotation":{"meta":null,"sourceSpan":{"end":[25,24],"start":[1,1]}},"moduleName":["Prim"]}],"moduleName":["Golden","Uncurrying","Test"],"modulePath":"golden/Golden/Uncurrying/Test.purs","reExports":{},"sourceSpan":{"end":[25,24],"start":[1,1]}} \ No newline at end of file diff --git a/test/ps/output/Golden.Uncurrying.Test/golden.ir b/test/ps/output/Golden.Uncurrying.Test/golden.ir new file mode 100644 index 0000000..1ddae8a --- /dev/null +++ b/test/ps/output/Golden.Uncurrying.Test/golden.ir @@ -0,0 +1,36 @@ +UberModule + { uberModuleBindings = + [ Standalone + ( QName + { qnameModuleName = ModuleName "Golden.Uncurrying.Test", qnameName = Name "uncurryFirst2Args" + }, Abs Nothing + ( ParamNamed Nothing ( Name "i" ) ) + ( Abs Nothing ( ParamUnused Nothing ) + ( Abs Nothing ( ParamUnused Nothing ) ( Ref Nothing ( Local ( Name "i" ) ) 0 ) ) + ) + ) + ], uberModuleForeigns = [], uberModuleExports = + [ + ( Name "call2", App Nothing + ( App Nothing + ( Ref Nothing + ( Imported ( ModuleName "Golden.Uncurrying.Test" ) ( Name "uncurryFirst2Args" ) ) 0 + ) + ( LiteralInt Nothing 1 ) + ) ( LiteralBool Nothing True ) + ), + ( Name "call3", App Nothing + ( App Nothing + ( App Nothing + ( Ref Nothing + ( Imported ( ModuleName "Golden.Uncurrying.Test" ) ( Name "uncurryFirst2Args" ) ) 0 + ) + ( LiteralInt Nothing 2 ) + ) ( LiteralBool Nothing False ) + ) + ( LiteralChar Nothing 'a' ) + ), + ( Name "call4", Abs Nothing ( ParamUnused Nothing ) ( LiteralInt Nothing 1 ) ), + ( Name "call5", Abs Nothing ( ParamUnused Nothing ) ( LiteralInt Nothing 3 ) ) + ] + } \ No newline at end of file diff --git a/test/ps/output/Golden.Uncurrying.Test/golden.lua b/test/ps/output/Golden.Uncurrying.Test/golden.lua new file mode 100644 index 0000000..d3f2c1d --- /dev/null +++ b/test/ps/output/Golden.Uncurrying.Test/golden.lua @@ -0,0 +1,10 @@ +local M = {} +M.Golden_Uncurrying_Test_uncurryFirst2Args = function(i) + return function() return i end +end +return { + call2 = M.Golden_Uncurrying_Test_uncurryFirst2Args(1, true), + call3 = M.Golden_Uncurrying_Test_uncurryFirst2Args(2, false)("a"), + call4 = function() return 1 end, + call5 = function() return 3 end +}