From 24475c9668b9d8793b3bb7ce5b234ba1f764d800 Mon Sep 17 00:00:00 2001
From: Grzegorz Uriasz <gorbak25@gmail.com>
Date: Sat, 23 Jan 2021 19:14:23 +0100
Subject: [PATCH 01/30] [WIP] Update the build cache after building every
 module

---
 CONTRIBUTORS.md                           |  9 +++++++
 src/Language/PureScript/Make.hs           | 33 +++++++++++++++++++----
 src/Language/PureScript/Make/Actions.hs   |  7 ++++-
 src/Language/PureScript/Make/BuildPlan.hs | 21 ++++++++++++++-
 src/Language/PureScript/Make/Cache.hs     | 19 ++++++++-----
 src/Language/PureScript/Make/Monad.hs     |  6 +++++
 6 files changed, 82 insertions(+), 13 deletions(-)

diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md
index 42f8195216..ca6246b5f6 100644
--- a/CONTRIBUTORS.md
+++ b/CONTRIBUTORS.md
@@ -21,6 +21,7 @@ If you would prefer to use different terms, please use the section below instead
 | [@andyarvanitis](https://github.com/andyarvanitis) | Andy Arvanitis | [MIT license](http://opensource.org/licenses/MIT) |
 | [@anthok88](https://github.com/anthok88) | anthoq88 | MIT license |
 | [@ardumont](https://github.com/ardumont) | Antoine R. Dumont | [MIT license](http://opensource.org/licenses/MIT) |
+| [@arrowd](https://github.com/arrowd) | Gleb Popov | [MIT license](http://opensource.org/licenses/MIT) |
 | [@aspidites](https://github.com/aspidites) | Edwin Marshall | [MIT license](http://opensource.org/licenses/MIT) |
 | [@bagl](https://github.com/bagl) | Petr Vapenka | [MIT license](http://opensource.org/licenses/MIT) |
 | [@balajirrao](https://github.com/balajirrao) | Balaji Rao | MIT license |
@@ -50,6 +51,7 @@ If you would prefer to use different terms, please use the section below instead
 | [@fehrenbach](https://github.com/fehrenbach) | Stefan Fehrenbach | [MIT license](http://opensource.org/licenses/MIT) |
 | [@felixSchl](https://github.com/felixSchl) | Felix Schlitter | [MIT license](http://opensource.org/licenses/MIT) |
 | [@FrigoEU](https://github.com/FrigoEU) | Simon Van Casteren | [MIT license](http://opensource.org/licenses/MIT) |
+| [@fsoikin](https://github.com/fsoikin) | Fyodor Soikin | [MIT license](http://opensource.org/licenses/MIT) |
 | [@garyb](https://github.com/garyb) | Gary Burgess | [MIT license](http://opensource.org/licenses/MIT) |
 | [@hdgarrood](https://github.com/hdgarrood) | Harry Garrood | [MIT license](http://opensource.org/licenses/MIT) |
 | [@houli](https://github.com/houli) | Eoin Houlihan | [MIT license](http://opensource.org/licenses/MIT) |
@@ -67,6 +69,7 @@ If you would prefer to use different terms, please use the section below instead
 | [@legrostdg](https://github.com/legrostdg) | Félix Sipma | [MIT license](http://opensource.org/licenses/MIT) |
 | [@LiamGoodacre](https://github.com/LiamGoodacre) | Liam Goodacre | [MIT license](http://opensource.org/licenses/MIT) |
 | [@lukerandall](https://github.com/lukerandall) | Luke Randall | [MIT license](http://opensource.org/licenses/MIT) |
+| [@lunaris](https://github.com/lunaris) | Will Jones | [MIT license](http://opensource.org/licenses/MIT) |
 | [@matthewleon](https://github.com/matthewleon) | Matthew Leon | [MIT license](http://opensource.org/licenses/MIT) |
 | [@mcoffin](https://github.com/mcoffin) | Matt Coffin | [MIT license](http://opensource.org/licenses/MIT) |
 | [@mhcurylo](https://github.com/mhcurylo) | Mateusz Curylo | [MIT license](http://opensource.org/licenses/MIT) |
@@ -75,6 +78,7 @@ If you would prefer to use different terms, please use the section below instead
 | [@mgmeier](https://github.com/mgmeier) | Michael Gilliland | [MIT license](http://opensource.org/licenses/MIT) |
 | [@michaelficarra](https://github.com/michaelficarra) | Michael Ficarra | [MIT license](http://opensource.org/licenses/MIT) |
 | [@MichaelXavier](https://github.com/MichaelXavier) | Michael Xavier | MIT license |
+| [@milesfrain](https://github.com/milesfrain) | Miles Frain | [MIT license](http://opensource.org/licenses/MIT) |
 | [@mjgpy3](https://github.com/mjgpy3) | Michael Gilliland | [MIT license](http://opensource.org/licenses/MIT) |
 | [@mpietrzak](https://github.com/mpietrzak) | Maciej Pietrzak | [MIT license](http://opensource.org/licenses/MIT) |
 | [@mrhania](https://github.com/mrhania) | Łukasz Hanuszczak | [MIT license](http://opensource.org/licenses/MIT) |
@@ -137,6 +141,9 @@ If you would prefer to use different terms, please use the section below instead
 | [@marcosh](https://github.com/marcosh) | Marco Perone | [MIT license](http://opensource.org/licenses/MIT) |
 | [@matthew-hilty](https://github.com/matthew-hilty) | Matthew Hilty | [MIT license](http://opensource.org/licenses/MIT) |
 | [@woody88](https://github.com/woody88) | Woodson Delhia | [MIT license](http://opensource.org/licenses/MIT) |
+| [@mhmdanas](https://github.com/mhmdanas) | Mohammed Anas | [MIT license](http://opensource.org/licenses/MIT) |
+| [@kl0tl](https://github.com/kl0tl) | Cyril Sobierajewicz | [MIT license](http://opensource.org/licenses/MIT) |
+| [@gorbak25](https://github.com/gorbak25) | Grzegorz Uriasz | [MIT license](http://opensource.org/licenses/MIT) |
 
 ### Contributors using Modified Terms
 
@@ -144,6 +151,7 @@ If you would prefer to use different terms, please use the section below instead
 | :------- | :--- | :------ |
 | [@charleso](https://github.com/charleso) | Charles O'Farrell | My existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright Charles O'Farrell, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). |
 | [@chrissmoak](https://github.com/chrissmoak) | Chris Smoak | My existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright Chris Smoak, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). |
+| [@citizengabe](https://github.com/citizengabe) | Gabe Johnson | All contributions I have or will make using the @citizengabe GitHub account are during employment at [CitizenNet Inc.](#companies) who owns the copyright. All of my existing or future contributions made using the @gabejohnson GitHub account are personal contributions and subject to the terms specified [above](#contributors-using-standard-terms). |
 | [@dylex](https://github.com/dylex) | Dylan Simon | My existing and all future contributions to the PureScript compiler until further notice are Copyright Dylan Simon, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). |
 | [@leighman](http://github.com/leighman) | Jack Leigh | My existing contributions and all future contributions until further notice are Copyright Jack Leigh, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). |
 | [@nagisa](https://github.com/nagisa) | nagisa | I hereby release my [only contribution](https://github.com/purescript/purescript/commit/80287a5d0de619862d3b4cda9c1ee276d18fdcd8) into public domain. |
@@ -153,5 +161,6 @@ If you would prefer to use different terms, please use the section below instead
 
 | Username | Company | Terms |
 | :------- | :--- | :------ |
+| [@citizennet](https://github.com/citizennet) | CitizenNet Inc. | Our existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright CitizenNet Inc., and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@dbenyamin-cn](https://github.com/dbenyamin-cn) |
 | [@slamdata](https://github.com/slamdata) | SlamData, Inc. | Speaking on behalf of SlamData for SlamData employees, our existing contributions and all future contributions to the PureScript compiler are, until further notice, Copyright SlamData Inc., and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - @jdegoes |
 | [@qfpl](https://github.com/qfpl) | qfpl @ Data61 / CSIRO | Our existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright Data61 / CSIRO, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@lightandlight](https://github.com/lightandlight) |
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index dfee03bd5a..e1f00ac143 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -138,12 +138,17 @@ make ma@MakeActions{..} ms = do
   (sorted, graph) <- sortModules (moduleSignature . CST.resPartial) ms
 
   (buildPlan, newCacheDb) <- BuildPlan.construct ma cacheDb (sorted, graph)
+  -- Fork and let a separate thread handle the cache
+  rChan <- C.newChan
+  buildPlan' <- BuildPlan.setResultChannel buildPlan (Just rChan)
+  doneMVar <- C.newEmptyMVar
+  _ <- fork $ handleCache rChan cacheDb newCacheDb doneMVar
 
-  let toBeRebuilt = filter (BuildPlan.needsRebuild buildPlan . getModuleName . CST.resPartial) sorted
+  let toBeRebuilt = filter (BuildPlan.needsRebuild buildPlan' . getModuleName . CST.resPartial) sorted
   for_ toBeRebuilt $ \m -> fork $ do
     let moduleName = getModuleName . CST.resPartial $ m
     let deps = fromMaybe (internalError "make: module not found in dependency graph.") (lookup moduleName graph)
-    buildModule buildPlan moduleName
+    buildModule buildPlan' moduleName
       (spanName . getModuleSourceSpan . CST.resPartial $ m)
       (importPrim <$> CST.resFull m)
       (deps `inOrderOf` map (getModuleName . CST.resPartial) sorted)
@@ -159,10 +164,12 @@ make ma@MakeActions{..} ms = do
         BuildJobSkipped ->
           Left mempty
     in
-      M.mapEither splitResults <$> BuildPlan.collectResults buildPlan
+      M.mapEither splitResults <$> BuildPlan.collectResults buildPlan'
 
-  -- Write the updated build cache database to disk
-  writeCacheDb $ Cache.removeModules (M.keysSet failures) newCacheDb
+  -- Notify the cache handler that we are done
+  _ <- BuildPlan.setResultChannel buildPlan' Nothing
+  -- And wait for it to save everything
+  _ <- C.takeMVar doneMVar
 
   -- If generating docs, also generate them for the Prim modules
   outputPrimDocs
@@ -237,6 +244,22 @@ make ma@MakeActions{..} ms = do
 
     BuildPlan.markComplete buildPlan moduleName result
 
+  handleCache :: ResultChannel -> Cache.CacheDb -> Cache.CacheDb -> MVar () -> m ()
+  handleCache rChan curDB finalDB doneMVar = do
+    r <- readChan rChan
+    case r of
+      Nothing -> do -- We are done
+        C.putMVar doneMVar ()
+        return ()
+      Just (mn, BuildJobSucceeded _ _) -> do -- Job succeeded - update cache key
+        let newDB = Cache.updateModule mn curDB finalDB
+        writeCacheDb newDB
+        handleCache rChan newDB finalDB doneMVar
+      Just (mn, _) -> do -- Job failed - remove cache key
+        let newDB = Cache.removeModule mn curDB
+        writeCacheDb newDB
+        handleCache rChan newDB finalDB doneMVar
+
 -- | Infer the module name for a module by looking for the same filename with
 -- a .js extension.
 inferForeignModules
diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs
index 8b6b367613..bf3498bd83 100644
--- a/src/Language/PureScript/Make/Actions.hs
+++ b/src/Language/PureScript/Make/Actions.hs
@@ -156,7 +156,12 @@ writeCacheDb'
   -> CacheDb
   -- ^ The CacheDb to be written
   -> m ()
-writeCacheDb' = writeJSONFile . cacheDbFile
+writeCacheDb' dir db = do
+    writeJSONFile file_tmp db
+    renameFile file_tmp file
+  where
+    file = cacheDbFile dir
+    file_tmp = file ++ ".tmp"
 
 -- | A set of make actions that read and write modules from the given directory.
 buildMakeActions
diff --git a/src/Language/PureScript/Make/BuildPlan.hs b/src/Language/PureScript/Make/BuildPlan.hs
index a8b0bfbab8..9168f77ccc 100644
--- a/src/Language/PureScript/Make/BuildPlan.hs
+++ b/src/Language/PureScript/Make/BuildPlan.hs
@@ -1,10 +1,12 @@
 module Language.PureScript.Make.BuildPlan
   ( BuildPlan(bpEnv)
   , BuildJobResult(..)
+  , ResultChannel
   , buildJobSuccess
   , buildJobFailure
   , construct
   , getResult
+  , setResultChannel
   , collectResults
   , markComplete
   , needsRebuild
@@ -39,8 +41,12 @@ data BuildPlan = BuildPlan
   { bpPrebuilt :: M.Map ModuleName Prebuilt
   , bpBuildJobs :: M.Map ModuleName BuildJob
   , bpEnv :: C.MVar Env
+  , bpResultChan :: Maybe ResultChannel
+  -- ^^ Optional channel for reporting build results, By sending Nothing we indicate that the build is done
   }
 
+type ResultChannel = C.Chan (Maybe (ModuleName, BuildJobResult))
+
 data Prebuilt = Prebuilt
   { pbModificationTime :: UTCTime
   , pbExternsFile :: ExternsFile
@@ -93,6 +99,9 @@ markComplete
   -> m ()
 markComplete buildPlan moduleName result = do
   let BuildJob rVar = fromMaybe (internalError "make: markComplete no barrier") $ M.lookup moduleName (bpBuildJobs buildPlan)
+  case bpResultChan buildPlan of
+    Just chan -> writeChan chan $ Just (moduleName, result)
+    Nothing -> return ()
   putMVar rVar result
 
 -- | Whether or not the module with the given ModuleName needs to be rebuilt
@@ -146,7 +155,7 @@ construct MakeActions{..} cacheDb (sorted, graph) = do
   buildJobs <- foldM makeBuildJob M.empty toBeRebuilt
   env <- C.newMVar primEnv
   pure
-    ( BuildPlan prebuilt buildJobs env
+    ( BuildPlan prebuilt buildJobs env Nothing
     , let
         update = flip $ \s ->
           M.alter (const (statusNewCacheInfo s)) (statusModuleName s)
@@ -214,6 +223,16 @@ construct MakeActions{..} cacheDb (sorted, graph) = do
                   prev
                 _ -> M.insert moduleName pb prev
 
+setResultChannel :: forall m. (Monad m, MonadBaseControl IO m)
+                    => BuildPlan
+                    -> Maybe ResultChannel
+                    -> m BuildPlan
+setResultChannel bp chan = do
+  case bpResultChan bp of
+    Just oldChan -> writeChan oldChan Nothing
+    Nothing -> return ()
+  pure $ bp { bpResultChan = chan }
+
 maximumMaybe :: Ord a => [a] -> Maybe a
 maximumMaybe [] = Nothing
 maximumMaybe xs = Just $ maximum xs
diff --git a/src/Language/PureScript/Make/Cache.hs b/src/Language/PureScript/Make/Cache.hs
index bfc3e4c7f8..9eb2002958 100644
--- a/src/Language/PureScript/Make/Cache.hs
+++ b/src/Language/PureScript/Make/Cache.hs
@@ -6,7 +6,8 @@ module Language.PureScript.Make.Cache
   , CacheDb
   , CacheInfo(..)
   , checkChanged
-  , removeModules
+  , removeModule
+  , updateModule
   , normaliseForCache
   ) where
 
@@ -24,7 +25,6 @@ import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Maybe (fromMaybe)
 import Data.Monoid (All(..))
-import Data.Set (Set)
 import Data.Text (Text)
 import Data.Text.Encoding (encodeUtf8, decodeUtf8)
 import Data.These (These(..))
@@ -128,10 +128,17 @@ checkChanged cacheDb mn basePath currentInfo = do
 
   pure (CacheInfo newInfo, getAll isUpToDate)
 
--- | Remove any modules from the given set from the cache database; used when
--- they failed to build.
-removeModules :: Set ModuleName -> CacheDb -> CacheDb
-removeModules moduleNames = flip Map.withoutKeys moduleNames
+-- | Removes the given module from the cache database; used when
+-- it failed to build.
+removeModule :: ModuleName -> CacheDb -> CacheDb
+removeModule = Map.delete
+
+-- | Moves cache info between databases; used when a module was built successfully
+updateModule :: ModuleName -> CacheDb -> CacheDb -> CacheDb
+updateModule mn cur new =
+  case Map.lookup mn new of
+    Just r -> Map.insert mn r cur
+    Nothing -> Map.delete mn cur
 
 -- | 1. Any path that is beneath our current working directory will be
 -- stored as a normalised relative path
diff --git a/src/Language/PureScript/Make/Monad.hs b/src/Language/PureScript/Make/Monad.hs
index 0f5aad1b03..72048f3285 100644
--- a/src/Language/PureScript/Make/Monad.hs
+++ b/src/Language/PureScript/Make/Monad.hs
@@ -19,6 +19,7 @@ module Language.PureScript.Make.Monad
   , writeCborFile
   , writeCborFileIO
   , copyFile
+  , renameFile
   ) where
 
 import           Prelude
@@ -186,5 +187,10 @@ copyFile src dest =
     createParentDirectory dest
     Directory.copyFile src dest
 
+renameFile :: (MonadIO m, MonadError MultipleErrors m) => FilePath -> FilePath -> m ()
+renameFile src dest =
+  makeIO ("rename file: " <> Text.pack src <> " -> " <> Text.pack dest) $ do
+    Directory.renameFile src dest
+
 createParentDirectory :: FilePath -> IO ()
 createParentDirectory = createDirectoryIfMissing True . takeDirectory

From 6c818092875b57365c343fde1ec93140236332e6 Mon Sep 17 00:00:00 2001
From: radrow <radrowicki@gmail.com>
Date: Fri, 29 Jan 2021 14:26:40 +0100
Subject: [PATCH 02/30] Aggressive TCO

---
 .../PureScript/CoreImp/Optimizer/TCO.hs       | 57 ++++++++-----------
 1 file changed, 25 insertions(+), 32 deletions(-)

diff --git a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs
index 5f2123ced6..200f4bb1f7 100644
--- a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs
+++ b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs
@@ -6,7 +6,7 @@ import Prelude.Compat
 import Control.Applicative (empty, liftA2)
 import Control.Monad (guard)
 import Control.Monad.State (State, evalState, get, modify)
-import Data.Foldable (foldr)
+import Data.Foldable (foldr, fold)
 import Data.Functor (($>), (<&>))
 import qualified Data.Set as S
 import Data.Text (Text, pack)
@@ -15,6 +15,8 @@ import Language.PureScript.CoreImp.AST
 import Language.PureScript.AST.SourcePos (SourceSpan)
 import Safe (headDef, tailSafe)
 
+import Debug.Trace
+
 -- | Eliminate tail calls
 tco :: AST -> AST
 tco = flip evalState 0 . everywhereTopDownM convert where
@@ -37,7 +39,7 @@ tco = flip evalState 0 . everywhereTopDownM convert where
   convert :: AST -> State Int AST
   convert (VariableIntroduction ss name (Just fn@Function {}))
       | Just trFns <- findTailRecursiveFns name arity body'
-      = VariableIntroduction ss name . Just . replace <$> toLoop trFns name arity outerArgs innerArgs body'
+      = trace ("TCO APPLIED FOR " <> show name) $ VariableIntroduction ss name . Just . replace <$> toLoop trFns name arity outerArgs innerArgs body'
     where
       innerArgs = headDef [] argss
       outerArgs = concat . reverse $ tailSafe argss
@@ -45,6 +47,7 @@ tco = flip evalState 0 . everywhereTopDownM convert where
       -- ^ this is the number of calls, not the number of arguments, if there's
       -- ever a practical difference.
       (argss, body', replace) = topCollectAllFunctionArgs [] id fn
+  convert js@(VariableIntroduction ss name (Just fn@Function {})) = trace ("NO TCO FOR " <> show name) $ pure js
   convert js = pure js
 
   rewriteFunctionsWith :: ([Text] -> [Text]) -> [[Text]] -> (AST -> AST) -> AST -> ([[Text]], AST, AST -> AST)
@@ -93,39 +96,29 @@ tco = flip evalState 0 . everywhereTopDownM convert where
   -- identifier to be considered in tail position (or Nothing if this
   -- identifier is used somewhere not as a tail call with full arity).
   findTailPositionDeps :: (Text, Int) -> AST -> Maybe (S.Set (Text, Int))
-  findTailPositionDeps (ident, arity) js = allInTailPosition js where
-    countSelfReferences = countReferences ident
-
-    allInTailPosition (Return _ expr)
-      | isSelfCall ident arity expr = guard (countSelfReferences expr == 1) $> S.empty
-      | otherwise = guard (countSelfReferences expr == 0) $> S.empty
-    allInTailPosition (While _ js1 body)
-      = guard (countSelfReferences js1 == 0) *> allInTailPosition body
-    allInTailPosition (For _ _ js1 js2 body)
-      = guard (countSelfReferences js1 == 0 && countSelfReferences js2 == 0) *> allInTailPosition body
-    allInTailPosition (ForIn _ _ js1 body)
-      = guard (countSelfReferences js1 == 0) *> allInTailPosition body
-    allInTailPosition (IfElse _ js1 body el)
-      = guard (countSelfReferences js1 == 0) *> liftA2 mappend (allInTailPosition body) (foldMapA allInTailPosition el)
-    allInTailPosition (Block _ body)
-      = foldMapA allInTailPosition body
-    allInTailPosition (Throw _ js1)
-      = guard (countSelfReferences js1 == 0) $> S.empty
-    allInTailPosition (ReturnNoResult _)
-      = pure S.empty
-    allInTailPosition (VariableIntroduction _ _ Nothing)
-      = pure S.empty
-    allInTailPosition (VariableIntroduction _ ident' (Just js1))
-      | countSelfReferences js1 == 0 = pure S.empty
+  findTailPositionDeps (ident, arity) js = anyInTailPosition js where
+
+    anyInTailPosition :: AST -> Maybe (S.Set (Text, Int))
+    anyInTailPosition (Return _ expr) | isSelfCall ident arity expr =
+                                          trace "FOUND SOME DUDE" $  pure S.empty
+    anyInTailPosition (While _ _ body)
+      = anyInTailPosition body
+    anyInTailPosition (For _ _ _ _ body)
+      = anyInTailPosition body
+    anyInTailPosition (ForIn _ _ _ body)
+      = anyInTailPosition body
+    anyInTailPosition (IfElse _ _ body el)
+      = (anyInTailPosition body) <> (foldMap anyInTailPosition el)
+    anyInTailPosition (Block _ body)
+      = foldMap anyInTailPosition body
+    anyInTailPosition (VariableIntroduction _ ident' (Just js1))
       | Function _ Nothing _ _ <- js1
       , (argss, body, _) <- innerCollectAllFunctionArgs [] id js1
-        = S.insert (ident', length argss) <$> allInTailPosition body
+        = S.insert (ident', length argss) <$> anyInTailPosition body
       | otherwise = empty
-    allInTailPosition (Assignment _ _ js1)
-      = guard (countSelfReferences js1 == 0) $> S.empty
-    allInTailPosition (Comment _ _ js1)
-      = allInTailPosition js1
-    allInTailPosition _
+    anyInTailPosition (Comment _ _ js1)
+      = anyInTailPosition js1
+    anyInTailPosition _
       = empty
 
   toLoop :: S.Set Text -> Text -> Int -> [Text] -> [Text] -> AST -> State Int AST

From 79729e9f06e3fe857643093170c5983ff779d27b Mon Sep 17 00:00:00 2001
From: radrow <radrowicki@gmail.com>
Date: Wed, 3 Feb 2021 12:54:23 +0100
Subject: [PATCH 03/30] Optims

---
 package.yaml                                  |  2 +-
 src/Language/PureScript/AST/Traversals.hs     | 67 ++++++++++---------
 src/Language/PureScript/CodeGen/JS.hs         |  6 +-
 src/Language/PureScript/CoreFn/Traversals.hs  | 24 ++++---
 src/Language/PureScript/CoreImp/Optimizer.hs  |  7 +-
 .../PureScript/CoreImp/Optimizer/TCO.hs       | 22 ++----
 src/Language/PureScript/Make.hs               | 12 ++--
 src/Language/PureScript/Make/Actions.hs       |  5 +-
 .../PureScript/Sugar/BindingGroups.hs         | 24 ++++---
 9 files changed, 91 insertions(+), 78 deletions(-)

diff --git a/package.yaml b/package.yaml
index 3840ebb5b6..857c66b3f0 100644
--- a/package.yaml
+++ b/package.yaml
@@ -102,7 +102,7 @@ build-tools:
 
 library:
   source-dirs: src
-  ghc-options: -Wall -O2
+  ghc-options: -Wall -O3
   other-modules: Paths_purescript
   default-extensions:
     - ConstraintKinds
diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs
index 4aaeeecad7..83dda247d0 100644
--- a/src/Language/PureScript/AST/Traversals.hs
+++ b/src/Language/PureScript/AST/Traversals.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE Strict #-}
 -- |
 -- AST traversal helpers
 --
@@ -8,7 +9,7 @@ import Prelude.Compat
 import Control.Monad
 
 import Data.Foldable (fold)
-import Data.List (mapAccumL)
+import Data.List (mapAccumL, foldl')
 import Data.Maybe (mapMaybe)
 import qualified Data.List.NonEmpty as NEL
 import qualified Data.Map as M
@@ -273,11 +274,11 @@ everythingOnValues (<>.) f g h i j = (f', g', h', i', j')
   where
 
   f' :: Declaration -> r
-  f' d@(DataBindingGroupDeclaration ds) = foldl (<>.) (f d) (fmap f' ds)
-  f' d@(ValueDeclaration vd) = foldl (<>.) (f d) (fmap h' (valdeclBinders vd) ++ concatMap (\(GuardedExpr grd v) -> fmap k' grd ++ [g' v]) (valdeclExpression vd))
-  f' d@(BindingGroupDeclaration ds) = foldl (<>.) (f d) (fmap (\(_, _, val) -> g' val) ds)
-  f' d@(TypeClassDeclaration _ _ _ _ _ ds) = foldl (<>.) (f d) (fmap f' ds)
-  f' d@(TypeInstanceDeclaration _ _ _ _ _ _ _ (ExplicitInstance ds)) = foldl (<>.) (f d) (fmap f' ds)
+  f' d@(DataBindingGroupDeclaration ds) = foldl' (<>.) (f d) (fmap f' ds)
+  f' d@(ValueDeclaration vd) = foldl' (<>.) (f d) (fmap h' (valdeclBinders vd) ++ concatMap (\(GuardedExpr grd v) -> fmap k' grd ++ [g' v]) (valdeclExpression vd))
+  f' d@(BindingGroupDeclaration ds) = foldl' (<>.) (f d) (fmap (\(_, _, val) -> g' val) ds)
+  f' d@(TypeClassDeclaration _ _ _ _ _ ds) = foldl' (<>.) (f d) (fmap f' ds)
+  f' d@(TypeInstanceDeclaration _ _ _ _ _ _ _ (ExplicitInstance ds)) = foldl' (<>.) (f d) (fmap f' ds)
   f' d@(BoundValueDeclaration _ b expr) = f d <>. h' b <>. g' expr
   f' d = f d
 
@@ -288,23 +289,23 @@ everythingOnValues (<>.) f g h i j = (f', g', h', i', j')
   g' v@(Parens v1) = g v <>. g' v1
   g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <>. g' v1
   g' v@(Accessor _ v1) = g v <>. g' v1
-  g' v@(ObjectUpdate obj vs) = foldl (<>.) (g v <>. g' obj) (fmap (g' . snd) vs)
-  g' v@(ObjectUpdateNested obj vs) = foldl (<>.) (g v <>. g' obj) (fmap g' vs)
+  g' v@(ObjectUpdate obj vs) = foldl' (<>.) (g v <>. g' obj) (fmap (g' . snd) vs)
+  g' v@(ObjectUpdateNested obj vs) = foldl' (<>.) (g v <>. g' obj) (fmap g' vs)
   g' v@(Abs b v1) = g v <>. h' b <>. g' v1
   g' v@(App v1 v2) = g v <>. g' v1 <>. g' v2
   g' v@(Unused v1) = g v <>. g' v1
   g' v@(IfThenElse v1 v2 v3) = g v <>. g' v1 <>. g' v2 <>. g' v3
-  g' v@(Case vs alts) = foldl (<>.) (foldl (<>.) (g v) (fmap g' vs)) (fmap i' alts)
+  g' v@(Case vs alts) = foldl' (<>.) (foldl' (<>.) (g v) (fmap g' vs)) (fmap i' alts)
   g' v@(TypedValue _ v1 _) = g v <>. g' v1
-  g' v@(Let _ ds v1) = foldl (<>.) (g v) (fmap f' ds) <>. g' v1
-  g' v@(Do _ es) = foldl (<>.) (g v) (fmap j' es)
-  g' v@(Ado _ es v1) = foldl (<>.) (g v) (fmap j' es) <>. g' v1
+  g' v@(Let _ ds v1) = foldl' (<>.) (g v) (fmap f' ds) <>. g' v1
+  g' v@(Do _ es) = foldl' (<>.) (g v) (fmap j' es)
+  g' v@(Ado _ es v1) = foldl' (<>.) (g v) (fmap j' es) <>. g' v1
   g' v@(PositionedValue _ _ v1) = g v <>. g' v1
   g' v = g v
 
   h' :: Binder -> r
   h' b@(LiteralBinder _ l) = lit (h b) h' l
-  h' b@(ConstructorBinder _ _ bs) = foldl (<>.) (h b) (fmap h' bs)
+  h' b@(ConstructorBinder _ _ bs) = foldl' (<>.) (h b) (fmap h' bs)
   h' b@(BinaryNoParensBinder b1 b2 b3) = h b <>. h' b1 <>. h' b2 <>. h' b3
   h' b@(ParensInBinder b1) = h b <>. h' b1
   h' b@(NamedBinder _ _ b1) = h b <>. h' b1
@@ -313,18 +314,18 @@ everythingOnValues (<>.) f g h i j = (f', g', h', i', j')
   h' b = h b
 
   lit :: r -> (a -> r) -> Literal a -> r
-  lit r go (ArrayLiteral as) = foldl (<>.) r (fmap go as)
-  lit r go (ObjectLiteral as) = foldl (<>.) r (fmap (go . snd) as)
+  lit r go (ArrayLiteral as) = foldl' (<>.) r (fmap go as)
+  lit r go (ObjectLiteral as) = foldl' (<>.) r (fmap (go . snd) as)
   lit r _ _ = r
 
   i' :: CaseAlternative -> r
   i' ca@(CaseAlternative bs gs) =
-    foldl (<>.) (i ca) (fmap h' bs ++ concatMap (\(GuardedExpr grd val) -> fmap k' grd ++ [g' val]) gs)
+    foldl' (<>.) (i ca) (fmap h' bs ++ concatMap (\(GuardedExpr grd val) -> fmap k' grd ++ [g' val]) gs)
 
   j' :: DoNotationElement -> r
   j' e@(DoNotationValue v) = j e <>. g' v
   j' e@(DoNotationBind b v) = j e <>. h' b <>. g' v
-  j' e@(DoNotationLet ds) = foldl (<>.) (j e) (fmap f' ds)
+  j' e@(DoNotationLet ds) = foldl' (<>.) (j e) (fmap f' ds)
   j' e@(PositionedDoNotationElement _ _ e1) = j e <>. j' e1
 
   k' :: Guard -> r
@@ -353,11 +354,11 @@ everythingWithContextOnValues s0 r0 (<>.) f g h i j = (f'' s0, g'' s0, h'' s0, i
   f'' s d = let (s', r) = f s d in r <>. f' s' d
 
   f' :: s -> Declaration -> r
-  f' s (DataBindingGroupDeclaration ds) = foldl (<>.) r0 (fmap (f'' s) ds)
-  f' s (ValueDeclaration vd) = foldl (<>.) r0 (fmap (h'' s) (valdeclBinders vd) ++ concatMap (\(GuardedExpr grd v) -> fmap (k' s) grd ++ [g'' s v]) (valdeclExpression vd))
-  f' s (BindingGroupDeclaration ds) = foldl (<>.) r0 (fmap (\(_, _, val) -> g'' s val) ds)
-  f' s (TypeClassDeclaration _ _ _ _ _ ds) = foldl (<>.) r0 (fmap (f'' s) ds)
-  f' s (TypeInstanceDeclaration _ _ _ _ _ _ _ (ExplicitInstance ds)) = foldl (<>.) r0 (fmap (f'' s) ds)
+  f' s (DataBindingGroupDeclaration ds) = foldl' (<>.) r0 (fmap (f'' s) ds)
+  f' s (ValueDeclaration vd) = foldl' (<>.) r0 (fmap (h'' s) (valdeclBinders vd) ++ concatMap (\(GuardedExpr grd v) -> fmap (k' s) grd ++ [g'' s v]) (valdeclExpression vd))
+  f' s (BindingGroupDeclaration ds) = foldl' (<>.) r0 (fmap (\(_, _, val) -> g'' s val) ds)
+  f' s (TypeClassDeclaration _ _ _ _ _ ds) = foldl' (<>.) r0 (fmap (f'' s) ds)
+  f' s (TypeInstanceDeclaration _ _ _ _ _ _ _ (ExplicitInstance ds)) = foldl' (<>.) r0 (fmap (f'' s) ds)
   f' _ _ = r0
 
   g'' :: s -> Expr -> r
@@ -370,17 +371,17 @@ everythingWithContextOnValues s0 r0 (<>.) f g h i j = (f'' s0, g'' s0, h'' s0, i
   g' s (Parens v1) = g'' s v1
   g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1
   g' s (Accessor _ v1) = g'' s v1
-  g' s (ObjectUpdate obj vs) = foldl (<>.) (g'' s obj) (fmap (g'' s . snd) vs)
-  g' s (ObjectUpdateNested obj vs) = foldl (<>.) (g'' s obj) (fmap (g'' s) vs)
+  g' s (ObjectUpdate obj vs) = foldl' (<>.) (g'' s obj) (fmap (g'' s . snd) vs)
+  g' s (ObjectUpdateNested obj vs) = foldl' (<>.) (g'' s obj) (fmap (g'' s) vs)
   g' s (Abs binder v1) = h'' s binder <>. g'' s v1
   g' s (App v1 v2) = g'' s v1 <>. g'' s v2
   g' s (Unused v) = g'' s v
   g' s (IfThenElse v1 v2 v3) = g'' s v1 <>. g'' s v2 <>. g'' s v3
-  g' s (Case vs alts) = foldl (<>.) (foldl (<>.) r0 (fmap (g'' s) vs)) (fmap (i'' s) alts)
+  g' s (Case vs alts) = foldl' (<>.) (foldl' (<>.) r0 (fmap (g'' s) vs)) (fmap (i'' s) alts)
   g' s (TypedValue _ v1 _) = g'' s v1
-  g' s (Let _ ds v1) = foldl (<>.) r0 (fmap (f'' s) ds) <>. g'' s v1
-  g' s (Do _ es) = foldl (<>.) r0 (fmap (j'' s) es)
-  g' s (Ado _ es v1) = foldl (<>.) r0 (fmap (j'' s) es) <>. g'' s v1
+  g' s (Let _ ds v1) = foldl' (<>.) r0 (fmap (f'' s) ds) <>. g'' s v1
+  g' s (Do _ es) = foldl' (<>.) r0 (fmap (j'' s) es)
+  g' s (Ado _ es v1) = foldl' (<>.) r0 (fmap (j'' s) es) <>. g'' s v1
   g' s (PositionedValue _ _ v1) = g'' s v1
   g' _ _ = r0
 
@@ -389,7 +390,7 @@ everythingWithContextOnValues s0 r0 (<>.) f g h i j = (f'' s0, g'' s0, h'' s0, i
 
   h' :: s -> Binder -> r
   h' s (LiteralBinder _ l) = lit h'' s l
-  h' s (ConstructorBinder _ _ bs) = foldl (<>.) r0 (fmap (h'' s) bs)
+  h' s (ConstructorBinder _ _ bs) = foldl' (<>.) r0 (fmap (h'' s) bs)
   h' s (BinaryNoParensBinder b1 b2 b3) = h'' s b1 <>. h'' s b2 <>. h'' s b3
   h' s (ParensInBinder b) = h'' s b
   h' s (NamedBinder _ _ b1) = h'' s b1
@@ -398,15 +399,15 @@ everythingWithContextOnValues s0 r0 (<>.) f g h i j = (f'' s0, g'' s0, h'' s0, i
   h' _ _ = r0
 
   lit :: (s -> a -> r) -> s -> Literal a -> r
-  lit go s (ArrayLiteral as) = foldl (<>.) r0 (fmap (go s) as)
-  lit go s (ObjectLiteral as) = foldl (<>.) r0 (fmap (go s . snd) as)
+  lit go s (ArrayLiteral as) = foldl' (<>.) r0 (fmap (go s) as)
+  lit go s (ObjectLiteral as) = foldl' (<>.) r0 (fmap (go s . snd) as)
   lit _ _ _ = r0
 
   i'' :: s -> CaseAlternative -> r
   i'' s ca = let (s', r) = i s ca in r <>. i' s' ca
 
   i' :: s -> CaseAlternative -> r
-  i' s (CaseAlternative bs gs) = foldl (<>.) r0 (fmap (h'' s) bs ++ concatMap (\(GuardedExpr grd val) -> fmap (k' s) grd ++ [g'' s val]) gs)
+  i' s (CaseAlternative bs gs) = foldl' (<>.) r0 (fmap (h'' s) bs ++ concatMap (\(GuardedExpr grd val) -> fmap (k' s) grd ++ [g'' s val]) gs)
 
   j'' :: s -> DoNotationElement -> r
   j'' s e = let (s', r) = j s e in r <>. j' s' e
@@ -414,7 +415,7 @@ everythingWithContextOnValues s0 r0 (<>.) f g h i j = (f'' s0, g'' s0, h'' s0, i
   j' :: s -> DoNotationElement -> r
   j' s (DoNotationValue v) = g'' s v
   j' s (DoNotationBind b v) = h'' s b <>. g'' s v
-  j' s (DoNotationLet ds) = foldl (<>.) r0 (fmap (f'' s) ds)
+  j' s (DoNotationLet ds) = foldl' (<>.) r0 (fmap (f'' s) ds)
   j' s (PositionedDoNotationElement _ _ e1) = j'' s e1
 
   k' :: s -> Guard -> r
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index f4ee7426bc..9c71773ee2 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -55,15 +55,17 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
     let usedNames = concatMap getNames decls
     let mnLookup = renameImports usedNames imps
     let decls' = renameModules mnLookup decls
+
+
     jsDecls <- mapM bindToJs decls'
     optimized <- traverse (traverse optimize) jsDecls
     let mnReverseLookup = M.fromList $ map (\(origName, (_, safeName)) -> (moduleNameToJs safeName, origName)) $ M.toList mnLookup
     let usedModuleNames = foldMap (foldMap (findModules mnReverseLookup)) optimized
     jsImports <- traverse (importToJs mnLookup)
-      . filter (flip S.member usedModuleNames)
+      . filter (`S.member` usedModuleNames)
       . (\\ (mn : C.primModules)) $ ordNub $ map snd imps
     F.traverse_ (F.traverse_ checkIntegers) optimized
-    comments <- not <$> asks optionsNoComments
+    comments <- asks (not . optionsNoComments)
     let strict = AST.StringLiteral Nothing "use strict"
     let header = if comments && not (null coms) then AST.Comment Nothing coms strict else strict
     let foreign' = [AST.VariableIntroduction Nothing "$foreign" foreign_ | not $ null foreigns || isNothing foreign_]
diff --git a/src/Language/PureScript/CoreFn/Traversals.hs b/src/Language/PureScript/CoreFn/Traversals.hs
index 5415911863..633ae9efb8 100644
--- a/src/Language/PureScript/CoreFn/Traversals.hs
+++ b/src/Language/PureScript/CoreFn/Traversals.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE Strict #-}
 -- |
 -- CoreFn traversal helpers
 --
@@ -5,12 +6,17 @@ module Language.PureScript.CoreFn.Traversals where
 
 import Prelude.Compat
 
+import Data.List(foldl')
 import Control.Arrow (second, (***), (+++))
 
 import Language.PureScript.AST.Literals
 import Language.PureScript.CoreFn.Binders
 import Language.PureScript.CoreFn.Expr
 
+strictMap :: (a -> b) -> [a] -> [b]
+strictMap _ [] = []
+strictMap f (h:t) = (f $! h) : strictMap f t
+
 everywhereOnValues :: (Bind a -> Bind a) ->
                       (Expr a -> Expr a) ->
                       (Binder a -> Binder a) ->
@@ -53,24 +59,24 @@ everythingOnValues :: (r -> r -> r) ->
 everythingOnValues (<>.) f g h i = (f', g', h', i')
   where
   f' b@(NonRec _ _ e) = f b <>. g' e
-  f' b@(Rec es) = foldl (<>.) (f b) (map (g' . snd) es)
+  f' b@(Rec es) = foldl' (<>.) (f b) (map (g' . snd) es)
 
-  g' v@(Literal _ l) = foldl (<>.) (g v) (map g' (extractLiteral l))
+  g' v@(Literal _ l) = foldl' (<>.) (g v) (map g' (extractLiteral l))
   g' v@(Accessor _ _ e1) = g v <>. g' e1
-  g' v@(ObjectUpdate _ obj vs) = foldl (<>.) (g v <>. g' obj) (map (g' . snd) vs)
+  g' v@(ObjectUpdate _ obj vs) = foldl' (<>.) (g v <>. g' obj) (map (g' . snd) vs)
   g' v@(Abs _ _ e1) = g v <>. g' e1
   g' v@(App _ e1 e2) = g v <>. g' e1 <>. g' e2
-  g' v@(Case _ vs alts) = foldl (<>.) (foldl (<>.) (g v) (map g' vs)) (map i' alts)
-  g' v@(Let _ ds e1) = foldl (<>.) (g v) (map f' ds) <>. g' e1
+  g' v@(Case _ vs alts) = foldl' (<>.) (foldl' (<>.) (g v) (map g' vs)) (map i' alts)
+  g' v@(Let _ ds e1) = foldl' (<>.) (g v) (map f' ds) <>. g' e1
   g' v = g v
 
-  h' b@(LiteralBinder _ l) = foldl (<>.) (h b) (map h' (extractLiteral l))
-  h' b@(ConstructorBinder _ _ _ bs) = foldl (<>.) (h b) (map h' bs)
+  h' b@(LiteralBinder _ l) = foldl' (<>.) (h b) (map h' (extractLiteral l))
+  h' b@(ConstructorBinder _ _ _ bs) = foldl' (<>.) (h b) (map h' bs)
   h' b@(NamedBinder _ _ b1) = h b <>. h' b1
   h' b = h b
 
-  i' ca@(CaseAlternative bs (Right val)) = foldl (<>.) (i ca) (map h' bs) <>. g' val
-  i' ca@(CaseAlternative bs (Left gs)) = foldl (<>.) (i ca) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)
+  i' ca@(CaseAlternative bs (Right val)) = foldl' (<>.) (i ca) (map h' bs) <>. g' val
+  i' ca@(CaseAlternative bs (Left gs)) = foldl' (<>.) (i ca) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)
 
   extractLiteral (ArrayLiteral xs) = xs
   extractLiteral (ObjectLiteral xs) = map snd xs
diff --git a/src/Language/PureScript/CoreImp/Optimizer.hs b/src/Language/PureScript/CoreImp/Optimizer.hs
index de92116251..3f7c51b155 100644
--- a/src/Language/PureScript/CoreImp/Optimizer.hs
+++ b/src/Language/PureScript/CoreImp/Optimizer.hs
@@ -30,13 +30,14 @@ import Language.PureScript.CoreImp.Optimizer.MagicDo
 import Language.PureScript.CoreImp.Optimizer.TCO
 import Language.PureScript.CoreImp.Optimizer.Unused
 
+
 -- | Apply a series of optimizer passes to simplified JavaScript code
 optimize :: MonadSupply m => AST -> m AST
 optimize js = do
     js' <- untilFixedPoint (inlineFnComposition . inlineUnsafeCoerce . inlineUnsafePartial . tidyUp . applyAll
       [ inlineCommonValues
       , inlineCommonOperators
-      ]) js
+      ]) js -- DROGIE
     untilFixedPoint (return . tidyUp) . tco . inlineST
       =<< untilFixedPoint (return . magicDoST)
       =<< untilFixedPoint (return . magicDoEff)
@@ -58,5 +59,5 @@ untilFixedPoint :: (Monad m, Eq a) => (a -> m a) -> a -> m a
 untilFixedPoint f = go
   where
   go a = do
-   a' <- f a
-   if a' == a then return a' else go a'
+    a' <- f a
+    if a' == a then return a' else go a'
diff --git a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs
index 200f4bb1f7..4660265b7a 100644
--- a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs
+++ b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs
@@ -3,11 +3,10 @@ module Language.PureScript.CoreImp.Optimizer.TCO (tco) where
 
 import Prelude.Compat
 
-import Control.Applicative (empty, liftA2)
+import Control.Applicative (empty)
 import Control.Monad (guard)
 import Control.Monad.State (State, evalState, get, modify)
-import Data.Foldable (foldr, fold)
-import Data.Functor (($>), (<&>))
+import Data.Functor ((<&>))
 import qualified Data.Set as S
 import Data.Text (Text, pack)
 import qualified Language.PureScript.Constants as C
@@ -15,8 +14,6 @@ import Language.PureScript.CoreImp.AST
 import Language.PureScript.AST.SourcePos (SourceSpan)
 import Safe (headDef, tailSafe)
 
-import Debug.Trace
-
 -- | Eliminate tail calls
 tco :: AST -> AST
 tco = flip evalState 0 . everywhereTopDownM convert where
@@ -39,7 +36,7 @@ tco = flip evalState 0 . everywhereTopDownM convert where
   convert :: AST -> State Int AST
   convert (VariableIntroduction ss name (Just fn@Function {}))
       | Just trFns <- findTailRecursiveFns name arity body'
-      = trace ("TCO APPLIED FOR " <> show name) $ VariableIntroduction ss name . Just . replace <$> toLoop trFns name arity outerArgs innerArgs body'
+      = VariableIntroduction ss name . Just . replace <$> toLoop trFns name arity outerArgs innerArgs body'
     where
       innerArgs = headDef [] argss
       outerArgs = concat . reverse $ tailSafe argss
@@ -47,7 +44,6 @@ tco = flip evalState 0 . everywhereTopDownM convert where
       -- ^ this is the number of calls, not the number of arguments, if there's
       -- ever a practical difference.
       (argss, body', replace) = topCollectAllFunctionArgs [] id fn
-  convert js@(VariableIntroduction ss name (Just fn@Function {})) = trace ("NO TCO FOR " <> show name) $ pure js
   convert js = pure js
 
   rewriteFunctionsWith :: ([Text] -> [Text]) -> [[Text]] -> (AST -> AST) -> AST -> ([[Text]], AST, AST -> AST)
@@ -87,7 +83,7 @@ tco = flip evalState 0 . everywhereTopDownM convert where
       case S.minView required of
         Just (r, required') -> do
           required'' <- findTailPositionDeps r js
-          go (S.insert (fst r) known, required' <> (S.filter (not . (`S.member` known) . fst) required''))
+          go (S.insert (fst r) known, required' <> S.filter (not . (`S.member` known) . fst) required'')
         Nothing ->
           pure known
 
@@ -99,8 +95,7 @@ tco = flip evalState 0 . everywhereTopDownM convert where
   findTailPositionDeps (ident, arity) js = anyInTailPosition js where
 
     anyInTailPosition :: AST -> Maybe (S.Set (Text, Int))
-    anyInTailPosition (Return _ expr) | isSelfCall ident arity expr =
-                                          trace "FOUND SOME DUDE" $  pure S.empty
+    anyInTailPosition (Return _ expr) | isSelfCall ident arity expr = pure S.empty
     anyInTailPosition (While _ _ body)
       = anyInTailPosition body
     anyInTailPosition (For _ _ _ _ body)
@@ -108,7 +103,7 @@ tco = flip evalState 0 . everywhereTopDownM convert where
     anyInTailPosition (ForIn _ _ _ body)
       = anyInTailPosition body
     anyInTailPosition (IfElse _ _ body el)
-      = (anyInTailPosition body) <> (foldMap anyInTailPosition el)
+      = anyInTailPosition body <> foldMap anyInTailPosition el
     anyInTailPosition (Block _ body)
       = foldMap anyInTailPosition body
     anyInTailPosition (VariableIntroduction _ ident' (Just js1))
@@ -162,7 +157,7 @@ tco = flip evalState 0 . everywhereTopDownM convert where
         , Function rootSS (Just tcoLoop) (outerArgs ++ innerArgs) (Block rootSS [loopify js])
         , While rootSS (Unary rootSS Not (Var rootSS tcoDone))
             (Block rootSS
-              [(Assignment rootSS (Var rootSS tcoResult) (App rootSS (Var rootSS tcoLoop) ((map (Var rootSS . tcoVar) outerArgs) ++ (map (Var rootSS . copyVar) innerArgs))))])
+              [Assignment rootSS (Var rootSS tcoResult) (App rootSS (Var rootSS tcoLoop) (map (Var rootSS . tcoVar) outerArgs ++ map (Var rootSS . copyVar) innerArgs))])
         , Return rootSS (Var rootSS tcoResult)
         ]
     where
@@ -184,6 +179,3 @@ tco = flip evalState 0 . everywhereTopDownM convert where
   isSelfCall ident 1 (App _ (Var _ ident') _) = ident == ident'
   isSelfCall ident arity (App _ fn _) = isSelfCall ident (arity - 1) fn
   isSelfCall _ _ _ = False
-
-foldMapA :: (Applicative f, Monoid w, Foldable t) => (a -> f w) -> t a -> f w
-foldMapA f = foldr (liftA2 mappend . f) (pure mempty)
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index e1f00ac143..05007acd82 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -48,6 +48,8 @@ import qualified Language.PureScript.CoreFn as CF
 import           System.Directory (doesFileExist)
 import           System.FilePath (replaceExtension)
 
+import Debug.Trace
+
 -- | Rebuild a single module.
 --
 -- This function is used for fast-rebuild workflows (PSCi and psc-ide are examples).
@@ -92,10 +94,12 @@ rebuildModule' MakeActions{..} exEnv externs m@(Module _ _ moduleName _ _) = do
   (deguarded, nextVar'') <- runSupplyT nextVar' $ do
     desugarCaseGuards elaborated
 
-  progress $ CollapseBindingGroupsModule moduleName
-  regrouped <- createBindingGroups moduleName . collapseBindingGroups $ deguarded
+  seq (last deguarded) $ progress $ CollapseBindingGroupsModule moduleName
+  let collapsed = collapseBindingGroups deguarded
+  seq (last collapsed) $ progress $ CreateBindingGroupsModule moduleName
+  regrouped <- createBindingGroups moduleName collapsed
   let mod' = Module ss coms moduleName regrouped exps
-  progress $ CoreFnGenModule moduleName
+  seq (last regrouped) $ progress $ CoreFnGenModule moduleName
   let corefn = CF.moduleToCoreFn env' mod'
   progress $ CoreFnOptModule moduleName
   let optimized = CF.optimizeCoreFn corefn
@@ -118,7 +122,7 @@ rebuildModule' MakeActions{..} exEnv externs m@(Module _ _ moduleName _ _) = do
                  ++ "; details:\n" ++ prettyPrintMultipleErrors defaultPPEOptions errs
                Right d -> d
 
-  progress $ CodegenModule moduleName
+  seq exts $ progress $ CodegenModule moduleName
   evalSupplyT nextVar'' $ codegen renamed docs exts
   progress $ DoneModule moduleName
   return exts
diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs
index bf3498bd83..64070376c3 100644
--- a/src/Language/PureScript/Make/Actions.hs
+++ b/src/Language/PureScript/Make/Actions.hs
@@ -46,7 +46,6 @@ import           Language.PureScript.Externs (ExternsFile, externsFileName)
 import           Language.PureScript.Make.Monad
 import           Language.PureScript.Make.Cache
 import           Language.PureScript.Names
-import           Language.PureScript.Names (runModuleName, ModuleName)
 import           Language.PureScript.Options hiding (codegenTargets)
 import           Language.PureScript.Pretty.Common (SMap(..))
 import qualified Paths_purescript as Paths
@@ -71,6 +70,7 @@ data ProgressMessage
   | TypeCheckModule ModuleName
   | DesugarCaseGuardsModule ModuleName
   | CollapseBindingGroupsModule ModuleName
+  | CreateBindingGroupsModule ModuleName
   | CoreFnGenModule ModuleName
   | CoreFnOptModule ModuleName
   | FFICodegenModule ModuleName
@@ -88,6 +88,7 @@ renderProgressMessage (DesugarModule mn) = renderPrefixed mn "Desugar module"
 renderProgressMessage (TypeCheckModule mn) = renderPrefixed mn "Typecheck module"
 renderProgressMessage (DesugarCaseGuardsModule mn) = renderPrefixed mn "Desugar case guards"
 renderProgressMessage (CollapseBindingGroupsModule mn) = renderPrefixed mn "Collapse Binding Groups"
+renderProgressMessage (CreateBindingGroupsModule mn) = renderPrefixed mn "Create Binding Groups"
 renderProgressMessage (CoreFnGenModule mn) = renderPrefixed mn "CoreFn gen"
 renderProgressMessage (CoreFnOptModule mn) = renderPrefixed mn "CoreFn opt"
 renderProgressMessage (FFICodegenModule mn) = renderPrefixed mn "Codegen FFI"
@@ -243,7 +244,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
               return $ Just $ Imp.App Nothing (Imp.Var Nothing "require") [Imp.StringLiteral Nothing "./foreign.js"]
         Nothing | requiresForeign m -> throwError . errorMessage' (CF.moduleSourceSpan m) $ MissingFFIModule mn
                 | otherwise -> return Nothing
-      rawJs <- J.moduleToJs m foreignInclude
+      rawJs <- J.moduleToJs m foreignInclude -- DROGIE!
       dir <- lift $ makeIO "get the current directory" getCurrentDirectory
       let sourceMaps = S.member JSSourceMap codegenTargets
           (pjs, mappings) = if sourceMaps then prettyPrintJSWithSourceMaps rawJs else (prettyPrintJS rawJs, [])
diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs
index a4efc201d6..1431e0f6a1 100644
--- a/src/Language/PureScript/Sugar/BindingGroups.hs
+++ b/src/Language/PureScript/Sugar/BindingGroups.hs
@@ -87,22 +87,28 @@ createBindingGroups moduleName = mapM f <=< handleDecls
       extractGuardedExpr [MkUnguarded expr] = expr
       extractGuardedExpr _ = internalError "Expected Guards to have been desugared in handleDecls."
 
+flattenBindingGroups :: [Declaration] -> [Declaration]
+flattenBindingGroups =
+  let go (DataBindingGroupDeclaration ds) = NEL.toList ds
+      go (BindingGroupDeclaration ds) =
+        NEL.toList $ fmap (\((sa, ident), nameKind, val) ->
+                             ValueDecl sa ident nameKind [] [MkUnguarded val]) ds
+      go other = [other]
+  in concatMap go
+
 -- |
 -- Collapse all binding groups to individual declarations
 --
 collapseBindingGroups :: [Declaration] -> [Declaration]
-collapseBindingGroups =
+collapseBindingGroups decls =
   let (f, _, _) = everywhereOnValues id collapseBindingGroupsForValue id
-  in fmap f . concatMap go
-  where
-  go (DataBindingGroupDeclaration ds) = NEL.toList ds
-  go (BindingGroupDeclaration ds) =
-    NEL.toList $ fmap (\((sa, ident), nameKind, val) ->
-      ValueDecl sa ident nameKind [] [MkUnguarded val]) ds
-  go other = [other]
+      gone = flattenBindingGroups decls
+      traversed = fmap f gone
+  in traversed
+
 
 collapseBindingGroupsForValue :: Expr -> Expr
-collapseBindingGroupsForValue (Let w ds val) = Let w (collapseBindingGroups ds) val
+collapseBindingGroupsForValue (Let w ds val) = Let w (flattenBindingGroups ds) val
 collapseBindingGroupsForValue other = other
 
 usedIdents :: ModuleName -> ValueDeclarationData Expr -> [Ident]

From f9e90b6b268183058997702f67d35bef6c55450e Mon Sep 17 00:00:00 2001
From: radrow <radrowicki@gmail.com>
Date: Thu, 4 Feb 2021 11:33:07 +0100
Subject: [PATCH 04/30] More strictness

---
 src/Language/PureScript/AST/Literals.hs            |  1 +
 src/Language/PureScript/AST/Operators.hs           |  1 +
 src/Language/PureScript/CoreFn/Expr.hs             |  1 +
 src/Language/PureScript/CoreImp/AST.hs             | 10 ++++++----
 .../PureScript/CoreImp/Optimizer/Common.hs         | 14 +++++++++++++-
 .../PureScript/CoreImp/Optimizer/Inliner.hs        |  5 +++--
 src/Language/PureScript/Docs/Collect.hs            |  2 ++
 src/Language/PureScript/Pretty/Common.hs           | 10 +++++++---
 8 files changed, 34 insertions(+), 10 deletions(-)

diff --git a/src/Language/PureScript/AST/Literals.hs b/src/Language/PureScript/AST/Literals.hs
index a161fd82ab..5939d3a5f0 100644
--- a/src/Language/PureScript/AST/Literals.hs
+++ b/src/Language/PureScript/AST/Literals.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE Strict #-}
 -- |
 -- The core functional representation for literal values.
 --
diff --git a/src/Language/PureScript/AST/Operators.hs b/src/Language/PureScript/AST/Operators.hs
index 41a129257e..4a73c19990 100644
--- a/src/Language/PureScript/AST/Operators.hs
+++ b/src/Language/PureScript/AST/Operators.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE Strict #-}
 {-# LANGUAGE DeriveGeneric #-}
 -- |
 -- Operators fixity and associativity
diff --git a/src/Language/PureScript/CoreFn/Expr.hs b/src/Language/PureScript/CoreFn/Expr.hs
index 981bf37c0f..de2eb2427d 100644
--- a/src/Language/PureScript/CoreFn/Expr.hs
+++ b/src/Language/PureScript/CoreFn/Expr.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE Strict #-}
 -- |
 -- The core functional representation
 --
diff --git a/src/Language/PureScript/CoreImp/AST.hs b/src/Language/PureScript/CoreImp/AST.hs
index b6dcad1446..7efdc7144f 100644
--- a/src/Language/PureScript/CoreImp/AST.hs
+++ b/src/Language/PureScript/CoreImp/AST.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE Strict #-}
 -- | Data types for the imperative core AST
 module Language.PureScript.CoreImp.AST where
 
@@ -6,6 +7,7 @@ import Prelude.Compat
 import Control.Monad ((>=>))
 import Control.Monad.Identity (Identity(..), runIdentity)
 import Data.Text (Text)
+import Data.List(foldl')
 
 import Language.PureScript.AST (SourceSpan(..))
 import Language.PureScript.Comments
@@ -204,12 +206,12 @@ everything :: (r -> r -> r) -> (AST -> r) -> AST -> r
 everything (<>.) f = go where
   go j@(Unary _ _ j1) = f j <>. go j1
   go j@(Binary _ _ j1 j2) = f j <>. go j1 <>. go j2
-  go j@(ArrayLiteral _ js) = foldl (<>.) (f j) (map go js)
+  go j@(ArrayLiteral _ js) = foldl' (<>.) (f j) (map go js)
   go j@(Indexer _ j1 j2) = f j <>. go j1 <>. go j2
-  go j@(ObjectLiteral _ js) = foldl (<>.) (f j) (map (go . snd) js)
+  go j@(ObjectLiteral _ js) = foldl' (<>.) (f j) (map (go . snd) js)
   go j@(Function _ _ _ j1) = f j <>. go j1
-  go j@(App _ j1 js) = foldl (<>.) (f j <>. go j1) (map go js)
-  go j@(Block _ js) = foldl (<>.) (f j) (map go js)
+  go j@(App _ j1 js) = foldl' (<>.) (f j <>. go j1) (map go js)
+  go j@(Block _ js) = foldl' (<>.) (f j) (map go js)
   go j@(VariableIntroduction _ _ (Just j1)) = f j <>. go j1
   go j@(Assignment _ j1 j2) = f j <>. go j1 <>. go j2
   go j@(While _ j1 j2) = f j <>. go j1 <>. go j2
diff --git a/src/Language/PureScript/CoreImp/Optimizer/Common.hs b/src/Language/PureScript/CoreImp/Optimizer/Common.hs
index 040995cb36..a0b3d695a7 100644
--- a/src/Language/PureScript/CoreImp/Optimizer/Common.hs
+++ b/src/Language/PureScript/CoreImp/Optimizer/Common.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE Strict #-}
 -- | Common functions used by the various optimizer phases
 module Language.PureScript.CoreImp.Optimizer.Common where
 
@@ -11,21 +12,25 @@ import Language.PureScript.Crash
 import Language.PureScript.CoreImp.AST
 import Language.PureScript.PSString (PSString)
 
+{-# INLINE applyAll #-}
 applyAll :: [a -> a] -> a -> a
-applyAll = foldl' (.) id
+applyAll l x = foldl' (flip ($!)) x l
 
+{-# INLINE replaceIdent #-}
 replaceIdent :: Text -> AST -> AST -> AST
 replaceIdent var1 js = everywhere replace
   where
   replace (Var _ var2) | var1 == var2 = js
   replace other = other
 
+{-# INLINE replaceIdents #-}
 replaceIdents :: [(Text, AST)] -> AST -> AST
 replaceIdents vars = everywhere replace
   where
   replace v@(Var _ var) = fromMaybe v $ lookup var vars
   replace other = other
 
+{-# INLINE isReassigned #-}
 isReassigned :: Text -> AST -> Bool
 isReassigned var1 = everything (||) check
   where
@@ -37,12 +42,14 @@ isReassigned var1 = everything (||) check
   check (ForIn _ arg _ _) | var1 == arg = True
   check _ = False
 
+{-# INLINE isRebound #-}
 isRebound :: AST -> AST -> Bool
 isRebound js d = any (\v -> isReassigned v d || isUpdated v d) (everything (++) variablesOf js)
   where
   variablesOf (Var _ var) = [var]
   variablesOf _ = []
 
+{-# INLINE isUsed #-}
 isUsed :: Text -> AST -> Bool
 isUsed var1 = everything (||) check
   where
@@ -51,11 +58,13 @@ isUsed var1 = everything (||) check
   check (Assignment _ target _) | var1 == targetVariable target = True
   check _ = False
 
+{-# INLINE targetVariable #-}
 targetVariable :: AST -> Text
 targetVariable (Var _ var) = var
 targetVariable (Indexer _ _ tgt) = targetVariable tgt
 targetVariable _ = internalError "Invalid argument to targetVariable"
 
+{-# INLINE isUpdated #-}
 isUpdated :: Text -> AST -> Bool
 isUpdated var1 = everything (||) check
   where
@@ -63,14 +72,17 @@ isUpdated var1 = everything (||) check
   check (Assignment _ target _) | var1 == targetVariable target = True
   check _ = False
 
+{-# INLINE removeFromBlock #-}
 removeFromBlock :: ([AST] -> [AST]) -> AST -> AST
 removeFromBlock go (Block ss sts) = Block ss (go sts)
 removeFromBlock _  js = js
 
+{-# INLINE isDict #-}
 isDict :: (Text, PSString) -> AST -> Bool
 isDict (moduleName, dictName) (Indexer _ (StringLiteral _ x) (Var _ y)) =
   x == dictName && y == moduleName
 isDict _ _ = False
 
+{-# INLINE isDict' #-}
 isDict' :: [(Text, PSString)] -> AST -> Bool
 isDict' xs js = any (`isDict` js) xs
diff --git a/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs
index 4b627abd06..6ee7529b9a 100644
--- a/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs
+++ b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE Strict #-}
 -- | This module performs basic inlining of known functions
 module Language.PureScript.CoreImp.Optimizer.Inliner
   ( inlineVariables
@@ -45,7 +46,7 @@ etaConvert = everywhere convert
   convert :: AST -> AST
   convert (Block ss [Return _ (App _ (Function _ Nothing idents block@(Block _ body)) args)])
     | all shouldInline args &&
-      not (any (`isRebound` block) (map (Var Nothing) idents)) &&
+      not (any ((`isRebound` block) . Var Nothing) idents) &&
       not (any (`isRebound` block) args)
       = Block ss (map (replaceIdents (zip idents args)) body)
   convert (Function _ Nothing [] (Block _ [Return _ (App _ fn [])])) = fn
@@ -283,7 +284,7 @@ inlineFnComposition = everywhereTopDownM convert where
   goApps (App _ (App _ (App _ fn [dict']) [x]) [y])
     | isFnCompose dict' fn = mappend <$> goApps x <*> goApps y
     | isFnComposeFlipped dict' fn = mappend <$> goApps y <*> goApps x
-  goApps app@(App {}) = pure . Right . (,app) <$> freshName
+  goApps app@App{} = pure . Right . (,app) <$> freshName
   goApps other = pure [Left other]
 
   isFnCompose :: AST -> AST -> Bool
diff --git a/src/Language/PureScript/Docs/Collect.hs b/src/Language/PureScript/Docs/Collect.hs
index 2c64384d61..3f1926d2b1 100644
--- a/src/Language/PureScript/Docs/Collect.hs
+++ b/src/Language/PureScript/Docs/Collect.hs
@@ -105,6 +105,8 @@ compileForDocs outputDir inputFiles = do
   renderProgressMessage :: P.ProgressMessage -> String
   renderProgressMessage (P.CompilingModule mn) =
     "Compiling documentation for " ++ T.unpack (P.runModuleName mn)
+  renderProgressMessage msg =
+    "Progress: " ++ show msg
 
   testOptions :: P.Options
   testOptions = P.defaultOptions { P.optionsCodegenTargets = Set.singleton P.Docs }
diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs
index 87adc6f3a5..6973caa510 100644
--- a/src/Language/PureScript/Pretty/Common.hs
+++ b/src/Language/PureScript/Pretty/Common.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE Strict #-}
 
 -- |
 -- Common pretty-printing utility functions
@@ -9,7 +10,7 @@ import Prelude.Compat
 
 import Control.Monad.State (StateT, modify, get)
 
-import Data.List (elemIndices, intersperse)
+import Data.List (elemIndices, intersperse, foldl')
 import Data.Text (Text)
 import qualified Data.Text as T
 
@@ -54,14 +55,17 @@ newtype StrPos = StrPos (SourcePos, Text, [SMap])
 -- the length of the left.
 --
 instance Semigroup StrPos where
+  {-# INLINE (<>) #-}
   StrPos (a,b,c) <> StrPos (a',b',c') = StrPos (a `addPos` a', b <> b', c ++ (bumpPos a <$> c'))
 
 instance Monoid StrPos where
+  {-# INLINE mempty #-}
   mempty = StrPos (SourcePos 0 0, "", [])
 
+  {-# INLINE mconcat #-}
   mconcat ms =
     let s' = foldMap (\(StrPos(_, s, _)) -> s) ms
-        (p, maps) = foldl plus (SourcePos 0 0, []) ms
+        (p, maps) = foldl' plus (SourcePos 0 0, []) ms
     in
         StrPos (p, s', concat $ reverse maps)
     where
@@ -108,7 +112,7 @@ addPos (SourcePos n m) (SourcePos 0 m') = SourcePos n (m+m')
 addPos (SourcePos n _) (SourcePos n' m') = SourcePos (n+n') m'
 
 
-data PrinterState = PrinterState { indent :: Int }
+newtype PrinterState = PrinterState { indent :: Int }
 
 emptyPrinterState :: PrinterState
 emptyPrinterState = PrinterState { indent = 0 }

From 2eeca8d927b77d567b214696032dd0e8b8cdab04 Mon Sep 17 00:00:00 2001
From: radrow <radrowicki@gmail.com>
Date: Fri, 5 Feb 2021 11:08:08 +0100
Subject: [PATCH 05/30] Label, Break, Continue. TCO WIP

---
 src/Language/PureScript/CST/Monad.hs          |  1 +
 src/Language/PureScript/CodeGen/JS.hs         |  2 +-
 src/Language/PureScript/CodeGen/JS/Printer.hs | 13 +++--
 src/Language/PureScript/CoreImp/AST.hs        | 30 +++++++++---
 .../PureScript/CoreImp/Optimizer/Common.hs    |  1 +
 .../PureScript/CoreImp/Optimizer/Inliner.hs   |  3 ++
 .../PureScript/CoreImp/Optimizer/MagicDo.hs   |  6 +--
 .../PureScript/CoreImp/Optimizer/TCO.hs       | 47 ++++++++++---------
 tests/TestMake.hs                             |  6 ++-
 9 files changed, 72 insertions(+), 37 deletions(-)

diff --git a/src/Language/PureScript/CST/Monad.hs b/src/Language/PureScript/CST/Monad.hs
index eb7a3be456..39abcf083d 100644
--- a/src/Language/PureScript/CST/Monad.hs
+++ b/src/Language/PureScript/CST/Monad.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE Strict #-}
 module Language.PureScript.CST.Monad where
 
 import Prelude
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 9c71773ee2..44c3253f73 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -325,7 +325,7 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
     jss <- forM binders $ \(CaseAlternative bs result) -> do
       ret <- guardsToJs result
       go valNames ret bs
-    return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (assignments ++ concat jss ++ [AST.Throw Nothing $ failedPatternError valNames])))
+    return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (AST.Label Nothing "xdd" :  assignments ++ concat jss ++ [AST.Throw Nothing $ failedPatternError valNames])))
                    []
     where
       go :: [Text] -> [AST] -> [Binder Ann] -> m [AST]
diff --git a/src/Language/PureScript/CodeGen/JS/Printer.hs b/src/Language/PureScript/CodeGen/JS/Printer.hs
index b69270cdac..a93f3ff2cd 100644
--- a/src/Language/PureScript/CodeGen/JS/Printer.hs
+++ b/src/Language/PureScript/CodeGen/JS/Printer.hs
@@ -73,13 +73,18 @@ literals = mkPattern' match'
     [ return $ emit $ "var " <> ident
     , maybe (return mempty) (fmap (emit " = " <>) . prettyPrintJS') value
     ]
+  match (VariableLetIntroduction _ ident value) = mconcat <$> sequence
+    [ return $ emit $ "let " <> ident
+    , maybe (return mempty) (fmap (emit " = " <>) . prettyPrintJS') value
+    ]
   match (Assignment _ target value) = mconcat <$> sequence
     [ prettyPrintJS' target
     , return $ emit " = "
     , prettyPrintJS' value
     ]
-  match (While _ cond sts) = mconcat <$> sequence
-    [ return $ emit "while ("
+  match (While _ name cond sts) = mconcat <$> sequence
+    [ return $ maybe mempty (emit . (<> ": ")) name
+    , return $ emit "while ("
     , prettyPrintJS' cond
     , return $ emit ") "
     , prettyPrintJS' sts
@@ -98,6 +103,8 @@ literals = mkPattern' match'
     , return $ emit ") "
     , prettyPrintJS' sts
     ]
+  match (Break _ name) = return $ emit "break" <> maybe mempty (emit . (" " <>)) name
+  match (Continue _ name) = return $ emit "continue" <> maybe mempty (emit . (" " <>)) name
   match (IfElse _ cond thens elses) = mconcat <$> sequence
     [ return $ emit "if ("
     , prettyPrintJS' cond
@@ -122,7 +129,7 @@ literals = mkPattern' match'
   match _ = mzero
 
   comment :: (Emit gen) => Comment -> StateT PrinterState Maybe gen
-  comment (LineComment com) = fmap mconcat $ sequence $
+  comment (LineComment com) = fmap mconcat $ sequence
     [ currentIndent
     , return $ emit "//" <> emit com <> emit "\n"
     ]
diff --git a/src/Language/PureScript/CoreImp/AST.hs b/src/Language/PureScript/CoreImp/AST.hs
index 7efdc7144f..68a39fef88 100644
--- a/src/Language/PureScript/CoreImp/AST.hs
+++ b/src/Language/PureScript/CoreImp/AST.hs
@@ -74,14 +74,22 @@ data AST
   -- ^ A block of expressions in braces
   | VariableIntroduction (Maybe SourceSpan) Text (Maybe AST)
   -- ^ A variable introduction and optional initialization
+  | VariableLetIntroduction (Maybe SourceSpan) Text (Maybe AST)
+  -- ^ A let variable introduction and optional initialization
   | Assignment (Maybe SourceSpan) AST AST
   -- ^ A variable assignment
-  | While (Maybe SourceSpan) AST AST
+  | While (Maybe SourceSpan) (Maybe Text) AST AST
   -- ^ While loop
   | For (Maybe SourceSpan) Text AST AST AST
   -- ^ For loop
   | ForIn (Maybe SourceSpan) Text AST AST
   -- ^ ForIn loop
+  | Break (Maybe SourceSpan) (Maybe Text)
+  -- ^ Loop break
+  | Continue (Maybe SourceSpan) (Maybe Text)
+  -- ^ Loop continue
+  | Label (Maybe SourceSpan) Text  -- TODO: add as a loop parameter instead of a separate instruction
+  -- ^ Loop label.
   | IfElse (Maybe SourceSpan) AST AST (Maybe AST)
   -- ^ If-then-else statement
   | Return (Maybe SourceSpan) AST
@@ -115,10 +123,14 @@ withSourceSpan withSpan = go where
   go (Var _ s) = Var ss s
   go (Block _ js) = Block ss js
   go (VariableIntroduction _ name j) = VariableIntroduction ss name j
+  go (VariableLetIntroduction _ name j) = VariableLetIntroduction ss name j
   go (Assignment _ j1 j2) = Assignment ss j1 j2
-  go (While _ j1 j2) = While ss j1 j2
+  go (While _ name j1 j2) = While ss name j1 j2
   go (For _ name j1 j2 j3) = For ss name j1 j2 j3
   go (ForIn _ name j1 j2) = ForIn ss name j1 j2
+  go (Break _ name) = Break ss name
+  go (Continue _ name) = Continue ss name
+  go (Label _ name) = Label ss name
   go (IfElse _ j1 j2 j3) = IfElse ss j1 j2 j3
   go (Return _ js) = Return ss js
   go (ReturnNoResult _) = ReturnNoResult ss
@@ -142,10 +154,14 @@ getSourceSpan = go where
   go (Var ss _) = ss
   go (Block ss _) = ss
   go (VariableIntroduction ss _ _) = ss
+  go (VariableLetIntroduction ss _ _) = ss
   go (Assignment ss _ _) = ss
-  go (While ss _ _) = ss
+  go (While ss _ _ _) = ss
   go (For ss _ _ _ _) = ss
   go (ForIn ss _ _ _) = ss
+  go (Break ss _) = ss
+  go (Continue ss _) = ss
+  go (Label ss _) = ss
   go (IfElse ss _ _ _) = ss
   go (Return ss _) = ss
   go (ReturnNoResult ss) = ss
@@ -165,8 +181,9 @@ everywhere f = go where
   go (App ss j js) = f (App ss (go j) (map go js))
   go (Block ss js) = f (Block ss (map go js))
   go (VariableIntroduction ss name j) = f (VariableIntroduction ss name (fmap go j))
+  go (VariableLetIntroduction ss name j) = f (VariableLetIntroduction ss name (fmap go j))
   go (Assignment ss j1 j2) = f (Assignment ss (go j1) (go j2))
-  go (While ss j1 j2) = f (While ss (go j1) (go j2))
+  go (While ss name j1 j2) = f (While ss name (go j1) (go j2))
   go (For ss name j1 j2 j3) = f (For ss name (go j1) (go j2) (go j3))
   go (ForIn ss name j1 j2) = f (ForIn ss name (go j1) (go j2))
   go (IfElse ss j1 j2 j3) = f (IfElse ss (go j1) (go j2) (fmap go j3))
@@ -191,8 +208,9 @@ everywhereTopDownM f = f >=> go where
   go (App ss j js) = App ss <$> f' j <*> traverse f' js
   go (Block ss js) = Block ss <$> traverse f' js
   go (VariableIntroduction ss name j) = VariableIntroduction ss name <$> traverse f' j
+  go (VariableLetIntroduction ss name j) = VariableLetIntroduction ss name <$> traverse f' j
   go (Assignment ss j1 j2) = Assignment ss <$> f' j1 <*> f' j2
-  go (While ss j1 j2) = While ss <$> f' j1 <*> f' j2
+  go (While ss name j1 j2) = While ss name <$> f' j1 <*> f' j2
   go (For ss name j1 j2 j3) = For ss name <$> f' j1 <*> f' j2 <*> f' j3
   go (ForIn ss name j1 j2) = ForIn ss name <$> f' j1 <*> f' j2
   go (IfElse ss j1 j2 j3) = IfElse ss <$> f' j1 <*> f' j2 <*> traverse f' j3
@@ -214,7 +232,7 @@ everything (<>.) f = go where
   go j@(Block _ js) = foldl' (<>.) (f j) (map go js)
   go j@(VariableIntroduction _ _ (Just j1)) = f j <>. go j1
   go j@(Assignment _ j1 j2) = f j <>. go j1 <>. go j2
-  go j@(While _ j1 j2) = f j <>. go j1 <>. go j2
+  go j@(While _ _ j1 j2) = f j <>. go j1 <>. go j2
   go j@(For _ _ j1 j2 j3) = f j <>. go j1 <>. go j2 <>. go j3
   go j@(ForIn _ _ j1 j2) = f j <>. go j1 <>. go j2
   go j@(IfElse _ j1 j2 Nothing) = f j <>. go j1 <>. go j2
diff --git a/src/Language/PureScript/CoreImp/Optimizer/Common.hs b/src/Language/PureScript/CoreImp/Optimizer/Common.hs
index a0b3d695a7..8192c63374 100644
--- a/src/Language/PureScript/CoreImp/Optimizer/Common.hs
+++ b/src/Language/PureScript/CoreImp/Optimizer/Common.hs
@@ -37,6 +37,7 @@ isReassigned var1 = everything (||) check
   check :: AST -> Bool
   check (Function _ _ args _) | var1 `elem` args = True
   check (VariableIntroduction _ arg _) | var1 == arg = True
+  check (VariableLetIntroduction _ arg _) | var1 == arg = True
   check (Assignment _ (Var _ arg) _) | var1 == arg = True
   check (For _ arg _ _ _) | var1 == arg = True
   check (ForIn _ arg _ _) | var1 == arg = True
diff --git a/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs
index 6ee7529b9a..172e5ebd87 100644
--- a/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs
+++ b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs
@@ -80,6 +80,9 @@ inlineVariables = everywhere $ removeFromBlock go
   go (VariableIntroduction _ var (Just js) : sts)
     | shouldInline js && not (any (isReassigned var) sts) && not (any (isRebound js) sts) && not (any (isUpdated var) sts) =
       go (map (replaceIdent var js) sts)
+  go (VariableLetIntroduction _ var (Just js) : sts)
+    | shouldInline js && not (any (isReassigned var) sts) && not (any (isRebound js) sts) && not (any (isUpdated var) sts) =
+      go (map (replaceIdent var js) sts)
   go (s:sts) = s : go sts
 
 inlineCommonValues :: AST -> AST
diff --git a/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs b/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs
index c14988f50a..3d127dd311 100644
--- a/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs
+++ b/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs
@@ -57,10 +57,10 @@ magicDo effectModule C.EffectDictionaries{..} = everywhereTopDown convert
     Function s1 (Just fnName) [] $ Block s2 (VariableIntroduction s2 arg (Just (App s2 m [])) : map applyReturns js)
   -- Desugar untilE
   convert (App s1 (App _ f [arg]) []) | isEffFunc edUntil f =
-    App s1 (Function s1 Nothing [] (Block s1 [ While s1 (Unary s1 Not (App s1 arg [])) (Block s1 []), Return s1 $ ObjectLiteral s1 []])) []
+    App s1 (Function s1 Nothing [] (Block s1 [ While s1 Nothing (Unary s1 Not (App s1 arg [])) (Block s1 []), Return s1 $ ObjectLiteral s1 []])) []
   -- Desugar whileE
   convert (App _ (App _ (App s1 f [arg1]) [arg2]) []) | isEffFunc edWhile f =
-    App s1 (Function s1 Nothing [] (Block s1 [ While s1 (App s1 arg1 []) (Block s1 [ App s1 arg2 [] ]), Return s1 $ ObjectLiteral s1 []])) []
+    App s1 (Function s1 Nothing [] (Block s1 [ While s1 Nothing (App s1 arg1 []) (Block s1 [ App s1 arg2 [] ]), Return s1 $ ObjectLiteral s1 []])) []
   -- Inline __do returns
   convert (Return _ (App _ (Function _ (Just ident) [] body) [])) | ident == fnName = body
   -- Inline double applications
@@ -92,7 +92,7 @@ magicDo effectModule C.EffectDictionaries{..} = everywhereTopDown convert
   applyReturns :: AST -> AST
   applyReturns (Return ss ret) = Return ss (App ss ret [])
   applyReturns (Block ss jss) = Block ss (map applyReturns jss)
-  applyReturns (While ss cond js) = While ss cond (applyReturns js)
+  applyReturns (While ss name cond js) = While ss name cond (applyReturns js)
   applyReturns (For ss v lo hi js) = For ss v lo hi (applyReturns js)
   applyReturns (ForIn ss v xs js) = ForIn ss v xs (applyReturns js)
   applyReturns (IfElse ss cond t f) = IfElse ss cond (applyReturns t) (applyReturns `fmap` f)
diff --git a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs
index 4660265b7a..198cf1bdbd 100644
--- a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs
+++ b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs
@@ -11,12 +11,15 @@ import qualified Data.Set as S
 import Data.Text (Text, pack)
 import qualified Language.PureScript.Constants as C
 import Language.PureScript.CoreImp.AST
-import Language.PureScript.AST.SourcePos (SourceSpan)
 import Safe (headDef, tailSafe)
 
 -- | Eliminate tail calls
 tco :: AST -> AST
 tco = flip evalState 0 . everywhereTopDownM convert where
+  uniq :: Text -> State Int Text
+  uniq v = get <&> \count -> v <>
+    if count == 0 then "" else pack . show $ count
+
   tcoVar :: Text -> Text
   tcoVar arg = "$tco_var_" <> arg
 
@@ -24,11 +27,10 @@ tco = flip evalState 0 . everywhereTopDownM convert where
   copyVar arg = "$copy_" <> arg
 
   tcoDoneM :: State Int Text
-  tcoDoneM = get <&> \count -> "$tco_done" <>
-    if count == 0 then "" else pack . show $ count
+  tcoDoneM = uniq "$tco_done"
 
-  tcoLoop :: Text
-  tcoLoop = "$tco_loop"
+  tcoLoopM :: State Int Text
+  tcoLoopM = uniq "$tco_loop"
 
   tcoResult :: Text
   tcoResult = "$tco_result"
@@ -96,7 +98,7 @@ tco = flip evalState 0 . everywhereTopDownM convert where
 
     anyInTailPosition :: AST -> Maybe (S.Set (Text, Int))
     anyInTailPosition (Return _ expr) | isSelfCall ident arity expr = pure S.empty
-    anyInTailPosition (While _ _ body)
+    anyInTailPosition (While _ _ _ body)
       = anyInTailPosition body
     anyInTailPosition (For _ _ _ _ body)
       = anyInTailPosition body
@@ -119,12 +121,10 @@ tco = flip evalState 0 . everywhereTopDownM convert where
   toLoop :: S.Set Text -> Text -> Int -> [Text] -> [Text] -> AST -> State Int AST
   toLoop trFns ident arity outerArgs innerArgs js = do
     tcoDone <- tcoDoneM
+    tcoLoop <- tcoLoopM
     modify (+ 1)
 
     let
-      markDone :: Maybe SourceSpan -> AST
-      markDone ss = Assignment ss (Var ss tcoDone) (BooleanLiteral ss True)
-
       loopify :: AST -> AST
       loopify (Return ss ret)
         | isSelfCall ident arity ret =
@@ -136,28 +136,31 @@ tco = flip evalState 0 . everywhereTopDownM convert where
                 Assignment ss (Var ss (tcoVar arg)) val) allArgumentValues outerArgs
               ++ zipWith (\val arg ->
                 Assignment ss (Var ss (copyVar arg)) val) (drop (length outerArgs) allArgumentValues) innerArgs
-              ++ [ ReturnNoResult ss ]
+              ++ [Continue ss (Just tcoLoop)]
         | isIndirectSelfCall ret = Return ss ret
-        | otherwise = Block ss [ markDone ss, Return ss ret ]
-      loopify (ReturnNoResult ss) = Block ss [ markDone ss, ReturnNoResult ss ]
-      loopify (While ss cond body) = While ss cond (loopify body)
+        | otherwise = Block ss
+          [ Assignment ss (Var rootSS tcoResult) ret
+          , Break ss (Just tcoLoop)
+          ]
+      loopify (While ss name cond body) = While ss name cond (loopify body)
       loopify (For ss i js1 js2 body) = For ss i js1 js2 (loopify body)
       loopify (ForIn ss i js1 body) = ForIn ss i js1 (loopify body)
       loopify (IfElse ss cond body el) = IfElse ss cond (loopify body) (fmap loopify el)
       loopify (Block ss body) = Block ss (map loopify body)
-      loopify (VariableIntroduction ss f (Just fn@(Function _ Nothing _ _)))
-        | (_, body, replace) <- innerCollectAllFunctionArgs [] id fn
-        , f `S.member` trFns = VariableIntroduction ss f (Just (replace (loopify body)))
+      -- loopify (VariableIntroduction ss f (Just fn@(Function _ Nothing _ _)))
+      --   | (_, body, replace) <- innerCollectAllFunctionArgs [] id fn
+      --   , f `S.member` trFns = VariableIntroduction ss f (Just (replace (loopify body)))
       loopify other = other
 
     pure $ Block rootSS $
         map (\arg -> VariableIntroduction rootSS (tcoVar arg) (Just (Var rootSS (copyVar arg)))) outerArgs ++
-        [ VariableIntroduction rootSS tcoDone (Just (BooleanLiteral rootSS False))
-        , VariableIntroduction rootSS tcoResult Nothing
-        , Function rootSS (Just tcoLoop) (outerArgs ++ innerArgs) (Block rootSS [loopify js])
-        , While rootSS (Unary rootSS Not (Var rootSS tcoDone))
-            (Block rootSS
-              [Assignment rootSS (Var rootSS tcoResult) (App rootSS (Var rootSS tcoLoop) (map (Var rootSS . tcoVar) outerArgs ++ map (Var rootSS . copyVar) innerArgs))])
+        [ VariableIntroduction rootSS tcoResult Nothing
+        , While rootSS (Just tcoLoop) (Unary rootSS Not (Var rootSS tcoDone))
+          (Block rootSS $
+            map (\v -> VariableLetIntroduction rootSS v (Just . Var rootSS . tcoVar $ v)) outerArgs ++
+            map (\v -> VariableLetIntroduction rootSS v (Just . Var rootSS . copyVar $ v)) innerArgs ++
+            [loopify js]
+          )
         , Return rootSS (Var rootSS tcoResult)
         ]
     where
diff --git a/tests/TestMake.hs b/tests/TestMake.hs
index dadee27fd7..f90ecca808 100644
--- a/tests/TestMake.hs
+++ b/tests/TestMake.hs
@@ -182,8 +182,10 @@ compileWithResult input = do
     foreigns <- P.inferForeignModules filePathMap
     let makeActions =
           (P.buildMakeActions modulesDir filePathMap foreigns True)
-            { P.progress = \(P.CompilingModule mn) ->
-                liftIO $ modifyMVar_ recompiled (return . Set.insert mn)
+            { P.progress = \p -> case p of
+                (P.CompilingModule mn) ->
+                  liftIO $ modifyMVar_ recompiled (return . Set.insert mn)
+                _ -> return ()
             }
     P.make makeActions (map snd ms)
 

From 4237c028ae6f10ccd1ca71f9e8c81526efe5d7f2 Mon Sep 17 00:00:00 2001
From: radrow <radrowicki@gmail.com>
Date: Fri, 5 Feb 2021 11:10:43 +0100
Subject: [PATCH 06/30] Bugfix

---
 src/Language/PureScript/CodeGen/JS.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 44c3253f73..9c71773ee2 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -325,7 +325,7 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
     jss <- forM binders $ \(CaseAlternative bs result) -> do
       ret <- guardsToJs result
       go valNames ret bs
-    return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (AST.Label Nothing "xdd" :  assignments ++ concat jss ++ [AST.Throw Nothing $ failedPatternError valNames])))
+    return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (assignments ++ concat jss ++ [AST.Throw Nothing $ failedPatternError valNames])))
                    []
     where
       go :: [Text] -> [AST] -> [Binder Ann] -> m [AST]

From 3d39396dc4e370f01040595205edcb94b616bb9e Mon Sep 17 00:00:00 2001
From: radrow <radrowicki@gmail.com>
Date: Fri, 5 Feb 2021 18:39:17 +0100
Subject: [PATCH 07/30] .

---
 src/Language/PureScript/CodeGen/JS.hs         | 33 ++++++++++---------
 src/Language/PureScript/CoreImp/AST.hs        |  1 +
 .../PureScript/Sugar/CaseDeclarations.hs      | 20 ++++-------
 3 files changed, 25 insertions(+), 29 deletions(-)

diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 9c71773ee2..1a56edf023 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -6,6 +6,8 @@ module Language.PureScript.CodeGen.JS
   , moduleToJs
   ) where
 
+import Debug.Trace
+
 import Prelude.Compat
 import Protolude (ordNub)
 
@@ -160,7 +162,7 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
        else AST.Comment Nothing com <$> nonRecToJS a i (modifyAnn removeComments e)
   nonRecToJS (ss, _, _, _) ident val = do
     js <- valueToJs val
-    withPos ss $ AST.VariableIntroduction Nothing (identToJs ident) (Just js)
+    withPos ss $ AST.VariableLetIntroduction Nothing (identToJs ident) (Just js)
 
   withPos :: SourceSpan -> AST -> m AST
   withPos ss js = do
@@ -247,9 +249,9 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
   valueToJs' (Let _ ds val) = do
     ds' <- concat <$> mapM bindToJs ds
     ret <- valueToJs val
-    return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (ds' ++ [AST.Return Nothing ret]))) []
+    return $ AST.Block Nothing (ds' ++ [ret])
   valueToJs' (Constructor (_, _, _, Just IsNewtype) _ ctor _) =
-    return $ AST.VariableIntroduction Nothing (properToJs ctor) (Just $
+    return $ AST.VariableLetIntroduction Nothing (properToJs ctor) (Just $
                 AST.ObjectLiteral Nothing [("create",
                   AST.Function Nothing Nothing ["value"]
                     (AST.Block Nothing [AST.Return Nothing $ AST.Var Nothing "value"]))])
@@ -269,7 +271,7 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
                           ]
 
   iife :: Text -> [AST] -> AST
-  iife v exprs = AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing $ exprs ++ [AST.Return Nothing $ AST.Var Nothing v])) []
+  iife v exprs = AST.Block Nothing $ exprs ++ [AST.Var Nothing v]
 
   literalToValueJS :: SourceSpan -> Literal (Expr Ann) -> m AST
   literalToValueJS ss (NumericLiteral (Left i)) = return $ AST.NumericLiteral (Just ss) (Left i)
@@ -290,15 +292,15 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
       jsKey = AST.Var Nothing key
       jsNewObj = AST.Var Nothing newObj
       jsEvaluatedObj = AST.Var Nothing evaluatedObj
-      block = AST.Block Nothing (evaluate:objAssign:copy:extend ++ [AST.Return Nothing jsNewObj])
-      evaluate = AST.VariableIntroduction Nothing evaluatedObj (Just obj)
-      objAssign = AST.VariableIntroduction Nothing newObj (Just $ AST.ObjectLiteral Nothing [])
+      block = AST.Block Nothing (evaluate:objAssign:copy:extend ++ [jsNewObj])
+      evaluate = AST.VariableLetIntroduction Nothing evaluatedObj (Just obj)
+      objAssign = AST.VariableLetIntroduction Nothing newObj (Just $ AST.ObjectLiteral Nothing [])
       copy = AST.ForIn Nothing key jsEvaluatedObj $ AST.Block Nothing [AST.IfElse Nothing cond assign Nothing]
       cond = AST.App Nothing (accessorString "call" (accessorString "hasOwnProperty" (AST.ObjectLiteral Nothing []))) [jsEvaluatedObj, jsKey]
       assign = AST.Block Nothing [AST.Assignment Nothing (AST.Indexer Nothing jsKey jsNewObj) (AST.Indexer Nothing jsKey jsEvaluatedObj)]
       stToAssign (s, js) = AST.Assignment Nothing (accessorString s jsNewObj) js
       extend = map stToAssign sts
-    return $ AST.App Nothing (AST.Function Nothing Nothing [] block) []
+    return block
 
   -- | Generate code in the simplified JavaScript intermediate representation for a reference to a
   -- variable.
@@ -321,12 +323,11 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
   bindersToJs :: SourceSpan -> [CaseAlternative Ann] -> [AST] -> m AST
   bindersToJs ss binders vals = do
     valNames <- replicateM (length vals) freshName
-    let assignments = zipWith (AST.VariableIntroduction Nothing) valNames (map Just vals)
+    let assignments = zipWith (AST.VariableLetIntroduction Nothing) valNames (map Just vals)
     jss <- forM binders $ \(CaseAlternative bs result) -> do
       ret <- guardsToJs result
       go valNames ret bs
-    return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (assignments ++ concat jss ++ [AST.Throw Nothing $ failedPatternError valNames])))
-                   []
+    return $ AST.Block Nothing (assignments ++ concat jss ++ [AST.Throw Nothing $ failedPatternError valNames])
     where
       go :: [Text] -> [AST] -> [Binder Ann] -> m [AST]
       go _ done [] = return done
@@ -370,7 +371,7 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
   binderToJs' varName done (LiteralBinder _ l) =
     literalToBinderJS varName done l
   binderToJs' varName done (VarBinder _ ident) =
-    return (AST.VariableIntroduction Nothing (identToJs ident) (Just (AST.Var Nothing varName)) : done)
+    return (AST.VariableLetIntroduction Nothing (identToJs ident) (Just (AST.Var Nothing varName)) : done)
   binderToJs' varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =
     binderToJs varName done b
   binderToJs' varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ ctor bs) = do
@@ -388,12 +389,12 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
       argVar <- freshName
       done'' <- go remain done'
       js <- binderToJs argVar done'' binder
-      return (AST.VariableIntroduction Nothing argVar (Just $ accessorString (mkString $ identToJs field) $ AST.Var Nothing varName) : js)
+      return (AST.VariableLetIntroduction Nothing argVar (Just $ accessorString (mkString $ identToJs field) $ AST.Var Nothing varName) : js)
   binderToJs' _ _ ConstructorBinder{} =
     internalError "binderToJs: Invalid ConstructorBinder in binderToJs"
   binderToJs' varName done (NamedBinder _ ident binder) = do
     js <- binderToJs varName done binder
-    return (AST.VariableIntroduction Nothing (identToJs ident) (Just (AST.Var Nothing varName)) : js)
+    return (AST.VariableLetIntroduction Nothing (identToJs ident) (Just (AST.Var Nothing varName)) : js)
 
   literalToBinderJS :: Text -> [AST] -> Literal (Binder Ann) -> m [AST]
   literalToBinderJS varName done (NumericLiteral num) =
@@ -414,7 +415,7 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
       propVar <- freshName
       done'' <- go done' bs'
       js <- binderToJs propVar done'' binder
-      return (AST.VariableIntroduction Nothing propVar (Just (accessorString prop (AST.Var Nothing varName))) : js)
+      return (AST.VariableLetIntroduction Nothing propVar (Just (accessorString prop (AST.Var Nothing varName))) : js)
   literalToBinderJS varName done (ArrayLiteral bs) = do
     js <- go done 0 bs
     return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (accessorString "length" (AST.Var Nothing varName)) (AST.NumericLiteral Nothing (Left (fromIntegral $ length bs)))) (AST.Block Nothing js) Nothing]
@@ -425,7 +426,7 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
       elVar <- freshName
       done'' <- go done' (index + 1) bs'
       js <- binderToJs elVar done'' binder
-      return (AST.VariableIntroduction Nothing elVar (Just (AST.Indexer Nothing (AST.NumericLiteral Nothing (Left index)) (AST.Var Nothing varName))) : js)
+      return (AST.VariableLetIntroduction Nothing elVar (Just (AST.Indexer Nothing (AST.NumericLiteral Nothing (Left index)) (AST.Var Nothing varName))) : js)
 
   -- Check that all integers fall within the valid int range for JavaScript.
   checkIntegers :: AST -> m ()
diff --git a/src/Language/PureScript/CoreImp/AST.hs b/src/Language/PureScript/CoreImp/AST.hs
index 68a39fef88..3e6ec51612 100644
--- a/src/Language/PureScript/CoreImp/AST.hs
+++ b/src/Language/PureScript/CoreImp/AST.hs
@@ -231,6 +231,7 @@ everything (<>.) f = go where
   go j@(App _ j1 js) = foldl' (<>.) (f j <>. go j1) (map go js)
   go j@(Block _ js) = foldl' (<>.) (f j) (map go js)
   go j@(VariableIntroduction _ _ (Just j1)) = f j <>. go j1
+  go j@(VariableLetIntroduction _ _ (Just j1)) = f j <>. go j1
   go j@(Assignment _ j1 j2) = f j <>. go j1 <>. go j2
   go j@(While _ _ j1 j2) = f j <>. go j1 <>. go j2
   go j@(For _ _ j1 j2 j3) = f j <>. go j1 <>. go j2 <>. go j3
diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs
index a03457b61a..87f4beb11b 100644
--- a/src/Language/PureScript/Sugar/CaseDeclarations.hs
+++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs
@@ -219,22 +219,16 @@ desugarGuardedExprs ss (Case scrut alternatives) =
                         -> m Expr
     desugarAltOutOfLine alt_binder rem_guarded rem_alts mk_body
       | Just rem_case <- mkCaseOfRemainingGuardsAndAlts = do
-
-        desugared     <- desugarGuardedExprs ss rem_case
-        rem_case_id   <- freshIdent'
-        unused_binder <- freshIdent'
-
+        desugared <- desugarGuardedExprs ss rem_case
         let
-          goto_rem_case :: Expr
-          goto_rem_case = Var ss (Qualified Nothing rem_case_id)
-            `App` Literal ss (BooleanLiteral True)
           alt_fail :: Int -> [CaseAlternative]
-          alt_fail n = [CaseAlternative (replicate n NullBinder) [MkUnguarded goto_rem_case]]
+          alt_fail n = [CaseAlternative (replicate n NullBinder) [MkUnguarded desugared]]
 
-        pure $ Let FromLet [
-          ValueDecl (ss, []) rem_case_id Private []
-            [MkUnguarded (Abs (VarBinder ss unused_binder) desugared)]
-          ] (mk_body alt_fail)
+        pure $ mk_body alt_fail
+        -- pure $ Let FromLet [
+        --   ValueDecl (ss, []) rem_case_id Private []
+        --     [MkUnguarded (Abs (VarBinder ss unused_binder) desugared)]
+        --   ] (mk_body alt_fail)
 
       | otherwise
       = pure $ mk_body (const [])

From ebfa38c5cbf9db353fd529ea76e9ad5044d6b7e6 Mon Sep 17 00:00:00 2001
From: radrow <radrowicki@gmail.com>
Date: Thu, 11 Feb 2021 11:23:16 +0100
Subject: [PATCH 08/30] WIP lambda elim

---
 src/Language/PureScript/CodeGen/JS.hs         | 170 +++++++++++-------
 .../PureScript/CoreImp/Optimizer/TCO.hs       |  15 ++
 src/Language/PureScript/Make/Actions.hs       |   8 +-
 src/Language/PureScript/Make/Monad.hs         |   7 +-
 4 files changed, 130 insertions(+), 70 deletions(-)

diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 1a56edf023..dee24eabd8 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -14,14 +14,15 @@ import Protolude (ordNub)
 import Control.Arrow ((&&&))
 import Control.Monad (forM, replicateM, void)
 import Control.Monad.Except (MonadError, throwError)
-import Control.Monad.Reader (MonadReader, asks)
+import Control.Monad.Reader (MonadReader, asks, local)
 import Control.Monad.Supply.Class
 
+import Data.Bifunctor(second, first)
 import Data.List ((\\), intersect)
 import qualified Data.Foldable as F
 import qualified Data.Map as M
 import qualified Data.Set as S
-import Data.Maybe (fromMaybe, isNothing)
+import Data.Maybe (fromMaybe, isNothing, mapMaybe)
 import Data.String (fromString)
 import Data.Text (Text)
 import qualified Data.Text as T
@@ -44,11 +45,16 @@ import qualified Language.PureScript.Constants as C
 
 import System.FilePath.Posix ((</>))
 
+import qualified Data.Map as Map
+import Data.Map(Map)
+
+type VarEnv = Map Text Text
+
 -- | Generate code in the simplified JavaScript intermediate representation for all declarations in a
 -- module.
 moduleToJs
   :: forall m
-   . (Monad m, MonadReader Options m, MonadSupply m, MonadError MultipleErrors m)
+   . (Monad m, MonadReader (Options, VarEnv) m, MonadSupply m, MonadError MultipleErrors m)
   => Module Ann
   -> Maybe AST
   -> m [AST]
@@ -58,7 +64,6 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
     let mnLookup = renameImports usedNames imps
     let decls' = renameModules mnLookup decls
 
-
     jsDecls <- mapM bindToJs decls'
     optimized <- traverse (traverse optimize) jsDecls
     let mnReverseLookup = M.fromList $ map (\(origName, (_, safeName)) -> (moduleNameToJs safeName, origName)) $ M.toList mnLookup
@@ -67,7 +72,7 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
       . filter (`S.member` usedModuleNames)
       . (\\ (mn : C.primModules)) $ ordNub $ map snd imps
     F.traverse_ (F.traverse_ checkIntegers) optimized
-    comments <- asks (not . optionsNoComments)
+    comments <- asks (not . optionsNoComments . fst)
     let strict = AST.StringLiteral Nothing "use strict"
     let header = if comments && not (null coms) then AST.Comment Nothing coms strict else strict
     let foreign' = [AST.VariableIntroduction Nothing "$foreign" foreign_ | not $ null foreigns || isNothing foreign_]
@@ -147,26 +152,29 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
   -- Generate code in the simplified JavaScript intermediate representation for a declaration
   --
   bindToJs :: Bind Ann -> m [AST]
-  bindToJs (NonRec ann ident val) = return <$> nonRecToJS ann ident val
-  bindToJs (Rec vals) = forM vals (uncurry . uncurry $ nonRecToJS)
+  bindToJs (NonRec ann ident val) = do
+    (decls, x) <- nonRecToJS ann ident val
+    return $ decls ++ [x]
+  bindToJs (Rec vals) = do
+    (\l -> l >>= \(decls, x) -> decls ++ [x]) <$> forM vals (uncurry . uncurry $ nonRecToJS)
 
   -- | Generate code in the simplified JavaScript intermediate representation for a single non-recursive
   -- declaration.
   --
   -- The main purpose of this function is to handle code generation for comments.
-  nonRecToJS :: Ann -> Ident -> Expr Ann -> m AST
+  nonRecToJS :: Ann -> Ident -> Expr Ann -> m ([AST], AST)
   nonRecToJS a i e@(extractAnn -> (_, com, _, _)) | not (null com) = do
-    withoutComment <- asks optionsNoComments
+    withoutComment <- asks $ optionsNoComments . fst
     if withoutComment
        then nonRecToJS a i (modifyAnn removeComments e)
-       else AST.Comment Nothing com <$> nonRecToJS a i (modifyAnn removeComments e)
+       else AST.Comment Nothing com <$$> nonRecToJS a i (modifyAnn removeComments e)
   nonRecToJS (ss, _, _, _) ident val = do
-    js <- valueToJs val
-    withPos ss $ AST.VariableLetIntroduction Nothing (identToJs ident) (Just js)
+    (decls, js) <- valueToJs val
+    fmap (decls,) $ withPos ss $ AST.VariableLetIntroduction Nothing (identToJs ident) (Just js)
 
   withPos :: SourceSpan -> AST -> m AST
   withPos ss js = do
-    withSM <- asks (elem JSSourceMap . optionsCodegenTargets)
+    withSM <- asks (elem JSSourceMap . optionsCodegenTargets . fst)
     return $ if withSM
       then withSourceSpan ss js
       else js
@@ -188,27 +196,34 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
   accessorString prop = AST.Indexer Nothing (AST.StringLiteral Nothing prop)
 
   -- | Generate code in the simplified JavaScript intermediate representation for a value or expression.
-  valueToJs :: Expr Ann -> m AST
-  valueToJs e =
-    let (ss, _, _, _) = extractAnn e in
-    withPos ss =<< valueToJs' e
+  valueToJs :: Expr Ann -> m ([AST], AST)
+  valueToJs e = do
+    let (ss, _, _, _) = extractAnn e
+    (decls, x) <- valueToJs' e
+    x' <- withPos ss x
+    return (decls, x')
+
+  single :: AST -> m ([AST], AST)
+  single = return . ([],)
 
-  valueToJs' :: Expr Ann -> m AST
+  (<$$>) f m = fmap (\(l, x) -> (map f l, f x)) m
+
+  valueToJs' :: Expr Ann -> m ([AST], AST)
   valueToJs' (Literal (pos, _, _, _) l) =
     rethrowWithPosition pos $ literalToValueJS pos l
   valueToJs' (Var (_, _, _, Just (IsConstructor _ [])) name) =
-    return $ accessorString "value" $ qualifiedToJS id name
+    single $ accessorString "value" $ qualifiedToJS id name
   valueToJs' (Var (_, _, _, Just (IsConstructor _ _)) name) =
-    return $ accessorString "create" $ qualifiedToJS id name
+    single $ accessorString "create" $ qualifiedToJS id name
   valueToJs' (Accessor _ prop val) =
-    accessorString prop <$> valueToJs val
+    accessorString prop <$$> valueToJs val
   valueToJs' (ObjectUpdate _ o ps) = do
-    obj <- valueToJs o
-    sts <- mapM (sndM valueToJs) ps
-    extendObj obj sts
-  valueToJs' e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) =
+    (decls, obj) <- valueToJs o
+    (declss, sts) <- unzip . map (\(p, (d, x)) -> (d, (p, x))) <$> mapM (sndM valueToJs) ps
+    first ((decls ++ concat declss) ++) <$> extendObj obj sts
+  valueToJs' e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) = do
     let args = unAbs e
-    in return $ AST.Function Nothing Nothing (map identToJs args) (AST.Block Nothing $ map assign args)
+    single $ AST.Function Nothing Nothing (map identToJs args) (AST.Block Nothing $ map assign args)
     where
     unAbs :: Expr Ann -> [Ident]
     unAbs (Abs _ arg val) = arg : unAbs val
@@ -221,42 +236,60 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
     let jsArg = case arg of
                   UnusedIdent -> []
                   _           -> [identToJs arg]
-    return $ AST.Function Nothing Nothing jsArg (AST.Block Nothing [AST.Return Nothing ret])
+    r <- single $ AST.Function Nothing Nothing jsArg (AST.Block Nothing $
+      case ret of
+        (decls, AST.Block ann bs) -> decls ++ bs
+        (decls, val) -> decls ++ [AST.Return Nothing val])
+    return r
   valueToJs' e@App{} = do
     let (f, args) = unApp e []
-    args' <- mapM valueToJs args
+    (declss, args') <- unzip <$> mapM valueToJs args
     case f of
-      Var (_, _, _, Just IsNewtype) _ -> return (head args')
+      Var (_, _, _, Just IsNewtype) _ -> return (concat declss, head args')
       Var (_, _, _, Just (IsConstructor _ fields)) name | length args == length fields ->
-        return $ AST.Unary Nothing AST.New $ AST.App Nothing (qualifiedToJS id name) args'
+        return (concat declss, AST.Unary Nothing AST.New $ AST.App Nothing (qualifiedToJS id name) args')
       Var (_, _, _, Just IsTypeClassConstructor) name ->
-        return $ AST.Unary Nothing AST.New $ AST.App Nothing (qualifiedToJS id name) args'
-      _ -> flip (foldl (\fn a -> AST.App Nothing fn [a])) args' <$> valueToJs f
+        return (concat declss, AST.Unary Nothing AST.New $ AST.App Nothing (qualifiedToJS id name) args')
+      _ -> do
+        (decls, v') <- valueToJs f
+        return (concat declss ++ decls, foldl (\fn a -> AST.App Nothing fn [a]) v' args')
     where
     unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])
     unApp (App _ val arg) args = unApp val (arg : args)
     unApp other args = (other, args)
   valueToJs' (Var (_, _, _, Just IsForeign) qi@(Qualified (Just mn') ident)) =
-    return $ if mn' == mn
+    single $ if mn' == mn
              then foreignIdent ident
              else varToJs qi
   valueToJs' (Var (_, _, _, Just IsForeign) ident) =
     internalError $ "Encountered an unqualified reference to a foreign ident " ++ T.unpack (showQualified showIdent ident)
-  valueToJs' (Var _ ident) = return $ varToJs ident
+  valueToJs' (Var _ q@(Qualified Nothing (Ident v))) = asks snd >>= \env ->
+    single $ case M.lookup v env of
+      Nothing -> varToJs q
+      Just name -> AST.Var Nothing name
+  valueToJs' (Var _ q) = single $ varToJs q
   valueToJs' (Case (ss, _, _, _) values binders) = do
-    vals <- mapM valueToJs values
-    bindersToJs ss binders vals
+    asts <- mapM valueToJs values
+    let (decls, vals) = unzip asts
+    (concat decls,) <$> bindersToJs ss binders vals
   valueToJs' (Let _ ds val) = do
     ds' <- concat <$> mapM bindToJs ds
-    ret <- valueToJs val
-    return $ AST.Block Nothing (ds' ++ [ret])
+    declsAndMap <- forM ds' $ \d -> case d of
+      AST.Var ann name -> do
+        q <- freshName
+        return (AST.Var ann q, Just (name, q))
+      _ -> return (d, Nothing)
+    let decls1 = map fst declsAndMap
+        env1 = Map.fromList $ mapMaybe snd declsAndMap
+    (ds'', ret) <- local (second $ Map.union env1) $ valueToJs val
+    return (decls1 ++ ds'', ret)
   valueToJs' (Constructor (_, _, _, Just IsNewtype) _ ctor _) =
-    return $ AST.VariableLetIntroduction Nothing (properToJs ctor) (Just $
+    single $ AST.VariableLetIntroduction Nothing (properToJs ctor) (Just $
                 AST.ObjectLiteral Nothing [("create",
                   AST.Function Nothing Nothing ["value"]
                     (AST.Block Nothing [AST.Return Nothing $ AST.Var Nothing "value"]))])
   valueToJs' (Constructor _ _ ctor []) =
-    return $ iife (properToJs ctor) [ AST.Function Nothing (Just (properToJs ctor)) [] (AST.Block Nothing [])
+    single $ iife (properToJs ctor) [ AST.Function Nothing (Just (properToJs ctor)) [] (AST.Block Nothing [])
            , AST.Assignment Nothing (accessorString "value" (AST.Var Nothing (properToJs ctor)))
                 (AST.Unary Nothing AST.New $ AST.App Nothing (AST.Var Nothing (properToJs ctor)) []) ]
   valueToJs' (Constructor _ _ ctor fields) =
@@ -266,24 +299,28 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
         createFn =
           let body = AST.Unary Nothing AST.New $ AST.App Nothing (AST.Var Nothing (properToJs ctor)) (var `map` fields)
           in foldr (\f inner -> AST.Function Nothing Nothing [identToJs f] (AST.Block Nothing [AST.Return Nothing inner])) body fields
-    in return $ iife (properToJs ctor) [ constructor
+    in single $ iife (properToJs ctor) [ constructor
                           , AST.Assignment Nothing (accessorString "create" (AST.Var Nothing (properToJs ctor))) createFn
                           ]
 
   iife :: Text -> [AST] -> AST
-  iife v exprs = AST.Block Nothing $ exprs ++ [AST.Var Nothing v]
-
-  literalToValueJS :: SourceSpan -> Literal (Expr Ann) -> m AST
-  literalToValueJS ss (NumericLiteral (Left i)) = return $ AST.NumericLiteral (Just ss) (Left i)
-  literalToValueJS ss (NumericLiteral (Right n)) = return $ AST.NumericLiteral (Just ss) (Right n)
-  literalToValueJS ss (StringLiteral s) = return $ AST.StringLiteral (Just ss) s
-  literalToValueJS ss (CharLiteral c) = return $ AST.StringLiteral (Just ss) (fromString [c])
-  literalToValueJS ss (BooleanLiteral b) = return $ AST.BooleanLiteral (Just ss) b
-  literalToValueJS ss (ArrayLiteral xs) = AST.ArrayLiteral (Just ss) <$> mapM valueToJs xs
-  literalToValueJS ss (ObjectLiteral ps) = AST.ObjectLiteral (Just ss) <$> mapM (sndM valueToJs) ps
+  iife v exprs = AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing $ exprs ++ [AST.Return Nothing $ AST.Var Nothing v])) []
+
+  literalToValueJS :: SourceSpan -> Literal (Expr Ann) -> m ([AST], AST)
+  literalToValueJS ss (NumericLiteral (Left i)) = single $ AST.NumericLiteral (Just ss) (Left i)
+  literalToValueJS ss (NumericLiteral (Right n)) = single $ AST.NumericLiteral (Just ss) (Right n)
+  literalToValueJS ss (StringLiteral s) = single $ AST.StringLiteral (Just ss) s
+  literalToValueJS ss (CharLiteral c) = single $ AST.StringLiteral (Just ss) (fromString [c])
+  literalToValueJS ss (BooleanLiteral b) = single $ AST.BooleanLiteral (Just ss) b
+  literalToValueJS ss (ArrayLiteral xs) = do
+    (declss, vals) <- unzip <$> mapM valueToJs xs
+    return (concat declss, AST.ArrayLiteral (Just ss) vals)
+  literalToValueJS ss (ObjectLiteral ps) = do
+    (declss, vals) <- unzip . map (\(p, (d, x)) -> (d, (p, x))) <$> mapM (sndM valueToJs) ps
+    return (concat declss, AST.ObjectLiteral (Just ss) vals)
 
   -- | Shallow copy an object.
-  extendObj :: AST -> [(PSString, AST)] -> m AST
+  extendObj :: AST -> [(PSString, AST)] -> m ([AST], AST)
   extendObj obj sts = do
     newObj <- freshName
     key <- freshName
@@ -292,7 +329,6 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
       jsKey = AST.Var Nothing key
       jsNewObj = AST.Var Nothing newObj
       jsEvaluatedObj = AST.Var Nothing evaluatedObj
-      block = AST.Block Nothing (evaluate:objAssign:copy:extend ++ [jsNewObj])
       evaluate = AST.VariableLetIntroduction Nothing evaluatedObj (Just obj)
       objAssign = AST.VariableLetIntroduction Nothing newObj (Just $ AST.ObjectLiteral Nothing [])
       copy = AST.ForIn Nothing key jsEvaluatedObj $ AST.Block Nothing [AST.IfElse Nothing cond assign Nothing]
@@ -300,7 +336,7 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
       assign = AST.Block Nothing [AST.Assignment Nothing (AST.Indexer Nothing jsKey jsNewObj) (AST.Indexer Nothing jsKey jsEvaluatedObj)]
       stToAssign (s, js) = AST.Assignment Nothing (accessorString s jsNewObj) js
       extend = map stToAssign sts
-    return block
+    return $ (evaluate:objAssign:copy:extend, jsNewObj)
 
   -- | Generate code in the simplified JavaScript intermediate representation for a reference to a
   -- variable.
@@ -327,7 +363,8 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
     jss <- forM binders $ \(CaseAlternative bs result) -> do
       ret <- guardsToJs result
       go valNames ret bs
-    return $ AST.Block Nothing (assignments ++ concat jss ++ [AST.Throw Nothing $ failedPatternError valNames])
+    return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (assignments ++ concat jss ++ [AST.Throw Nothing $ failedPatternError valNames])))
+                  []
     where
       go :: [Text] -> [AST] -> [Binder Ann] -> m [AST]
       go _ done [] = return done
@@ -349,15 +386,22 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
       valueError s _                        = accessorString "name" . accessorString "constructor" $ AST.Var Nothing s
 
       guardsToJs :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [AST]
-      guardsToJs (Left gs) = traverse genGuard gs where
+      guardsToJs (Left gs) = concat <$> traverse genGuard gs where
         genGuard (cond, val) = do
-          cond' <- valueToJs cond
-          val'   <- valueToJs val
-          return
-            (AST.IfElse Nothing cond'
-              (AST.Block Nothing [AST.Return Nothing val']) Nothing)
-
-      guardsToJs (Right v) = return . AST.Return Nothing <$> valueToJs v
+          (declsC, cond') <- valueToJs cond
+          (declsV, val')   <- valueToJs val
+          return $ declsC ++ declsV ++
+            [AST.IfElse Nothing cond'
+              (case val' of
+                 AST.Block _ _ -> val'
+                 _ -> AST.Return Nothing val') Nothing
+            ]
+
+      guardsToJs (Right v) = do
+        (decls, val') <- valueToJs v
+        return $ case val' of
+          AST.Block _ bs -> decls ++ bs
+          _ -> decls ++ [AST.Return Nothing val']
 
   binderToJs :: Text -> [AST] -> Binder Ann -> m [AST]
   binderToJs s done binder =
diff --git a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs
index 198cf1bdbd..dc1595a047 100644
--- a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs
+++ b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs
@@ -46,6 +46,16 @@ tco = flip evalState 0 . everywhereTopDownM convert where
       -- ^ this is the number of calls, not the number of arguments, if there's
       -- ever a practical difference.
       (argss, body', replace) = topCollectAllFunctionArgs [] id fn
+  convert (VariableLetIntroduction ss name (Just fn@Function {}))
+      | Just trFns <- findTailRecursiveFns name arity body'
+      = VariableLetIntroduction ss name . Just . replace <$> toLoop trFns name arity outerArgs innerArgs body'
+    where
+      innerArgs = headDef [] argss
+      outerArgs = concat . reverse $ tailSafe argss
+      arity = length argss
+      -- ^ this is the number of calls, not the number of arguments, if there's
+      -- ever a practical difference.
+      (argss, body', replace) = topCollectAllFunctionArgs [] id fn
   convert js = pure js
 
   rewriteFunctionsWith :: ([Text] -> [Text]) -> [[Text]] -> (AST -> AST) -> AST -> ([[Text]], AST, AST -> AST)
@@ -113,6 +123,11 @@ tco = flip evalState 0 . everywhereTopDownM convert where
       , (argss, body, _) <- innerCollectAllFunctionArgs [] id js1
         = S.insert (ident', length argss) <$> anyInTailPosition body
       | otherwise = empty
+    anyInTailPosition (VariableLetIntroduction _ ident' (Just js1))
+      | Function _ Nothing _ _ <- js1
+      , (argss, body, _) <- innerCollectAllFunctionArgs [] id js1
+        = S.insert (ident', length argss) <$> anyInTailPosition body
+      | otherwise = empty
     anyInTailPosition (Comment _ _ js1)
       = anyInTailPosition js1
     anyInTailPosition _
diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs
index 64070376c3..319782d1a4 100644
--- a/src/Language/PureScript/Make/Actions.hs
+++ b/src/Language/PureScript/Make/Actions.hs
@@ -210,7 +210,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
 
   getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime)
   getOutputTimestamp mn = do
-    codegenTargets <- asks optionsCodegenTargets
+    codegenTargets <- asks $ optionsCodegenTargets . fst
     let outputPaths = [outputFilename mn externsFileName] <> fmap (targetFilename mn) (S.toList codegenTargets)
     timestamps <- traverse getTimestampMaybe outputPaths
     pure $ fmap minimum . NEL.nonEmpty =<< sequence timestamps
@@ -222,7 +222,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
 
   outputPrimDocs :: Make ()
   outputPrimDocs = do
-    codegenTargets <- asks optionsCodegenTargets
+    codegenTargets <- asks $ optionsCodegenTargets . fst
     when (S.member Docs codegenTargets) $ for_ Docs.Prim.primModules $ \docsMod@Docs.Module{..} ->
       writeJSONFile (outputFilename modName "docs.json") docsMod
 
@@ -230,7 +230,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
   codegen m docs exts = do
     let mn = CF.moduleName m
     lift $ writeCborFile (outputFilename mn externsFileName) exts
-    codegenTargets <- lift $ asks optionsCodegenTargets
+    codegenTargets <- lift $ asks $ optionsCodegenTargets . fst
     when (S.member CoreFn codegenTargets) $ do
       let coreFnFile = targetFilename mn CoreFn
           json = CFJ.moduleToJSON Paths.version m
@@ -261,7 +261,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
 
   ffiCodegen :: CF.Module CF.Ann -> Make ()
   ffiCodegen m = do
-    codegenTargets <- asks optionsCodegenTargets
+    codegenTargets <- asks $ optionsCodegenTargets . fst
     when (S.member JS codegenTargets) $ do
       let mn = CF.moduleName m
       case mn `M.lookup` foreigns of
diff --git a/src/Language/PureScript/Make/Monad.hs b/src/Language/PureScript/Make/Monad.hs
index 72048f3285..608dfa4dfb 100644
--- a/src/Language/PureScript/Make/Monad.hs
+++ b/src/Language/PureScript/Make/Monad.hs
@@ -51,11 +51,12 @@ import qualified System.Directory as Directory
 import           System.FilePath (takeDirectory)
 import           System.IO.Error (tryIOError, isDoesNotExistError)
 import           System.IO.UTF8 (readUTF8FileT)
+import Data.Map as M
 
 -- | A monad for running make actions
 newtype Make a = Make
-  { unMake :: ReaderT Options (ExceptT MultipleErrors (Logger MultipleErrors)) a
-  } deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options)
+  { unMake :: ReaderT (Options, M.Map Text Text) (ExceptT MultipleErrors (Logger MultipleErrors)) a
+  } deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader (Options, M.Map Text Text))
 
 instance MonadBase IO Make where
   liftBase = liftIO
@@ -67,7 +68,7 @@ instance MonadBaseControl IO Make where
 
 -- | Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings.
 runMake :: Options -> Make a -> IO (Either MultipleErrors a, MultipleErrors)
-runMake opts = runLogger' . runExceptT . flip runReaderT opts . unMake
+runMake opts = runLogger' . runExceptT . flip runReaderT (opts, M.empty) . unMake
 
 -- | Run an 'IO' action in the 'Make' monad. The 'String' argument should
 -- describe what we were trying to do; it is used for rendering errors in the

From 766fc51bf25b8f51464485969be23ff033fecac2 Mon Sep 17 00:00:00 2001
From: radrow <radrowicki@gmail.com>
Date: Mon, 15 Feb 2021 11:57:33 +0100
Subject: [PATCH 09/30] collapsing ands

---
 src/Language/PureScript/AST/Declarations.hs   |  4 ++++
 src/Language/PureScript/CodeGen/JS.hs         |  4 ++--
 src/Language/PureScript/CoreFn/Desugar.hs     |  1 +
 src/Language/PureScript/CoreFn/Expr.hs        |  4 ++++
 src/Language/PureScript/Renamer.hs            |  1 +
 .../PureScript/Sugar/CaseDeclarations.hs      | 19 +++++++++++++++----
 src/Language/PureScript/Sugar/Operators.hs    |  2 +-
 7 files changed, 28 insertions(+), 7 deletions(-)

diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
index 63ef0af4aa..cff92b2bdd 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -839,6 +839,10 @@ data Expr
   -- A value with source position information
   --
   | PositionedValue SourceSpan [Comment] Expr
+  -- |
+  -- Failing pattern match – order to try the next branch
+  ---
+  | SafeCaseFail
   deriving (Show)
 
 -- |
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index dee24eabd8..be32b5c7e4 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -269,8 +269,7 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
       Just name -> AST.Var Nothing name
   valueToJs' (Var _ q) = single $ varToJs q
   valueToJs' (Case (ss, _, _, _) values binders) = do
-    asts <- mapM valueToJs values
-    let (decls, vals) = unzip asts
+    (decls, vals) <- unzip <$> mapM valueToJs values
     (concat decls,) <$> bindersToJs ss binders vals
   valueToJs' (Let _ ds val) = do
     ds' <- concat <$> mapM bindToJs ds
@@ -302,6 +301,7 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
     in single $ iife (properToJs ctor) [ constructor
                           , AST.Assignment Nothing (accessorString "create" (AST.Var Nothing (properToJs ctor))) createFn
                           ]
+  valueToJs' SafeCaseFail = return ([], AST.StringLiteral Nothing "skip")
 
   iife :: Text -> [AST] -> AST
   iife v exprs = AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing $ exprs ++ [AST.Return Nothing $ AST.Var Nothing v])) []
diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs
index 547fe316c2..c0fccb3fcc 100644
--- a/src/Language/PureScript/CoreFn/Desugar.hs
+++ b/src/Language/PureScript/CoreFn/Desugar.hs
@@ -117,6 +117,7 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) =
       (Accessor (ssAnn ss) (mkString $ runIdent ident) (Var (ssAnn ss) $ Qualified Nothing (Ident "dict")))
   exprToCoreFn _ com ty (A.PositionedValue ss com1 v) =
     exprToCoreFn ss (com ++ com1) ty v
+  exprToCoreFn _ _ _ A.SafeCaseFail = SafeCaseFail
   exprToCoreFn _ _ _ e =
     error $ "Unexpected value in exprToCoreFn mn: " ++ show e
 
diff --git a/src/Language/PureScript/CoreFn/Expr.hs b/src/Language/PureScript/CoreFn/Expr.hs
index de2eb2427d..95f9c1df37 100644
--- a/src/Language/PureScript/CoreFn/Expr.hs
+++ b/src/Language/PureScript/CoreFn/Expr.hs
@@ -53,6 +53,10 @@ data Expr a
   -- A let binding
   --
   | Let a [Bind a] (Expr a)
+  -- |
+  -- Failing pattern match – order to try the next branch
+  ---
+  | SafeCaseFail
   deriving (Show, Functor)
 
 -- |
diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs
index 4ee82ad0d3..98623e4e7b 100644
--- a/src/Language/PureScript/Renamer.hs
+++ b/src/Language/PureScript/Renamer.hs
@@ -159,6 +159,7 @@ renameInValue (Case ann vs alts) =
   newScope $ Case ann <$> traverse renameInValue vs <*> traverse renameInCaseAlternative alts
 renameInValue (Let ann ds v) =
   newScope $ Let ann <$> traverse (renameInDecl False) ds <*> renameInValue v
+renameInValue SafeCaseFail = return SafeCaseFail
 
 -- |
 -- Renames within literals.
diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs
index 87f4beb11b..1f73c24e17 100644
--- a/src/Language/PureScript/Sugar/CaseDeclarations.hs
+++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs
@@ -24,6 +24,7 @@ import Language.PureScript.Environment
 import Language.PureScript.Errors
 import Language.PureScript.Names
 import Language.PureScript.TypeChecker.Monad (guardWith)
+import qualified Language.PureScript.Constants as C
 
 -- |
 -- Replace all top-level binders in a module with case expressions.
@@ -186,18 +187,28 @@ desugarGuardedExprs ss (Case scrut alternatives) =
           --
         in Case scrut
             (CaseAlternative vb [MkUnguarded (desugarGuard gs e alt_fail)]
-              : (alt_fail' (length scrut)))
+              : alt_fail' (length scrut))
 
       return [ CaseAlternative scrut_nullbinder [MkUnguarded rhs]]
 
-    desugarGuard :: [Guard] -> Expr -> (Int ->[CaseAlternative]) -> Expr
+    pass :: Int -> [CaseAlternative]
+    pass n = [CaseAlternative (replicate n NullBinder) [MkUnguarded SafeCaseFail]]
+
+    desugarGuard :: [Guard] -> Expr -> (Int -> [CaseAlternative]) -> Expr
     desugarGuard [] e _ = e
+    desugarGuard (ConditionGuard c1 : ConditionGuard c2 : gs) e match_failed =
+      desugarGuard (ConditionGuard (
+                       App (App (App (Var ss (Qualified (Just (ModuleName "Data.HeytingAlgebra")) (Ident C.conj)))
+                                  (Var ss (Qualified (Just (ModuleName "Data.HeytingAlgebra")) (Ident C.heytingAlgebraBoolean))))
+                                 c1)
+                             c2)
+                     : gs) e match_failed
     desugarGuard (ConditionGuard c : gs) e match_failed
       | isTrueExpr c = desugarGuard gs e match_failed
       | otherwise =
         Case [c]
           (CaseAlternative [LiteralBinder ss (BooleanLiteral True)]
-            [MkUnguarded (desugarGuard gs e match_failed)] : match_failed 1)
+            [MkUnguarded (desugarGuard gs e pass)] : match_failed 1)
 
     desugarGuard (PatternGuard vb g : gs) e match_failed =
       Case [g]
@@ -206,7 +217,7 @@ desugarGuardedExprs ss (Case scrut alternatives) =
       where
         -- don't consider match_failed case if the binder is irrefutable
         match_failed' | isIrrefutable vb = []
-                      | otherwise        = match_failed 1
+                      | otherwise        = pass 1
 
     -- we generate a let-binding for the remaining guards
     -- and alternatives. A CaseAlternative is passed (or in
diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs
index 1d0bb8aec4..c54999975e 100644
--- a/src/Language/PureScript/Sugar/Operators.hs
+++ b/src/Language/PureScript/Sugar/Operators.hs
@@ -38,7 +38,7 @@ import Data.Traversable (for)
 import qualified Data.Map as M
 
 import qualified Language.PureScript.Constants as C
-
+import Debug.Trace
 -- |
 -- Removes unary negation operators and replaces them with calls to `negate`.
 --

From 265bba3a55257a7ff749211e6a1b3e2434333a7f Mon Sep 17 00:00:00 2001
From: radrow <radrowicki@gmail.com>
Date: Tue, 16 Feb 2021 13:21:31 +0100
Subject: [PATCH 10/30] hope it works

---
 src/Language/PureScript/CodeGen/JS.hs         | 141 ++++++++-------
 src/Language/PureScript/CodeGen/JS/Printer.hs |   6 +-
 src/Language/PureScript/CoreFn/Desugar.hs     |  11 +-
 src/Language/PureScript/CoreFn/Expr.hs        |  15 +-
 src/Language/PureScript/CoreFn/FromJSON.hs    |   6 +-
 src/Language/PureScript/CoreFn/ToJSON.hs      |   6 +-
 src/Language/PureScript/CoreFn/Traversals.hs  |  12 +-
 src/Language/PureScript/CoreImp/AST.hs        |  16 +-
 .../PureScript/CoreImp/Optimizer/Blocks.hs    |  10 +-
 .../PureScript/CoreImp/Optimizer/Common.hs    |   2 +-
 .../PureScript/CoreImp/Optimizer/Inliner.hs   |  34 ++--
 .../PureScript/CoreImp/Optimizer/MagicDo.hs   |  24 +--
 .../PureScript/CoreImp/Optimizer/TCO.hs       |  24 +--
 src/Language/PureScript/Renamer.hs            |   7 +-
 .../PureScript/Sugar/CaseDeclarations.hs      | 168 ++++--------------
 15 files changed, 213 insertions(+), 269 deletions(-)

diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index be32b5c7e4..6af0fa4d30 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -17,7 +17,7 @@ import Control.Monad.Except (MonadError, throwError)
 import Control.Monad.Reader (MonadReader, asks, local)
 import Control.Monad.Supply.Class
 
-import Data.Bifunctor(second, first)
+import Data.Bifunctor(second, first, bimap)
 import Data.List ((\\), intersect)
 import qualified Data.Foldable as F
 import qualified Data.Map as M
@@ -153,10 +153,10 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
   --
   bindToJs :: Bind Ann -> m [AST]
   bindToJs (NonRec ann ident val) = do
-    (decls, x) <- nonRecToJS ann ident val
-    return $ decls ++ [x]
+    (ds, x) <- nonRecToJS ann ident val
+    return $ ds ++ [x]
   bindToJs (Rec vals) = do
-    (\l -> l >>= \(decls, x) -> decls ++ [x]) <$> forM vals (uncurry . uncurry $ nonRecToJS)
+    (\l -> l >>= \(ds, x) -> ds ++ [x]) <$> forM vals (uncurry . uncurry $ nonRecToJS)
 
   -- | Generate code in the simplified JavaScript intermediate representation for a single non-recursive
   -- declaration.
@@ -169,8 +169,8 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
        then nonRecToJS a i (modifyAnn removeComments e)
        else AST.Comment Nothing com <$$> nonRecToJS a i (modifyAnn removeComments e)
   nonRecToJS (ss, _, _, _) ident val = do
-    (decls, js) <- valueToJs val
-    fmap (decls,) $ withPos ss $ AST.VariableLetIntroduction Nothing (identToJs ident) (Just js)
+    (ds, js) <- valueToJs val
+    fmap (ds,) $ withPos ss $ AST.VariableLetIntroduction Nothing (identToJs ident) (Just js)
 
   withPos :: SourceSpan -> AST -> m AST
   withPos ss js = do
@@ -199,14 +199,18 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
   valueToJs :: Expr Ann -> m ([AST], AST)
   valueToJs e = do
     let (ss, _, _, _) = extractAnn e
-    (decls, x) <- valueToJs' e
+    (ds, x) <- valueToJs' e
     x' <- withPos ss x
-    return (decls, x')
+    return (ds, x')
 
   single :: AST -> m ([AST], AST)
   single = return . ([],)
 
-  (<$$>) f m = fmap (\(l, x) -> (map f l, f x)) m
+  (<$$>) :: (a -> b) -> m ([a], a) -> m ([b], b)
+  (<$$>) f m = fmap (bimap (map f) f) m
+  traverseCat f l = do
+    (ds, vs) <- unzip <$> traverse f l
+    return (concat ds, vs)
 
   valueToJs' :: Expr Ann -> m ([AST], AST)
   valueToJs' (Literal (pos, _, _, _) l) =
@@ -218,12 +222,12 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
   valueToJs' (Accessor _ prop val) =
     accessorString prop <$$> valueToJs val
   valueToJs' (ObjectUpdate _ o ps) = do
-    (decls, obj) <- valueToJs o
-    (declss, sts) <- unzip . map (\(p, (d, x)) -> (d, (p, x))) <$> mapM (sndM valueToJs) ps
-    first ((decls ++ concat declss) ++) <$> extendObj obj sts
+    (dso, obj) <- valueToJs o
+    (dss, sts) <- traverseCat (fmap (\(p, (d, x)) -> (d, (p, x))) . sndM valueToJs) ps
+    first ((dso ++ dss) ++) <$> extendObj obj sts
   valueToJs' e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) = do
     let args = unAbs e
-    single $ AST.Function Nothing Nothing (map identToJs args) (AST.Block Nothing $ map assign args)
+    single $ AST.Function Nothing Nothing (map identToJs args) (AST.Block Nothing Nothing $ map assign args)
     where
     unAbs :: Expr Ann -> [Ident]
     unAbs (Abs _ arg val) = arg : unAbs val
@@ -236,23 +240,24 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
     let jsArg = case arg of
                   UnusedIdent -> []
                   _           -> [identToJs arg]
-    r <- single $ AST.Function Nothing Nothing jsArg (AST.Block Nothing $
+    r <- single $ AST.Function Nothing Nothing jsArg (AST.Block Nothing Nothing $
       case ret of
-        (decls, AST.Block ann bs) -> decls ++ bs
-        (decls, val) -> decls ++ [AST.Return Nothing val])
+        (ds, AST.Block _ Nothing bs) -> ds ++ bs
+        (ds, b@AST.Block{}) -> ds ++ [b]
+        (ds, v) -> ds ++ [AST.Return Nothing v])
     return r
   valueToJs' e@App{} = do
     let (f, args) = unApp e []
-    (declss, args') <- unzip <$> mapM valueToJs args
+    (dsa, args') <- traverseCat valueToJs args
     case f of
-      Var (_, _, _, Just IsNewtype) _ -> return (concat declss, head args')
+      Var (_, _, _, Just IsNewtype) _ -> return (dsa, head args')
       Var (_, _, _, Just (IsConstructor _ fields)) name | length args == length fields ->
-        return (concat declss, AST.Unary Nothing AST.New $ AST.App Nothing (qualifiedToJS id name) args')
+        return (dsa, AST.Unary Nothing AST.New $ AST.App Nothing (qualifiedToJS id name) args')
       Var (_, _, _, Just IsTypeClassConstructor) name ->
-        return (concat declss, AST.Unary Nothing AST.New $ AST.App Nothing (qualifiedToJS id name) args')
+        return (dsa, AST.Unary Nothing AST.New $ AST.App Nothing (qualifiedToJS id name) args')
       _ -> do
-        (decls, v') <- valueToJs f
-        return (concat declss ++ decls, foldl (\fn a -> AST.App Nothing fn [a]) v' args')
+        (dsf, v') <- valueToJs f
+        return (dsa ++ dsf, foldl (\fn a -> AST.App Nothing fn [a]) v' args')
     where
     unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])
     unApp (App _ val arg) args = unApp val (arg : args)
@@ -269,8 +274,8 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
       Just name -> AST.Var Nothing name
   valueToJs' (Var _ q) = single $ varToJs q
   valueToJs' (Case (ss, _, _, _) values binders) = do
-    (decls, vals) <- unzip <$> mapM valueToJs values
-    (concat decls,) <$> bindersToJs ss binders vals
+    (ds, vals) <- traverseCat valueToJs values
+    (ds,) <$> bindersToJs ss binders vals
   valueToJs' (Let _ ds val) = do
     ds' <- concat <$> mapM bindToJs ds
     declsAndMap <- forM ds' $ \d -> case d of
@@ -286,25 +291,24 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
     single $ AST.VariableLetIntroduction Nothing (properToJs ctor) (Just $
                 AST.ObjectLiteral Nothing [("create",
                   AST.Function Nothing Nothing ["value"]
-                    (AST.Block Nothing [AST.Return Nothing $ AST.Var Nothing "value"]))])
+                    (AST.Block Nothing Nothing [AST.Return Nothing $ AST.Var Nothing "value"]))])
   valueToJs' (Constructor _ _ ctor []) =
-    single $ iife (properToJs ctor) [ AST.Function Nothing (Just (properToJs ctor)) [] (AST.Block Nothing [])
+    single $ iife (properToJs ctor) [ AST.Function Nothing (Just (properToJs ctor)) [] (AST.Block Nothing Nothing [])
            , AST.Assignment Nothing (accessorString "value" (AST.Var Nothing (properToJs ctor)))
                 (AST.Unary Nothing AST.New $ AST.App Nothing (AST.Var Nothing (properToJs ctor)) []) ]
   valueToJs' (Constructor _ _ ctor fields) =
     let constructor =
           let body = [ AST.Assignment Nothing ((accessorString $ mkString $ identToJs f) (AST.Var Nothing "this")) (var f) | f <- fields ]
-          in AST.Function Nothing (Just (properToJs ctor)) (identToJs `map` fields) (AST.Block Nothing body)
+          in AST.Function Nothing (Just (properToJs ctor)) (identToJs `map` fields) (AST.Block Nothing Nothing body)
         createFn =
           let body = AST.Unary Nothing AST.New $ AST.App Nothing (AST.Var Nothing (properToJs ctor)) (var `map` fields)
-          in foldr (\f inner -> AST.Function Nothing Nothing [identToJs f] (AST.Block Nothing [AST.Return Nothing inner])) body fields
+          in foldr (\f inner -> AST.Function Nothing Nothing [identToJs f] (AST.Block Nothing Nothing [AST.Return Nothing inner])) body fields
     in single $ iife (properToJs ctor) [ constructor
                           , AST.Assignment Nothing (accessorString "create" (AST.Var Nothing (properToJs ctor))) createFn
                           ]
-  valueToJs' SafeCaseFail = return ([], AST.StringLiteral Nothing "skip")
 
   iife :: Text -> [AST] -> AST
-  iife v exprs = AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing $ exprs ++ [AST.Return Nothing $ AST.Var Nothing v])) []
+  iife v exprs = AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing  Nothing $ exprs ++ [AST.Return Nothing $ AST.Var Nothing v])) []
 
   literalToValueJS :: SourceSpan -> Literal (Expr Ann) -> m ([AST], AST)
   literalToValueJS ss (NumericLiteral (Left i)) = single $ AST.NumericLiteral (Just ss) (Left i)
@@ -331,12 +335,12 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
       jsEvaluatedObj = AST.Var Nothing evaluatedObj
       evaluate = AST.VariableLetIntroduction Nothing evaluatedObj (Just obj)
       objAssign = AST.VariableLetIntroduction Nothing newObj (Just $ AST.ObjectLiteral Nothing [])
-      copy = AST.ForIn Nothing key jsEvaluatedObj $ AST.Block Nothing [AST.IfElse Nothing cond assign Nothing]
+      copy = AST.ForIn Nothing key jsEvaluatedObj $ AST.Block Nothing Nothing [AST.IfElse Nothing cond assign Nothing]
       cond = AST.App Nothing (accessorString "call" (accessorString "hasOwnProperty" (AST.ObjectLiteral Nothing []))) [jsEvaluatedObj, jsKey]
-      assign = AST.Block Nothing [AST.Assignment Nothing (AST.Indexer Nothing jsKey jsNewObj) (AST.Indexer Nothing jsKey jsEvaluatedObj)]
+      assign = AST.Block Nothing Nothing [AST.Assignment Nothing (AST.Indexer Nothing jsKey jsNewObj) (AST.Indexer Nothing jsKey jsEvaluatedObj)]
       stToAssign (s, js) = AST.Assignment Nothing (accessorString s jsNewObj) js
       extend = map stToAssign sts
-    return $ (evaluate:objAssign:copy:extend, jsNewObj)
+    return (evaluate:objAssign:copy:extend, jsNewObj)
 
   -- | Generate code in the simplified JavaScript intermediate representation for a reference to a
   -- variable.
@@ -357,14 +361,13 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
   -- | Generate code in the simplified JavaScript intermediate representation for pattern match binders
   -- and guards.
   bindersToJs :: SourceSpan -> [CaseAlternative Ann] -> [AST] -> m AST
-  bindersToJs ss binders vals = do
+  bindersToJs ss alts vals = do
     valNames <- replicateM (length vals) freshName
     let assignments = zipWith (AST.VariableLetIntroduction Nothing) valNames (map Just vals)
-    jss <- forM binders $ \(CaseAlternative bs result) -> do
+    jss <- forM alts $ \(CaseAlternative bs result) -> do
       ret <- guardsToJs result
       go valNames ret bs
-    return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (assignments ++ concat jss ++ [AST.Throw Nothing $ failedPatternError valNames])))
-                  []
+    return $ AST.Block Nothing Nothing (assignments ++ concat jss ++ [failedPatternError valNames])
     where
       go :: [Text] -> [AST] -> [Binder Ann] -> m [AST]
       go _ done [] = return done
@@ -383,25 +386,39 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
       valueError _ l@(AST.NumericLiteral _ _) = l
       valueError _ l@(AST.StringLiteral _ _)  = l
       valueError _ l@(AST.BooleanLiteral _ _) = l
-      valueError s _                        = accessorString "name" . accessorString "constructor" $ AST.Var Nothing s
-
-      guardsToJs :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [AST]
-      guardsToJs (Left gs) = concat <$> traverse genGuard gs where
-        genGuard (cond, val) = do
-          (declsC, cond') <- valueToJs cond
-          (declsV, val')   <- valueToJs val
-          return $ declsC ++ declsV ++
-            [AST.IfElse Nothing cond'
-              (case val' of
-                 AST.Block _ _ -> val'
-                 _ -> AST.Return Nothing val') Nothing
-            ]
-
+      valueError s _                          = accessorString "name" . accessorString "constructor" $ AST.Var Nothing s
+
+      guardsToJs :: Either [([Guard Ann], Expr Ann)] (Expr Ann) -> m [AST]
+      guardsToJs (Left gs) = do
+        let genGuard :: ([Guard Ann], Expr Ann) -> m AST
+            genGuard (conds, val) = do
+              rollback <- freshName
+              guardSeqJs <- guardSeqToJs (Just rollback) conds val
+              return $ AST.Block Nothing (Just rollback) guardSeqJs
+        traverse genGuard gs
       guardsToJs (Right v) = do
-        (decls, val') <- valueToJs v
-        return $ case val' of
-          AST.Block _ bs -> decls ++ bs
-          _ -> decls ++ [AST.Return Nothing val']
+        guardSeqToJs Nothing [] v
+
+      guardSeqToJs :: Maybe Text -> [Guard Ann] -> Expr Ann -> m [AST]
+      guardSeqToJs _ [] fin = do
+        (ds, fin') <- valueToJs fin
+        return $ case fin' of
+          AST.Block _ Nothing bs -> ds ++ bs
+          b@AST.Block{} -> ds ++ [b]
+          _ -> ds ++ [AST.Return Nothing fin']
+      guardSeqToJs rollback (ConditionGuard e : rest) fin = do
+         (ds, val) <- valueToJs e
+         cont <- guardSeqToJs rollback rest fin
+         return $ ds ++
+           [ AST.IfElse Nothing val (AST.Block Nothing Nothing cont)
+             (AST.Break Nothing . Just <$> rollback)
+           ]
+      guardSeqToJs rollback (PatternGuard lv rv : rest) fin = do
+         (ds, rv') <- valueToJs rv
+         casevar <- freshName
+         cont <- guardSeqToJs rollback rest fin
+         bind <- binderToJs casevar cont lv
+         return $ ds ++ [AST.VariableLetIntroduction Nothing casevar (Just rv')] ++ bind ++ maybe [] ((:[]) . AST.Break Nothing . Just) rollback
 
   binderToJs :: Text -> [AST] -> Binder Ann -> m [AST]
   binderToJs s done binder =
@@ -424,7 +441,7 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
       ProductType -> js
       SumType ->
         [AST.IfElse Nothing (AST.InstanceOf Nothing (AST.Var Nothing varName) (qualifiedToJS (Ident . runProperName) ctor))
-                  (AST.Block Nothing js)
+                  (AST.Block Nothing Nothing js)
                   Nothing]
     where
     go :: [(Ident, Binder Ann)] -> [AST] -> m [AST]
@@ -442,15 +459,15 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
 
   literalToBinderJS :: Text -> [AST] -> Literal (Binder Ann) -> m [AST]
   literalToBinderJS varName done (NumericLiteral num) =
-    return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.NumericLiteral Nothing num)) (AST.Block Nothing done) Nothing]
+    return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.NumericLiteral Nothing num)) (AST.Block Nothing Nothing done) Nothing]
   literalToBinderJS varName done (CharLiteral c) =
-    return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.StringLiteral Nothing (fromString [c]))) (AST.Block Nothing done) Nothing]
+    return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.StringLiteral Nothing (fromString [c]))) (AST.Block Nothing Nothing done) Nothing]
   literalToBinderJS varName done (StringLiteral str) =
-    return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.StringLiteral Nothing str)) (AST.Block Nothing done) Nothing]
+    return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.StringLiteral Nothing str)) (AST.Block Nothing Nothing done) Nothing]
   literalToBinderJS varName done (BooleanLiteral True) =
-    return [AST.IfElse Nothing (AST.Var Nothing varName) (AST.Block Nothing done) Nothing]
+    return [AST.IfElse Nothing (AST.Var Nothing varName) (AST.Block Nothing Nothing done) Nothing]
   literalToBinderJS varName done (BooleanLiteral False) =
-    return [AST.IfElse Nothing (AST.Unary Nothing AST.Not (AST.Var Nothing varName)) (AST.Block Nothing done) Nothing]
+    return [AST.IfElse Nothing (AST.Unary Nothing AST.Not (AST.Var Nothing varName)) (AST.Block Nothing Nothing done) Nothing]
   literalToBinderJS varName done (ObjectLiteral bs) = go done bs
     where
     go :: [AST] -> [(PSString, Binder Ann)] -> m [AST]
@@ -462,7 +479,7 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
       return (AST.VariableLetIntroduction Nothing propVar (Just (accessorString prop (AST.Var Nothing varName))) : js)
   literalToBinderJS varName done (ArrayLiteral bs) = do
     js <- go done 0 bs
-    return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (accessorString "length" (AST.Var Nothing varName)) (AST.NumericLiteral Nothing (Left (fromIntegral $ length bs)))) (AST.Block Nothing js) Nothing]
+    return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (accessorString "length" (AST.Var Nothing varName)) (AST.NumericLiteral Nothing (Left (fromIntegral $ length bs)))) (AST.Block Nothing Nothing js) Nothing]
     where
     go :: [AST] -> Integer -> [Binder Ann] -> m [AST]
     go done' _ [] = return done'
diff --git a/src/Language/PureScript/CodeGen/JS/Printer.hs b/src/Language/PureScript/CodeGen/JS/Printer.hs
index a93f3ff2cd..e8905b0d6e 100644
--- a/src/Language/PureScript/CodeGen/JS/Printer.hs
+++ b/src/Language/PureScript/CodeGen/JS/Printer.hs
@@ -61,8 +61,9 @@ literals = mkPattern' match'
           s'
         _ ->
           prettyPrintStringJS s
-  match (Block _ sts) = mconcat <$> sequence
-    [ return $ emit "{\n"
+  match (Block _ name sts) = mconcat <$> sequence
+    [ return $ maybe mempty (emit . (<> ": ")) name
+    , return $ emit "{\n"
     , withIndent $ prettyStatements sts
     , return $ emit "\n"
     , currentIndent
@@ -126,6 +127,7 @@ literals = mkPattern' match'
     , mconcat <$> forM com comment
     , prettyPrintJS' js
     ]
+  match Pass = return $ emit ""
   match _ = mzero
 
   comment :: (Emit gen) => Comment -> StateT PrinterState Maybe gen
diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs
index c0fccb3fcc..446b43eaf2 100644
--- a/src/Language/PureScript/CoreFn/Desugar.hs
+++ b/src/Language/PureScript/CoreFn/Desugar.hs
@@ -117,7 +117,6 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) =
       (Accessor (ssAnn ss) (mkString $ runIdent ident) (Var (ssAnn ss) $ Qualified Nothing (Ident "dict")))
   exprToCoreFn _ com ty (A.PositionedValue ss com1 v) =
     exprToCoreFn ss (com ++ com1) ty v
-  exprToCoreFn _ _ _ A.SafeCaseFail = SafeCaseFail
   exprToCoreFn _ _ _ e =
     error $ "Unexpected value in exprToCoreFn mn: " ++ show e
 
@@ -125,17 +124,17 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) =
   altToCoreFn :: SourceSpan -> A.CaseAlternative -> CaseAlternative Ann
   altToCoreFn ss (A.CaseAlternative bs vs) = CaseAlternative (map (binderToCoreFn ss []) bs) (go vs)
     where
-    go :: [A.GuardedExpr] -> Either [(Guard Ann, Expr Ann)] (Expr Ann)
+    go :: [A.GuardedExpr] -> Either [([Guard Ann], Expr Ann)] (Expr Ann)
     go [A.MkUnguarded e]
       = Right (exprToCoreFn ss [] Nothing e)
     go gs
-      = Left [ (exprToCoreFn ss [] Nothing cond, exprToCoreFn ss [] Nothing e)
+      = Left [ (guard', exprToCoreFn ss [] Nothing e)
              | A.GuardedExpr g e <- gs
-             , let cond = guardToExpr g
+             , let guard' = map guardToCoreFn g
              ]
 
-    guardToExpr [A.ConditionGuard cond] = cond
-    guardToExpr _ = internalError "Guard not correctly desugared"
+    guardToCoreFn (A.ConditionGuard cond) = ConditionGuard (exprToCoreFn ss [] Nothing cond)
+    guardToCoreFn (A.PatternGuard lv rv) = PatternGuard (binderToCoreFn ss [] lv) (exprToCoreFn ss [] Nothing rv)
 
   -- | Desugars case binders from AST to CoreFn representation.
   binderToCoreFn :: SourceSpan -> [Comment] -> A.Binder -> Binder Ann
diff --git a/src/Language/PureScript/CoreFn/Expr.hs b/src/Language/PureScript/CoreFn/Expr.hs
index 95f9c1df37..fdfe6bc7c2 100644
--- a/src/Language/PureScript/CoreFn/Expr.hs
+++ b/src/Language/PureScript/CoreFn/Expr.hs
@@ -53,10 +53,6 @@ data Expr a
   -- A let binding
   --
   | Let a [Bind a] (Expr a)
-  -- |
-  -- Failing pattern match – order to try the next branch
-  ---
-  | SafeCaseFail
   deriving (Show, Functor)
 
 -- |
@@ -73,9 +69,11 @@ data Bind a
   | Rec [((a, Ident), Expr a)] deriving (Show, Functor)
 
 -- |
--- A guard is just a boolean-valued expression that appears alongside a set of binders
+-- A guard is just a boolean-valued expression that appears along side a set of binders
 --
-type Guard a = Expr a
+data Guard a = ConditionGuard (Expr a)
+             | PatternGuard (Binder a) (Expr a)
+  deriving (Show, Functor)
 
 -- |
 -- An alternative in a case statement
@@ -88,14 +86,14 @@ data CaseAlternative a = CaseAlternative
     -- |
     -- The result expression or a collect of guarded expressions
     --
-  , caseAlternativeResult :: Either [(Guard a, Expr a)] (Expr a)
+  , caseAlternativeResult :: Either [([Guard a], Expr a)] (Expr a)
   } deriving (Show)
 
 instance Functor CaseAlternative where
 
   fmap f (CaseAlternative cabs car) = CaseAlternative
     (fmap (fmap f) cabs)
-    (either (Left . fmap (fmap f *** fmap f)) (Right . fmap f) car)
+    (either (Left . fmap (fmap (fmap f) *** fmap f)) (Right . fmap f) car)
 
 -- |
 -- Extract the annotation from a term
@@ -111,7 +109,6 @@ extractAnn (Var a _) = a
 extractAnn (Case a _ _) = a
 extractAnn (Let a _ _) = a
 
-
 -- |
 -- Modify the annotation on a term
 --
diff --git a/src/Language/PureScript/CoreFn/FromJSON.hs b/src/Language/PureScript/CoreFn/FromJSON.hs
index 798ce2b843..4e2c93a2db 100644
--- a/src/Language/PureScript/CoreFn/FromJSON.hs
+++ b/src/Language/PureScript/CoreFn/FromJSON.hs
@@ -247,7 +247,8 @@ caseAlternativeFromJSON modulePath = withObject "CaseAlternative" caseAlternativ
       if isGuarded
         then do
           es <- o .: "expressions" >>= listParser parseResultWithGuard
-          return $ CaseAlternative bs (Left es)
+          error "TODO: fromJSON"
+          -- return $ CaseAlternative bs (Left es)
         else do
           e <- o .: "expression" >>= exprFromJSON modulePath
           return $ CaseAlternative bs (Right e)
@@ -257,7 +258,8 @@ caseAlternativeFromJSON modulePath = withObject "CaseAlternative" caseAlternativ
       \o -> do
         g <- o .: "guard" >>= exprFromJSON modulePath
         e <- o .: "expression" >>= exprFromJSON modulePath
-        return (g, e)
+        error "TODO: fromJSON"
+        -- return (g, e)
 
 binderFromJSON :: FilePath -> Value -> Parser (Binder Ann)
 binderFromJSON modulePath = withObject "Binder" binderFromObj
diff --git a/src/Language/PureScript/CoreFn/ToJSON.hs b/src/Language/PureScript/CoreFn/ToJSON.hs
index ec54c1e5c7..8f677fff1a 100644
--- a/src/Language/PureScript/CoreFn/ToJSON.hs
+++ b/src/Language/PureScript/CoreFn/ToJSON.hs
@@ -199,10 +199,14 @@ caseAlternativeToJSON (CaseAlternative bs r') =
       , T.pack "isGuarded"   .= toJSON isGuarded
       , T.pack (if isGuarded then "expressions" else "expression")
          .= case r' of
-             Left rs -> toJSON $ map (\(g, e) -> object [ T.pack "guard" .= exprToJSON g, T.pack "expression" .= exprToJSON e]) rs
+             Left rs -> toJSON $ map (\(g, e) -> object [ T.pack "guard" .= toJSON (map guardToJSON g), T.pack "expression" .= exprToJSON e]) rs
              Right r -> exprToJSON r
       ]
 
+guardToJSON :: Guard Ann -> Value
+guardToJSON (ConditionGuard e) = object [T.pack "guardCondition" .= exprToJSON e]
+guardToJSON (PatternGuard lv rv) = object [T.pack "guardLvalue" .= binderToJSON lv, T.pack "guardRvalue" .= exprToJSON rv]
+
 binderToJSON :: Binder Ann -> Value
 binderToJSON (VarBinder ann v)              = object [ T.pack "binderType"  .= "VarBinder"
                                                      , T.pack "annotation"  .= annToJSON ann
diff --git a/src/Language/PureScript/CoreFn/Traversals.hs b/src/Language/PureScript/CoreFn/Traversals.hs
index 633ae9efb8..d8a1e5b6a9 100644
--- a/src/Language/PureScript/CoreFn/Traversals.hs
+++ b/src/Language/PureScript/CoreFn/Traversals.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE Strict #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 -- |
 -- CoreFn traversal helpers
 --
@@ -40,9 +41,12 @@ everywhereOnValues f g h = (f', g', h')
   h' (ConstructorBinder a q1 q2 bs) = h (ConstructorBinder a q1 q2 (map h' bs))
   h' b = h b
 
+  handleGuard (ConditionGuard e) = ConditionGuard (g' e)
+  handleGuard (PatternGuard p e) = PatternGuard (h' p) (g' e)
+
   handleCaseAlternative ca =
     ca { caseAlternativeBinders = map h' (caseAlternativeBinders ca)
-       , caseAlternativeResult = (map (g' *** g') +++ g') (caseAlternativeResult ca)
+       , caseAlternativeResult = (map (map handleGuard *** g') +++ g') (caseAlternativeResult ca)
        }
 
   handleLiteral :: (a -> a) -> Literal a -> Literal a
@@ -76,7 +80,11 @@ everythingOnValues (<>.) f g h i = (f', g', h', i')
   h' b = h b
 
   i' ca@(CaseAlternative bs (Right val)) = foldl' (<>.) (i ca) (map h' bs) <>. g' val
-  i' ca@(CaseAlternative bs (Left gs)) = foldl' (<>.) (i ca) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)
+  i' ca@(CaseAlternative bs (Left gs)) = foldl' (<>.) (i ca)
+    (map h' bs ++ concatMap (\(grd, val) -> map handleGuard grd ++ [g' val]) gs)
+
+  handleGuard (ConditionGuard e) = g' e
+  handleGuard (PatternGuard p e) = h' p <>. g' e
 
   extractLiteral (ArrayLiteral xs) = xs
   extractLiteral (ObjectLiteral xs) = map snd xs
diff --git a/src/Language/PureScript/CoreImp/AST.hs b/src/Language/PureScript/CoreImp/AST.hs
index 3e6ec51612..d0c7f1aae8 100644
--- a/src/Language/PureScript/CoreImp/AST.hs
+++ b/src/Language/PureScript/CoreImp/AST.hs
@@ -70,7 +70,7 @@ data AST
   -- ^ Function application
   | Var (Maybe SourceSpan) Text
   -- ^ Variable
-  | Block (Maybe SourceSpan) [AST]
+  | Block (Maybe SourceSpan) (Maybe Text) [AST]
   -- ^ A block of expressions in braces
   | VariableIntroduction (Maybe SourceSpan) Text (Maybe AST)
   -- ^ A variable introduction and optional initialization
@@ -102,6 +102,8 @@ data AST
   -- ^ instanceof check
   | Comment (Maybe SourceSpan) [Comment] AST
   -- ^ Commented JavaScript
+  | Pass
+  -- ^ Empty instruction
   deriving (Show, Eq)
 
 withSourceSpan :: SourceSpan -> AST -> AST
@@ -121,7 +123,7 @@ withSourceSpan withSpan = go where
   go (Function _ name args j) = Function ss name args j
   go (App _ j js) = App ss j js
   go (Var _ s) = Var ss s
-  go (Block _ js) = Block ss js
+  go (Block _ n js) = Block ss n js
   go (VariableIntroduction _ name j) = VariableIntroduction ss name j
   go (VariableLetIntroduction _ name j) = VariableLetIntroduction ss name j
   go (Assignment _ j1 j2) = Assignment ss j1 j2
@@ -137,6 +139,7 @@ withSourceSpan withSpan = go where
   go (Throw _ js) = Throw ss js
   go (InstanceOf _ j1 j2) = InstanceOf ss j1 j2
   go (Comment _ com j) = Comment ss com j
+  go Pass = Pass
 
 getSourceSpan :: AST -> Maybe SourceSpan
 getSourceSpan = go where
@@ -152,7 +155,7 @@ getSourceSpan = go where
   go (Function ss _ _ _) = ss
   go (App ss _ _) = ss
   go (Var ss _) = ss
-  go (Block ss _) = ss
+  go (Block ss _ _) = ss
   go (VariableIntroduction ss _ _) = ss
   go (VariableLetIntroduction ss _ _) = ss
   go (Assignment ss _ _) = ss
@@ -168,6 +171,7 @@ getSourceSpan = go where
   go (Throw ss _) = ss
   go (InstanceOf ss _ _) = ss
   go (Comment ss _ _) = ss
+  go Pass = Nothing
 
 everywhere :: (AST -> AST) -> AST -> AST
 everywhere f = go where
@@ -179,7 +183,7 @@ everywhere f = go where
   go (ObjectLiteral ss js) = f (ObjectLiteral ss (map (fmap go) js))
   go (Function ss name args j) = f (Function ss name args (go j))
   go (App ss j js) = f (App ss (go j) (map go js))
-  go (Block ss js) = f (Block ss (map go js))
+  go (Block ss n js) = f (Block ss n (map go js))
   go (VariableIntroduction ss name j) = f (VariableIntroduction ss name (fmap go j))
   go (VariableLetIntroduction ss name j) = f (VariableLetIntroduction ss name (fmap go j))
   go (Assignment ss j1 j2) = f (Assignment ss (go j1) (go j2))
@@ -206,7 +210,7 @@ everywhereTopDownM f = f >=> go where
   go (ObjectLiteral ss js) = ObjectLiteral ss <$> traverse (sndM f') js
   go (Function ss name args j) = Function ss name args <$> f' j
   go (App ss j js) = App ss <$> f' j <*> traverse f' js
-  go (Block ss js) = Block ss <$> traverse f' js
+  go (Block ss n js) = Block ss n <$> traverse f' js
   go (VariableIntroduction ss name j) = VariableIntroduction ss name <$> traverse f' j
   go (VariableLetIntroduction ss name j) = VariableLetIntroduction ss name <$> traverse f' j
   go (Assignment ss j1 j2) = Assignment ss <$> f' j1 <*> f' j2
@@ -229,7 +233,7 @@ everything (<>.) f = go where
   go j@(ObjectLiteral _ js) = foldl' (<>.) (f j) (map (go . snd) js)
   go j@(Function _ _ _ j1) = f j <>. go j1
   go j@(App _ j1 js) = foldl' (<>.) (f j <>. go j1) (map go js)
-  go j@(Block _ js) = foldl' (<>.) (f j) (map go js)
+  go j@(Block _ _ js) = foldl' (<>.) (f j) (map go js)
   go j@(VariableIntroduction _ _ (Just j1)) = f j <>. go j1
   go j@(VariableLetIntroduction _ _ (Just j1)) = f j <>. go j1
   go j@(Assignment _ j1 j2) = f j <>. go j1 <>. go j2
diff --git a/src/Language/PureScript/CoreImp/Optimizer/Blocks.hs b/src/Language/PureScript/CoreImp/Optimizer/Blocks.hs
index 04febf2039..c630fb5a12 100644
--- a/src/Language/PureScript/CoreImp/Optimizer/Blocks.hs
+++ b/src/Language/PureScript/CoreImp/Optimizer/Blocks.hs
@@ -12,17 +12,17 @@ import Language.PureScript.CoreImp.AST
 collapseNestedBlocks :: AST -> AST
 collapseNestedBlocks = everywhere collapse where
   collapse :: AST -> AST
-  collapse (Block ss sts) = Block ss (concatMap go sts)
+  collapse (Block ss n sts) = Block ss n (concatMap go sts)
   collapse js = js
-  
+
   go :: AST -> [AST]
-  go (Block _ sts) = sts
+  go (Block _ Nothing sts) = sts
   go s = [s]
 
 collapseNestedIfs :: AST -> AST
 collapseNestedIfs = everywhere collapse where
   collapse :: AST -> AST
-  collapse (IfElse _ (BooleanLiteral _ True) (Block _ [js]) _) = js
-  collapse (IfElse s1 cond1 (Block _ [IfElse s2 cond2 body Nothing]) Nothing) =
+  collapse (IfElse _ (BooleanLiteral _ True) (Block _ _ [js]) _) = js
+  collapse (IfElse s1 cond1 (Block _ Nothing [IfElse s2 cond2 body Nothing]) Nothing) =
       IfElse s1 (Binary s2 And cond1 cond2) body Nothing
   collapse js = js
diff --git a/src/Language/PureScript/CoreImp/Optimizer/Common.hs b/src/Language/PureScript/CoreImp/Optimizer/Common.hs
index 8192c63374..16c536566d 100644
--- a/src/Language/PureScript/CoreImp/Optimizer/Common.hs
+++ b/src/Language/PureScript/CoreImp/Optimizer/Common.hs
@@ -75,7 +75,7 @@ isUpdated var1 = everything (||) check
 
 {-# INLINE removeFromBlock #-}
 removeFromBlock :: ([AST] -> [AST]) -> AST -> AST
-removeFromBlock go (Block ss sts) = Block ss (go sts)
+removeFromBlock go (Block ss n sts) = Block ss n (go sts)
 removeFromBlock _  js = js
 
 {-# INLINE isDict #-}
diff --git a/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs
index 172e5ebd87..e7ce415eb3 100644
--- a/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs
+++ b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs
@@ -44,31 +44,31 @@ etaConvert :: AST -> AST
 etaConvert = everywhere convert
   where
   convert :: AST -> AST
-  convert (Block ss [Return _ (App _ (Function _ Nothing idents block@(Block _ body)) args)])
+  convert (Block ss n [Return _ (App _ (Function _ Nothing idents block@(Block _ _ body)) args)])
     | all shouldInline args &&
       not (any ((`isRebound` block) . Var Nothing) idents) &&
       not (any (`isRebound` block) args)
-      = Block ss (map (replaceIdents (zip idents args)) body)
-  convert (Function _ Nothing [] (Block _ [Return _ (App _ fn [])])) = fn
+      = Block ss n (map (replaceIdents (zip idents args)) body)
+  convert (Function _ Nothing [] (Block _ Nothing [Return _ (App _ fn [])])) = fn
   convert js = js
 
 unThunk :: AST -> AST
 unThunk = everywhere convert
   where
   convert :: AST -> AST
-  convert (Block ss []) = Block ss []
-  convert (Block ss jss) =
+  convert (Block ss n []) = Block ss n []
+  convert (Block ss n jss) =
     case last jss of
-      Return _ (App _ (Function _ Nothing [] (Block _ body)) []) -> Block ss $ init jss ++ body
-      _ -> Block ss jss
+      Return _ (App _ (Function _ Nothing [] (Block _ Nothing body)) []) -> Block ss n $ init jss ++ body
+      _ -> Block ss n jss
   convert js = js
 
 evaluateIifes :: AST -> AST
 evaluateIifes = everywhere convert
   where
   convert :: AST -> AST
-  convert (App _ (Function _ Nothing [] (Block _ [Return _ ret])) []) = ret
-  convert (App _ (Function _ Nothing idents (Block _ [Return ss ret])) [])
+  convert (App _ (Function _ Nothing [] (Block _ _ [Return _ ret])) []) = ret
+  convert (App _ (Function _ Nothing idents (Block _ _ [Return ss ret])) [])
     | not (any (`isReassigned` ret) idents) = replaceIdents (map (, Var ss C.undefined) idents) ret
   convert js = js
 
@@ -198,16 +198,16 @@ inlineCommonOperators = everywhereTopDown $ applyAll $
 
   mkFn :: Int -> AST -> AST
   mkFn = mkFn' C.dataFunctionUncurried C.mkFn $ \ss1 ss2 ss3 args js ->
-    Function ss1 Nothing args (Block ss2 [Return ss3 js])
+    Function ss1 Nothing args (Block ss2 Nothing [Return ss3 js])
 
   mkEffFn :: Text -> Text -> Int -> AST -> AST
   mkEffFn modName fnName = mkFn' modName fnName $ \ss1 ss2 ss3 args js ->
-    Function ss1 Nothing args (Block ss2 [Return ss3 (App ss3 js [])])
+    Function ss1 Nothing args (Block ss2 Nothing [Return ss3 (App ss3 js [])])
 
   mkFn' :: Text -> Text -> (Maybe SourceSpan -> Maybe SourceSpan -> Maybe SourceSpan -> [Text] -> AST -> AST) -> Int -> AST -> AST
   mkFn' modName fnName res 0 = convert where
     convert :: AST -> AST
-    convert (App _ mkFnN [Function s1 Nothing [_] (Block s2 [Return s3 js])]) | isNFn modName fnName 0 mkFnN =
+    convert (App _ mkFnN [Function s1 Nothing [_] (Block s2 Nothing [Return s3 js])]) | isNFn modName fnName 0 mkFnN =
       res s1 s2 s3 [] js
     convert other = other
   mkFn' modName fnName res n = convert where
@@ -218,8 +218,8 @@ inlineCommonOperators = everywhereTopDown $ applyAll $
         _ -> orig
     convert other = other
     collectArgs :: Int -> [Text] -> AST -> Maybe ([Text], [AST])
-    collectArgs 1 acc (Function _ Nothing [oneArg] (Block _ js)) | length acc == n - 1 = Just (reverse (oneArg : acc), js)
-    collectArgs m acc (Function _ Nothing [oneArg] (Block _ [Return _ ret])) = collectArgs (m - 1) (oneArg : acc) ret
+    collectArgs 1 acc (Function _ Nothing [oneArg] (Block _ _ js)) | length acc == n - 1 = Just (reverse (oneArg : acc), js)
+    collectArgs m acc (Function _ Nothing [oneArg] (Block _ _ [Return _ ret])) = collectArgs (m - 1) (oneArg : acc) ret
     collectArgs _ _   _ = Nothing
 
   isNFn :: Text -> Text -> Int -> AST -> Bool
@@ -232,7 +232,7 @@ inlineCommonOperators = everywhereTopDown $ applyAll $
 
   runEffFn :: Text -> Text -> Int -> AST -> AST
   runEffFn modName fnName = runFn' modName fnName $ \ss fn acc ->
-    Function ss Nothing [] (Block ss [Return ss (App ss fn acc)])
+    Function ss Nothing [] (Block ss Nothing [Return ss (App ss fn acc)])
 
   runFn' :: Text -> Text -> (Maybe SourceSpan -> AST -> [AST] -> AST) -> Int -> AST -> AST
   runFn' modName runFnName res n = convert where
@@ -274,10 +274,10 @@ inlineFnComposition = everywhereTopDownM convert where
   convert other = return other
 
   mkApps :: Maybe SourceSpan -> [Either AST (Text, AST)] -> Text -> AST
-  mkApps ss fns a = App ss (Function ss Nothing [] (Block ss $ vars <> [Return Nothing comp])) []
+  mkApps ss fns a = App ss (Function ss Nothing [] (Block ss Nothing $ vars <> [Return Nothing comp])) []
     where
     vars = uncurry (VariableIntroduction ss) . fmap Just <$> rights fns
-    comp = Function ss Nothing [a] (Block ss [Return Nothing apps])
+    comp = Function ss Nothing [a] (Block ss Nothing [Return Nothing apps])
     apps = foldr (\fn acc -> App ss (mkApp fn) [acc]) (Var ss a) fns
 
   mkApp :: Either AST (Text, AST) -> AST
diff --git a/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs b/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs
index 3d127dd311..0cf9894a51 100644
--- a/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs
+++ b/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs
@@ -46,26 +46,26 @@ magicDo effectModule C.EffectDictionaries{..} = everywhereTopDown convert
   -- Desugar pure
   convert (App _ (App _ pure' [val]) []) | isPure pure' = val
   -- Desugar discard
-  convert (App _ (App _ bind [m]) [Function s1 Nothing [] (Block s2 js)]) | isDiscard bind =
-    Function s1 (Just fnName) [] $ Block s2 (App s2 m [] : map applyReturns js )
+  convert (App _ (App _ bind [m]) [Function s1 Nothing [] (Block s2 n js)]) | isDiscard bind =
+    Function s1 (Just fnName) [] $ Block s2 n (App s2 m [] : map applyReturns js )
   -- Desugar bind to wildcard
-  convert (App _ (App _ bind [m]) [Function s1 Nothing [] (Block s2 js)])
+  convert (App _ (App _ bind [m]) [Function s1 Nothing [] (Block s2 n js)])
     | isBind bind =
-    Function s1 (Just fnName) [] $ Block s2 (App s2 m [] : map applyReturns js )
+    Function s1 (Just fnName) [] $ Block s2 n (App s2 m [] : map applyReturns js )
   -- Desugar bind
-  convert (App _ (App _ bind [m]) [Function s1 Nothing [arg] (Block s2 js)]) | isBind bind =
-    Function s1 (Just fnName) [] $ Block s2 (VariableIntroduction s2 arg (Just (App s2 m [])) : map applyReturns js)
+  convert (App _ (App _ bind [m]) [Function s1 Nothing [arg] (Block s2 n js)]) | isBind bind =
+    Function s1 (Just fnName) [] $ Block s2 n (VariableIntroduction s2 arg (Just (App s2 m [])) : map applyReturns js)
   -- Desugar untilE
   convert (App s1 (App _ f [arg]) []) | isEffFunc edUntil f =
-    App s1 (Function s1 Nothing [] (Block s1 [ While s1 Nothing (Unary s1 Not (App s1 arg [])) (Block s1 []), Return s1 $ ObjectLiteral s1 []])) []
+    App s1 (Function s1 Nothing [] (Block s1 Nothing [ While s1 Nothing (Unary s1 Not (App s1 arg [])) (Block s1 Nothing []), Return s1 $ ObjectLiteral s1 []])) []
   -- Desugar whileE
   convert (App _ (App _ (App s1 f [arg1]) [arg2]) []) | isEffFunc edWhile f =
-    App s1 (Function s1 Nothing [] (Block s1 [ While s1 Nothing (App s1 arg1 []) (Block s1 [ App s1 arg2 [] ]), Return s1 $ ObjectLiteral s1 []])) []
+    App s1 (Function s1 Nothing [] (Block s1 Nothing [ While s1 Nothing (App s1 arg1 []) (Block s1 Nothing [ App s1 arg2 [] ]), Return s1 $ ObjectLiteral s1 []])) []
   -- Inline __do returns
   convert (Return _ (App _ (Function _ (Just ident) [] body) [])) | ident == fnName = body
   -- Inline double applications
-  convert (App _ (App s1 (Function s2 Nothing [] (Block ss body)) []) []) =
-    App s1 (Function s2 Nothing [] (Block ss (applyReturns `fmap` body))) []
+  convert (App _ (App s1 (Function s2 Nothing [] (Block ss n body)) []) []) =
+    App s1 (Function s2 Nothing [] (Block ss n (applyReturns `fmap` body))) []
   convert other = other
   -- Check if an expression represents a monomorphic call to >>= for the Eff monad
   isBind (App _ fn [dict]) | isDict (effectModule, edBindDict) dict && isBindPoly fn = True
@@ -91,7 +91,7 @@ magicDo effectModule C.EffectDictionaries{..} = everywhereTopDown convert
 
   applyReturns :: AST -> AST
   applyReturns (Return ss ret) = Return ss (App ss ret [])
-  applyReturns (Block ss jss) = Block ss (map applyReturns jss)
+  applyReturns (Block ss n jss) = Block ss n (map applyReturns jss)
   applyReturns (While ss name cond js) = While ss name cond (applyReturns js)
   applyReturns (For ss v lo hi js) = For ss v lo hi (applyReturns js)
   applyReturns (ForIn ss v xs js) = ForIn ss v xs (applyReturns js)
@@ -116,7 +116,7 @@ inlineST = everywhere convertBlock
   -- or in a more aggressive way, turning wrappers into local variables depending on the
   -- agg(ressive) parameter.
   convert agg (App s1 f [arg]) | isSTFunc C.newSTRef f =
-   Function s1 Nothing [] (Block s1 [Return s1 $ if agg then arg else ObjectLiteral s1 [(mkString C.stRefValue, arg)]])
+   Function s1 Nothing [] (Block s1 Nothing [Return s1 $ if agg then arg else ObjectLiteral s1 [(mkString C.stRefValue, arg)]])
   convert agg (App _ (App s1 f [ref]) []) | isSTFunc C.readSTRef f =
     if agg then ref else Indexer s1 (StringLiteral s1 C.stRefValue) ref
   convert agg (App _ (App _ (App s1 f [arg]) [ref]) []) | isSTFunc C.writeSTRef f =
diff --git a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs
index dc1595a047..28ba3395be 100644
--- a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs
+++ b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs
@@ -61,13 +61,13 @@ tco = flip evalState 0 . everywhereTopDownM convert where
   rewriteFunctionsWith :: ([Text] -> [Text]) -> [[Text]] -> (AST -> AST) -> AST -> ([[Text]], AST, AST -> AST)
   rewriteFunctionsWith argMapper = collectAllFunctionArgs
     where
-    collectAllFunctionArgs allArgs f (Function s1 ident args (Block s2 (body@(Return _ _):_))) =
-      collectAllFunctionArgs (args : allArgs) (\b -> f (Function s1 ident (argMapper args) (Block s2 [b]))) body
-    collectAllFunctionArgs allArgs f (Function ss ident args body@(Block _ _)) =
+    collectAllFunctionArgs allArgs f (Function s1 ident args (Block s2 n (body@(Return _ _):_))) =
+      collectAllFunctionArgs (args : allArgs) (\b -> f (Function s1 ident (argMapper args) (Block s2 n [b]))) body
+    collectAllFunctionArgs allArgs f (Function ss ident args body@(Block _ _ _)) =
       (args : allArgs, body, f . Function ss ident (argMapper args))
-    collectAllFunctionArgs allArgs f (Return s1 (Function s2 ident args (Block s3 [body]))) =
-      collectAllFunctionArgs (args : allArgs) (\b -> f (Return s1 (Function s2 ident (argMapper args) (Block s3 [b])))) body
-    collectAllFunctionArgs allArgs f (Return s1 (Function s2 ident args body@(Block _ _))) =
+    collectAllFunctionArgs allArgs f (Return s1 (Function s2 ident args (Block s3 n [body]))) =
+      collectAllFunctionArgs (args : allArgs) (\b -> f (Return s1 (Function s2 ident (argMapper args) (Block s3 n [b])))) body
+    collectAllFunctionArgs allArgs f (Return s1 (Function s2 ident args body@(Block _ _ _))) =
       (args : allArgs, body, f . Return s1 . Function s2 ident (argMapper args))
     collectAllFunctionArgs allArgs f body = (allArgs, body, f)
 
@@ -116,7 +116,7 @@ tco = flip evalState 0 . everywhereTopDownM convert where
       = anyInTailPosition body
     anyInTailPosition (IfElse _ _ body el)
       = anyInTailPosition body <> foldMap anyInTailPosition el
-    anyInTailPosition (Block _ body)
+    anyInTailPosition (Block _ _ body)
       = foldMap anyInTailPosition body
     anyInTailPosition (VariableIntroduction _ ident' (Just js1))
       | Function _ Nothing _ _ <- js1
@@ -146,14 +146,14 @@ tco = flip evalState 0 . everywhereTopDownM convert where
           let
             allArgumentValues = concat $ collectArgs [] ret
           in
-            Block ss $
+            Block ss Nothing $
               zipWith (\val arg ->
                 Assignment ss (Var ss (tcoVar arg)) val) allArgumentValues outerArgs
               ++ zipWith (\val arg ->
                 Assignment ss (Var ss (copyVar arg)) val) (drop (length outerArgs) allArgumentValues) innerArgs
               ++ [Continue ss (Just tcoLoop)]
         | isIndirectSelfCall ret = Return ss ret
-        | otherwise = Block ss
+        | otherwise = Block ss Nothing
           [ Assignment ss (Var rootSS tcoResult) ret
           , Break ss (Just tcoLoop)
           ]
@@ -161,17 +161,17 @@ tco = flip evalState 0 . everywhereTopDownM convert where
       loopify (For ss i js1 js2 body) = For ss i js1 js2 (loopify body)
       loopify (ForIn ss i js1 body) = ForIn ss i js1 (loopify body)
       loopify (IfElse ss cond body el) = IfElse ss cond (loopify body) (fmap loopify el)
-      loopify (Block ss body) = Block ss (map loopify body)
+      loopify (Block ss n body) = Block ss n (map loopify body)
       -- loopify (VariableIntroduction ss f (Just fn@(Function _ Nothing _ _)))
       --   | (_, body, replace) <- innerCollectAllFunctionArgs [] id fn
       --   , f `S.member` trFns = VariableIntroduction ss f (Just (replace (loopify body)))
       loopify other = other
 
-    pure $ Block rootSS $
+    pure $ Block rootSS Nothing $
         map (\arg -> VariableIntroduction rootSS (tcoVar arg) (Just (Var rootSS (copyVar arg)))) outerArgs ++
         [ VariableIntroduction rootSS tcoResult Nothing
         , While rootSS (Just tcoLoop) (Unary rootSS Not (Var rootSS tcoDone))
-          (Block rootSS $
+          (Block rootSS Nothing $
             map (\v -> VariableLetIntroduction rootSS v (Just . Var rootSS . tcoVar $ v)) outerArgs ++
             map (\v -> VariableLetIntroduction rootSS v (Just . Var rootSS . copyVar $ v)) innerArgs ++
             [loopify js]
diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs
index 98623e4e7b..23d3c100b9 100644
--- a/src/Language/PureScript/Renamer.hs
+++ b/src/Language/PureScript/Renamer.hs
@@ -159,7 +159,6 @@ renameInValue (Case ann vs alts) =
   newScope $ Case ann <$> traverse renameInValue vs <*> traverse renameInCaseAlternative alts
 renameInValue (Let ann ds v) =
   newScope $ Let ann <$> traverse (renameInDecl False) ds <*> renameInValue v
-renameInValue SafeCaseFail = return SafeCaseFail
 
 -- |
 -- Renames within literals.
@@ -175,7 +174,11 @@ renameInLiteral _ l = return l
 renameInCaseAlternative :: CaseAlternative Ann -> Rename (CaseAlternative Ann)
 renameInCaseAlternative (CaseAlternative bs v) = newScope $
   CaseAlternative <$> traverse renameInBinder bs
-                  <*> eitherM (traverse (pairM renameInValue renameInValue)) renameInValue v
+                  <*> eitherM (traverse (pairM (mapM renameInGuard) renameInValue)) renameInValue v
+
+renameInGuard :: Guard Ann -> Rename (Guard Ann)
+renameInGuard (ConditionGuard e) = ConditionGuard <$> renameInValue e
+renameInGuard (PatternGuard lv rv) = PatternGuard <$> renameInBinder lv <*> renameInValue rv
 
 -- |
 -- Renames within binders.
diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs
index 1f73c24e17..72e3f08bac 100644
--- a/src/Language/PureScript/Sugar/CaseDeclarations.hs
+++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs
@@ -81,143 +81,51 @@ desugarGuardedExprs ss (Case scrut alternatives)
 
 desugarGuardedExprs ss (Case scrut alternatives) =
   let
-    -- Alternatives which do not have guards are
-    -- left as-is. Alternatives which
-    --
-    --   1) have multiple clauses of the form
-    --      binder | g_1
-    --             , g_2
-    --             , ...
-    --             , g_n
-    --             -> expr
-    --
-    --   2) and/or contain pattern guards of the form
-    --      binder | pat_bind <- e
-    --             , ...
-    --
-    -- are desugared to a sequence of nested case expressions.
-    --
-    -- Consider an example case expression:
-    --
-    --   case e of
-    --    (T s) | Just info <- Map.lookup s names
-    --          , is_used info
-    --          -> f info
-    --
-    -- We desugar this to
-    --
-    --   case e of
-    --    (T s) -> case Map.lookup s names of
-    --               Just info -> case is_used info of
-    --                              True -> f info
-    --                              (_    -> <partial>)
-    --               (_ -> <partial>)
-    --
-    -- Note that if the original case is partial the desugared
-    -- case is also partial.
-    --
-    -- Consider an exhaustive case expression:
-    --
-    --   case e of
-    --    (T s) | Just info <- Map.lookup s names
-    --          , is_used info
-    --          -> f info
-    --    _     -> Nothing
-    --
-    -- desugars to:
-    --
-    --    case e of
-    --      _ -> let
-    --                v _ = Nothing
-    --           in
-    --             case e of
-    --                (T s) -> case Map.lookup s names of
-    --                          Just info -> f info
-    --                          _ -> v true
-    --                _  -> v true
-    --
-    -- This might look strange but simplifies the algorithm a lot.
-    --
     desugarAlternatives :: [CaseAlternative]
                         -> m [CaseAlternative]
-    desugarAlternatives [] = pure []
-
-    -- the trivial case: no guards
-    desugarAlternatives (a@(CaseAlternative _ [MkUnguarded _]) : as) =
-      (a :) <$> desugarAlternatives as
-
-    -- Special case: CoreFn understands single condition guards on
-    -- binders right hand side.
-    desugarAlternatives (CaseAlternative ab ge : as)
-      | not (null cond_guards) =
-          (CaseAlternative ab cond_guards :)
-            <$> desugarGuardedAlternative ab rest as
-      | otherwise = desugarGuardedAlternative ab ge as
-      where
-        (cond_guards, rest) = span isSingleCondGuard ge
-
-        isSingleCondGuard (GuardedExpr [ConditionGuard _] _) = True
-        isSingleCondGuard _ = False
-
-    desugarGuardedAlternative :: [Binder]
-                              -> [GuardedExpr]
-                              -> [CaseAlternative]
-                              -> m [CaseAlternative]
-    desugarGuardedAlternative _vb [] rem_alts =
-      desugarAlternatives rem_alts
-
-    desugarGuardedAlternative vb (GuardedExpr gs e : ge) rem_alts = do
-      rhs <- desugarAltOutOfLine vb ge rem_alts $ \alt_fail ->
-        let
-          -- if the binder is a var binder we must not add
-          -- the fail case as it results in unreachable
-          -- alternative
-          alt_fail' n | all isIrrefutable vb = []
-                      | otherwise = alt_fail n
-
-
-          -- we are here:
-          --
-          -- case scrut of
-          --   ...
-          --   _ -> let
-          --         v _ = <out of line case>
-          --        in case scrut of -- we are here
-          --            ...
-          --
-        in Case scrut
-            (CaseAlternative vb [MkUnguarded (desugarGuard gs e alt_fail)]
-              : alt_fail' (length scrut))
-
-      return [ CaseAlternative scrut_nullbinder [MkUnguarded rhs]]
-
-    pass :: Int -> [CaseAlternative]
-    pass n = [CaseAlternative (replicate n NullBinder) [MkUnguarded SafeCaseFail]]
-
-    desugarGuard :: [Guard] -> Expr -> (Int -> [CaseAlternative]) -> Expr
-    desugarGuard [] e _ = e
-    desugarGuard (ConditionGuard c1 : ConditionGuard c2 : gs) e match_failed =
+    desugarAlternatives = mapM desugarAlternative
+
+    desugarAlternative (CaseAlternative ab ge) = do
+      dge <- forM ge $ \(GuardedExpr g e) -> GuardedExpr (desugarGuard g) <$> desugarGuardedExprs ss e
+      return $ CaseAlternative ab dge
+
+    -- -- Special case: CoreFn understands single condition guards on
+    -- -- binders right hand side.
+    -- desugarAlternatives (CaseAlternative ab ge : as)
+    --   | not (null cond_guards) =
+    --       (CaseAlternative ab cond_guards :)
+    --         <$> desugarGuardedAlternative ab rest as
+    --   | otherwise = desugarGuardedAlternative ab ge as
+    --   where
+    --     (cond_guards, rest) = span isSingleCondGuard ge
+
+    --     isSingleCondGuard (GuardedExpr [ConditionGuard _] _) = True
+    --     isSingleCondGuard _ = False
+
+    -- desugarGuardedAlternative :: [Binder]
+    --                           -> [GuardedExpr]
+    --                           -> [CaseAlternative]
+    --                           -> m [CaseAlternative]
+    -- desugarGuardedAlternative _vb [] rem_alts =
+    --   desugarAlternatives rem_alts
+
+    -- desugarGuardedAlternative vb (GuardedExpr gs e : ge) rem_alts = do
+    --   rhs <- desugarAltOutOfLine vb ge rem_alts $ \alt_fail ->
+    --     Case scrut
+    --     (CaseAlternative vb (desugarGuard gs)
+    --       : alt_fail' (length scrut))
+
+
+    desugarGuard :: [Guard] -> [Guard]
+    desugarGuard (ConditionGuard c1 : ConditionGuard c2 : gs) =
       desugarGuard (ConditionGuard (
                        App (App (App (Var ss (Qualified (Just (ModuleName "Data.HeytingAlgebra")) (Ident C.conj)))
                                   (Var ss (Qualified (Just (ModuleName "Data.HeytingAlgebra")) (Ident C.heytingAlgebraBoolean))))
                                  c1)
                              c2)
-                     : gs) e match_failed
-    desugarGuard (ConditionGuard c : gs) e match_failed
-      | isTrueExpr c = desugarGuard gs e match_failed
-      | otherwise =
-        Case [c]
-          (CaseAlternative [LiteralBinder ss (BooleanLiteral True)]
-            [MkUnguarded (desugarGuard gs e pass)] : match_failed 1)
-
-    desugarGuard (PatternGuard vb g : gs) e match_failed =
-      Case [g]
-        (CaseAlternative [vb] [MkUnguarded (desugarGuard gs e match_failed)]
-          : match_failed')
-      where
-        -- don't consider match_failed case if the binder is irrefutable
-        match_failed' | isIrrefutable vb = []
-                      | otherwise        = pass 1
+                     : gs)
+    desugarGuard [] = []
+    desugarGuard (h:t) = h:desugarGuard t
 
     -- we generate a let-binding for the remaining guards
     -- and alternatives. A CaseAlternative is passed (or in

From 3adaec7a3b4b50e42e2dad44e45e67179887877d Mon Sep 17 00:00:00 2001
From: radrow <radrowicki@gmail.com>
Date: Tue, 16 Feb 2021 18:05:06 +0100
Subject: [PATCH 11/30] Monad update

---
 src/Language/PureScript/CodeGen/JS.hs   | 34 +++++++++++++++++--------
 src/Language/PureScript/Make/Actions.hs |  8 +++---
 src/Language/PureScript/Make/Monad.hs   |  9 ++++---
 3 files changed, 33 insertions(+), 18 deletions(-)

diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 6af0fa4d30..97e25a74d9 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -3,6 +3,7 @@
 module Language.PureScript.CodeGen.JS
   ( module AST
   , module Common
+  , Env(..)
   , moduleToJs
   ) where
 
@@ -48,13 +49,25 @@ import System.FilePath.Posix ((</>))
 import qualified Data.Map as Map
 import Data.Map(Map)
 
+data Env = Env
+  { options :: Options
+  , vars :: VarEnv
+  , continuation :: AST -> AST
+  }
+
+inLet :: MonadReader Env m => Text -> m a -> m a
+inLet var = local $ \env -> env{continuation = AST.Assignment Nothing (AST.Var Nothing var)}
+
+inFun :: MonadReader Env m => m a -> m a
+inFun = local $ \env -> env{continuation = AST.Return Nothing}
+
 type VarEnv = Map Text Text
 
 -- | Generate code in the simplified JavaScript intermediate representation for all declarations in a
 -- module.
 moduleToJs
   :: forall m
-   . (Monad m, MonadReader (Options, VarEnv) m, MonadSupply m, MonadError MultipleErrors m)
+   . (Monad m, MonadReader Env m, MonadSupply m, MonadError MultipleErrors m)
   => Module Ann
   -> Maybe AST
   -> m [AST]
@@ -64,7 +77,7 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
     let mnLookup = renameImports usedNames imps
     let decls' = renameModules mnLookup decls
 
-    jsDecls <- mapM bindToJs decls'
+    jsDecls <- inFun $ mapM bindToJs decls'
     optimized <- traverse (traverse optimize) jsDecls
     let mnReverseLookup = M.fromList $ map (\(origName, (_, safeName)) -> (moduleNameToJs safeName, origName)) $ M.toList mnLookup
     let usedModuleNames = foldMap (foldMap (findModules mnReverseLookup)) optimized
@@ -72,7 +85,7 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
       . filter (`S.member` usedModuleNames)
       . (\\ (mn : C.primModules)) $ ordNub $ map snd imps
     F.traverse_ (F.traverse_ checkIntegers) optimized
-    comments <- asks (not . optionsNoComments . fst)
+    comments <- asks (not . optionsNoComments . options)
     let strict = AST.StringLiteral Nothing "use strict"
     let header = if comments && not (null coms) then AST.Comment Nothing coms strict else strict
     let foreign' = [AST.VariableIntroduction Nothing "$foreign" foreign_ | not $ null foreigns || isNothing foreign_]
@@ -164,7 +177,7 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
   -- The main purpose of this function is to handle code generation for comments.
   nonRecToJS :: Ann -> Ident -> Expr Ann -> m ([AST], AST)
   nonRecToJS a i e@(extractAnn -> (_, com, _, _)) | not (null com) = do
-    withoutComment <- asks $ optionsNoComments . fst
+    withoutComment <- asks $ optionsNoComments . options
     if withoutComment
        then nonRecToJS a i (modifyAnn removeComments e)
        else AST.Comment Nothing com <$$> nonRecToJS a i (modifyAnn removeComments e)
@@ -174,7 +187,7 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
 
   withPos :: SourceSpan -> AST -> m AST
   withPos ss js = do
-    withSM <- asks (elem JSSourceMap . optionsCodegenTargets . fst)
+    withSM <- asks (elem JSSourceMap . optionsCodegenTargets . options)
     return $ if withSM
       then withSourceSpan ss js
       else js
@@ -236,7 +249,7 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
     assign name = AST.Assignment Nothing (accessorString (mkString $ runIdent name) (AST.Var Nothing "this"))
                                (var name)
   valueToJs' (Abs _ arg val) = do
-    ret <- valueToJs val
+    ret <- inFun $ valueToJs val
     let jsArg = case arg of
                   UnusedIdent -> []
                   _           -> [identToJs arg]
@@ -268,7 +281,7 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
              else varToJs qi
   valueToJs' (Var (_, _, _, Just IsForeign) ident) =
     internalError $ "Encountered an unqualified reference to a foreign ident " ++ T.unpack (showQualified showIdent ident)
-  valueToJs' (Var _ q@(Qualified Nothing (Ident v))) = asks snd >>= \env ->
+  valueToJs' (Var _ q@(Qualified Nothing (Ident v))) = asks vars >>= \env ->
     single $ case M.lookup v env of
       Nothing -> varToJs q
       Just name -> AST.Var Nothing name
@@ -285,7 +298,7 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
       _ -> return (d, Nothing)
     let decls1 = map fst declsAndMap
         env1 = Map.fromList $ mapMaybe snd declsAndMap
-    (ds'', ret) <- local (second $ Map.union env1) $ valueToJs val
+    (ds'', ret) <- local (\env -> env{vars = Map.union env1 (vars env)}) $ valueToJs val
     return (decls1 ++ ds'', ret)
   valueToJs' (Constructor (_, _, _, Just IsNewtype) _ ctor _) =
     single $ AST.VariableLetIntroduction Nothing (properToJs ctor) (Just $
@@ -367,7 +380,7 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
     jss <- forM alts $ \(CaseAlternative bs result) -> do
       ret <- guardsToJs result
       go valNames ret bs
-    return $ AST.Block Nothing Nothing (assignments ++ concat jss ++ [failedPatternError valNames])
+    return $ AST.Block Nothing Nothing (assignments ++ concat jss ++ [AST.Throw Nothing $ failedPatternError valNames])
     where
       go :: [Text] -> [AST] -> [Binder Ann] -> m [AST]
       go _ done [] = return done
@@ -402,10 +415,11 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
       guardSeqToJs :: Maybe Text -> [Guard Ann] -> Expr Ann -> m [AST]
       guardSeqToJs _ [] fin = do
         (ds, fin') <- valueToJs fin
+        finalCont <- asks continuation
         return $ case fin' of
           AST.Block _ Nothing bs -> ds ++ bs
           b@AST.Block{} -> ds ++ [b]
-          _ -> ds ++ [AST.Return Nothing fin']
+          _ -> ds ++ [finalCont fin']
       guardSeqToJs rollback (ConditionGuard e : rest) fin = do
          (ds, val) <- valueToJs e
          cont <- guardSeqToJs rollback rest fin
diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs
index 319782d1a4..ec975f6273 100644
--- a/src/Language/PureScript/Make/Actions.hs
+++ b/src/Language/PureScript/Make/Actions.hs
@@ -210,7 +210,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
 
   getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime)
   getOutputTimestamp mn = do
-    codegenTargets <- asks $ optionsCodegenTargets . fst
+    codegenTargets <- asks $ optionsCodegenTargets . J.options
     let outputPaths = [outputFilename mn externsFileName] <> fmap (targetFilename mn) (S.toList codegenTargets)
     timestamps <- traverse getTimestampMaybe outputPaths
     pure $ fmap minimum . NEL.nonEmpty =<< sequence timestamps
@@ -222,7 +222,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
 
   outputPrimDocs :: Make ()
   outputPrimDocs = do
-    codegenTargets <- asks $ optionsCodegenTargets . fst
+    codegenTargets <- asks $ optionsCodegenTargets . J.options
     when (S.member Docs codegenTargets) $ for_ Docs.Prim.primModules $ \docsMod@Docs.Module{..} ->
       writeJSONFile (outputFilename modName "docs.json") docsMod
 
@@ -230,7 +230,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
   codegen m docs exts = do
     let mn = CF.moduleName m
     lift $ writeCborFile (outputFilename mn externsFileName) exts
-    codegenTargets <- lift $ asks $ optionsCodegenTargets . fst
+    codegenTargets <- lift $ asks $ optionsCodegenTargets . J.options
     when (S.member CoreFn codegenTargets) $ do
       let coreFnFile = targetFilename mn CoreFn
           json = CFJ.moduleToJSON Paths.version m
@@ -261,7 +261,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
 
   ffiCodegen :: CF.Module CF.Ann -> Make ()
   ffiCodegen m = do
-    codegenTargets <- asks $ optionsCodegenTargets . fst
+    codegenTargets <- asks $ optionsCodegenTargets . J.options
     when (S.member JS codegenTargets) $ do
       let mn = CF.moduleName m
       case mn `M.lookup` foreigns of
diff --git a/src/Language/PureScript/Make/Monad.hs b/src/Language/PureScript/Make/Monad.hs
index 608dfa4dfb..f759977e00 100644
--- a/src/Language/PureScript/Make/Monad.hs
+++ b/src/Language/PureScript/Make/Monad.hs
@@ -41,22 +41,23 @@ import qualified Data.ByteString as B
 import           Data.Text (Text)
 import qualified Data.Text as Text
 import           Data.Time.Clock (UTCTime)
+import           Data.Map as M
 import           Language.PureScript.AST
 import           Language.PureScript.Errors
 import           Language.PureScript.Externs (ExternsFile, externsIsCurrentVersion)
 import           Language.PureScript.Make.Cache (ContentHash, hash)
 import           Language.PureScript.Options
+import           Language.PureScript.CodeGen.JS(Env(..))
 import           System.Directory (createDirectoryIfMissing, getModificationTime)
 import qualified System.Directory as Directory
 import           System.FilePath (takeDirectory)
 import           System.IO.Error (tryIOError, isDoesNotExistError)
 import           System.IO.UTF8 (readUTF8FileT)
-import Data.Map as M
 
 -- | A monad for running make actions
 newtype Make a = Make
-  { unMake :: ReaderT (Options, M.Map Text Text) (ExceptT MultipleErrors (Logger MultipleErrors)) a
-  } deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader (Options, M.Map Text Text))
+  { unMake :: ReaderT Env (ExceptT MultipleErrors (Logger MultipleErrors)) a
+  } deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Env)
 
 instance MonadBase IO Make where
   liftBase = liftIO
@@ -68,7 +69,7 @@ instance MonadBaseControl IO Make where
 
 -- | Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings.
 runMake :: Options -> Make a -> IO (Either MultipleErrors a, MultipleErrors)
-runMake opts = runLogger' . runExceptT . flip runReaderT (opts, M.empty) . unMake
+runMake opts = runLogger' . runExceptT . flip runReaderT Env{options = opts, vars = M.empty, continuation = id} . unMake
 
 -- | Run an 'IO' action in the 'Make' monad. The 'String' argument should
 -- describe what we were trying to do; it is used for rendering errors in the

From b33cbb6c7324e8715ea1815c8090155abd1089ad Mon Sep 17 00:00:00 2001
From: radrow <radrowicki@gmail.com>
Date: Wed, 17 Feb 2021 14:35:42 +0100
Subject: [PATCH 12/30] Codegen fixup"

---
 src/Control/Monad/Supply/Class.hs     |  3 ++
 src/Language/PureScript/CodeGen/JS.hs | 71 ++++++++++++++++-----------
 src/Language/PureScript/Make/Monad.hs |  2 +-
 3 files changed, 47 insertions(+), 29 deletions(-)

diff --git a/src/Control/Monad/Supply/Class.hs b/src/Control/Monad/Supply/Class.hs
index 64038a6aac..b0e37666fa 100644
--- a/src/Control/Monad/Supply/Class.hs
+++ b/src/Control/Monad/Supply/Class.hs
@@ -34,3 +34,6 @@ instance (Monoid w, MonadSupply m) => MonadSupply (WriterT w m)
 
 freshName :: MonadSupply m => m Text
 freshName = fmap (("$" <> ) . pack . show) fresh
+
+freshNameHint :: MonadSupply m => Text -> m Text
+freshNameHint hint = fmap ((("$" <> hint) <> ) . pack . show) fresh
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 97e25a74d9..d84450da7a 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -55,12 +55,6 @@ data Env = Env
   , continuation :: AST -> AST
   }
 
-inLet :: MonadReader Env m => Text -> m a -> m a
-inLet var = local $ \env -> env{continuation = AST.Assignment Nothing (AST.Var Nothing var)}
-
-inFun :: MonadReader Env m => m a -> m a
-inFun = local $ \env -> env{continuation = AST.Return Nothing}
-
 type VarEnv = Map Text Text
 
 -- | Generate code in the simplified JavaScript intermediate representation for all declarations in a
@@ -98,6 +92,21 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
 
   where
 
+  inLet :: MonadReader Env m => Text -> Ident -> m a -> m a
+  inLet breakRef i = local $ \env ->
+    env{continuation = \val ->
+        AST.Block Nothing Nothing [AST.Assignment Nothing (var i) val, AST.Break Nothing (Just breakRef)]
+       }
+
+  inFun :: MonadReader Env m => m a -> m a
+  inFun = local $ \env -> env{continuation = AST.Return Nothing}
+
+  inExpr :: MonadReader Env m => m a -> m a
+  inExpr = local $ \env -> env{continuation = id}
+
+  withCont :: MonadReader Env m => AST -> m AST
+  withCont ast = asks $ ($ast) . continuation
+
   -- | Extracts all declaration names from a binding group.
   getNames :: Bind Ann -> [Ident]
   getNames (NonRec _ ident _) = [ident]
@@ -166,24 +175,28 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
   --
   bindToJs :: Bind Ann -> m [AST]
   bindToJs (NonRec ann ident val) = do
-    (ds, x) <- nonRecToJS ann ident val
-    return $ ds ++ [x]
+    ds <- nonRecToJS ann ident val
+    return ds
   bindToJs (Rec vals) = do
-    (\l -> l >>= \(ds, x) -> ds ++ [x]) <$> forM vals (uncurry . uncurry $ nonRecToJS)
+    concat <$> forM vals (uncurry . uncurry $ nonRecToJS)
 
   -- | Generate code in the simplified JavaScript intermediate representation for a single non-recursive
   -- declaration.
   --
   -- The main purpose of this function is to handle code generation for comments.
-  nonRecToJS :: Ann -> Ident -> Expr Ann -> m ([AST], AST)
+  nonRecToJS :: Ann -> Ident -> Expr Ann -> m [AST]
   nonRecToJS a i e@(extractAnn -> (_, com, _, _)) | not (null com) = do
     withoutComment <- asks $ optionsNoComments . options
     if withoutComment
        then nonRecToJS a i (modifyAnn removeComments e)
-       else AST.Comment Nothing com <$$> nonRecToJS a i (modifyAnn removeComments e)
-  nonRecToJS (ss, _, _, _) ident val = do
-    (ds, js) <- valueToJs val
-    fmap (ds,) $ withPos ss $ AST.VariableLetIntroduction Nothing (identToJs ident) (Just js)
+       else map (AST.Comment Nothing com) <$> nonRecToJS a i (modifyAnn removeComments e)
+  nonRecToJS (_, _, _, _) ident val = do
+    breakRef <- freshNameHint $ "init_" <> identToJs ident <> "_"
+    (ds, js) <- inLet breakRef ident $ valueToJs val
+    return (AST.VariableLetIntroduction Nothing (identToJs ident) Nothing :
+            ds ++
+            [AST.Block Nothing (Just breakRef) [js]]
+           )
 
   withPos :: SourceSpan -> AST -> m AST
   withPos ss js = do
@@ -214,7 +227,10 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
     let (ss, _, _, _) = extractAnn e
     (ds, x) <- valueToJs' e
     x' <- withPos ss x
-    return (ds, x')
+    finCont <- asks continuation
+    case x' of
+      AST.Block _ Nothing _ -> return (ds, x')
+      _ -> return (ds, finCont x')
 
   single :: AST -> m ([AST], AST)
   single = return . ([],)
@@ -233,10 +249,10 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
   valueToJs' (Var (_, _, _, Just (IsConstructor _ _)) name) =
     single $ accessorString "create" $ qualifiedToJS id name
   valueToJs' (Accessor _ prop val) =
-    accessorString prop <$$> valueToJs val
+    accessorString prop <$$> inExpr (valueToJs val)
   valueToJs' (ObjectUpdate _ o ps) = do
-    (dso, obj) <- valueToJs o
-    (dss, sts) <- traverseCat (fmap (\(p, (d, x)) -> (d, (p, x))) . sndM valueToJs) ps
+    (dso, obj) <- inExpr $ valueToJs o
+    (dss, sts) <- inExpr $ traverseCat (fmap (\(p, (d, x)) -> (d, (p, x))) . sndM valueToJs) ps
     first ((dso ++ dss) ++) <$> extendObj obj sts
   valueToJs' e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) = do
     let args = unAbs e
@@ -256,12 +272,11 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
     r <- single $ AST.Function Nothing Nothing jsArg (AST.Block Nothing Nothing $
       case ret of
         (ds, AST.Block _ Nothing bs) -> ds ++ bs
-        (ds, b@AST.Block{}) -> ds ++ [b]
-        (ds, v) -> ds ++ [AST.Return Nothing v])
+        (ds, v) -> ds ++ [v])
     return r
   valueToJs' e@App{} = do
     let (f, args) = unApp e []
-    (dsa, args') <- traverseCat valueToJs args
+    (dsa, args') <- inExpr $ traverseCat valueToJs args
     case f of
       Var (_, _, _, Just IsNewtype) _ -> return (dsa, head args')
       Var (_, _, _, Just (IsConstructor _ fields)) name | length args == length fields ->
@@ -269,7 +284,7 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
       Var (_, _, _, Just IsTypeClassConstructor) name ->
         return (dsa, AST.Unary Nothing AST.New $ AST.App Nothing (qualifiedToJS id name) args')
       _ -> do
-        (dsf, v') <- valueToJs f
+        (dsf, v') <- inExpr $ valueToJs f
         return (dsa ++ dsf, foldl (\fn a -> AST.App Nothing fn [a]) v' args')
     where
     unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])
@@ -287,12 +302,12 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
       Just name -> AST.Var Nothing name
   valueToJs' (Var _ q) = single $ varToJs q
   valueToJs' (Case (ss, _, _, _) values binders) = do
-    (ds, vals) <- traverseCat valueToJs values
+    (ds, vals) <- inExpr $ traverseCat valueToJs values
     (ds,) <$> bindersToJs ss binders vals
   valueToJs' (Let _ ds val) = do
-    ds' <- concat <$> mapM bindToJs ds
+    ds' <- inExpr $ concat <$> mapM bindToJs ds
     declsAndMap <- forM ds' $ \d -> case d of
-      AST.Var ann name -> do
+      AST.Var ann name -> do -- FIXME renaming
         q <- freshName
         return (AST.Var ann q, Just (name, q))
       _ -> return (d, Nothing)
@@ -414,21 +429,21 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
 
       guardSeqToJs :: Maybe Text -> [Guard Ann] -> Expr Ann -> m [AST]
       guardSeqToJs _ [] fin = do
-        (ds, fin') <- valueToJs fin
+        (ds, fin') <- inExpr $ valueToJs fin
         finalCont <- asks continuation
         return $ case fin' of
           AST.Block _ Nothing bs -> ds ++ bs
           b@AST.Block{} -> ds ++ [b]
           _ -> ds ++ [finalCont fin']
       guardSeqToJs rollback (ConditionGuard e : rest) fin = do
-         (ds, val) <- valueToJs e
+         (ds, val) <- inExpr $ valueToJs e
          cont <- guardSeqToJs rollback rest fin
          return $ ds ++
            [ AST.IfElse Nothing val (AST.Block Nothing Nothing cont)
              (AST.Break Nothing . Just <$> rollback)
            ]
       guardSeqToJs rollback (PatternGuard lv rv : rest) fin = do
-         (ds, rv') <- valueToJs rv
+         (ds, rv') <- inExpr $ valueToJs rv
          casevar <- freshName
          cont <- guardSeqToJs rollback rest fin
          bind <- binderToJs casevar cont lv
diff --git a/src/Language/PureScript/Make/Monad.hs b/src/Language/PureScript/Make/Monad.hs
index f759977e00..b1b405c76c 100644
--- a/src/Language/PureScript/Make/Monad.hs
+++ b/src/Language/PureScript/Make/Monad.hs
@@ -69,7 +69,7 @@ instance MonadBaseControl IO Make where
 
 -- | Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings.
 runMake :: Options -> Make a -> IO (Either MultipleErrors a, MultipleErrors)
-runMake opts = runLogger' . runExceptT . flip runReaderT Env{options = opts, vars = M.empty, continuation = id} . unMake
+runMake opts = runLogger' . runExceptT . flip runReaderT Env{options = opts, vars = M.empty, continuation = const (error "codegen continuation undefined")} . unMake
 
 -- | Run an 'IO' action in the 'Make' monad. The 'String' argument should
 -- describe what we were trying to do; it is used for rendering errors in the

From 50f6c03f21ec2d3716cac97d6cc52c102c3007b0 Mon Sep 17 00:00:00 2001
From: radrow <radrowicki@gmail.com>
Date: Wed, 17 Feb 2021 18:16:41 +0100
Subject: [PATCH 13/30] Codegen fixup zwei

---
 src/Language/PureScript/CodeGen/JS.hs | 13 +++++++++----
 1 file changed, 9 insertions(+), 4 deletions(-)

diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index d84450da7a..e7f67400a4 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -221,6 +221,12 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
   accessorString :: PSString -> AST -> AST
   accessorString prop = AST.Indexer Nothing (AST.StringLiteral Nothing prop)
 
+  willHandleContinuationByItself :: Expr Ann -> Bool
+  willHandleContinuationByItself e = case e of
+    Let{} -> True
+    Case{} -> True
+    _ -> False
+
   -- | Generate code in the simplified JavaScript intermediate representation for a value or expression.
   valueToJs :: Expr Ann -> m ([AST], AST)
   valueToJs e = do
@@ -230,7 +236,7 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
     finCont <- asks continuation
     case x' of
       AST.Block _ Nothing _ -> return (ds, x')
-      _ -> return (ds, finCont x')
+      _ -> return (ds, if willHandleContinuationByItself e then x' else finCont x')
 
   single :: AST -> m ([AST], AST)
   single = return . ([],)
@@ -429,12 +435,11 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
 
       guardSeqToJs :: Maybe Text -> [Guard Ann] -> Expr Ann -> m [AST]
       guardSeqToJs _ [] fin = do
-        (ds, fin') <- inExpr $ valueToJs fin
-        finalCont <- asks continuation
+        (ds, fin') <- valueToJs fin
         return $ case fin' of
           AST.Block _ Nothing bs -> ds ++ bs
           b@AST.Block{} -> ds ++ [b]
-          _ -> ds ++ [finalCont fin']
+          _ -> ds ++ [fin']
       guardSeqToJs rollback (ConditionGuard e : rest) fin = do
          (ds, val) <- inExpr $ valueToJs e
          cont <- guardSeqToJs rollback rest fin

From ac463be3154aafa5ba5fe1200f8e3a332abb1cc5 Mon Sep 17 00:00:00 2001
From: radrow <radrowicki@gmail.com>
Date: Thu, 18 Feb 2021 09:19:10 +0100
Subject: [PATCH 14/30] Fix array and objects

---
 src/Language/PureScript/CodeGen/JS.hs | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index e7f67400a4..4e45b36f1e 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -351,10 +351,10 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
   literalToValueJS ss (CharLiteral c) = single $ AST.StringLiteral (Just ss) (fromString [c])
   literalToValueJS ss (BooleanLiteral b) = single $ AST.BooleanLiteral (Just ss) b
   literalToValueJS ss (ArrayLiteral xs) = do
-    (declss, vals) <- unzip <$> mapM valueToJs xs
-    return (concat declss, AST.ArrayLiteral (Just ss) vals)
+    (declss, vals) <- traverseCat (inExpr . valueToJs) xs
+    return (declss, AST.ArrayLiteral (Just ss) vals)
   literalToValueJS ss (ObjectLiteral ps) = do
-    (declss, vals) <- unzip . map (\(p, (d, x)) -> (d, (p, x))) <$> mapM (sndM valueToJs) ps
+    (declss, vals) <- unzip . map (\(p, (d, x)) -> (d, (p, x))) <$> mapM (sndM (inExpr . valueToJs)) ps
     return (concat declss, AST.ObjectLiteral (Just ss) vals)
 
   -- | Shallow copy an object.

From 7b049da0b40cf9862db85ef265c1174241e8ddc6 Mon Sep 17 00:00:00 2001
From: radrow <radrowicki@gmail.com>
Date: Thu, 18 Feb 2021 11:33:06 +0100
Subject: [PATCH 15/30] Fix compound expressions

---
 src/Language/PureScript/CodeGen/JS.hs | 52 +++++++++++++++------------
 1 file changed, 29 insertions(+), 23 deletions(-)

diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 4e45b36f1e..969cec0909 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -102,10 +102,17 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
   inFun = local $ \env -> env{continuation = AST.Return Nothing}
 
   inExpr :: MonadReader Env m => m a -> m a
-  inExpr = local $ \env -> env{continuation = id}
-
-  withCont :: MonadReader Env m => AST -> m AST
-  withCont ast = asks $ ($ast) . continuation
+  inExpr = local $ \env -> env{continuation = \x -> if isExpr x then x else error $ "NOT EXPR: " <> show x} where
+    isExpr x = case x of
+      AST.Block{} -> False
+      AST.Return{} -> False
+      AST.VariableIntroduction{} -> False
+      AST.VariableLetIntroduction{} -> False
+      AST.Label{} -> False
+      AST.For{} -> False
+      AST.While{} -> False
+      AST.IfElse{} -> False
+      _ -> True
 
   -- | Extracts all declaration names from a binding group.
   getNames :: Bind Ann -> [Ident]
@@ -191,12 +198,7 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
        then nonRecToJS a i (modifyAnn removeComments e)
        else map (AST.Comment Nothing com) <$> nonRecToJS a i (modifyAnn removeComments e)
   nonRecToJS (_, _, _, _) ident val = do
-    breakRef <- freshNameHint $ "init_" <> identToJs ident <> "_"
-    (ds, js) <- inLet breakRef ident $ valueToJs val
-    return (AST.VariableLetIntroduction Nothing (identToJs ident) Nothing :
-            ds ++
-            [AST.Block Nothing (Just breakRef) [js]]
-           )
+    bindToVar ident (valueToJs val)
 
   withPos :: SourceSpan -> AST -> m AST
   withPos ss js = do
@@ -234,9 +236,7 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
     (ds, x) <- valueToJs' e
     x' <- withPos ss x
     finCont <- asks continuation
-    case x' of
-      AST.Block _ Nothing _ -> return (ds, x')
-      _ -> return (ds, if willHandleContinuationByItself e then x' else finCont x')
+    return (ds, if willHandleContinuationByItself e then x' else finCont x')
 
   single :: AST -> m ([AST], AST)
   single = return . ([],)
@@ -247,6 +247,16 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
     (ds, vs) <- unzip <$> traverse f l
     return (concat ds, vs)
 
+  bindToVar :: Ident -> m ([AST], AST) -> m [AST]
+  bindToVar v ex = do
+    breakRef <- freshNameHint $ "def_" <> identToJs v <> "_"
+    (ds, js) <- inLet breakRef v ex
+    return
+      (AST.VariableLetIntroduction Nothing (identToJs v) Nothing :
+       ds ++
+       [AST.Block Nothing (Just breakRef) [js]]
+      )
+
   valueToJs' :: Expr Ann -> m ([AST], AST)
   valueToJs' (Literal (pos, _, _, _) l) =
     rethrowWithPosition pos $ literalToValueJS pos l
@@ -271,14 +281,11 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
     assign name = AST.Assignment Nothing (accessorString (mkString $ runIdent name) (AST.Var Nothing "this"))
                                (var name)
   valueToJs' (Abs _ arg val) = do
-    ret <- inFun $ valueToJs val
+    (ds, v) <- inFun $ valueToJs val
     let jsArg = case arg of
                   UnusedIdent -> []
                   _           -> [identToJs arg]
-    r <- single $ AST.Function Nothing Nothing jsArg (AST.Block Nothing Nothing $
-      case ret of
-        (ds, AST.Block _ Nothing bs) -> ds ++ bs
-        (ds, v) -> ds ++ [v])
+    r <- single $ AST.Function Nothing Nothing jsArg (AST.Block Nothing Nothing $ ds ++ [v])
     return r
   valueToJs' e@App{} = do
     let (f, args) = unApp e []
@@ -309,7 +316,9 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
   valueToJs' (Var _ q) = single $ varToJs q
   valueToJs' (Case (ss, _, _, _) values binders) = do
     (ds, vals) <- inExpr $ traverseCat valueToJs values
-    (ds,) <$> bindersToJs ss binders vals
+    resVar <- ("case" <>) . T.pack . show <$> fresh
+    dsr <- bindToVar (Ident resVar) (([],) <$> bindersToJs ss binders vals)
+    return (ds ++ dsr, AST.Var Nothing resVar)
   valueToJs' (Let _ ds val) = do
     ds' <- inExpr $ concat <$> mapM bindToJs ds
     declsAndMap <- forM ds' $ \d -> case d of
@@ -436,10 +445,7 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
       guardSeqToJs :: Maybe Text -> [Guard Ann] -> Expr Ann -> m [AST]
       guardSeqToJs _ [] fin = do
         (ds, fin') <- valueToJs fin
-        return $ case fin' of
-          AST.Block _ Nothing bs -> ds ++ bs
-          b@AST.Block{} -> ds ++ [b]
-          _ -> ds ++ [fin']
+        return $ ds ++ [fin']
       guardSeqToJs rollback (ConditionGuard e : rest) fin = do
          (ds, val) <- inExpr $ valueToJs e
          cont <- guardSeqToJs rollback rest fin

From 0274757b798c865060c0104ed9f504b9359b6b01 Mon Sep 17 00:00:00 2001
From: radrow <radrowicki@gmail.com>
Date: Thu, 18 Feb 2021 15:25:54 +0100
Subject: [PATCH 16/30] Fix var indexing

---
 src/Language/PureScript/CodeGen/JS.hs | 99 ++++++++++++++++++---------
 src/Language/PureScript/Make/Monad.hs |  2 +-
 2 files changed, 66 insertions(+), 35 deletions(-)

diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 969cec0909..b436be473c 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -10,10 +10,10 @@ module Language.PureScript.CodeGen.JS
 import Debug.Trace
 
 import Prelude.Compat
-import Protolude (ordNub)
+import Protolude (ordNub, swap)
 
 import Control.Arrow ((&&&))
-import Control.Monad (forM, replicateM, void)
+import Control.Monad (forM, replicateM, void, foldM)
 import Control.Monad.Except (MonadError, throwError)
 import Control.Monad.Reader (MonadReader, asks, local)
 import Control.Monad.Supply.Class
@@ -53,6 +53,8 @@ data Env = Env
   { options :: Options
   , vars :: VarEnv
   , continuation :: AST -> AST
+  , currentModule :: Maybe ModuleName
+  , inToplevel :: Bool
   }
 
 type VarEnv = Map Text Text
@@ -66,12 +68,16 @@ moduleToJs
   -> Maybe AST
   -> m [AST]
 moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
-  rethrow (addHint (ErrorInModule mn)) $ do
+  rethrow (addHint (ErrorInModule mn)) $ local (\e -> e{currentModule = Just mn}) $ do
     let usedNames = concatMap getNames decls
     let mnLookup = renameImports usedNames imps
     let decls' = renameModules mnLookup decls
 
-    jsDecls <- inFun $ mapM bindToJs decls'
+    env0 <- asks vars
+    let proceedDecl (prevEnv, prevDecls) decl' = do
+          (env'', decl'') <- local (\e -> e{vars = prevEnv}) $ bindToJs decl'
+          return (M.union env'' prevEnv, prevDecls . (decl'':))
+    jsDecls <- inFun $ ($[]) . snd <$> foldM proceedDecl (env0, id) decls'
     optimized <- traverse (traverse optimize) jsDecls
     let mnReverseLookup = M.fromList $ map (\(origName, (_, safeName)) -> (moduleNameToJs safeName, origName)) $ M.toList mnLookup
     let usedModuleNames = foldMap (foldMap (findModules mnReverseLookup)) optimized
@@ -86,16 +92,23 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
     let moduleBody = header : foreign' ++ jsImports ++ concat optimized
     let foreignExps = exps `intersect` foreigns
     let standardExps = exps \\ foreignExps
-    let exps' = AST.ObjectLiteral Nothing $ map (mkString . runIdent &&& AST.Var Nothing . identToJs) standardExps
-                               ++ map (mkString . runIdent &&& foreignIdent) foreignExps
+    let exps' =
+          AST.ObjectLiteral Nothing $
+          map (mkString . runIdent &&&
+               AST.Var Nothing . identToJs
+              ) standardExps
+          ++ map (mkString . runIdent &&& foreignIdent) foreignExps
     return $ moduleBody ++ [AST.Assignment Nothing (accessorString "exports" (AST.Var Nothing "module")) exps']
 
   where
 
-  inLet :: MonadReader Env m => Text -> Ident -> m a -> m a
+  escapeTopLevel :: m a -> m a
+  escapeTopLevel = local $ \e -> e{inToplevel = False}
+
+  inLet :: MonadReader Env m => Text -> Text -> m a -> m a
   inLet breakRef i = local $ \env ->
     env{continuation = \val ->
-        AST.Block Nothing Nothing [AST.Assignment Nothing (var i) val, AST.Break Nothing (Just breakRef)]
+        AST.Block Nothing Nothing [AST.Assignment Nothing (AST.Var Nothing i) val, AST.Break Nothing (Just breakRef)]
        }
 
   inFun :: MonadReader Env m => m a -> m a
@@ -180,25 +193,45 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
   -- |
   -- Generate code in the simplified JavaScript intermediate representation for a declaration
   --
-  bindToJs :: Bind Ann -> m [AST]
+  bindToJs :: Bind Ann -> m (VarEnv, [AST])
   bindToJs (NonRec ann ident val) = do
-    ds <- nonRecToJS ann ident val
-    return ds
+    let nameStr = identToJs ident
+    env <- do
+      inTop <- asks inToplevel
+      if inTop then return M.empty
+      else do newName <- freshNameHint nameStr
+              return (M.singleton nameStr newName)
+    local (\e -> e{vars = M.union env (vars e)}) $ do
+      ds <- nonRecToJS ann nameStr val
+      return (env, ds)
   bindToJs (Rec vals) = do
-    concat <$> forM vals (uncurry . uncurry $ nonRecToJS)
+    env <- do
+      inTop <- asks inToplevel
+      if inTop then return M.empty
+      else fmap M.fromList $ forM vals $ \((_, ident), _) -> do
+         let nameStr = identToJs ident
+         newName <- freshNameHint nameStr
+         return (nameStr, newName)
+    ds <- local (\e -> e{vars = M.union env (vars e)}) $
+      fmap concat $ forM vals $ \((ann, ident), val) -> nonRecToJS ann (identToJs ident) val
+    return (env, ds)
 
   -- | Generate code in the simplified JavaScript intermediate representation for a single non-recursive
   -- declaration.
   --
   -- The main purpose of this function is to handle code generation for comments.
-  nonRecToJS :: Ann -> Ident -> Expr Ann -> m [AST]
+  nonRecToJS :: Ann -> Text -> Expr Ann -> m [AST]
   nonRecToJS a i e@(extractAnn -> (_, com, _, _)) | not (null com) = do
     withoutComment <- asks $ optionsNoComments . options
     if withoutComment
        then nonRecToJS a i (modifyAnn removeComments e)
        else map (AST.Comment Nothing com) <$> nonRecToJS a i (modifyAnn removeComments e)
-  nonRecToJS (_, _, _, _) ident val = do
-    bindToVar ident (valueToJs val)
+  nonRecToJS (_, _, _, _) ident val = escapeTopLevel $ do
+    env <- asks vars
+    let solvedIdent = case M.lookup ident env of
+          Just ii -> ii
+          _ -> ident
+    bindToVar solvedIdent (valueToJs val)
 
   withPos :: SourceSpan -> AST -> m AST
   withPos ss js = do
@@ -247,12 +280,12 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
     (ds, vs) <- unzip <$> traverse f l
     return (concat ds, vs)
 
-  bindToVar :: Ident -> m ([AST], AST) -> m [AST]
+  bindToVar :: Text -> m ([AST], AST) -> m [AST]
   bindToVar v ex = do
-    breakRef <- freshNameHint $ "def_" <> identToJs v <> "_"
+    breakRef <- freshNameHint $ "def_" <> v <> "_"
     (ds, js) <- inLet breakRef v ex
     return
-      (AST.VariableLetIntroduction Nothing (identToJs v) Nothing :
+      (AST.VariableLetIntroduction Nothing v Nothing :
        ds ++
        [AST.Block Nothing (Just breakRef) [js]]
       )
@@ -309,27 +342,25 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
              else varToJs qi
   valueToJs' (Var (_, _, _, Just IsForeign) ident) =
     internalError $ "Encountered an unqualified reference to a foreign ident " ++ T.unpack (showQualified showIdent ident)
-  valueToJs' (Var _ q@(Qualified Nothing (Ident v))) = asks vars >>= \env ->
-    single $ case M.lookup v env of
-      Nothing -> varToJs q
-      Just name -> AST.Var Nothing name
-  valueToJs' (Var _ q) = single $ varToJs q
+  valueToJs' (Var _ q@(Qualified qual (Ident v))) = do
+    env <- asks vars
+    currMod <- asks currentModule
+    single $
+      if isNothing qual || qual == currMod
+      then case M.lookup v env of
+        Nothing -> varToJs q
+        Just name -> AST.Var Nothing name
+      else varToJs q
   valueToJs' (Case (ss, _, _, _) values binders) = do
     (ds, vals) <- inExpr $ traverseCat valueToJs values
-    resVar <- ("case" <>) . T.pack . show <$> fresh
-    dsr <- bindToVar (Ident resVar) (([],) <$> bindersToJs ss binders vals)
+    resVar <- freshNameHint "case"
+    dsr <- bindToVar resVar (([],) <$> bindersToJs ss binders vals)
     return (ds ++ dsr, AST.Var Nothing resVar)
   valueToJs' (Let _ ds val) = do
-    ds' <- inExpr $ concat <$> mapM bindToJs ds
-    declsAndMap <- forM ds' $ \d -> case d of
-      AST.Var ann name -> do -- FIXME renaming
-        q <- freshName
-        return (AST.Var ann q, Just (name, q))
-      _ -> return (d, Nothing)
-    let decls1 = map fst declsAndMap
-        env1 = Map.fromList $ mapMaybe snd declsAndMap
+    (envs, ds') <- inExpr $ unzip <$> mapM bindToJs ds
+    let env1 = M.unions envs
     (ds'', ret) <- local (\env -> env{vars = Map.union env1 (vars env)}) $ valueToJs val
-    return (decls1 ++ ds'', ret)
+    return (concat ds' ++ ds'', ret)
   valueToJs' (Constructor (_, _, _, Just IsNewtype) _ ctor _) =
     single $ AST.VariableLetIntroduction Nothing (properToJs ctor) (Just $
                 AST.ObjectLiteral Nothing [("create",
diff --git a/src/Language/PureScript/Make/Monad.hs b/src/Language/PureScript/Make/Monad.hs
index b1b405c76c..60453de1f7 100644
--- a/src/Language/PureScript/Make/Monad.hs
+++ b/src/Language/PureScript/Make/Monad.hs
@@ -69,7 +69,7 @@ instance MonadBaseControl IO Make where
 
 -- | Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings.
 runMake :: Options -> Make a -> IO (Either MultipleErrors a, MultipleErrors)
-runMake opts = runLogger' . runExceptT . flip runReaderT Env{options = opts, vars = M.empty, continuation = const (error "codegen continuation undefined")} . unMake
+runMake opts = runLogger' . runExceptT . flip runReaderT Env{options = opts, vars = M.empty, continuation = const (error "codegen continuation undefined"), currentModule = Nothing, inToplevel = True} . unMake
 
 -- | Run an 'IO' action in the 'Make' monad. The 'String' argument should
 -- describe what we were trying to do; it is used for rendering errors in the

From 6b119c758c9c1e77325d03678e68d47c4d00adf9 Mon Sep 17 00:00:00 2001
From: radrow <radrowicki@gmail.com>
Date: Thu, 18 Feb 2021 15:46:10 +0100
Subject: [PATCH 17/30] Fix var indexing vol2

---
 src/Language/PureScript/CodeGen/JS.hs | 8 ++++++--
 1 file changed, 6 insertions(+), 2 deletions(-)

diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index b436be473c..38c5035424 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -357,8 +357,12 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
     dsr <- bindToVar resVar (([],) <$> bindersToJs ss binders vals)
     return (ds ++ dsr, AST.Var Nothing resVar)
   valueToJs' (Let _ ds val) = do
-    (envs, ds') <- inExpr $ unzip <$> mapM bindToJs ds
-    let env1 = M.unions envs
+    env0 <- asks vars
+    let proceedDecl (prevEnv, prevDecls) decl' = do
+          (env'', decl'') <- local (\e -> e{vars = prevEnv}) $ bindToJs decl'
+          return (M.union env'' prevEnv, prevDecls . (decl'':))
+    (env1, ds'c) <- inExpr $ foldM proceedDecl (env0, id) ds
+    let ds' = ds'c []
     (ds'', ret) <- local (\env -> env{vars = Map.union env1 (vars env)}) $ valueToJs val
     return (concat ds' ++ ds'', ret)
   valueToJs' (Constructor (_, _, _, Just IsNewtype) _ ctor _) =

From 2c924f67ea6913384c216b7e2d1396c8f3adf8f9 Mon Sep 17 00:00:00 2001
From: radrow <radrowicki@gmail.com>
Date: Thu, 18 Feb 2021 19:00:37 +0100
Subject: [PATCH 18/30] Fix continuation handle and variable naming

---
 src/Language/PureScript/CodeGen/JS.hs | 29 ++++++++++-----------------
 1 file changed, 11 insertions(+), 18 deletions(-)

diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 38c5035424..9a6181b1f8 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -10,7 +10,7 @@ module Language.PureScript.CodeGen.JS
 import Debug.Trace
 
 import Prelude.Compat
-import Protolude (ordNub, swap)
+import Protolude (ordNub)
 
 import Control.Arrow ((&&&))
 import Control.Monad (forM, replicateM, void, foldM)
@@ -18,12 +18,12 @@ import Control.Monad.Except (MonadError, throwError)
 import Control.Monad.Reader (MonadReader, asks, local)
 import Control.Monad.Supply.Class
 
-import Data.Bifunctor(second, first, bimap)
+import Data.Bifunctor(first, second, bimap)
 import Data.List ((\\), intersect)
 import qualified Data.Foldable as F
 import qualified Data.Map as M
 import qualified Data.Set as S
-import Data.Maybe (fromMaybe, isNothing, mapMaybe)
+import Data.Maybe (fromMaybe, isNothing)
 import Data.String (fromString)
 import Data.Text (Text)
 import qualified Data.Text as T
@@ -46,9 +46,6 @@ import qualified Language.PureScript.Constants as C
 
 import System.FilePath.Posix ((</>))
 
-import qualified Data.Map as Map
-import Data.Map(Map)
-
 data Env = Env
   { options :: Options
   , vars :: VarEnv
@@ -57,7 +54,7 @@ data Env = Env
   , inToplevel :: Bool
   }
 
-type VarEnv = Map Text Text
+type VarEnv = M.Map Text Text
 
 -- | Generate code in the simplified JavaScript intermediate representation for all declarations in a
 -- module.
@@ -73,11 +70,7 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
     let mnLookup = renameImports usedNames imps
     let decls' = renameModules mnLookup decls
 
-    env0 <- asks vars
-    let proceedDecl (prevEnv, prevDecls) decl' = do
-          (env'', decl'') <- local (\e -> e{vars = prevEnv}) $ bindToJs decl'
-          return (M.union env'' prevEnv, prevDecls . (decl'':))
-    jsDecls <- inFun $ ($[]) . snd <$> foldM proceedDecl (env0, id) decls'
+    jsDecls <- inFun $ map snd <$> mapM bindToJs decls'
     optimized <- traverse (traverse optimize) jsDecls
     let mnReverseLookup = M.fromList $ map (\(origName, (_, safeName)) -> (moduleNameToJs safeName, origName)) $ M.toList mnLookup
     let usedModuleNames = foldMap (foldMap (findModules mnReverseLookup)) optimized
@@ -342,12 +335,12 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
              else varToJs qi
   valueToJs' (Var (_, _, _, Just IsForeign) ident) =
     internalError $ "Encountered an unqualified reference to a foreign ident " ++ T.unpack (showQualified showIdent ident)
-  valueToJs' (Var _ q@(Qualified qual (Ident v))) = do
+  valueToJs' (Var _ q@(Qualified qual i)) = do
     env <- asks vars
     currMod <- asks currentModule
     single $
       if isNothing qual || qual == currMod
-      then case M.lookup v env of
+      then case M.lookup (identToJs i) env of
         Nothing -> varToJs q
         Just name -> AST.Var Nothing name
       else varToJs q
@@ -355,15 +348,15 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
     (ds, vals) <- inExpr $ traverseCat valueToJs values
     resVar <- freshNameHint "case"
     dsr <- bindToVar resVar (([],) <$> bindersToJs ss binders vals)
-    return (ds ++ dsr, AST.Var Nothing resVar)
+    cont <- asks continuation
+    return (ds ++ dsr, cont $ AST.Var Nothing resVar)
   valueToJs' (Let _ ds val) = do
     env0 <- asks vars
     let proceedDecl (prevEnv, prevDecls) decl' = do
           (env'', decl'') <- local (\e -> e{vars = prevEnv}) $ bindToJs decl'
           return (M.union env'' prevEnv, prevDecls . (decl'':))
-    (env1, ds'c) <- inExpr $ foldM proceedDecl (env0, id) ds
-    let ds' = ds'c []
-    (ds'', ret) <- local (\env -> env{vars = Map.union env1 (vars env)}) $ valueToJs val
+    (env1, ds') <- inExpr $ second ($[]) <$> foldM proceedDecl (env0, id) ds
+    (ds'', ret) <- local (\env -> env{vars = env1}) $ valueToJs val
     return (concat ds' ++ ds'', ret)
   valueToJs' (Constructor (_, _, _, Just IsNewtype) _ ctor _) =
     single $ AST.VariableLetIntroduction Nothing (properToJs ctor) (Just $

From e2b3c95ed5930d6f6912ecc79774f493796620d8 Mon Sep 17 00:00:00 2001
From: radrow <radrowicki@gmail.com>
Date: Fri, 19 Feb 2021 12:08:37 +0100
Subject: [PATCH 19/30] Fix TCO

---
 src/Language/PureScript/CodeGen/JS.hs         |  44 ++--
 src/Language/PureScript/CodeGen/JS/Printer.hs |   1 -
 src/Language/PureScript/CoreImp/AST.hs        |   8 -
 .../PureScript/CoreImp/Optimizer/TCO.hs       | 230 ++++++++----------
 src/Language/PureScript/Make/Actions.hs       |   2 +-
 src/Language/PureScript/Make/Monad.hs         |  12 +-
 6 files changed, 136 insertions(+), 161 deletions(-)

diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 9a6181b1f8..53e6039ba3 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -7,8 +7,6 @@ module Language.PureScript.CodeGen.JS
   , moduleToJs
   ) where
 
-import Debug.Trace
-
 import Prelude.Compat
 import Protolude (ordNub)
 
@@ -46,14 +44,24 @@ import qualified Language.PureScript.Constants as C
 
 import System.FilePath.Posix ((</>))
 
+data ContinuationKind = InExpr | InFun | InLet Text Text
 data Env = Env
   { options :: Options
   , vars :: VarEnv
-  , continuation :: AST -> AST
+  , continuationKind :: ContinuationKind
   , currentModule :: Maybe ModuleName
   , inToplevel :: Bool
   }
 
+runASTCont :: ContinuationKind -> AST -> AST
+runASTCont InExpr = id
+runASTCont InFun = AST.Return Nothing
+runASTCont (InLet breakRef i) =
+  \val -> AST.Block Nothing Nothing
+          [ AST.Assignment Nothing (AST.Var Nothing i) val
+          , AST.Break Nothing (Just breakRef)
+          ]
+
 type VarEnv = M.Map Text Text
 
 -- | Generate code in the simplified JavaScript intermediate representation for all declarations in a
@@ -100,25 +108,14 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
 
   inLet :: MonadReader Env m => Text -> Text -> m a -> m a
   inLet breakRef i = local $ \env ->
-    env{continuation = \val ->
-        AST.Block Nothing Nothing [AST.Assignment Nothing (AST.Var Nothing i) val, AST.Break Nothing (Just breakRef)]
+    env{continuationKind = InLet breakRef i
        }
 
   inFun :: MonadReader Env m => m a -> m a
-  inFun = local $ \env -> env{continuation = AST.Return Nothing}
+  inFun = local $ \env -> env{continuationKind = InFun}
 
   inExpr :: MonadReader Env m => m a -> m a
-  inExpr = local $ \env -> env{continuation = \x -> if isExpr x then x else error $ "NOT EXPR: " <> show x} where
-    isExpr x = case x of
-      AST.Block{} -> False
-      AST.Return{} -> False
-      AST.VariableIntroduction{} -> False
-      AST.VariableLetIntroduction{} -> False
-      AST.Label{} -> False
-      AST.For{} -> False
-      AST.While{} -> False
-      AST.IfElse{} -> False
-      _ -> True
+  inExpr = local $ \env -> env{continuationKind = InExpr}
 
   -- | Extracts all declaration names from a binding group.
   getNames :: Bind Ann -> [Ident]
@@ -261,7 +258,7 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
     let (ss, _, _, _) = extractAnn e
     (ds, x) <- valueToJs' e
     x' <- withPos ss x
-    finCont <- asks continuation
+    finCont <- asks $ runASTCont . continuationKind
     return (ds, if willHandleContinuationByItself e then x' else finCont x')
 
   single :: AST -> m ([AST], AST)
@@ -347,9 +344,14 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
   valueToJs' (Case (ss, _, _, _) values binders) = do
     (ds, vals) <- inExpr $ traverseCat valueToJs values
     resVar <- freshNameHint "case"
-    dsr <- bindToVar resVar (([],) <$> bindersToJs ss binders vals)
-    cont <- asks continuation
-    return (ds ++ dsr, cont $ AST.Var Nothing resVar)
+    contKind <- asks continuationKind
+    case contKind of
+      InFun -> do
+        val <- bindersToJs ss binders vals
+        return (ds, val)
+      _ -> do
+        dsr <- bindToVar resVar (([],) <$> bindersToJs ss binders vals)
+        return (ds ++ dsr, runASTCont contKind $ AST.Var Nothing resVar)
   valueToJs' (Let _ ds val) = do
     env0 <- asks vars
     let proceedDecl (prevEnv, prevDecls) decl' = do
diff --git a/src/Language/PureScript/CodeGen/JS/Printer.hs b/src/Language/PureScript/CodeGen/JS/Printer.hs
index e8905b0d6e..79f67a08fa 100644
--- a/src/Language/PureScript/CodeGen/JS/Printer.hs
+++ b/src/Language/PureScript/CodeGen/JS/Printer.hs
@@ -127,7 +127,6 @@ literals = mkPattern' match'
     , mconcat <$> forM com comment
     , prettyPrintJS' js
     ]
-  match Pass = return $ emit ""
   match _ = mzero
 
   comment :: (Emit gen) => Comment -> StateT PrinterState Maybe gen
diff --git a/src/Language/PureScript/CoreImp/AST.hs b/src/Language/PureScript/CoreImp/AST.hs
index d0c7f1aae8..a98dc3bef9 100644
--- a/src/Language/PureScript/CoreImp/AST.hs
+++ b/src/Language/PureScript/CoreImp/AST.hs
@@ -88,8 +88,6 @@ data AST
   -- ^ Loop break
   | Continue (Maybe SourceSpan) (Maybe Text)
   -- ^ Loop continue
-  | Label (Maybe SourceSpan) Text  -- TODO: add as a loop parameter instead of a separate instruction
-  -- ^ Loop label.
   | IfElse (Maybe SourceSpan) AST AST (Maybe AST)
   -- ^ If-then-else statement
   | Return (Maybe SourceSpan) AST
@@ -102,8 +100,6 @@ data AST
   -- ^ instanceof check
   | Comment (Maybe SourceSpan) [Comment] AST
   -- ^ Commented JavaScript
-  | Pass
-  -- ^ Empty instruction
   deriving (Show, Eq)
 
 withSourceSpan :: SourceSpan -> AST -> AST
@@ -132,14 +128,12 @@ withSourceSpan withSpan = go where
   go (ForIn _ name j1 j2) = ForIn ss name j1 j2
   go (Break _ name) = Break ss name
   go (Continue _ name) = Continue ss name
-  go (Label _ name) = Label ss name
   go (IfElse _ j1 j2 j3) = IfElse ss j1 j2 j3
   go (Return _ js) = Return ss js
   go (ReturnNoResult _) = ReturnNoResult ss
   go (Throw _ js) = Throw ss js
   go (InstanceOf _ j1 j2) = InstanceOf ss j1 j2
   go (Comment _ com j) = Comment ss com j
-  go Pass = Pass
 
 getSourceSpan :: AST -> Maybe SourceSpan
 getSourceSpan = go where
@@ -164,14 +158,12 @@ getSourceSpan = go where
   go (ForIn ss _ _ _) = ss
   go (Break ss _) = ss
   go (Continue ss _) = ss
-  go (Label ss _) = ss
   go (IfElse ss _ _ _) = ss
   go (Return ss _) = ss
   go (ReturnNoResult ss) = ss
   go (Throw ss _) = ss
   go (InstanceOf ss _ _) = ss
   go (Comment ss _ _) = ss
-  go Pass = Nothing
 
 everywhere :: (AST -> AST) -> AST -> AST
 everywhere f = go where
diff --git a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs
index 28ba3395be..6f2aa47ba0 100644
--- a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs
+++ b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs
@@ -3,21 +3,55 @@ module Language.PureScript.CoreImp.Optimizer.TCO (tco) where
 
 import Prelude.Compat
 
-import Control.Applicative (empty)
-import Control.Monad (guard)
-import Control.Monad.State (State, evalState, get, modify)
+import Debug.Trace
+
+import Control.Monad.State
 import Data.Functor ((<&>))
-import qualified Data.Set as S
 import Data.Text (Text, pack)
 import qualified Language.PureScript.Constants as C
 import Language.PureScript.CoreImp.AST
 import Safe (headDef, tailSafe)
 
+data TCOState = TCOState
+  { supply :: !Int
+  -- | If there is a variable return right after the block end
+  -- then assignment to that variable and breaking will be considered
+  -- as a TCO candidate
+  , returnBlock :: !(Maybe (Text, Text))
+  , tailCalls :: !Int
+  }
+emptyTCOState :: TCOState
+emptyTCOState = TCOState
+  { supply = 0
+  , returnBlock = Nothing
+  , tailCalls = 0
+  }
+
+fresh :: State TCOState Int
+fresh = do
+  x <- gets supply
+  modify (\s -> s{supply = x + 1})
+  return x
+
+inBlock :: Text -> Text -> State TCOState a -> State TCOState a
+inBlock breakL retvar act = do
+  prev <- gets returnBlock
+  modify' (\s -> s{returnBlock = Just (breakL, retvar)})
+  r <- act
+  modify' (\s -> s{returnBlock = prev})
+  return r
+
+incrTailCount :: State TCOState ()
+incrTailCount = modify (\s -> s{tailCalls = tailCalls s + 1})
+
+resetTailCount :: State TCOState ()
+resetTailCount = modify (\s -> s{tailCalls = 0})
+
 -- | Eliminate tail calls
 tco :: AST -> AST
-tco = flip evalState 0 . everywhereTopDownM convert where
-  uniq :: Text -> State Int Text
-  uniq v = get <&> \count -> v <>
+tco = flip evalState emptyTCOState . everywhereTopDownM convertAST where
+  uniq :: Text -> State TCOState Text
+  uniq v = fresh <&> \count -> v <>
     if count == 0 then "" else pack . show $ count
 
   tcoVar :: Text -> Text
@@ -26,157 +60,100 @@ tco = flip evalState 0 . everywhereTopDownM convert where
   copyVar :: Text -> Text
   copyVar arg = "$copy_" <> arg
 
-  tcoDoneM :: State Int Text
-  tcoDoneM = uniq "$tco_done"
-
-  tcoLoopM :: State Int Text
+  tcoLoopM :: State TCOState Text
   tcoLoopM = uniq "$tco_loop"
 
-  tcoResult :: Text
-  tcoResult = "$tco_result"
+  convertAST :: AST -> State TCOState AST
+  convertAST js@(Assignment ass (Var vss name) fn@Function {}) = do
+    conv <- convert name fn
+    return $ case conv of
+      Just looped -> Assignment ass (Var vss name) looped
+      _ -> js
+  convertAST js = pure js
 
-  convert :: AST -> State Int AST
-  convert (VariableIntroduction ss name (Just fn@Function {}))
-      | Just trFns <- findTailRecursiveFns name arity body'
-      = VariableIntroduction ss name . Just . replace <$> toLoop trFns name arity outerArgs innerArgs body'
-    where
-      innerArgs = headDef [] argss
-      outerArgs = concat . reverse $ tailSafe argss
-      arity = length argss
-      -- ^ this is the number of calls, not the number of arguments, if there's
-      -- ever a practical difference.
-      (argss, body', replace) = topCollectAllFunctionArgs [] id fn
-  convert (VariableLetIntroduction ss name (Just fn@Function {}))
-      | Just trFns <- findTailRecursiveFns name arity body'
-      = VariableLetIntroduction ss name . Just . replace <$> toLoop trFns name arity outerArgs innerArgs body'
-    where
+  convert :: Text -> AST -> State TCOState (Maybe AST)
+  convert name fn = do
+    let
       innerArgs = headDef [] argss
       outerArgs = concat . reverse $ tailSafe argss
       arity = length argss
       -- ^ this is the number of calls, not the number of arguments, if there's
       -- ever a practical difference.
       (argss, body', replace) = topCollectAllFunctionArgs [] id fn
-  convert js = pure js
+
+    looped <- toLoop name arity outerArgs innerArgs body'
+
+    tcs <- gets tailCalls
+    resetTailCount
+    return $ if tcs == 0
+      then Nothing
+      else Just $ replace looped
 
   rewriteFunctionsWith :: ([Text] -> [Text]) -> [[Text]] -> (AST -> AST) -> AST -> ([[Text]], AST, AST -> AST)
   rewriteFunctionsWith argMapper = collectAllFunctionArgs
     where
     collectAllFunctionArgs allArgs f (Function s1 ident args (Block s2 n (body@(Return _ _):_))) =
       collectAllFunctionArgs (args : allArgs) (\b -> f (Function s1 ident (argMapper args) (Block s2 n [b]))) body
-    collectAllFunctionArgs allArgs f (Function ss ident args body@(Block _ _ _)) =
+    collectAllFunctionArgs allArgs f (Function ss ident args body@Block{}) =
       (args : allArgs, body, f . Function ss ident (argMapper args))
     collectAllFunctionArgs allArgs f (Return s1 (Function s2 ident args (Block s3 n [body]))) =
       collectAllFunctionArgs (args : allArgs) (\b -> f (Return s1 (Function s2 ident (argMapper args) (Block s3 n [b])))) body
-    collectAllFunctionArgs allArgs f (Return s1 (Function s2 ident args body@(Block _ _ _))) =
+    collectAllFunctionArgs allArgs f (Return s1 (Function s2 ident args body@Block{})) =
       (args : allArgs, body, f . Return s1 . Function s2 ident (argMapper args))
     collectAllFunctionArgs allArgs f body = (allArgs, body, f)
 
   topCollectAllFunctionArgs :: [[Text]] -> (AST -> AST) -> AST -> ([[Text]], AST, AST -> AST)
   topCollectAllFunctionArgs = rewriteFunctionsWith (map copyVar)
 
-  innerCollectAllFunctionArgs :: [[Text]] -> (AST -> AST) -> AST -> ([[Text]], AST, AST -> AST)
-  innerCollectAllFunctionArgs = rewriteFunctionsWith id
-
-  countReferences :: Text -> AST -> Int
-  countReferences ident = everything (+) match where
-    match :: AST -> Int
-    match (Var _ ident') | ident == ident' = 1
-    match _ = 0
-
-  -- If `ident` is a tail-recursive function, returns a set of identifiers
-  -- that are locally bound to functions participating in the tail recursion.
-  -- Otherwise, returns Nothing.
-  findTailRecursiveFns :: Text -> Int -> AST -> Maybe (S.Set Text)
-  findTailRecursiveFns ident arity js = guard (countReferences ident js > 0) *> go (S.empty, S.singleton (ident, arity))
-    where
-
-    go :: (S.Set Text, S.Set (Text, Int)) -> Maybe (S.Set Text)
-    go (known, required) =
-      case S.minView required of
-        Just (r, required') -> do
-          required'' <- findTailPositionDeps r js
-          go (S.insert (fst r) known, required' <> S.filter (not . (`S.member` known) . fst) required'')
-        Nothing ->
-          pure known
-
-  -- Returns set of identifiers (with their arities) that need to be used
-  -- exclusively in tail calls using their full arity in order for this
-  -- identifier to be considered in tail position (or Nothing if this
-  -- identifier is used somewhere not as a tail call with full arity).
-  findTailPositionDeps :: (Text, Int) -> AST -> Maybe (S.Set (Text, Int))
-  findTailPositionDeps (ident, arity) js = anyInTailPosition js where
-
-    anyInTailPosition :: AST -> Maybe (S.Set (Text, Int))
-    anyInTailPosition (Return _ expr) | isSelfCall ident arity expr = pure S.empty
-    anyInTailPosition (While _ _ _ body)
-      = anyInTailPosition body
-    anyInTailPosition (For _ _ _ _ body)
-      = anyInTailPosition body
-    anyInTailPosition (ForIn _ _ _ body)
-      = anyInTailPosition body
-    anyInTailPosition (IfElse _ _ body el)
-      = anyInTailPosition body <> foldMap anyInTailPosition el
-    anyInTailPosition (Block _ _ body)
-      = foldMap anyInTailPosition body
-    anyInTailPosition (VariableIntroduction _ ident' (Just js1))
-      | Function _ Nothing _ _ <- js1
-      , (argss, body, _) <- innerCollectAllFunctionArgs [] id js1
-        = S.insert (ident', length argss) <$> anyInTailPosition body
-      | otherwise = empty
-    anyInTailPosition (VariableLetIntroduction _ ident' (Just js1))
-      | Function _ Nothing _ _ <- js1
-      , (argss, body, _) <- innerCollectAllFunctionArgs [] id js1
-        = S.insert (ident', length argss) <$> anyInTailPosition body
-      | otherwise = empty
-    anyInTailPosition (Comment _ _ js1)
-      = anyInTailPosition js1
-    anyInTailPosition _
-      = empty
-
-  toLoop :: S.Set Text -> Text -> Int -> [Text] -> [Text] -> AST -> State Int AST
-  toLoop trFns ident arity outerArgs innerArgs js = do
-    tcoDone <- tcoDoneM
+  toLoop :: Text -> Int -> [Text] -> [Text] -> AST -> State TCOState AST
+  toLoop ident arity outerArgs innerArgs js = do
     tcoLoop <- tcoLoopM
-    modify (+ 1)
 
     let
-      loopify :: AST -> AST
-      loopify (Return ss ret)
-        | isSelfCall ident arity ret =
-          let
-            allArgumentValues = concat $ collectArgs [] ret
-          in
-            Block ss Nothing $
-              zipWith (\val arg ->
-                Assignment ss (Var ss (tcoVar arg)) val) allArgumentValues outerArgs
-              ++ zipWith (\val arg ->
-                Assignment ss (Var ss (copyVar arg)) val) (drop (length outerArgs) allArgumentValues) innerArgs
-              ++ [Continue ss (Just tcoLoop)]
-        | isIndirectSelfCall ret = Return ss ret
-        | otherwise = Block ss Nothing
-          [ Assignment ss (Var rootSS tcoResult) ret
-          , Break ss (Just tcoLoop)
-          ]
-      loopify (While ss name cond body) = While ss name cond (loopify body)
-      loopify (For ss i js1 js2 body) = For ss i js1 js2 (loopify body)
-      loopify (ForIn ss i js1 body) = ForIn ss i js1 (loopify body)
-      loopify (IfElse ss cond body el) = IfElse ss cond (loopify body) (fmap loopify el)
-      loopify (Block ss n body) = Block ss n (map loopify body)
-      -- loopify (VariableIntroduction ss f (Just fn@(Function _ Nothing _ _)))
-      --   | (_, body, replace) <- innerCollectAllFunctionArgs [] id fn
-      --   , f `S.member` trFns = VariableIntroduction ss f (Just (replace (loopify body)))
-      loopify other = other
+      makeTailJump ss ret = do
+        incrTailCount
+        let allArgumentValues = concat $ collectArgs [] ret
+        return $ Block ss Nothing $
+          zipWith (\val arg ->
+                     Assignment ss (Var ss (tcoVar arg)) val) allArgumentValues outerArgs
+          ++ zipWith (\val arg ->
+                        Assignment ss (Var ss (copyVar arg)) val) (drop (length outerArgs) allArgumentValues) innerArgs
+          ++ [Continue ss (Just tcoLoop)]
+
+      loopify :: AST -> State TCOState AST
+      loopify (Return ss ret) | isSelfCall ident arity ret = makeTailJump ss ret
+      loopify (While ss name cond body) = While ss name cond <$> loopify body
+      loopify (For ss i js1 js2 body) = For ss i js1 js2 <$> loopify body
+      loopify (ForIn ss i js1 body) = ForIn ss i js1 <$> loopify body
+      loopify (IfElse ss cond body el) = IfElse ss cond <$> loopify body <*> mapM loopify el
+      loopify (Block ss n body) = Block ss n <$> loopifyBlock body
+      loopify other = return other
+
+      loopifyBlock :: [AST] -> State TCOState [AST]
+      loopifyBlock [] = return []
+      loopifyBlock (Block ss (Just n) body : Return _ (Var _ var) : _) =
+        (:[]) . Block ss (Just n) <$> inBlock n var (loopifyBlock body)
+      loopifyBlock (h1@(Assignment _ (Var _ v) expr) : h2@(Break _ (Just block)) : t) = do
+        rb <- gets returnBlock
+        case rb of
+          Just (rbBlock, rbVar)
+            | rbBlock == block, rbVar == v ->
+              if isSelfCall ident arity expr
+              then (:[]) <$> makeTailJump Nothing expr
+              else return [Return Nothing expr]
+          _ -> (:) <$> loopify h1 <*> loopifyBlock (h2:t)
+      loopifyBlock (h:t) = (:) <$> loopify h <*> loopifyBlock t
+
+    looped <- loopify js
 
     pure $ Block rootSS Nothing $
         map (\arg -> VariableIntroduction rootSS (tcoVar arg) (Just (Var rootSS (copyVar arg)))) outerArgs ++
-        [ VariableIntroduction rootSS tcoResult Nothing
-        , While rootSS (Just tcoLoop) (Unary rootSS Not (Var rootSS tcoDone))
+        [ While rootSS (Just tcoLoop) (BooleanLiteral Nothing True)
           (Block rootSS Nothing $
             map (\v -> VariableLetIntroduction rootSS v (Just . Var rootSS . tcoVar $ v)) outerArgs ++
             map (\v -> VariableLetIntroduction rootSS v (Just . Var rootSS . copyVar $ v)) innerArgs ++
-            [loopify js]
+            [looped]
           )
-        , Return rootSS (Var rootSS tcoResult)
         ]
     where
     rootSS = Nothing
@@ -188,11 +165,6 @@ tco = flip evalState 0 . everywhereTopDownM convert where
     collectArgs acc (App _ fn args') = collectArgs (args' : acc) fn
     collectArgs acc _ = acc
 
-    isIndirectSelfCall :: AST -> Bool
-    isIndirectSelfCall (App _ (Var _ ident') _) = ident' `S.member` trFns
-    isIndirectSelfCall (App _ fn _) = isIndirectSelfCall fn
-    isIndirectSelfCall _ = False
-
   isSelfCall :: Text -> Int -> AST -> Bool
   isSelfCall ident 1 (App _ (Var _ ident') _) = ident == ident'
   isSelfCall ident arity (App _ fn _) = isSelfCall ident (arity - 1) fn
diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs
index ec975f6273..47fb6c65c4 100644
--- a/src/Language/PureScript/Make/Actions.hs
+++ b/src/Language/PureScript/Make/Actions.hs
@@ -250,7 +250,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
           (pjs, mappings) = if sourceMaps then prettyPrintJSWithSourceMaps rawJs else (prettyPrintJS rawJs, [])
           jsFile = targetFilename mn JS
           mapFile = targetFilename mn JSSourceMap
-          prefix = ["Generated by purs version " <> T.pack (showVersion Paths.version) | usePrefix]
+          prefix = ["Generated by purs version " <> T.pack (showVersion Paths.version) <> ". Patched for erlscripten!" | usePrefix]
           js = T.unlines $ map ("// " <>) prefix ++ [pjs]
           mapRef = if sourceMaps then "//# sourceMappingURL=index.js.map\n" else ""
       lift $ do
diff --git a/src/Language/PureScript/Make/Monad.hs b/src/Language/PureScript/Make/Monad.hs
index 60453de1f7..9b2b76cc5f 100644
--- a/src/Language/PureScript/Make/Monad.hs
+++ b/src/Language/PureScript/Make/Monad.hs
@@ -69,7 +69,17 @@ instance MonadBaseControl IO Make where
 
 -- | Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings.
 runMake :: Options -> Make a -> IO (Either MultipleErrors a, MultipleErrors)
-runMake opts = runLogger' . runExceptT . flip runReaderT Env{options = opts, vars = M.empty, continuation = const (error "codegen continuation undefined"), currentModule = Nothing, inToplevel = True} . unMake
+runMake opts
+  = runLogger'
+  . runExceptT
+  . flip runReaderT
+  Env{ options = opts
+     , vars = M.empty
+     , continuationKind = error "codegen continuation undefined"
+     , currentModule = Nothing
+     , inToplevel = True
+     }
+  . unMake
 
 -- | Run an 'IO' action in the 'Make' monad. The 'String' argument should
 -- describe what we were trying to do; it is used for rendering errors in the

From 6b0efcebd086d2f66257d6d261071e174d8b2458 Mon Sep 17 00:00:00 2001
From: radrow <radrowicki@gmail.com>
Date: Fri, 19 Feb 2021 16:11:50 +0100
Subject: [PATCH 20/30] Fix object accessor

---
 src/Language/PureScript/CodeGen/JS.hs | 4 +---
 tests/TestCoreFn.hs                   | 2 +-
 2 files changed, 2 insertions(+), 4 deletions(-)

diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 53e6039ba3..9a064cc988 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -264,8 +264,6 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
   single :: AST -> m ([AST], AST)
   single = return . ([],)
 
-  (<$$>) :: (a -> b) -> m ([a], a) -> m ([b], b)
-  (<$$>) f m = fmap (bimap (map f) f) m
   traverseCat f l = do
     (ds, vs) <- unzip <$> traverse f l
     return (concat ds, vs)
@@ -288,7 +286,7 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
   valueToJs' (Var (_, _, _, Just (IsConstructor _ _)) name) =
     single $ accessorString "create" $ qualifiedToJS id name
   valueToJs' (Accessor _ prop val) =
-    accessorString prop <$$> inExpr (valueToJs val)
+    second (accessorString prop) <$> inExpr (valueToJs val)
   valueToJs' (ObjectUpdate _ o ps) = do
     (dso, obj) <- inExpr $ valueToJs o
     (dss, sts) <- inExpr $ traverseCat (fmap (\(p, (d, x)) -> (d, (p, x))) . sndM valueToJs) ps
diff --git a/tests/TestCoreFn.hs b/tests/TestCoreFn.hs
index 04b9fa9185..675d9b5a6f 100644
--- a/tests/TestCoreFn.hs
+++ b/tests/TestCoreFn.hs
@@ -164,7 +164,7 @@ spec = context "CoreFnFromJsonTest" $ do
                     Case ann [Var ann (Qualified Nothing (Ident "x"))]
                       [ CaseAlternative
                         [ NullBinder ann ]
-                        (Left [(Literal ann (BooleanLiteral True), Literal ann (CharLiteral 'a'))])
+                        (Left [([Literal ann (BooleanLiteral True)], Literal ann (CharLiteral 'a'))])
                       ]
                 ]
       parseMod m `shouldSatisfy` isSuccess

From fcc7ef80f9dba16c80a7780ca1e17ff09b2ef917 Mon Sep 17 00:00:00 2001
From: radrow <radrowicki@gmail.com>
Date: Fri, 19 Feb 2021 16:31:42 +0100
Subject: [PATCH 21/30] Let in bundle

---
 src/Language/PureScript/Bundle.hs | 6 ++++++
 1 file changed, 6 insertions(+)

diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs
index cf90d2e0ae..c291463543 100644
--- a/src/Language/PureScript/Bundle.hs
+++ b/src/Language/PureScript/Bundle.hs
@@ -468,6 +468,12 @@ matchMember stmt
   , JSIdentifier _ name <- var
   , JSVarInit _ decl <- varInit
   = Just (Internal, name, decl)
+  -- let foo = expr;
+  | JSLet _ jsInit _ <- stmt
+  , [JSVarInitExpression var varInit] <- commaList jsInit
+  , JSIdentifier _ name <- var
+  , JSVarInit _ decl <- varInit
+  = Just (Internal, name, decl)
   -- exports.foo = expr; exports["foo"] = expr;
   | JSAssignStatement e (JSAssign _) decl _ <- stmt
   , Just name <- exportsAccessor e

From f3f336bc4492caf9d32157eba8dcfb72d165dbb6 Mon Sep 17 00:00:00 2001
From: radrow <radrowicki@gmail.com>
Date: Mon, 22 Feb 2021 10:58:19 +0100
Subject: [PATCH 22/30] TCO fixes

---
 .../PureScript/CoreImp/Optimizer/TCO.hs       | 54 +++++++++++++------
 1 file changed, 38 insertions(+), 16 deletions(-)

diff --git a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs
index 6f2aa47ba0..60bcab7f10 100644
--- a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs
+++ b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs
@@ -6,6 +6,7 @@ import Prelude.Compat
 import Debug.Trace
 
 import Control.Monad.State
+import Data.List
 import Data.Functor ((<&>))
 import Data.Text (Text, pack)
 import qualified Language.PureScript.Constants as C
@@ -17,13 +18,13 @@ data TCOState = TCOState
   -- | If there is a variable return right after the block end
   -- then assignment to that variable and breaking will be considered
   -- as a TCO candidate
-  , returnBlock :: !(Maybe (Text, Text))
+  , returnBlock :: ![(Text, Text)]
   , tailCalls :: !Int
   }
 emptyTCOState :: TCOState
 emptyTCOState = TCOState
   { supply = 0
-  , returnBlock = Nothing
+  , returnBlock = []
   , tailCalls = 0
   }
 
@@ -36,7 +37,7 @@ fresh = do
 inBlock :: Text -> Text -> State TCOState a -> State TCOState a
 inBlock breakL retvar act = do
   prev <- gets returnBlock
-  modify' (\s -> s{returnBlock = Just (breakL, retvar)})
+  modify' (\s -> s{returnBlock = (breakL, retvar):prev})
   r <- act
   modify' (\s -> s{returnBlock = prev})
   return r
@@ -121,27 +122,48 @@ tco = flip evalState emptyTCOState . everywhereTopDownM convertAST where
           ++ [Continue ss (Just tcoLoop)]
 
       loopify :: AST -> State TCOState AST
-      loopify (Return ss ret) | isSelfCall ident arity ret = makeTailJump ss ret
+      loopify (Return ss ret) | isSelfCall ident arity ret
+                                        = makeTailJump ss ret
       loopify (While ss name cond body) = While ss name cond <$> loopify body
-      loopify (For ss i js1 js2 body) = For ss i js1 js2 <$> loopify body
-      loopify (ForIn ss i js1 body) = ForIn ss i js1 <$> loopify body
-      loopify (IfElse ss cond body el) = IfElse ss cond <$> loopify body <*> mapM loopify el
-      loopify (Block ss n body) = Block ss n <$> loopifyBlock body
-      loopify other = return other
+      loopify (For ss i js1 js2 body)   = For ss i js1 js2 <$> loopify body
+      loopify (ForIn ss i js1 body)     = ForIn ss i js1 <$> loopify body
+      loopify (IfElse ss cond body el)  = IfElse ss cond <$> loopify body <*> mapM loopify el
+      loopify (Block ss n body)         = Block ss n <$> loopifyBlock body
+      loopify other                     = return other
 
       loopifyBlock :: [AST] -> State TCOState [AST]
       loopifyBlock [] = return []
-      loopifyBlock (Block ss (Just n) body : Return _ (Var _ var) : _) =
-        (:[]) . Block ss (Just n) <$> inBlock n var (loopifyBlock body)
-      loopifyBlock (h1@(Assignment _ (Var _ v) expr) : h2@(Break _ (Just block)) : t) = do
+      loopifyBlock (Block ss (Just n) body : ret@(Return _ (Var _ var)) : _) =
+        (:[ret]) . Block ss (Just n) <$> inBlock n var (loopifyBlock body)
+      loopifyBlock (h1@(Block ss (Just n) body) : h2@(Assignment _ (Var _ out) (Var _ in_)) : h3@(Break _ (Just block)) : _) = do
         rb <- gets returnBlock
-        case rb of
-          Just (rbBlock, rbVar)
-            | rbBlock == block, rbVar == v ->
+        if any (\(rbBlock, rbVar) -> rbBlock == block && rbVar == out) rb
+          then
+              sequence [Block ss (Just n) <$> inBlock n in_ (loopifyBlock body), pure h2, pure h3]
+          else traverse loopify [h1, h2, h3]
+      loopifyBlock (h1@(Assignment _ (Var _ v) expr) : h2@(Break _ (Just block)) : _) = do
+        rb <- gets returnBlock
+        if any (\(rbBlock, rbVar) -> rbBlock == block && rbVar == v) rb
+          then
               if isSelfCall ident arity expr
               then (:[]) <$> makeTailJump Nothing expr
               else return [Return Nothing expr]
-          _ -> (:) <$> loopify h1 <*> loopifyBlock (h2:t)
+          else traverse loopify [h1, h2]
+
+      -- FIXME: these are unrelated to TCO
+      loopifyBlock (VariableLetIntroduction ss var Nothing : Block _ blockname (Assignment _ (Var _ vname) expr : tb) : t)
+        | vname == var
+        , case tb of
+            [] -> True
+            (Break _ Nothing : _) -> True
+            (Break _ breakname : _) | breakname == blockname -> True
+            _ -> False
+        = loopifyBlock (VariableLetIntroduction ss var (Just expr) : t)
+      loopifyBlock (h@Return{}:_)   = (:[]) <$> loopify h
+      loopifyBlock (h@Break{}:_)    = (:[]) <$> loopify h
+      loopifyBlock (h@Continue{}:_) = (:[]) <$> loopify h
+      loopifyBlock (h@Throw{}:_)    = (:[]) <$> loopify h
+
       loopifyBlock (h:t) = (:) <$> loopify h <*> loopifyBlock t
 
     looped <- loopify js

From d28dc7674cac4cbf42b43dc29b783e4fe5edbf70 Mon Sep 17 00:00:00 2001
From: radrow <radrowicki@gmail.com>
Date: Tue, 23 Feb 2021 14:07:24 +0100
Subject: [PATCH 23/30] Fix JSON. Move letdefs to inner blocks

---
 src/Language/PureScript/CodeGen/JS.hs      |  3 +-
 src/Language/PureScript/CoreFn/FromJSON.hs | 33 ++++++--
 src/Language/PureScript/CoreFn/ToJSON.hs   | 13 ++-
 tests/TestCoreFn.hs                        |  2 +-
 tests/purs/passing/TCOMutRec.purs          | 95 ----------------------
 5 files changed, 37 insertions(+), 109 deletions(-)
 delete mode 100644 tests/purs/passing/TCOMutRec.purs

diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 9a064cc988..5a28471924 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -274,8 +274,7 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
     (ds, js) <- inLet breakRef v ex
     return
       (AST.VariableLetIntroduction Nothing v Nothing :
-       ds ++
-       [AST.Block Nothing (Just breakRef) [js]]
+       [AST.Block Nothing (Just breakRef) (ds ++[js])]
       )
 
   valueToJs' :: Expr Ann -> m ([AST], AST)
diff --git a/src/Language/PureScript/CoreFn/FromJSON.hs b/src/Language/PureScript/CoreFn/FromJSON.hs
index 4e2c93a2db..68aec2de8b 100644
--- a/src/Language/PureScript/CoreFn/FromJSON.hs
+++ b/src/Language/PureScript/CoreFn/FromJSON.hs
@@ -246,20 +246,37 @@ caseAlternativeFromJSON modulePath = withObject "CaseAlternative" caseAlternativ
       isGuarded <- o .: "isGuarded"
       if isGuarded
         then do
-          es <- o .: "expressions" >>= listParser parseResultWithGuard
-          error "TODO: fromJSON"
-          -- return $ CaseAlternative bs (Left es)
+          es <- o .: "expressions" >>= listParser parseResultWithGuards
+          return $ CaseAlternative bs (Left es)
         else do
           e <- o .: "expression" >>= exprFromJSON modulePath
           return $ CaseAlternative bs (Right e)
 
-    parseResultWithGuard :: Value -> Parser (Guard Ann, Expr Ann)
-    parseResultWithGuard = withObject "parseCaseWithGuards" $
+    parseResultWithGuards :: Value -> Parser ([Guard Ann], Expr Ann)
+    parseResultWithGuards = withObject "parseCaseWithGuards" $
       \o -> do
-        g <- o .: "guard" >>= exprFromJSON modulePath
+        g <- o .: "guards" >>= listParser (guardFromJSON modulePath)
         e <- o .: "expression" >>= exprFromJSON modulePath
-        error "TODO: fromJSON"
-        -- return (g, e)
+        return (g, e)
+
+guardFromJSON :: FilePath -> Value -> Parser (Guard Ann)
+guardFromJSON modulePath = withObject "Guard" guardFromObj
+  where
+    guardFromObj o = do
+      type_ <- o .: "guardType"
+      case type_ of
+        "ConditionGuard" -> conditionGuardFromObj o
+        "PatternGuard"   -> patternGuardFromObj o
+        _ -> fail ("not recognized guard: \"" ++ T.unpack type_ ++ "\"")
+
+    conditionGuardFromObj o = do
+      cond <- o .: "guardCondition" >>= exprFromJSON modulePath
+      return $ ConditionGuard cond
+
+    patternGuardFromObj o = do
+      lv <- o .: "guardLvalue" >>= binderFromJSON modulePath
+      rv <- o .: "guardRvalue" >>= exprFromJSON modulePath
+      return $ PatternGuard lv rv
 
 binderFromJSON :: FilePath -> Value -> Parser (Binder Ann)
 binderFromJSON modulePath = withObject "Binder" binderFromObj
diff --git a/src/Language/PureScript/CoreFn/ToJSON.hs b/src/Language/PureScript/CoreFn/ToJSON.hs
index 8f677fff1a..3b5423b04a 100644
--- a/src/Language/PureScript/CoreFn/ToJSON.hs
+++ b/src/Language/PureScript/CoreFn/ToJSON.hs
@@ -199,13 +199,20 @@ caseAlternativeToJSON (CaseAlternative bs r') =
       , T.pack "isGuarded"   .= toJSON isGuarded
       , T.pack (if isGuarded then "expressions" else "expression")
          .= case r' of
-             Left rs -> toJSON $ map (\(g, e) -> object [ T.pack "guard" .= toJSON (map guardToJSON g), T.pack "expression" .= exprToJSON e]) rs
+             Left rs -> toJSON $ map (\(g, e) -> object [ T.pack "guards" .= toJSON (map guardToJSON g), T.pack "expression" .= exprToJSON e]) rs
              Right r -> exprToJSON r
       ]
 
 guardToJSON :: Guard Ann -> Value
-guardToJSON (ConditionGuard e) = object [T.pack "guardCondition" .= exprToJSON e]
-guardToJSON (PatternGuard lv rv) = object [T.pack "guardLvalue" .= binderToJSON lv, T.pack "guardRvalue" .= exprToJSON rv]
+guardToJSON (ConditionGuard e)   = object
+  [ T.pack "guardType" .= "ConditionGuard"
+  , T.pack "guardCondition" .= exprToJSON e
+  ]
+guardToJSON (PatternGuard lv rv) = object
+  [ T.pack "guardType" .= "PatternGuard"
+  , T.pack "guardLvalue" .= binderToJSON lv
+  , T.pack "guardRvalue" .= exprToJSON rv
+  ]
 
 binderToJSON :: Binder Ann -> Value
 binderToJSON (VarBinder ann v)              = object [ T.pack "binderType"  .= "VarBinder"
diff --git a/tests/TestCoreFn.hs b/tests/TestCoreFn.hs
index 675d9b5a6f..9eec09e57b 100644
--- a/tests/TestCoreFn.hs
+++ b/tests/TestCoreFn.hs
@@ -164,7 +164,7 @@ spec = context "CoreFnFromJsonTest" $ do
                     Case ann [Var ann (Qualified Nothing (Ident "x"))]
                       [ CaseAlternative
                         [ NullBinder ann ]
-                        (Left [([Literal ann (BooleanLiteral True)], Literal ann (CharLiteral 'a'))])
+                        (Left [([ConditionGuard $ Literal ann (BooleanLiteral True)], Literal ann (CharLiteral 'a'))])
                       ]
                 ]
       parseMod m `shouldSatisfy` isSuccess
diff --git a/tests/purs/passing/TCOMutRec.purs b/tests/purs/passing/TCOMutRec.purs
deleted file mode 100644
index 6f599c5bd6..0000000000
--- a/tests/purs/passing/TCOMutRec.purs
+++ /dev/null
@@ -1,95 +0,0 @@
-module Main where
-
-import Prelude
-import Effect (Effect)
-import Effect.Console (log)
-import Test.Assert (assertEqual, assertThrows)
-
-tco1 :: Int -> Int
-tco1 = f 0
-  where
-  f x y = g (x + 2) (y - 1)
-    where
-    g x' y' = if y' <= 0 then x' else f x' y'
-
-tco2 :: Int -> Int
-tco2 = f 0
-  where
-  f x y = g (x + 2) (y - 1)
-    where
-    g x' y' = h (y' <= 0) x' y'
-    h test x' y' = if test then x' else f x' y'
-
-tco3 :: Int -> Int
-tco3 y0 = f 0 y0
-  where
-  f x y = g x (h y)
-    where
-    g x' y' =
-      if y' <= 0 then x'
-      else if y' > y0 / 2 then g (j x') (y' - 1)
-      else f (x' + 2) y'
-    h y = y - 1
-  j x = x + 3
-
-tco4 :: Int -> Int
-tco4 = f 0
-  where
-  f x y = if y <= 0 then x else g (y - 1)
-    where
-    g y' = f (x + 2) y'
-
--- The following examples are functions which are prevented from being TCO'd
--- because the arity of the function being looped does not match the function
--- call. In theory, these could be made to optimize via eta-expansion in the
--- future, in which case the assertions can change.
-
-ntco1 :: Int -> Int
-ntco1 y0 = f 0 y0
-  where
-  f x = if x > 10 * y0 then (x + _) else g x
-    where
-    g x' y' = f (x' + 10) (y' - 1)
-
-ntco2 :: Int -> Int
-ntco2 = f 0
-  where
-  f x y = if y <= 0 then x else g x (y - 1)
-    where
-    g x' = f (x' + 2)
-
-ntco3 :: Int -> Int
-ntco3 = f 0
-  where
-  f x y = if y <= 0 then x else g (y - 1)
-    where
-    g = f (x + 2)
-
-ntco4 :: Int -> Int
-ntco4 = f 0
-  where
-  f x y = if y <= 0 then x else g (y - 1)
-    where
-    g = h x
-    h x' y' = f (x' + 2) y'
-
-main :: Effect Unit
-main = do
-  assertEqual { expected: 200000, actual: tco1 100000 }
-  assertEqual { expected: 200000, actual: tco2 100000 }
-  assertEqual { expected: 249997, actual: tco3 100000 }
-  assertEqual { expected: 200000, actual: tco4 100000 }
-
-  assertEqual { expected: 1009, actual: ntco1 100 }
-  assertThrows \_ -> ntco1 100000
-
-  assertEqual { expected: 200, actual: ntco2 100 }
-  assertThrows \_ -> ntco2 100000
-
-  assertEqual { expected: 200, actual: ntco3 100 }
-  assertThrows \_ -> ntco3 100000
-
-  assertEqual { expected: 200, actual: ntco4 100 }
-  assertThrows \_ -> ntco4 100000
-
-  log "Done"

From a1ae1c00b0e32259327bc81a09918a8a6d2f1ebe Mon Sep 17 00:00:00 2001
From: Grzegorz Uriasz <gorbak25@gmail.com>
Date: Tue, 23 Feb 2021 21:41:54 +0100
Subject: [PATCH 24/30] AST cleanup

---
 src/Language/PureScript/CodeGen/JS.hs         |  4 +++-
 src/Language/PureScript/CoreImp/Optimizer.hs  |  2 +-
 .../PureScript/CoreImp/Optimizer/Blocks.hs    | 22 ++++++++++++++++++-
 .../PureScript/CoreImp/Optimizer/TCO.hs       |  4 ++--
 4 files changed, 27 insertions(+), 5 deletions(-)

diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 5a28471924..dc0efa933f 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -79,7 +79,9 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
     let decls' = renameModules mnLookup decls
 
     jsDecls <- inFun $ map snd <$> mapM bindToJs decls'
-    optimized <- traverse (traverse optimize) jsDecls
+    jsDecls' <- traverse (traverse optimize) jsDecls
+    optimized <- traverse (pure . cleanupBlockStatements) jsDecls'
+
     let mnReverseLookup = M.fromList $ map (\(origName, (_, safeName)) -> (moduleNameToJs safeName, origName)) $ M.toList mnLookup
     let usedModuleNames = foldMap (foldMap (findModules mnReverseLookup)) optimized
     jsImports <- traverse (importToJs mnLookup)
diff --git a/src/Language/PureScript/CoreImp/Optimizer.hs b/src/Language/PureScript/CoreImp/Optimizer.hs
index 3f7c51b155..f72f02559d 100644
--- a/src/Language/PureScript/CoreImp/Optimizer.hs
+++ b/src/Language/PureScript/CoreImp/Optimizer.hs
@@ -17,7 +17,7 @@
 --  * Inline Prelude.($), Prelude.(#), Prelude.(++), Prelude.(!!)
 --
 --  * Inlining primitive JavaScript operators
-module Language.PureScript.CoreImp.Optimizer (optimize) where
+module Language.PureScript.CoreImp.Optimizer (optimize, cleanupBlockStatements) where
 
 import Prelude.Compat
 
diff --git a/src/Language/PureScript/CoreImp/Optimizer/Blocks.hs b/src/Language/PureScript/CoreImp/Optimizer/Blocks.hs
index c630fb5a12..1885010402 100644
--- a/src/Language/PureScript/CoreImp/Optimizer/Blocks.hs
+++ b/src/Language/PureScript/CoreImp/Optimizer/Blocks.hs
@@ -2,6 +2,7 @@
 module Language.PureScript.CoreImp.Optimizer.Blocks
   ( collapseNestedBlocks
   , collapseNestedIfs
+  , cleanupBlockStatements
   ) where
 
 import Prelude.Compat
@@ -12,17 +13,36 @@ import Language.PureScript.CoreImp.AST
 collapseNestedBlocks :: AST -> AST
 collapseNestedBlocks = everywhere collapse where
   collapse :: AST -> AST
-  collapse (Block ss n sts) = Block ss n (concatMap go sts)
+  collapse (Block ss n sts) = Block ss n (cleanupBlockStatements $ concatMap go sts)
   collapse js = js
 
   go :: AST -> [AST]
   go (Block _ Nothing sts) = sts
   go s = [s]
 
+cleanupBlockStatements :: [AST] -> [AST]
+cleanupBlockStatements = go where
+  go :: [AST] -> [AST]
+  -- TODO: ensure e1 is PURE
+  go ((IfElse ss e1 b1 Nothing):(IfElse _ e2 b2 Nothing):t) | e1 == e2 = go $ (IfElse ss e1 (Block ss Nothing [b1, b2]) Nothing):t
+  go ((IfElse ss1 e1 b1 Nothing):(IfElse ss2 (Binary _ And e2 e3) b2 me):t) | e1 == e2 = go $ (IfElse ss1 e1 (Block ss1 Nothing [b1, IfElse ss2 e3 b2 me]) Nothing):t
+  go ((Block ss l sts1):(Block _ Nothing sts2):t) = go $ ((Block ss l (sts1 ++ sts2)):t)
+  go ((VariableLetIntroduction ss1 n1 Nothing):(Block _ (Just label1) [Assignment _ (Var _ n2) js, Break _ (Just label2)]):t) | n1 == n2, label1 == label2 = (VariableLetIntroduction ss1 n1 (Just js)):(go t)
+  go (js@(Return _ _):_) = [js]
+  go (js@(ReturnNoResult _):_) = [js]
+  go (js@(Throw _ _):_) = [js]
+  go (js@(Break _ _):_) = [js]
+  go (js@(Continue _ _):_) = [js]
+  go (h:t) = h:(go t)
+  go [] = []
+
 collapseNestedIfs :: AST -> AST
 collapseNestedIfs = everywhere collapse where
   collapse :: AST -> AST
   collapse (IfElse _ (BooleanLiteral _ True) (Block _ _ [js]) _) = js
+  collapse (IfElse _ (BooleanLiteral _ False) _ (Just (Block _ _ [js]))) = js
+  collapse (IfElse _ (BooleanLiteral _ True) js _) = js
+  collapse (IfElse _ (BooleanLiteral _ False) _ (Just js)) = js
   collapse (IfElse s1 cond1 (Block _ Nothing [IfElse s2 cond2 body Nothing]) Nothing) =
       IfElse s1 (Binary s2 And cond1 cond2) body Nothing
   collapse js = js
diff --git a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs
index 60bcab7f10..1f935bb8c1 100644
--- a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs
+++ b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs
@@ -65,10 +65,10 @@ tco = flip evalState emptyTCOState . everywhereTopDownM convertAST where
   tcoLoopM = uniq "$tco_loop"
 
   convertAST :: AST -> State TCOState AST
-  convertAST js@(Assignment ass (Var vss name) fn@Function {}) = do
+  convertAST js@(VariableLetIntroduction ss name (Just fn@Function {})) = do
     conv <- convert name fn
     return $ case conv of
-      Just looped -> Assignment ass (Var vss name) looped
+      Just looped -> VariableLetIntroduction ss name (Just looped)
       _ -> js
   convertAST js = pure js
 

From 6a7844241d902680b14cb3332bd113e3fe3bde29 Mon Sep 17 00:00:00 2001
From: radrow <radrowicki@gmail.com>
Date: Wed, 24 Feb 2021 10:38:29 +0100
Subject: [PATCH 25/30] Debug, remove this commit
 AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA

---
 src/Language/PureScript/Bundle.hs        | 17 +++++++++--------
 src/Language/PureScript/CoreFn/ToJSON.hs |  2 +-
 2 files changed, 10 insertions(+), 9 deletions(-)

diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs
index c291463543..1577d72d48 100644
--- a/src/Language/PureScript/Bundle.hs
+++ b/src/Language/PureScript/Bundle.hs
@@ -54,7 +54,7 @@ data ErrorMessage
   = UnsupportedModulePath String
   | InvalidTopLevel
   | UnableToParseModule String
-  | UnsupportedExport
+  | UnsupportedExport String -- TODO REMOVE STIRNG
   | ErrorInModule ModuleIdentifier ErrorMessage
   | MissingEntryPoint String
   | MissingMainModule String
@@ -206,10 +206,11 @@ printErrorMessage (UnableToParseModule err) =
   [ "The module could not be parsed:"
   , err
   ]
-printErrorMessage UnsupportedExport =
+printErrorMessage (UnsupportedExport s) =
   [ "An export was unsupported. Exports can be defined in one of two ways: "
   , "  1) exports.name = ..."
   , "  2) exports = { ... }"
+  , "ERROR: " <> s
   ]
 printErrorMessage (ErrorInModule mid e) =
   ("Error in module " ++ displayIdentifier mid ++ ":")
@@ -395,7 +396,7 @@ toModule mids mid filename top
       toExport (JSPropertyNameandValue name _ [val]) =
         (,,val,[]) <$> exportType val
                    <*> extractLabel' name
-      toExport _ = err UnsupportedExport
+      toExport e = err $ UnsupportedExport $ "toExport: " <> show e
 
       exportType :: JSExpression -> m ExportType
       exportType (JSMemberDot f _ _)
@@ -405,9 +406,9 @@ toModule mids mid filename top
         | JSIdentifier _ "$foreign" <- f
         = pure ForeignReexport
       exportType (JSIdentifier _ s) = pure (RegularExport s)
-      exportType _ = err UnsupportedExport
+      exportType e = err $ UnsupportedExport $ "exportType: " <> show e
 
-      extractLabel' = maybe (err UnsupportedExport) pure . extractLabel
+      extractLabel' = maybe (err $ UnsupportedExport "extractLabel1") pure . extractLabel
 
   toModuleElement other = pure (Other other)
 
@@ -435,10 +436,10 @@ getExportedIdentifiers mname top
 
   toIdent (JSPropertyNameandValue name _ [_]) =
     extractLabel' name
-  toIdent _ =
-    err UnsupportedExport
+  toIdent e =
+    err $ UnsupportedExport $ "toIdent: " <> show e
 
-  extractLabel' = maybe (err UnsupportedExport) pure . extractLabel
+  extractLabel' = maybe (err $ UnsupportedExport "extractLabel2") pure . extractLabel
 
 -- Matches JS statements like this:
 -- var ModuleName = require("file");
diff --git a/src/Language/PureScript/CoreFn/ToJSON.hs b/src/Language/PureScript/CoreFn/ToJSON.hs
index 3b5423b04a..7ddabf0296 100644
--- a/src/Language/PureScript/CoreFn/ToJSON.hs
+++ b/src/Language/PureScript/CoreFn/ToJSON.hs
@@ -185,7 +185,7 @@ exprToJSON (Case ann ss cs)         = object [ T.pack "type"        .= "Case"
                                              , T.pack "caseAlternatives"
                                                                     .= map caseAlternativeToJSON cs
                                              ]
-exprToJSON (Let ann bs e)           = object [ T.pack "type"        .= "Let" 
+exprToJSON (Let ann bs e)           = object [ T.pack "type"        .= "Let"
                                              , T.pack "annotation"  .= annToJSON ann
                                              , T.pack "binds"       .= map bindToJSON bs
                                              , T.pack "expression"  .= exprToJSON e

From ed7b12acb789065032b7be1914a7687f3955ea73 Mon Sep 17 00:00:00 2001
From: radrow <radrowicki@gmail.com>
Date: Wed, 24 Feb 2021 12:07:23 +0100
Subject: [PATCH 26/30] Fix TCO one more time

---
 src/Language/PureScript/CoreImp/Optimizer.hs  |  2 +-
 .../PureScript/CoreImp/Optimizer/TCO.hs       | 25 ++++++++-----------
 2 files changed, 11 insertions(+), 16 deletions(-)

diff --git a/src/Language/PureScript/CoreImp/Optimizer.hs b/src/Language/PureScript/CoreImp/Optimizer.hs
index f72f02559d..dfbb3a0f58 100644
--- a/src/Language/PureScript/CoreImp/Optimizer.hs
+++ b/src/Language/PureScript/CoreImp/Optimizer.hs
@@ -37,7 +37,7 @@ optimize js = do
     js' <- untilFixedPoint (inlineFnComposition . inlineUnsafeCoerce . inlineUnsafePartial . tidyUp . applyAll
       [ inlineCommonValues
       , inlineCommonOperators
-      ]) js -- DROGIE
+      ]) js
     untilFixedPoint (return . tidyUp) . tco . inlineST
       =<< untilFixedPoint (return . magicDoST)
       =<< untilFixedPoint (return . magicDoEff)
diff --git a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs
index 1f935bb8c1..c1a2b260ca 100644
--- a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs
+++ b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs
@@ -6,7 +6,6 @@ import Prelude.Compat
 import Debug.Trace
 
 import Control.Monad.State
-import Data.List
 import Data.Functor ((<&>))
 import Data.Text (Text, pack)
 import qualified Language.PureScript.Constants as C
@@ -70,6 +69,16 @@ tco = flip evalState emptyTCOState . everywhereTopDownM convertAST where
     return $ case conv of
       Just looped -> VariableLetIntroduction ss name (Just looped)
       _ -> js
+  convertAST js@(VariableIntroduction ss name (Just fn@Function {})) = do
+    conv <- convert name fn
+    return $ case conv of
+      Just looped -> VariableIntroduction ss name (Just looped)
+      _ -> js
+  convertAST js@(Assignment ss (Var vss name) fn@Function {}) = do
+    conv <- convert name fn
+    return $ case conv of
+      Just looped -> Assignment ss (Var vss name) looped
+      _ -> js
   convertAST js = pure js
 
   convert :: Text -> AST -> State TCOState (Maybe AST)
@@ -150,20 +159,6 @@ tco = flip evalState emptyTCOState . everywhereTopDownM convertAST where
               else return [Return Nothing expr]
           else traverse loopify [h1, h2]
 
-      -- FIXME: these are unrelated to TCO
-      loopifyBlock (VariableLetIntroduction ss var Nothing : Block _ blockname (Assignment _ (Var _ vname) expr : tb) : t)
-        | vname == var
-        , case tb of
-            [] -> True
-            (Break _ Nothing : _) -> True
-            (Break _ breakname : _) | breakname == blockname -> True
-            _ -> False
-        = loopifyBlock (VariableLetIntroduction ss var (Just expr) : t)
-      loopifyBlock (h@Return{}:_)   = (:[]) <$> loopify h
-      loopifyBlock (h@Break{}:_)    = (:[]) <$> loopify h
-      loopifyBlock (h@Continue{}:_) = (:[]) <$> loopify h
-      loopifyBlock (h@Throw{}:_)    = (:[]) <$> loopify h
-
       loopifyBlock (h:t) = (:) <$> loopify h <*> loopifyBlock t
 
     looped <- loopify js

From 47f6f5b35463f0970c64f7c12d04b4fb81328c2c Mon Sep 17 00:00:00 2001
From: Grzegorz Uriasz <gorbak25@gmail.com>
Date: Wed, 24 Feb 2021 12:14:32 +0100
Subject: [PATCH 27/30] More opt

---
 package.yaml | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/package.yaml b/package.yaml
index 857c66b3f0..fafe2d0533 100644
--- a/package.yaml
+++ b/package.yaml
@@ -102,7 +102,7 @@ build-tools:
 
 library:
   source-dirs: src
-  ghc-options: -Wall -O3
+  ghc-options: -Wall -O3 -optc-O3
   other-modules: Paths_purescript
   default-extensions:
     - ConstraintKinds
@@ -131,7 +131,7 @@ executables:
   purs:
     main: Main.hs
     source-dirs: app
-    ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-N
+    ghc-options: -Wall -O3 -optc-O3 -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-N
     other-modules:
       - Command.Bundle
       - Command.Compile

From 5d977603864a905ff1ecccd401f077fb30be9788 Mon Sep 17 00:00:00 2001
From: radrow <radrowicki@gmail.com>
Date: Thu, 25 Feb 2021 15:47:48 +0100
Subject: [PATCH 28/30] WIP fix bundler

---
 src/Language/PureScript/AST/Declarations.hs   |   7 +-
 src/Language/PureScript/Bundle.hs             | 116 ++++++++++--------
 src/Language/PureScript/Bundle/Types.hs       |  40 ++++++
 src/Language/PureScript/CodeGen/JS.hs         |  14 ++-
 src/Language/PureScript/CoreImp/AST.hs        |  14 +++
 .../PureScript/CoreImp/Optimizer/Blocks.hs    |  53 ++++++--
 .../PureScript/Sugar/CaseDeclarations.hs      |  65 +---------
 tests/TestBundle.hs                           |  10 +-
 8 files changed, 175 insertions(+), 144 deletions(-)
 create mode 100644 src/Language/PureScript/Bundle/Types.hs

diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
index cff92b2bdd..50f467110d 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -1,6 +1,5 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE DeriveFoldable #-}
 {-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE DeriveAnyClass #-}
 
@@ -34,7 +33,7 @@ import Language.PureScript.Kinds
 import Language.PureScript.TypeClassDictionaries
 import Language.PureScript.Comments
 import Language.PureScript.Environment
-import qualified Language.PureScript.Bundle as Bundle
+import qualified Language.PureScript.Bundle.Types as Bundle
 import qualified Language.PureScript.Constants as C
 import qualified Language.PureScript.CST.Errors as CST
 
@@ -839,10 +838,6 @@ data Expr
   -- A value with source position information
   --
   | PositionedValue SourceSpan [Comment] Expr
-  -- |
-  -- Failing pattern match – order to try the next branch
-  ---
-  | SafeCaseFail
   deriving (Show)
 
 -- |
diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs
index 1577d72d48..bafad47d12 100644
--- a/src/Language/PureScript/Bundle.hs
+++ b/src/Language/PureScript/Bundle.hs
@@ -17,6 +17,8 @@ module Language.PureScript.Bundle
   , Module
   ) where
 
+import Debug.Trace
+
 import Prelude.Compat
 import Protolude (ordNub)
 
@@ -36,8 +38,12 @@ import Data.Version (showVersion)
 import qualified Data.Aeson as A
 import qualified Data.Map as M
 import qualified Data.Set as S
+import qualified Data.Text as TS
 import qualified Data.Text.Lazy as T
 
+import Language.PureScript.Bundle.Types
+import qualified Language.PureScript.CoreImp.AST as CoreAST
+
 import Language.JavaScript.Parser
 import Language.JavaScript.Parser.AST
 import Language.JavaScript.Process.Minify
@@ -48,41 +54,6 @@ import System.FilePath (takeFileName, takeDirectory, takeDirectory, makeRelative
 
 import SourceMap.Types
 
--- | The type of error messages. We separate generation and rendering of errors using a data
--- type, in case we need to match on error types later.
-data ErrorMessage
-  = UnsupportedModulePath String
-  | InvalidTopLevel
-  | UnableToParseModule String
-  | UnsupportedExport String -- TODO REMOVE STIRNG
-  | ErrorInModule ModuleIdentifier ErrorMessage
-  | MissingEntryPoint String
-  | MissingMainModule String
-  deriving (Show)
-
--- | Modules are either "regular modules" (i.e. those generated by the PureScript compiler) or
--- foreign modules.
-data ModuleType
-  = Regular
-  | Foreign
-  deriving (Show, Eq, Ord)
-
-showModuleType :: ModuleType -> String
-showModuleType Regular = "Regular"
-showModuleType Foreign = "Foreign"
-
--- | A module is identified by its module name and its type.
-data ModuleIdentifier = ModuleIdentifier String ModuleType deriving (Show, Eq, Ord)
-
-instance A.ToJSON ModuleIdentifier where
-  toJSON (ModuleIdentifier name mt) =
-    A.object [ "name" .= name
-             , "type" .= show mt
-             ]
-
-moduleName :: ModuleIdentifier -> String
-moduleName (ModuleIdentifier name _) = name
-
 -- | Given a filename, assuming it is in the correct place on disk, infer a ModuleIdentifier.
 guessModuleIdentifier :: MonadError ErrorMessage m => FilePath -> m ModuleIdentifier
 guessModuleIdentifier filename = ModuleIdentifier (takeFileName (takeDirectory filename)) <$> guessModuleType (takeFileName filename)
@@ -122,6 +93,7 @@ data ModuleElement
   = Require JSStatement String (Either String ModuleIdentifier)
   | Member JSStatement Visibility String JSExpression [Key]
   | ExportsList [(ExportType, String, JSExpression, [Key])]
+  | Block (Maybe String) [JSStatement] [Key]
   | Other JSStatement
   | Skip JSStatement
   deriving (Show)
@@ -148,6 +120,11 @@ instance A.ToJSON ModuleElement where
       A.object [ "type"    .= A.String "ExportsList"
                , "exports" .= map exportToJSON exports
                ]
+    (Block name stmts dependsOn) ->
+      A.object [ "statemtents" .= A.toJSON (map getFragment stmts)
+               , "name" .= A.toJSON name
+               , "dependsOn"  .= map keyToJSON dependsOn
+               ]
     (Other stmt) ->
       A.object [ "type" .= A.String "Other"
                , "js"   .= getFragment stmt
@@ -268,15 +245,20 @@ withDeps (Module modulePath fn es) = Module modulePath fn (map expandDeps es)
 
   -- | Collects all member names in scope, so that we can identify dependencies of the second type.
   boundNames :: [String]
-  boundNames = mapMaybe toBoundName es
+  boundNames = concatMap toBoundName es
     where
-    toBoundName :: ModuleElement -> Maybe String
-    toBoundName (Member _ Internal nm _ _) = Just nm
-    toBoundName _ = Nothing
+    toBoundName :: ModuleElement -> [String]
+    toBoundName (Member _ Internal nm _ _) = [nm]
+    toBoundName _ = []
 
   -- | Calculate dependencies and add them to the current element.
   expandDeps :: ModuleElement -> ModuleElement
   expandDeps (Member n f nm decl _) = Member n f nm decl (ordNub $ dependencies modulePath decl)
+  expandDeps (Block n b _) = Block n b keys where
+    keys = ordNub $
+      dependencies modulePath
+      (JSFunctionExpression JSNoAnnot JSIdentNone JSNoAnnot JSLNil JSNoAnnot
+        (JSBlock JSNoAnnot b JSNoAnnot))
   expandDeps (ExportsList exps) = ExportsList (map expand exps)
       where
       expand (ty, nm, n1, _) = (ty, nm, n1, ordNub (dependencies modulePath n1))
@@ -312,9 +294,9 @@ withDeps (Module modulePath fn es) = Module modulePath fn (map expandDeps es)
             mapMaybe unPropertyIdentRef $
             trailingCommaList props
         in
-          (map (\name -> (m, name, Internal)) shorthandNames, bn)
+          (map (m, , Internal) shorthandNames, bn)
     toReference (JSFunctionExpression _ _ _ params _ _) bn
-      = ([], bn \\ (mapMaybe unIdentifier $ commaList params))
+      = ([], bn \\ mapMaybe unIdentifier (commaList params))
     toReference e bn
       | Just nm <- exportsAccessor e
       -- exports.foo means there's a dependency on the public member "foo" of
@@ -388,6 +370,9 @@ toModule mids mid filename top
   toModuleElement stmt
     | Just (visibility, name, decl) <- matchMember stmt
     = pure (Member stmt visibility name decl [])
+  toModuleElement stmt
+    | Just (name, block) <- matchBlock stmt
+    = pure (Block name block [])
   toModuleElement stmt
     | Just props <- matchExportsAssignment stmt
     = ExportsList <$> traverse toExport (trailingCommaList props)
@@ -482,6 +467,13 @@ matchMember stmt
   | otherwise
   = Nothing
 
+matchBlock :: JSStatement -> Maybe (Maybe String, [JSStatement])
+matchBlock (JSLabelled (JSIdentName _ label) _ block)
+  | Just (Nothing, matched) <- matchBlock block
+  = Just (Just label, matched)
+matchBlock (JSStatementBlock _ block _ _) = Just (Nothing, block)
+matchBlock _ = Nothing
+
 -- Matches exports.* or exports["*"] expressions and returns the property name.
 exportsAccessor :: JSExpression -> Maybe String
 exportsAccessor (JSMemberDot exports _ nm)
@@ -531,6 +523,9 @@ compile modules entryPoints = filteredModules
     -- inlined wherever they are used inside other module elements.
     toVertices :: ModuleIdentifier -> ModuleElement -> [(ModuleElement, Key, [Key])]
     toVertices p m@(Member _ visibility nm _ deps) = [(m, (p, nm, visibility), deps)]
+    toVertices p m@(Block (Just init_name) _ deps)
+      | Just n <- CoreAST.dropInitializerName (TS.pack init_name)
+      = [(m, (p, TS.unpack n, Public), deps)]
     toVertices p m@(ExportsList exps) = map toVertex exps
       where
       toVertex (ForeignReexport, nm, _, ks) = (m, (p, nm, Public), ks)
@@ -539,10 +534,10 @@ compile modules entryPoints = filteredModules
 
   -- | The set of vertices whose connected components we are interested in keeping.
   entryPointVertices :: [Vertex]
-  entryPointVertices = catMaybes $ do
+  entryPointVertices = catMaybes (do
     (_, k@(mid, _, Public), _) <- verts
     guard $ mid `elem` entryPoints
-    return (vertexFor k)
+    return (vertexFor k))
 
   -- | The set of vertices reachable from an entry point
   reachableSet :: S.Set Vertex
@@ -559,20 +554,21 @@ compile modules entryPoints = filteredModules
   filteredModules = map filterUsed modules
     where
     filterUsed :: Module -> Module
-    filterUsed (Module mid fn ds) = Module mid fn (map filterExports (go ds))
+    filterUsed (Module mid fn ds) =  trace ("REFERENCED: " <> show (fold $ M.lookup mid moduleReferenceMap)) $  Module mid fn (map filterExports (go ds))
       where
       go :: [ModuleElement] -> [ModuleElement]
       go [] = []
       go (d : rest)
-        | not (isDeclUsed d) = skipDecl d : go rest
+        | not (isDeclUsed d) = skipDecl d ++ go rest
         | otherwise = d : go rest
 
-      skipDecl :: ModuleElement -> ModuleElement
-      skipDecl (Require s _ _) = Skip s
-      skipDecl (Member s _ _ _ _) = Skip s
-      skipDecl (ExportsList _) = Skip (JSEmptyStatement JSNoAnnot)
-      skipDecl (Other s) = Skip s
-      skipDecl (Skip s) = Skip s
+      skipDecl :: ModuleElement -> [ModuleElement]
+      skipDecl (Require s _ _) = [Skip s]
+      skipDecl (Member s _ _ _ _) = [Skip s]
+      skipDecl (Block _ s _) = map Skip s
+      skipDecl (ExportsList _) = [Skip (JSEmptyStatement JSNoAnnot)]
+      skipDecl (Other s) = [Skip s]
+      skipDecl (Skip s) = [Skip s]
 
       -- | Filter out the exports for members which aren't used.
       filterExports :: ModuleElement -> ModuleElement
@@ -581,10 +577,22 @@ compile modules entryPoints = filteredModules
 
       isDeclUsed :: ModuleElement -> Bool
       isDeclUsed (Member _ visibility nm _ _) = isKeyUsed (mid, nm, visibility)
+      isDeclUsed (Block (Just "$init__main") _ deps) =
+        let r1 = isKeyUsed (mid, "main", Public)
+            r2 = isKeyUsed (mid, "main", Internal)
+        in trace ("KURWA: " <> show r1 <> " CHUJ " <> show r2 <>
+                 "DEPS ARE " <> show deps <> "\n\n") r1
+      isDeclUsed (Block (Just n) _ _)
+        | Just varName <- CoreAST.dropInitializerName (TS.pack n)
+        = isKeyUsed (mid, TS.unpack varName, Public)
       isDeclUsed (Require _ _ (Right midRef)) = midRef `S.member` modulesReferenced
       isDeclUsed _ = True
 
       isKeyUsed :: Key -> Bool
+      isKeyUsed k@(_, "eq", _)
+        | Just me <- vertexFor k = trace ("USED " <> show k <> ":\n" <> show ( me `S.member` reachableSet)) $ me `S.member` reachableSet
+      isKeyUsed k@(_, "main", _)
+        | Just me <- vertexFor k = trace ("USED " <> show k <> ":\n" <> show ( me `S.member` reachableSet)) $ me `S.member` reachableSet
       isKeyUsed k
         | Just me <- vertexFor k = me `S.member` reachableSet
         | otherwise = False
@@ -651,7 +659,7 @@ codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping o
           map (\(porig, pgen) -> Mapping {
                 mapOriginal = Just (Pos (fromIntegral $ porig + 1) 0)
               , mapSourceFile = pathToFile <$> file
-              , mapGenerated = (Pos (fromIntegral $ pos + pgen) 0)
+              , mapGenerated = Pos (fromIntegral $ pos + pgen) 0
               , mapName = Nothing
               })
             (offsets (0,0) (Right 1 : positions)))
@@ -690,6 +698,8 @@ codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping o
     declToJS :: ModuleElement -> ([JSStatement], Either Int Int)
     declToJS (Member n _ _ _ _) = withLength [n]
     declToJS (Other n) = withLength [n]
+    declToJS (Block Nothing b _) = withLength [JSStatementBlock JSAnnotSpace b JSAnnotSpace JSSemiAuto]
+    declToJS (Block (Just name) b _) = withLength [JSLabelled (JSIdentName JSAnnotSpace name) JSAnnotSpace (JSStatementBlock JSAnnotSpace b JSAnnotSpace JSSemiAuto)]
     declToJS (Skip n) = ([], Left $ moduleLength [n])
     declToJS (Require _ nm req) = withLength
       [
@@ -736,7 +746,7 @@ codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping o
     keepCol (TokenPn _ _ c) = TokenPn 0 0 (if c >= 0 then c + 2 else 2)
 
   prelude :: JSStatement
-  prelude = JSVariable (JSAnnot tokenPosnEmpty [ CommentA tokenPosnEmpty $ "// Generated by purs bundle " ++ showVersion Paths.version
+  prelude = JSVariable (JSAnnot tokenPosnEmpty [ CommentA tokenPosnEmpty $ "// Generated by purs bundle " ++ showVersion Paths.version ++ ". Erlscripten edition!"
                                                , WhiteSpace tokenPosnEmpty "\n" ])
               (cList [
                 JSVarInitExpression (JSIdentifier sp optionsNamespace)
diff --git a/src/Language/PureScript/Bundle/Types.hs b/src/Language/PureScript/Bundle/Types.hs
new file mode 100644
index 0000000000..7a1714c6a7
--- /dev/null
+++ b/src/Language/PureScript/Bundle/Types.hs
@@ -0,0 +1,40 @@
+module Language.PureScript.Bundle.Types where
+
+import Data.Aeson ((.=))
+import qualified Data.Aeson as A
+import Prelude.Compat
+
+-- | Modules are either "regular modules" (i.e. those generated by the PureScript compiler) or
+-- foreign modules.
+data ModuleType
+  = Regular
+  | Foreign
+  deriving (Show, Eq, Ord)
+
+showModuleType :: ModuleType -> String
+showModuleType Regular = "Regular"
+showModuleType Foreign = "Foreign"
+
+-- | A module is identified by its module name and its type.
+data ModuleIdentifier = ModuleIdentifier String ModuleType deriving (Show, Eq, Ord)
+
+instance A.ToJSON ModuleIdentifier where
+  toJSON (ModuleIdentifier name mt) =
+    A.object [ "name" .= name
+             , "type" .= show mt
+             ]
+
+moduleName :: ModuleIdentifier -> String
+moduleName (ModuleIdentifier name _) = name
+
+-- | The type of error messages. We separate generation and rendering of errors using a data
+-- type, in case we need to match on error types later.
+data ErrorMessage
+  = UnsupportedModulePath String
+  | InvalidTopLevel
+  | UnableToParseModule String
+  | UnsupportedExport String -- TODO REMOVE STIRNG
+  | ErrorInModule ModuleIdentifier ErrorMessage
+  | MissingEntryPoint String
+  | MissingMainModule String
+  deriving (Show)
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index dc0efa933f..4ac4679222 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -16,7 +16,7 @@ import Control.Monad.Except (MonadError, throwError)
 import Control.Monad.Reader (MonadReader, asks, local)
 import Control.Monad.Supply.Class
 
-import Data.Bifunctor(first, second, bimap)
+import Data.Bifunctor(first, second)
 import Data.List ((\\), intersect)
 import qualified Data.Foldable as F
 import qualified Data.Map as M
@@ -215,9 +215,11 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
   nonRecToJS :: Ann -> Text -> Expr Ann -> m [AST]
   nonRecToJS a i e@(extractAnn -> (_, com, _, _)) | not (null com) = do
     withoutComment <- asks $ optionsNoComments . options
-    if withoutComment
-       then nonRecToJS a i (modifyAnn removeComments e)
-       else map (AST.Comment Nothing com) <$> nonRecToJS a i (modifyAnn removeComments e)
+    js <- nonRecToJS a i (modifyAnn removeComments e)
+    return $ if withoutComment then js
+             else case js of
+                    []    -> js
+                    (h:t) -> AST.Comment Nothing com h : t
   nonRecToJS (_, _, _, _) ident val = escapeTopLevel $ do
     env <- asks vars
     let solvedIdent = case M.lookup ident env of
@@ -272,11 +274,11 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
 
   bindToVar :: Text -> m ([AST], AST) -> m [AST]
   bindToVar v ex = do
-    breakRef <- freshNameHint $ "def_" <> v <> "_"
+    let breakRef = AST.initializerName v
     (ds, js) <- inLet breakRef v ex
     return
       (AST.VariableLetIntroduction Nothing v Nothing :
-       [AST.Block Nothing (Just breakRef) (ds ++[js])]
+       [AST.Block Nothing (Just breakRef) (ds ++ [js])]
       )
 
   valueToJs' :: Expr Ann -> m ([AST], AST)
diff --git a/src/Language/PureScript/CoreImp/AST.hs b/src/Language/PureScript/CoreImp/AST.hs
index a98dc3bef9..3358747446 100644
--- a/src/Language/PureScript/CoreImp/AST.hs
+++ b/src/Language/PureScript/CoreImp/AST.hs
@@ -7,6 +7,7 @@ import Prelude.Compat
 import Control.Monad ((>=>))
 import Control.Monad.Identity (Identity(..), runIdentity)
 import Data.Text (Text)
+import qualified Data.Text as Text
 import Data.List(foldl')
 
 import Language.PureScript.AST (SourceSpan(..))
@@ -102,6 +103,19 @@ data AST
   -- ^ Commented JavaScript
   deriving (Show, Eq)
 
+initializerPrefix :: Text
+initializerPrefix = "$init__"
+
+initializerName :: Text -> Text
+initializerName name = initializerPrefix <> name
+
+dropInitializerName :: Text -> Maybe Text
+dropInitializerName name =
+  let l = Text.length initializerPrefix
+  in case Text.splitAt l name of
+    (pref, rest) | pref == initializerPrefix -> Just rest
+    _ -> Nothing
+
 withSourceSpan :: SourceSpan -> AST -> AST
 withSourceSpan withSpan = go where
   ss :: Maybe SourceSpan
diff --git a/src/Language/PureScript/CoreImp/Optimizer/Blocks.hs b/src/Language/PureScript/CoreImp/Optimizer/Blocks.hs
index 1885010402..7eca22c103 100644
--- a/src/Language/PureScript/CoreImp/Optimizer/Blocks.hs
+++ b/src/Language/PureScript/CoreImp/Optimizer/Blocks.hs
@@ -6,6 +6,10 @@ module Language.PureScript.CoreImp.Optimizer.Blocks
   ) where
 
 import Prelude.Compat
+import qualified Data.Map as M
+import Data.Maybe
+import Language.PureScript.Comments
+import Language.PureScript.AST.SourcePos
 
 import Language.PureScript.CoreImp.AST
 
@@ -21,19 +25,44 @@ collapseNestedBlocks = everywhere collapse where
   go s = [s]
 
 cleanupBlockStatements :: [AST] -> [AST]
-cleanupBlockStatements = go where
-  go :: [AST] -> [AST]
+cleanupBlockStatements block = bringBackComments (go noComments) [] where
+
+  stripComments :: [AST]
+                -> Int
+                -> [([Int], AST)]
+                -> M.Map Int [(Maybe SourceSpan, [Comment])]
+                -> ([([Int], AST)], M.Map Int [(Maybe SourceSpan, [Comment])])
+  stripComments (Comment ss com h : t) n acc strip =
+    stripComments (h:t) n acc (M.insertWith (++) n [(ss, com)] strip)
+  stripComments (h:t) n acc strip =
+    stripComments t (n + 1) (([n], h):acc) strip
+  stripComments [] _ acc strip =
+    (reverse acc, strip)
+
+  (noComments, comments) = stripComments block 0 [] M.empty
+
+  bringBackComments :: [([Int], AST)] -> [AST] -> [AST]
+  bringBackComments [] acc = reverse acc
+  bringBackComments ((ids, ast):rest) acc =
+    let coms = concat $ mapMaybe (`M.lookup` comments) ids
+    in bringBackComments rest (foldr (\(ss, com) r -> Comment ss com r) ast coms : acc)
+
+  go :: [([Int], AST)] -> [([Int], AST)]
   -- TODO: ensure e1 is PURE
-  go ((IfElse ss e1 b1 Nothing):(IfElse _ e2 b2 Nothing):t) | e1 == e2 = go $ (IfElse ss e1 (Block ss Nothing [b1, b2]) Nothing):t
-  go ((IfElse ss1 e1 b1 Nothing):(IfElse ss2 (Binary _ And e2 e3) b2 me):t) | e1 == e2 = go $ (IfElse ss1 e1 (Block ss1 Nothing [b1, IfElse ss2 e3 b2 me]) Nothing):t
-  go ((Block ss l sts1):(Block _ Nothing sts2):t) = go $ ((Block ss l (sts1 ++ sts2)):t)
-  go ((VariableLetIntroduction ss1 n1 Nothing):(Block _ (Just label1) [Assignment _ (Var _ n2) js, Break _ (Just label2)]):t) | n1 == n2, label1 == label2 = (VariableLetIntroduction ss1 n1 (Just js)):(go t)
-  go (js@(Return _ _):_) = [js]
-  go (js@(ReturnNoResult _):_) = [js]
-  go (js@(Throw _ _):_) = [js]
-  go (js@(Break _ _):_) = [js]
-  go (js@(Continue _ _):_) = [js]
-  go (h:t) = h:(go t)
+  go ((n1, IfElse ss e1 b1 Nothing) : (n2, IfElse _ e2 b2 Nothing) : t)
+    | e1 == e2 = go $ (n1 ++ n2, IfElse ss e1 (Block ss Nothing [b1, b2]) Nothing) : t
+  go ((n1, IfElse ss1 e1 b1 Nothing):(n2, IfElse ss2 (Binary _ And e2 e3) b2 me) : t)
+    | e1 == e2 = go $ (n1 ++ n2, IfElse ss1 e1 (Block ss1 Nothing [b1, IfElse ss2 e3 b2 me]) Nothing) : t
+  go ((n1, Block ss l sts1) : (n2, Block _ Nothing sts2) : t) = go $ (n1 ++ n2, Block ss l (sts1 ++ sts2)) : t
+  go ((n1, VariableLetIntroduction ss1 name1 Nothing) : (n2, Block _ (Just label1) [Assignment _ (Var _ name2) js, Break _ (Just label2)]) : t)
+    | name1 == name2, label1 == label2 = (n1 ++ n2, VariableLetIntroduction ss1 name1 (Just js)) : go t
+  go ((n, js@(Return _ _)):_) = [(n, js)]
+  go ((n, js@(ReturnNoResult _)):_) = [(n, js)]
+  go ((n, js@(Throw _ _)):_) = [(n, js)]
+  go ((n, js@(Break _ _)):_) = [(n, js)]
+  go ((n, js@(Continue _ _)):_) = [(n, js)]
+
+  go (h:t) = h : go t
   go [] = []
 
 collapseNestedIfs :: AST -> AST
diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs
index 72e3f08bac..2b40c79eb4 100644
--- a/src/Language/PureScript/Sugar/CaseDeclarations.hs
+++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs
@@ -59,7 +59,7 @@ desugarGuardedExprs
   -> Expr
   -> m Expr
 desugarGuardedExprs ss (Case scrut alternatives)
-  | any (not . isTrivialExpr) scrut = do
+  | not $ all isTrivialExpr scrut = do
     -- in case the scrutinee is non trivial (e.g. not a Var or Literal)
     -- we may evaluate the scrutinee more than once when a guard occurrs.
     -- We bind the scrutinee to Vars here to mitigate this case.
@@ -89,33 +89,6 @@ desugarGuardedExprs ss (Case scrut alternatives) =
       dge <- forM ge $ \(GuardedExpr g e) -> GuardedExpr (desugarGuard g) <$> desugarGuardedExprs ss e
       return $ CaseAlternative ab dge
 
-    -- -- Special case: CoreFn understands single condition guards on
-    -- -- binders right hand side.
-    -- desugarAlternatives (CaseAlternative ab ge : as)
-    --   | not (null cond_guards) =
-    --       (CaseAlternative ab cond_guards :)
-    --         <$> desugarGuardedAlternative ab rest as
-    --   | otherwise = desugarGuardedAlternative ab ge as
-    --   where
-    --     (cond_guards, rest) = span isSingleCondGuard ge
-
-    --     isSingleCondGuard (GuardedExpr [ConditionGuard _] _) = True
-    --     isSingleCondGuard _ = False
-
-    -- desugarGuardedAlternative :: [Binder]
-    --                           -> [GuardedExpr]
-    --                           -> [CaseAlternative]
-    --                           -> m [CaseAlternative]
-    -- desugarGuardedAlternative _vb [] rem_alts =
-    --   desugarAlternatives rem_alts
-
-    -- desugarGuardedAlternative vb (GuardedExpr gs e : ge) rem_alts = do
-    --   rhs <- desugarAltOutOfLine vb ge rem_alts $ \alt_fail ->
-    --     Case scrut
-    --     (CaseAlternative vb (desugarGuard gs)
-    --       : alt_fail' (length scrut))
-
-
     desugarGuard :: [Guard] -> [Guard]
     desugarGuard (ConditionGuard c1 : ConditionGuard c2 : gs) =
       desugarGuard (ConditionGuard (
@@ -127,42 +100,6 @@ desugarGuardedExprs ss (Case scrut alternatives) =
     desugarGuard [] = []
     desugarGuard (h:t) = h:desugarGuard t
 
-    -- we generate a let-binding for the remaining guards
-    -- and alternatives. A CaseAlternative is passed (or in
-    -- fact the original case is partial non is passed) to
-    -- mk_body which branches to the generated let-binding.
-    desugarAltOutOfLine :: [Binder]
-                        -> [GuardedExpr]
-                        -> [CaseAlternative]
-                        -> ((Int -> [CaseAlternative]) -> Expr)
-                        -> m Expr
-    desugarAltOutOfLine alt_binder rem_guarded rem_alts mk_body
-      | Just rem_case <- mkCaseOfRemainingGuardsAndAlts = do
-        desugared <- desugarGuardedExprs ss rem_case
-        let
-          alt_fail :: Int -> [CaseAlternative]
-          alt_fail n = [CaseAlternative (replicate n NullBinder) [MkUnguarded desugared]]
-
-        pure $ mk_body alt_fail
-        -- pure $ Let FromLet [
-        --   ValueDecl (ss, []) rem_case_id Private []
-        --     [MkUnguarded (Abs (VarBinder ss unused_binder) desugared)]
-        --   ] (mk_body alt_fail)
-
-      | otherwise
-      = pure $ mk_body (const [])
-      where
-        mkCaseOfRemainingGuardsAndAlts
-          | not (null rem_guarded)
-          = Just $ Case scrut (CaseAlternative alt_binder rem_guarded : rem_alts)
-          | not (null rem_alts)
-          = Just $ Case scrut rem_alts
-          | otherwise
-          = Nothing
-
-    scrut_nullbinder :: [Binder]
-    scrut_nullbinder = replicate (length scrut) NullBinder
-
     -- case expressions with a single alternative which have
     -- a NullBinder occur frequently after desugaring
     -- complex guards. This function removes these superflous
diff --git a/tests/TestBundle.hs b/tests/TestBundle.hs
index ab209d5989..2cb4ae923c 100644
--- a/tests/TestBundle.hs
+++ b/tests/TestBundle.hs
@@ -68,16 +68,20 @@ assertBundles supportModules supportExterns supportForeigns inputFiles outputFil
         process <- findNodeProcess
         jsFiles <- Glob.globDir1 (Glob.compile "**/*.js") modulesDir
         let entryPoint = modulesDir </> "index.js"
-        let entryModule = map (`ModuleIdentifier` Regular) ["Main"] 
+        let entryModule = map (`ModuleIdentifier` Regular) ["Main"]
+        let logFile = entryPoint ++ "." ++ show (sum $ map length inputFiles)
         bundled <- runExceptT $ do
           input <- forM jsFiles $ \filename -> do
             js <- liftIO $ readUTF8File filename
+            -- liftIO $ putStrLn $ "FILE: " ++ filename ++ "\n" ++ js ++ "\n\n"
             mid <- guessModuleIdentifier filename
-            length js `seq` return (mid, Just filename, js) 
+            length js `seq` return (mid, Just filename, js)
           bundleSM input entryModule (Just $ "Main") "PS" (Just entryPoint) Nothing
         case bundled of
             Right (_, js) -> do
               writeUTF8File entryPoint js
+              liftIO $ putStrLn $ "LOG INTO: " ++ logFile
+              writeUTF8File logFile js
               result <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process
               hPutStrLn outputFile $ "\n" <> takeFileName (last inputFiles) <> ":"
               case result of
@@ -89,7 +93,7 @@ assertBundles supportModules supportExterns supportForeigns inputFiles outputFil
                  | otherwise -> return $ Just $ "Test did not finish with 'Done':\n\n" <> out
                 Just (ExitFailure _, _, err) -> return $ Just err
                 Nothing -> return $ Just "Couldn't find node.js executable"
-            Left err -> return . Just $ "Coud not bundle: " ++ show err
+            Left err -> return . Just $ "Could not bundle: " ++ show err
 
 logfile :: FilePath
 logfile = "bundle-tests.out"

From 741654b62a12d4e2d37d10eba175217fe63b98cb Mon Sep 17 00:00:00 2001
From: radrow <radrowicki@gmail.com>
Date: Thu, 25 Feb 2021 16:20:33 +0100
Subject: [PATCH 29/30] Remove prints

---
 src/Language/PureScript/Bundle.hs | 11 +----------
 1 file changed, 1 insertion(+), 10 deletions(-)

diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs
index bafad47d12..60d01039c6 100644
--- a/src/Language/PureScript/Bundle.hs
+++ b/src/Language/PureScript/Bundle.hs
@@ -554,7 +554,7 @@ compile modules entryPoints = filteredModules
   filteredModules = map filterUsed modules
     where
     filterUsed :: Module -> Module
-    filterUsed (Module mid fn ds) =  trace ("REFERENCED: " <> show (fold $ M.lookup mid moduleReferenceMap)) $  Module mid fn (map filterExports (go ds))
+    filterUsed (Module mid fn ds) = Module mid fn (map filterExports (go ds))
       where
       go :: [ModuleElement] -> [ModuleElement]
       go [] = []
@@ -577,11 +577,6 @@ compile modules entryPoints = filteredModules
 
       isDeclUsed :: ModuleElement -> Bool
       isDeclUsed (Member _ visibility nm _ _) = isKeyUsed (mid, nm, visibility)
-      isDeclUsed (Block (Just "$init__main") _ deps) =
-        let r1 = isKeyUsed (mid, "main", Public)
-            r2 = isKeyUsed (mid, "main", Internal)
-        in trace ("KURWA: " <> show r1 <> " CHUJ " <> show r2 <>
-                 "DEPS ARE " <> show deps <> "\n\n") r1
       isDeclUsed (Block (Just n) _ _)
         | Just varName <- CoreAST.dropInitializerName (TS.pack n)
         = isKeyUsed (mid, TS.unpack varName, Public)
@@ -589,10 +584,6 @@ compile modules entryPoints = filteredModules
       isDeclUsed _ = True
 
       isKeyUsed :: Key -> Bool
-      isKeyUsed k@(_, "eq", _)
-        | Just me <- vertexFor k = trace ("USED " <> show k <> ":\n" <> show ( me `S.member` reachableSet)) $ me `S.member` reachableSet
-      isKeyUsed k@(_, "main", _)
-        | Just me <- vertexFor k = trace ("USED " <> show k <> ":\n" <> show ( me `S.member` reachableSet)) $ me `S.member` reachableSet
       isKeyUsed k
         | Just me <- vertexFor k = me `S.member` reachableSet
         | otherwise = False

From a1096e0548754e3c00249c782947ef86583e3705 Mon Sep 17 00:00:00 2001
From: radrow <radrowicki@gmail.com>
Date: Wed, 3 Mar 2021 17:33:50 +0100
Subject: [PATCH 30/30] minor fix

---
 src/Language/PureScript/CodeGen/JS.hs | 3 +--
 1 file changed, 1 insertion(+), 2 deletions(-)

diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index 4ac4679222..480f9e5398 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -79,8 +79,7 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ =
     let decls' = renameModules mnLookup decls
 
     jsDecls <- inFun $ map snd <$> mapM bindToJs decls'
-    jsDecls' <- traverse (traverse optimize) jsDecls
-    optimized <- traverse (pure . cleanupBlockStatements) jsDecls'
+    optimized <- map cleanupBlockStatements <$> traverse (traverse optimize) jsDecls
 
     let mnReverseLookup = M.fromList $ map (\(origName, (_, safeName)) -> (moduleNameToJs safeName, origName)) $ M.toList mnLookup
     let usedModuleNames = foldMap (foldMap (findModules mnReverseLookup)) optimized