From 5f464c5ec73ffd3cdfe2241da2b16cefba736169 Mon Sep 17 00:00:00 2001
From: gnumonik <gnumonik@protonmail.com>
Date: Tue, 20 Feb 2024 23:56:54 -0500
Subject: [PATCH 01/20] Primitive infrastructure for golden tests, removed some
 dead options

---
 app/Command/Compile.hs                     |  6 +-
 purescript.cabal                           |  1 +
 src/Language/PureScript/CoreFn/Desugar.hs  |  3 +-
 src/Language/PureScript/CoreFn/FromJSON.hs |  4 +
 src/Language/PureScript/CoreFn/Module.hs   | 93 +++++++++++++++++++++-
 src/Language/PureScript/CoreFn/ToJSON.hs   | 24 ++++++
 src/Language/PureScript/Ide/Rebuild.hs     |  2 +
 src/Language/PureScript/Make.hs            |  4 +-
 src/Language/PureScript/Make/Actions.hs    | 91 +++++++++++----------
 src/Language/PureScript/Options.hs         | 15 ++--
 10 files changed, 184 insertions(+), 59 deletions(-)

diff --git a/app/Command/Compile.hs b/app/Command/Compile.hs
index 8f348da9d..fc268cd34 100644
--- a/app/Command/Compile.hs
+++ b/app/Command/Compile.hs
@@ -130,11 +130,11 @@ codegenTargets :: Opts.Parser [P.CodegenTarget]
 codegenTargets = Opts.option targetParser $
      Opts.short 'g'
   <> Opts.long "codegen"
-  <> Opts.value [P.JS]
+  <> Opts.value [P.CoreFn]
   <> Opts.help
       ( "Specifies comma-separated codegen targets to include. "
       <> targetsMessage
-      <> " The default target is 'js', but if this option is used only the targets specified will be used."
+      <> " The default target is 'coreFn', but if this option is used only the targets specified will be used."
       )
 
 targetsMessage :: String
@@ -158,7 +158,7 @@ options =
   where
     -- Ensure that the JS target is included if sourcemaps are
     handleTargets :: [P.CodegenTarget] -> S.Set P.CodegenTarget
-    handleTargets ts = S.fromList (if P.JSSourceMap `elem` ts then P.JS : ts else ts)
+    handleTargets ts = S.fromList ts
 
 pscMakeOptions :: Opts.Parser PSCMakeOptions
 pscMakeOptions = PSCMakeOptions <$> many inputFile
diff --git a/purescript.cabal b/purescript.cabal
index 31f72e7d3..2b15b65e1 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -155,6 +155,7 @@ common defaults
     -- specific version.
     aeson >=2.0.3.0 && <2.1,
     aeson-better-errors >=0.9.1.1 && <0.10,
+    aeson-diff,
     ansi-terminal >=0.11.3 && <0.12,
     array >=0.5.4.0 && <0.6,
     base >=4.16.2.0 && <4.18,
diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs
index 9c361f43e..4f4407c36 100644
--- a/src/Language/PureScript/CoreFn/Desugar.hs
+++ b/src/Language/PureScript/CoreFn/Desugar.hs
@@ -445,7 +445,8 @@ transformLetBindings mn _ss seen (A.ValueDecl sa@(ss,_) ident nameKind [] [A.MkU
               <> showIdent' ident
               <> "'\ncontains unification variables:\n "
               <> ppType 1000 ty
-              <> "\nPlease add a type signature for '" <> showIdent' ident <> "'"
+              <> "\nIf this let-bound identifier occurs in a user-defined `let-binding`, please add a type signature for '" <> showIdent' ident <> "'"
+              <> "\nIf the identifier occurs in a compiler-generated `let-binding` with guards (e.g. in a guarded case branch), try removing the guarded expression (e.g. use a normal if-then expression)"
 -- NOTE/TODO: This is super hack-ey. Ugh.
 transformLetBindings mn _ss seen (A.BindingGroupDeclaration ds : rest) ret = wrapTrace "transformLetBindings BINDINGGROUPDEC" $ do
   SplitBindingGroup untyped typed dict <- typeDictionaryForBindingGroup Nothing . NEL.toList $ fmap (\(i, _, v) -> (i, v)) ds
diff --git a/src/Language/PureScript/CoreFn/FromJSON.hs b/src/Language/PureScript/CoreFn/FromJSON.hs
index 4ae83fecf..1f083f51a 100644
--- a/src/Language/PureScript/CoreFn/FromJSON.hs
+++ b/src/Language/PureScript/CoreFn/FromJSON.hs
@@ -30,6 +30,10 @@ import Language.PureScript.Types ()
 
 import Text.ParserCombinators.ReadP (readP_to_S)
 
+-- dunno how to work around the orphan
+instance FromJSON (Module Ann) where
+  parseJSON = fmap snd .  moduleFromJSON
+
 parseVersion' :: String -> Maybe Version
 parseVersion' str =
   case filter (null . snd) $ readP_to_S parseVersion str of
diff --git a/src/Language/PureScript/CoreFn/Module.hs b/src/Language/PureScript/CoreFn/Module.hs
index 09f5189c4..f874ab311 100644
--- a/src/Language/PureScript/CoreFn/Module.hs
+++ b/src/Language/PureScript/CoreFn/Module.hs
@@ -1,13 +1,18 @@
+{-# LANGUAGE StandaloneDeriving, ScopedTypeVariables #-}
 module Language.PureScript.CoreFn.Module where
 
 import Prelude
 
 import Data.Map.Strict (Map)
+import Data.List (sort)
 
 import Language.PureScript.AST.SourcePos (SourceSpan)
+import Language.PureScript.AST.Literals (Literal(..))
 import Language.PureScript.Comments (Comment)
-import Language.PureScript.CoreFn.Expr (Bind)
+import Language.PureScript.CoreFn.Expr (Bind(..), Expr(..), CaseAlternative)
+import Language.PureScript.CoreFn.Ann
 import Language.PureScript.Names (Ident, ModuleName)
+import Data.Bifunctor (second)
 
 -- |
 -- The CoreFn module representation
@@ -23,3 +28,89 @@ data Module a = Module
   , moduleForeign :: [Ident]
   , moduleDecls :: [Bind a]
   } deriving (Functor, Show)
+
+deriving instance Eq a => Eq (Module a)
+
+data DiffResult a =
+    DiffSourceSpan SourceSpan SourceSpan
+  | DiffComments [Comment] [Comment]
+  | DiffName ModuleName ModuleName
+  | DiffPath FilePath FilePath
+  | DiffImports [(a,ModuleName)] [(a,ModuleName)]
+  | DiffReExports (Map ModuleName [Ident]) (Map ModuleName [Ident])
+  | DiffExports [Ident] [Ident]
+  | DiffForeign [Ident] [Ident]
+  | DiffDecl (Maybe (Bind a)) (Maybe (Bind a))
+
+deriving instance Eq a => Eq (DiffResult a)
+deriving instance Ord a => Ord (DiffResult a)
+deriving instance Show a => Show (DiffResult a)
+
+diffModule :: Module Ann -> Module Ann -> [DiffResult Ann]
+diffModule m1 m2 = ezDiff DiffSourceSpan moduleSourceSpan
+                   <> ezDiff DiffComments moduleComments
+                   <> ezDiff DiffName moduleName
+                   <> ezDiff DiffPath modulePath
+                   <> ezDiff DiffImports moduleImports
+                   <> ezDiff DiffReExports moduleReExports
+                   <> ezDiff DiffExports moduleExports
+                   <> ezDiff DiffForeign moduleForeign
+                   <> diffDecls (sort $ fmap removeComments <$>  moduleDecls m1) (sort $ fmap removeComments <$> moduleDecls m2)
+  where
+    ezDiff :: Eq b => (b -> b -> DiffResult Ann) -> (Module Ann -> b) -> [DiffResult Ann]
+    ezDiff f g
+      | g m1 == g m2 = []
+      | otherwise = [f (g m1) (g m2)]
+
+    diffDecls :: [Bind Ann] -> [Bind Ann] -> [DiffResult Ann]
+    diffDecls [] bs@(_:_) = map (DiffDecl Nothing . Just) bs
+    diffDecls as@(_:_) [] = map (\a -> DiffDecl (Just a) Nothing) as
+    diffDecls [] [] = []
+    diffDecls (a:as) (b:bs)
+      | a == b = diffDecls as bs
+      | otherwise = DiffDecl (Just a) (Just b) : diffDecls as bs
+
+canonicalizeModule :: Ord a => Module a -> Module a
+canonicalizeModule (Module modSS modComments modName modPath modImports modExports modReExports modForeign modDecls)
+  = Module modSS modComments' modName modPath modImports' modExports' modReExports' modForeign' modDecls'
+ where
+   modComments' = sort modComments
+   modImports' = sort modImports
+   modExports' = sort modExports
+   modForeign' = sort modForeign
+   modReExports' = sort <$> modReExports
+   modDecls' = sort . map canonicalizeDecl $ modDecls
+
+canonicalizeDecl :: Ord a => Bind a -> Bind a
+canonicalizeDecl = \case
+  NonRec ann ident expr -> NonRec ann ident (canonicalizeExpr expr)
+  Rec recBindingGroup -> Rec . sort . fmap (second canonicalizeExpr) $ recBindingGroup
+
+canonicalizeExpr :: Ord a => Expr a -> Expr a
+canonicalizeExpr = \case
+  Literal ann ty lit -> Literal ann ty (canonicalizeLit lit)
+  Constructor a ty tName cName fields -> Constructor a ty tName cName fields
+  Accessor a ty fieldName expr -> Accessor a ty fieldName (canonicalizeExpr expr)
+  ObjectUpdate a ty origVal copyFields updateFields ->
+    let updateFields' = sort $ second canonicalizeExpr <$> updateFields
+        copyFields' = sort <$> copyFields
+        origVal' = canonicalizeExpr origVal
+    in ObjectUpdate a ty origVal' copyFields' updateFields'
+  Abs a ty ident body -> Abs a ty ident (canonicalizeExpr body)
+  App a ty e1 e2 ->
+    let e1' = canonicalizeExpr e1
+        e2' = canonicalizeExpr e2
+    in App a ty e1' e2'
+  Var a ty ident -> Var a ty ident
+  -- This one is confusing. The order intrinsically matters. Can't sort at the top level. Not sure what to do about that.
+  Case a ty es alts -> Case a ty (canonicalizeExpr <$> es) (canonicalizeAlt <$> alts)
+  Let a ty binds expr ->
+    let binds' = sort $ canonicalizeDecl <$> binds
+        expr'   = canonicalizeExpr expr
+    in Let a ty binds' expr'
+
+canonicalizeAlt :: CaseAlternative a -> CaseAlternative a
+canonicalizeAlt = id -- TODO
+
+canonicalizeLit :: Literal (Expr a) -> Literal (Expr a)
+canonicalizeLit = id
diff --git a/src/Language/PureScript/CoreFn/ToJSON.hs b/src/Language/PureScript/CoreFn/ToJSON.hs
index b7a1fc708..3b6aa4c58 100644
--- a/src/Language/PureScript/CoreFn/ToJSON.hs
+++ b/src/Language/PureScript/CoreFn/ToJSON.hs
@@ -5,6 +5,7 @@
 --
 module Language.PureScript.CoreFn.ToJSON
   ( moduleToJSON
+  , moduleToJSON'
   ) where
 
 import Prelude
@@ -139,6 +140,29 @@ moduleToJSON v m = object
   reExportsToJSON :: M.Map ModuleName [Ident] -> Value
   reExportsToJSON = toJSON . M.map (map runIdent)
 
+
+moduleToJSON' ::  Module Ann -> Value
+moduleToJSON' m = object
+  [ "sourceSpan" .= sourceSpanToJSON (moduleSourceSpan m)
+  , "moduleName" .= moduleNameToJSON (moduleName m)
+  , "modulePath" .= toJSON (modulePath m)
+  , "imports"    .= map importToJSON (moduleImports m)
+  , "exports"    .= map identToJSON (moduleExports m)
+  , "reExports"  .= reExportsToJSON (moduleReExports m)
+  , "foreign"    .= map identToJSON (moduleForeign m)
+  , "decls"      .= map bindToJSON (moduleDecls m)
+  , "comments"   .= map toJSON (moduleComments m)
+  ]
+  where
+  importToJSON (ann,mn) = object
+    [ "annotation" .= annToJSON ann
+    , "moduleName" .= moduleNameToJSON mn
+    ]
+
+  reExportsToJSON :: M.Map ModuleName [Ident] -> Value
+  reExportsToJSON = toJSON . M.map (map runIdent)
+
+
 bindToJSON :: Bind Ann -> Value
 bindToJSON (NonRec ann n e)
   = object
diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs
index ebc34339e..923e10b8c 100644
--- a/src/Language/PureScript/Ide/Rebuild.hs
+++ b/src/Language/PureScript/Ide/Rebuild.hs
@@ -122,12 +122,14 @@ updateCacheDb codegenTargets outputDirectory file actualFile moduleName = do
   let moduleCacheInfo = (normaliseForCache cwd (fromMaybe file actualFile), (dayZero, contentHash))
 
   foreignCacheInfo <-
+    {-
     if S.member P.JS codegenTargets then do
       foreigns' <- P.inferForeignModules (M.singleton moduleName (Right (fromMaybe file actualFile)))
       for (M.lookup moduleName foreigns') \foreignPath -> do
         foreignHash <- P.hashFile foreignPath
         pure (normaliseForCache cwd foreignPath, (dayZero, foreignHash))
     else
+    -}
       pure Nothing
 
   let cacheInfo = M.fromList (moduleCacheInfo : maybeToList foreignCacheInfo)
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index a808e992a..b041af6aa 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -50,7 +50,6 @@ import Language.PureScript.Make.Monad as Monad
 import Language.PureScript.CoreFn qualified as CF
 import Language.PureScript.CoreFn qualified as CFT
 import Language.PureScript.CoreFn.Pretty qualified as CFT
-import Language.PureScript.CoreFn.Module qualified as CFT
 import System.Directory (doesFileExist)
 import System.FilePath (replaceExtension)
 
@@ -121,7 +120,6 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _
   traceM "PURUS START HERE"
   ((coreFn,chkSt),nextVar'') <- runSupplyT nextVar' $ runStateT (CFT.moduleToCoreFn mod') (emptyCheckState env')
   traceM $ prettyEnv (checkEnv chkSt)
-  --mapM_ (traceM . show) . CFT.moduleDecls $ coreFn
   traceM $ CFT.prettyPrintModule'  coreFn
   let corefn = coreFn
       (optimized, nextVar''') = runSupply nextVar'' $ CF.optimizeCoreFn corefn
@@ -173,7 +171,7 @@ make ma@MakeActions{..} ms = do
 
   (buildPlan, newCacheDb) <- BuildPlan.construct ma cacheDb (sorted, graph)
 
-  let toBeRebuilt = filter (BuildPlan.needsRebuild buildPlan . getModuleName . CST.resPartial) sorted
+  let toBeRebuilt = sorted  -- filter (BuildPlan.needsRebuild buildPlan . getModuleName . CST.resPartial) sorted
   let totalModuleCount = length toBeRebuilt
   for_ toBeRebuilt $ \m -> fork $ do
     let moduleName = getModuleName . CST.resPartial $ m
diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs
index 6739b4bf0..4162faa00 100644
--- a/src/Language/PureScript/Make/Actions.hs
+++ b/src/Language/PureScript/Make/Actions.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE TypeApplications #-}
 module Language.PureScript.Make.Actions
   ( MakeActions(..)
   , RebuildPolicy(..)
@@ -20,13 +21,13 @@ import Control.Monad.Reader (asks)
 import Control.Monad.Supply (SupplyT)
 import Control.Monad.Trans.Class (MonadTrans(..))
 import Control.Monad.Writer.Class (MonadWriter(..))
-import Data.Aeson (Value(String), (.=), object)
+import Data.Aeson (Value(String), (.=), object, decode, encode, Result (..), fromJSON)
 import Data.Bifunctor (bimap, first)
 import Data.Either (partitionEithers)
 import Data.Foldable (for_)
 import Data.List.NonEmpty qualified as NEL
 import Data.Map qualified as M
-import Data.Maybe (fromMaybe, maybeToList)
+import Data.Maybe (fromMaybe, maybeToList, fromJust)
 import Data.Set qualified as S
 import Data.Text qualified as T
 import Data.Text.IO qualified as TIO
@@ -39,6 +40,7 @@ import Language.PureScript.Bundle qualified as Bundle
 import Language.PureScript.CodeGen.UPLC qualified as PC
 import Language.PureScript.CoreFn qualified as CF
 import Language.PureScript.CoreFn.ToJSON qualified as CFJ
+import Language.PureScript.CoreFn.FromJSON ()
 import Language.PureScript.Crash (internalError)
 import Language.PureScript.CST qualified as CST
 import Language.PureScript.Docs.Prim qualified as Docs.Prim
@@ -181,18 +183,22 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
     :: ModuleName
     -> Make (Either RebuildPolicy (M.Map FilePath (UTCTime, Make ContentHash)))
   getInputTimestampsAndHashes mn = do
-    let path = fromMaybe (internalError "Module has no filename in 'make'") $ M.lookup mn filePathMap
-    case path of
-      Left policy ->
-        return (Left policy)
-      Right filePath -> do
-        cwd <- makeIO "Getting the current directory" getCurrentDirectory
-        let inputPaths = map (normaliseForCache cwd) (filePath : maybeToList (M.lookup mn foreigns))
-            getInfo fp = do
-              ts <- getTimestamp fp
-              return (ts, hashFile fp)
-        pathsWithInfo <- traverse (\fp -> (fp,) <$> getInfo fp) inputPaths
-        return $ Right $ M.fromList pathsWithInfo
+    codegenTargets <- asks optionsCodegenTargets
+    if  CheckCoreFn `S.member` codegenTargets
+      then pure (Left RebuildAlways)
+      else do
+        let path = fromMaybe (internalError "Module has no filename in 'make'") $ M.lookup mn filePathMap
+        case path of
+          Left policy ->
+            return (Left policy)
+          Right filePath -> do
+            cwd <- makeIO "Getting the current directory" getCurrentDirectory
+            let inputPaths = map (normaliseForCache cwd) (filePath : maybeToList (M.lookup mn foreigns))
+                getInfo fp = do
+                  ts <- getTimestamp fp
+                  return (ts, hashFile fp)
+            pathsWithInfo <- traverse (\fp -> (fp,) <$> getInfo fp) inputPaths
+            return $ Right $ M.fromList pathsWithInfo
 
   outputFilename :: ModuleName -> String -> FilePath
   outputFilename mn fn =
@@ -201,11 +207,9 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
 
   targetFilename :: ModuleName -> CodegenTarget -> FilePath
   targetFilename mn = \case
-    JS -> outputFilename mn "index.js"
-    JSSourceMap -> outputFilename mn "index.js.map"
-    -- CoreFn -> outputFilename mn "corefn.json"
     Docs -> outputFilename mn "docs.json"
-    UPLC -> outputFilename mn "index.cfn"
+    CoreFn -> outputFilename mn "index.cfn"
+    CheckCoreFn -> outputFilename mn "index.cfn"
 
   getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime)
   getOutputTimestamp mn = do
@@ -251,39 +255,31 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
     let mn = CF.moduleName m
     lift $ writeCborFile (outputFilename mn externsFileName) exts
     codegenTargets <- lift $ asks optionsCodegenTargets
-    when (S.member UPLC codegenTargets) $ do
+    {- -when (S.member UPLC codegenTargets) $ do
       let coreFnFile = targetFilename mn UPLC
           json = CFJ.moduleToJSON Paths.version m
       lift $ writeJSONFile coreFnFile json
-     {-
-     when (S.member JS codegenTargets) $ do
-      foreignInclude <- case mn `M.lookup` foreigns of
-        Just _
-          | not $ requiresForeign m -> do
-              return Nothing
-          | otherwise -> do
-              return $ Just "./foreign.js"
-        Nothing | requiresForeign m -> throwError . errorMessage' (CF.moduleSourceSpan m) $ MissingFFIModule mn
-                | otherwise -> return Nothing
-     rawJs <- J.moduleToJs m foreignInclude
-      dir <- lift $ makeIO "get the current directory" getCurrentDirectory
-      let sourceMaps = S.member JSSourceMap codegenTargets
-          (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]
-          js = T.unlines $ map ("// " <>) prefix ++ [pjs]
-          mapRef = if sourceMaps then "//# sourceMappingURL=index.js.map\n" else ""
-      lift $ do
-        writeTextFile jsFile (TE.encodeUtf8 $ js <> mapRef)
-        when sourceMaps $ genSourceMap dir mapFile (length prefix) mappings
     -}
     when (S.member Docs codegenTargets) $ do
       lift $ writeJSONFile (outputFilename mn "docs.json") docs
-    when (S.member UPLC codegenTargets) $ do
-      lift $ writeJSONFile (targetFilename mn UPLC) (moduleToJSON (makeVersion [0,0,1]) m)
-      -- uplc <- PC.moduleToUPLC m
-      -- lift $ PC.printUPLC uplc
+    when (S.member CoreFn codegenTargets) $ do
+      lift $ writeJSONFile (targetFilename mn CoreFn) (moduleToJSON (makeVersion [0,0,1]) m)
+    when (S.member CheckCoreFn codegenTargets) $ do
+      let mn' = T.unpack (runModuleName mn)
+      mabOldModule <- lift $ readJSONFile  (targetFilename mn CoreFn)
+      case mabOldModule of
+        Nothing -> error "Cannot check CoreFn output - could not parse JSON serialization of old module"
+        Just oldM -> do
+          let oldM' = CF.canonicalizeModule oldM
+              m'    = CF.canonicalizeModule (jsonRoundTrip m)
+              diff  = CF.diffModule oldM' m'
+          lift $ makeIO "print golden result" $ putStrLn $ "checkCoreFn mismatches: " <> show diff
+   where
+     jsonRoundTrip :: CF.Module CF.Ann -> CF.Module CF.Ann
+     jsonRoundTrip mdl =  case fromJSON $  moduleToJSON (makeVersion [0,0,1]) mdl of
+       Error str -> error str
+       Success a -> a
+
 
   ffiCodegen :: CF.Module CF.Ann -> Make ()
   ffiCodegen m = do
@@ -439,7 +435,8 @@ ffiCodegen'
   -> Maybe (ModuleName -> String -> FilePath)
   -> CF.Module CF.Ann
   -> Make ()
-ffiCodegen' foreigns codegenTargets makeOutputPath m = do
+ffiCodegen' foreigns codegenTargets makeOutputPath m = pure ()
+  {-
   when (S.member JS codegenTargets) $ do
     let mn = CF.moduleName m
     case mn `M.lookup` foreigns of
@@ -455,8 +452,10 @@ ffiCodegen' foreigns codegenTargets makeOutputPath m = do
                 throwError $ errorMessage' (CF.moduleSourceSpan m) $ DeprecatedFFICommonJSModule mn path
       Nothing | requiresForeign m -> throwError . errorMessage' (CF.moduleSourceSpan m) $ MissingFFIModule mn
               | otherwise -> return ()
+
   where
   requiresForeign = not . null . CF.moduleForeign
 
   copyForeign path mn =
     for_ makeOutputPath (\outputFilename -> copyFile path (outputFilename mn "foreign.js"))
+   -}
diff --git a/src/Language/PureScript/Options.hs b/src/Language/PureScript/Options.hs
index 059b27fb8..ae4131559 100644
--- a/src/Language/PureScript/Options.hs
+++ b/src/Language/PureScript/Options.hs
@@ -18,16 +18,21 @@ data Options = Options
 
 -- Default make options
 defaultOptions :: Options
-defaultOptions = Options False False (S.singleton JS)
+defaultOptions = Options False False (S.singleton CoreFn)
 
-data CodegenTarget = JS | JSSourceMap | Docs | UPLC
+data CodegenTarget
+    = Docs
+    | CoreFn
+    {- N.B. We need a compilation mode that tests for changes from existing serialized CoreFn.
+            This is the easiest way to implement that (though maybe we should do something else for the final version)
+    -}
+    | CheckCoreFn
   deriving (Eq, Ord, Show)
 
 codegenTargets :: Map String CodegenTarget
 codegenTargets = Map.fromList
-  [ ("js", JS)
-  , ("uplc", UPLC)
-  , ("sourcemaps", JSSourceMap)
+  [ ("coreFn", CoreFn)
+  , ("checkCoreFn", CheckCoreFn)
   -- , ("corefn", CoreFn)
   , ("docs", Docs)
   ]

From aa95066bee1007aa15625921530f1ef591941cb8 Mon Sep 17 00:00:00 2001
From: gnumonik <gnumonik@protonmail.com>
Date: Wed, 21 Feb 2024 23:17:20 -0500
Subject: [PATCH 02/20] testing infrastructure, ported some tests/purs/passing
 tests to debug compiler

---
 purescript.cabal                              |  26 +++-
 {app => purs-lib}/Command/Bundle.hs           |   0
 {app => purs-lib}/Command/Compile.hs          |  23 +++-
 {app => purs-lib}/Command/Docs.hs             |   0
 {app => purs-lib}/Command/Docs/Html.hs        |   0
 {app => purs-lib}/Command/Docs/Markdown.hs    |   0
 {app => purs-lib}/Command/Graph.hs            |   0
 {app => purs-lib}/Command/Hierarchy.hs        |   0
 {app => purs-lib}/Command/Ide.hs              |   0
 {app => purs-lib}/Command/Publish.hs          |   0
 {app => purs-lib}/Command/REPL.hs             |   0
 {app => purs-lib}/Version.hs                  |   0
 src/Language/PureScript/CoreFn/Desugar.hs     |   4 +-
 src/Language/PureScript/Environment.hs        |   3 +
 tests/Language/PureScript/Ide/RebuildSpec.hs  |   2 +-
 tests/Main.hs                                 |  20 +--
 tests/TestCoreFn.hs                           |  21 ++--
 tests/TestMake.hs                             |   2 +-
 tests/TestPurus.hs                            | 115 ++++++++++++++++++
 tests/TestSourceMaps.hs                       |   2 +-
 tests/purus/passing/2018/A.purs               |   7 ++
 tests/purus/passing/2018/B.purs               |   3 +
 tests/purus/passing/2138/Lib.purs             |   3 +
 tests/purus/passing/2609/Eg.purs              |   5 +
 tests/purus/passing/4035/Other.purs           |   4 +
 tests/purus/passing/4101/Lib.purs             |   9 ++
 tests/purus/passing/4105/Lib.purs             |   5 +
 tests/purus/passing/4200/Lib.purs             |   7 ++
 tests/purus/passing/4310/Lib.purs             |  20 +++
 tests/purus/passing/ClassRefSyntax/Lib.purs   |   5 +
 tests/purus/passing/Coercible/Lib.purs        |  12 ++
 tests/purus/passing/Coercible/Lib2.purs       |   3 +
 .../passing/DctorOperatorAlias/List.purs      |   5 +
 .../passing/ExplicitImportReExport/Bar.purs   |   3 +
 .../passing/ExplicitImportReExport/Foo.purs   |   4 +
 tests/purus/passing/ExportExplicit/M1.purs    |  10 ++
 tests/purus/passing/ExportExplicit2/M1.purs   |   7 ++
 tests/purus/passing/ForeignKind/Lib.purs      |  60 +++++++++
 tests/purus/passing/Import/M1.purs            |   6 +
 tests/purus/passing/Import/M2.purs            |   5 +
 tests/purus/passing/ImportExplicit/M1.purs    |   4 +
 tests/purus/passing/ImportQualified/M1.purs   |   3 +
 .../ImportedClassName.purs                    |   4 +
 tests/purus/passing/ModuleDeps/M1.purs        |   5 +
 tests/purus/passing/ModuleDeps/M2.purs        |   5 +
 tests/purus/passing/ModuleDeps/M3.purs        |   3 +
 .../NonOrphanInstanceFunDepExtra/Lib.purs     |   4 +
 .../passing/NonOrphanInstanceMulti/Lib.purs   |   4 +
 48 files changed, 409 insertions(+), 24 deletions(-)
 rename {app => purs-lib}/Command/Bundle.hs (100%)
 rename {app => purs-lib}/Command/Compile.hs (85%)
 rename {app => purs-lib}/Command/Docs.hs (100%)
 rename {app => purs-lib}/Command/Docs/Html.hs (100%)
 rename {app => purs-lib}/Command/Docs/Markdown.hs (100%)
 rename {app => purs-lib}/Command/Graph.hs (100%)
 rename {app => purs-lib}/Command/Hierarchy.hs (100%)
 rename {app => purs-lib}/Command/Ide.hs (100%)
 rename {app => purs-lib}/Command/Publish.hs (100%)
 rename {app => purs-lib}/Command/REPL.hs (100%)
 rename {app => purs-lib}/Version.hs (100%)
 create mode 100644 tests/TestPurus.hs
 create mode 100644 tests/purus/passing/2018/A.purs
 create mode 100644 tests/purus/passing/2018/B.purs
 create mode 100644 tests/purus/passing/2138/Lib.purs
 create mode 100644 tests/purus/passing/2609/Eg.purs
 create mode 100644 tests/purus/passing/4035/Other.purs
 create mode 100644 tests/purus/passing/4101/Lib.purs
 create mode 100644 tests/purus/passing/4105/Lib.purs
 create mode 100644 tests/purus/passing/4200/Lib.purs
 create mode 100644 tests/purus/passing/4310/Lib.purs
 create mode 100644 tests/purus/passing/ClassRefSyntax/Lib.purs
 create mode 100644 tests/purus/passing/Coercible/Lib.purs
 create mode 100644 tests/purus/passing/Coercible/Lib2.purs
 create mode 100644 tests/purus/passing/DctorOperatorAlias/List.purs
 create mode 100644 tests/purus/passing/ExplicitImportReExport/Bar.purs
 create mode 100644 tests/purus/passing/ExplicitImportReExport/Foo.purs
 create mode 100644 tests/purus/passing/ExportExplicit/M1.purs
 create mode 100644 tests/purus/passing/ExportExplicit2/M1.purs
 create mode 100644 tests/purus/passing/ForeignKind/Lib.purs
 create mode 100644 tests/purus/passing/Import/M1.purs
 create mode 100644 tests/purus/passing/Import/M2.purs
 create mode 100644 tests/purus/passing/ImportExplicit/M1.purs
 create mode 100644 tests/purus/passing/ImportQualified/M1.purs
 create mode 100644 tests/purus/passing/InstanceUnnamedSimilarClassName/ImportedClassName.purs
 create mode 100644 tests/purus/passing/ModuleDeps/M1.purs
 create mode 100644 tests/purus/passing/ModuleDeps/M2.purs
 create mode 100644 tests/purus/passing/ModuleDeps/M3.purs
 create mode 100644 tests/purus/passing/NonOrphanInstanceFunDepExtra/Lib.purs
 create mode 100644 tests/purus/passing/NonOrphanInstanceMulti/Lib.purs

diff --git a/purescript.cabal b/purescript.cabal
index 2b15b65e1..ae6ab30fc 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -409,13 +409,35 @@ executable purs
     exceptions >=0.10.4 && <0.11,
     network >=3.1.2.7 && <3.2,
     optparse-applicative >=0.17.0.0 && <0.18,
-    purescript
+    purescript,
+    purs-lib
   if flag(release)
     cpp-options: -DRELEASE
   else
     build-depends:
       gitrev >=1.2.0 && <1.4
   other-modules:
+    Paths_purescript
+  autogen-modules:
+    Paths_purescript
+
+library purs-lib
+  import: defaults
+  hs-source-dirs: purs-lib
+  -- main-is: Main.hs
+  ghc-options: -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-N -Wno-unused-packages
+  build-depends:
+    ansi-wl-pprint >=0.6.9 && <0.7,
+    exceptions >=0.10.4 && <0.11,
+    network >=3.1.2.7 && <3.2,
+    optparse-applicative >=0.17.0.0 && <0.18,
+    purescript
+  if flag(release)
+    cpp-options: -DRELEASE
+  else
+    build-depends:
+      gitrev >=1.2.0 && <1.4
+  exposed-modules:
     Command.Bundle
     Command.Compile
     Command.Docs
@@ -440,6 +462,7 @@ test-suite tests
   ghc-options: -Wno-incomplete-uni-patterns -Wno-unused-packages
   build-depends:
     purescript,
+    purs-lib,
     generic-random >=1.5.0.1 && <1.6,
     hspec >= 2.10.7 && < 3,
     HUnit >=1.6.2.0 && <1.7,
@@ -480,6 +503,7 @@ test-suite tests
     TestPsci.EvalTest
     TestPsci.TestEnv
     TestPscPublish
+    TestPurus
     TestSourceMaps
     TestUtils
     Paths_purescript
diff --git a/app/Command/Bundle.hs b/purs-lib/Command/Bundle.hs
similarity index 100%
rename from app/Command/Bundle.hs
rename to purs-lib/Command/Bundle.hs
diff --git a/app/Command/Compile.hs b/purs-lib/Command/Compile.hs
similarity index 85%
rename from app/Command/Compile.hs
rename to purs-lib/Command/Compile.hs
index fc268cd34..9cd29b37f 100644
--- a/app/Command/Compile.hs
+++ b/purs-lib/Command/Compile.hs
@@ -1,4 +1,4 @@
-module Command.Compile (command) where
+module Command.Compile  where
 
 import Prelude
 
@@ -31,7 +31,7 @@ data PSCMakeOptions = PSCMakeOptions
   , pscmOpts         :: P.Options
   , pscmUsePrefix    :: Bool
   , pscmJSONErrors   :: Bool
-  }
+  } deriving Show
 
 -- | Arguments: verbose, use JSON, warnings, errors
 printWarningsAndErrors :: Bool -> Bool -> [(FilePath, T.Text)] -> P.MultipleErrors -> Either P.MultipleErrors a -> IO ()
@@ -72,6 +72,25 @@ compile PSCMakeOptions{..} = do
   printWarningsAndErrors (P.optionsVerboseErrors pscmOpts) pscmJSONErrors moduleFiles makeWarnings makeErrors
   exitSuccess
 
+compileForTests :: PSCMakeOptions -> IO ()
+compileForTests PSCMakeOptions{..} = do
+  included <- globWarningOnMisses warnFileTypeNotFound pscmInput
+  excluded <- globWarningOnMisses warnFileTypeNotFound pscmExclude
+  let input = included \\ excluded
+  if (null input) then  do
+    hPutStr stderr $ unlines [ "purs compile: No input files."
+                             , "Usage: For basic information, try the `--help' option."
+                             ]
+  else do
+    moduleFiles <- readUTF8FilesT input
+    (makeErrors, makeWarnings) <- runMake pscmOpts $ do
+      ms <- CST.parseModulesFromFiles id moduleFiles
+      let filePathMap = M.fromList $ map (\(fp, pm) -> (P.getModuleName $ CST.resPartial pm, Right fp)) ms
+      foreigns <- inferForeignModules filePathMap
+      let makeActions = buildMakeActions pscmOutputDir filePathMap foreigns pscmUsePrefix
+      P.make makeActions (map snd ms)
+    printWarningsAndErrors (P.optionsVerboseErrors pscmOpts) pscmJSONErrors moduleFiles makeWarnings makeErrors
+
 warnFileTypeNotFound :: String -> IO ()
 warnFileTypeNotFound = hPutStrLn stderr . ("purs compile: No files found using pattern: " ++)
 
diff --git a/app/Command/Docs.hs b/purs-lib/Command/Docs.hs
similarity index 100%
rename from app/Command/Docs.hs
rename to purs-lib/Command/Docs.hs
diff --git a/app/Command/Docs/Html.hs b/purs-lib/Command/Docs/Html.hs
similarity index 100%
rename from app/Command/Docs/Html.hs
rename to purs-lib/Command/Docs/Html.hs
diff --git a/app/Command/Docs/Markdown.hs b/purs-lib/Command/Docs/Markdown.hs
similarity index 100%
rename from app/Command/Docs/Markdown.hs
rename to purs-lib/Command/Docs/Markdown.hs
diff --git a/app/Command/Graph.hs b/purs-lib/Command/Graph.hs
similarity index 100%
rename from app/Command/Graph.hs
rename to purs-lib/Command/Graph.hs
diff --git a/app/Command/Hierarchy.hs b/purs-lib/Command/Hierarchy.hs
similarity index 100%
rename from app/Command/Hierarchy.hs
rename to purs-lib/Command/Hierarchy.hs
diff --git a/app/Command/Ide.hs b/purs-lib/Command/Ide.hs
similarity index 100%
rename from app/Command/Ide.hs
rename to purs-lib/Command/Ide.hs
diff --git a/app/Command/Publish.hs b/purs-lib/Command/Publish.hs
similarity index 100%
rename from app/Command/Publish.hs
rename to purs-lib/Command/Publish.hs
diff --git a/app/Command/REPL.hs b/purs-lib/Command/REPL.hs
similarity index 100%
rename from app/Command/REPL.hs
rename to purs-lib/Command/REPL.hs
diff --git a/app/Version.hs b/purs-lib/Version.hs
similarity index 100%
rename from app/Version.hs
rename to purs-lib/Version.hs
diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs
index 4f4407c36..9e72366ef 100644
--- a/src/Language/PureScript/CoreFn/Desugar.hs
+++ b/src/Language/PureScript/CoreFn/Desugar.hs
@@ -486,11 +486,11 @@ inferBinder' val (A.ConstructorBinder ss ctor binders) = wrapTrace ("inferBinder
     Just (_, _, ty, _) -> do
       traceM (ppType 100 ty)
       let (args, ret) = peelArgs ty
-      unifyTypes ret val -- TODO: Check whether necesseary?
+      -- unifyTypes ret val -- TODO: Check whether necesseary?
       M.unions <$> zipWithM inferBinder' (reverse args) binders
     _ -> throwError . errorMessage' ss . UnknownName . fmap DctorName $ ctor
   where
-  -- NOTE: Maybe forbid invalid return types?
+  -- REVIEW: Instantiating the quantifier might not be safe here?
   peelArgs :: Type a -> ([Type a], Type a) -- NOTE: Not sure if we want to "peel constraints" too. Need to think of an example to test.
   peelArgs = go []
     where
diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
index b456ba8eb..cab4e45f5 100644
--- a/src/Language/PureScript/Environment.hs
+++ b/src/Language/PureScript/Environment.hs
@@ -379,6 +379,9 @@ pattern ArrayT :: Type a -> Type a
 pattern ArrayT a <-
   TypeApp _ (TypeConstructor _ C.Array) a
 
+arrayT :: Type a -> Type ()
+arrayT = TypeApp () (TypeConstructor () C.Array) . fmap (const ())
+
 pattern RecordT :: Type a -> Type a
 pattern RecordT a <-
   TypeApp _ (TypeConstructor _ C.Record) a
diff --git a/tests/Language/PureScript/Ide/RebuildSpec.hs b/tests/Language/PureScript/Ide/RebuildSpec.hs
index 93a0cabe5..7da70065c 100644
--- a/tests/Language/PureScript/Ide/RebuildSpec.hs
+++ b/tests/Language/PureScript/Ide/RebuildSpec.hs
@@ -15,7 +15,7 @@ import System.Directory (doesFileExist, removePathForcibly)
 import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy)
 
 defaultTarget :: Set P.CodegenTarget
-defaultTarget = Set.singleton P.JS
+defaultTarget = Set.singleton P.CoreFn
 
 load :: [Text] -> Command
 load = LoadSync . map Test.mn
diff --git a/tests/Main.hs b/tests/Main.hs
index b8f6ea979..6b8ec2c0e 100644
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -21,6 +21,7 @@ import TestSourceMaps qualified
 import TestMake qualified
 import TestUtils qualified
 import TestGraph qualified
+import TestPurus (shouldPassTests)
 
 import System.IO (hSetEncoding, stdout, stderr, utf8)
 
@@ -28,21 +29,26 @@ main :: IO ()
 main = do
   hSetEncoding stdout utf8
   hSetEncoding stderr utf8
+  shouldPassTests   {- do
+  hSetEncoding stdout utf8
+  hSetEncoding stderr utf8
 
   TestUtils.updateSupportCode
+  shouldPassTests
 
   hspec $ do
     describe "cst" TestCst.spec
     describe "ast" TestAst.spec
-    describe "ide" TestIde.spec
+    -- describe "ide" TestIde.spec
     beforeAll TestUtils.setupSupportModules $ do
       describe "compiler" TestCompiler.spec
-      describe "sourcemaps" TestSourceMaps.spec
+      -- describe "sourcemaps" TestSourceMaps.spec
     describe "make" TestMake.spec
-    describe "psci" TestPsci.spec
+    -- describe "psci" TestPsci.spec
     describe "corefn" TestCoreFn.spec
-    describe "docs" TestDocs.spec
-    describe "prim-docs" TestPrimDocs.spec
-    describe "publish" TestPscPublish.spec
+    -- describe "docs" TestDocs.spec
+    -- describe "prim-docs" TestPrimDocs.spec
+    -- describe "publish" TestPscPublish.spec
     describe "hierarchy" TestHierarchy.spec
-    describe "graph" TestGraph.spec
+    -- describe "graph" TestGraph.spec
+-}
diff --git a/tests/TestCoreFn.hs b/tests/TestCoreFn.hs
index 588c6817b..07b757e96 100644
--- a/tests/TestCoreFn.hs
+++ b/tests/TestCoreFn.hs
@@ -17,8 +17,10 @@ import Language.PureScript.CoreFn.FromJSON (moduleFromJSON)
 import Language.PureScript.CoreFn.ToJSON (moduleToJSON)
 import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName(..), ProperName(..), Qualified(..), QualifiedBy(..))
 import Language.PureScript.PSString (mkString)
+import Language.PureScript.Environment
 
 import Test.Hspec (Spec, context, shouldBe, shouldSatisfy, specify)
+import Language.PureScript.CoreFn.Desugar.Utils (purusTy)
 
 parseModule :: Value -> Result (Version, Module Ann)
 parseModule = parse moduleFromJSON
@@ -102,16 +104,17 @@ spec = context "CoreFnFromJson" $ do
   context "Expr" $ do
     specify "should parse literals" $ do
       let m = Module ss [] mn mp [] [] M.empty []
-                [ NonRec ann (Ident "x1") $ Literal ann (NumericLiteral (Left 1))
-                , NonRec ann (Ident "x2") $ Literal ann (NumericLiteral (Right 1.0))
-                , NonRec ann (Ident "x3") $ Literal ann (StringLiteral (mkString "abc"))
-                , NonRec ann (Ident "x4") $ Literal ann (CharLiteral 'c')
-                , NonRec ann (Ident "x5") $ Literal ann (BooleanLiteral True)
-                , NonRec ann (Ident "x6") $ Literal ann (ArrayLiteral [Literal ann (CharLiteral 'a')])
-                , NonRec ann (Ident "x7") $ Literal ann (ObjectLiteral [(mkString "a", Literal ann (CharLiteral 'a'))])
+                [ NonRec ann (Ident "x1") $ Literal ann (purusTy tyInt) (NumericLiteral (Left 1))
+                , NonRec ann (Ident "x2") $ Literal ann (purusTy tyNumber) (NumericLiteral (Right 1.0))
+                , NonRec ann (Ident "x3") $ Literal ann (purusTy tyString) (StringLiteral (mkString "abc"))
+                , NonRec ann (Ident "x4") $ Literal ann (purusTy tyChar) (CharLiteral 'c')
+                , NonRec ann (Ident "x5") $ Literal ann (purusTy tyBoolean) (BooleanLiteral True)
+                , NonRec ann (Ident "x6") $ Literal ann (arrayT tyChar) (ArrayLiteral [Literal ann (purusTy tyChar) (CharLiteral 'a')])
+                -- TODO: Need helpers to make the type
+                -- , NonRec ann (Ident "x7") $ Literal ann (ObjectLiteral [(mkString "a", Literal ann (CharLiteral 'a'))])
                 ]
       parseMod m `shouldSatisfy` isSuccess
-
+{- don't have the tools to write type sigs, TODO come back an fix
     specify "should parse Constructor" $ do
       let m = Module ss [] mn mp [] [] M.empty []
                 [ NonRec ann (Ident "constructor") $ Constructor ann (ProperName "Either") (ProperName "Left") [Ident "value0"] ]
@@ -256,7 +259,7 @@ spec = context "CoreFnFromJson" $ do
                       ]
                 ]
       parseMod m `shouldSatisfy` isSuccess
-
+  -}
   context "Comments" $ do
     specify "should parse LineComment" $ do
       let m = Module ss [ LineComment "line" ] mn mp [] [] M.empty [] []
diff --git a/tests/TestMake.hs b/tests/TestMake.hs
index 610e8465c..6cd5347f4 100644
--- a/tests/TestMake.hs
+++ b/tests/TestMake.hs
@@ -164,7 +164,7 @@ spec = do
       let modulePath = sourcesDir </> "Module.purs"
           moduleContent1 = "module Module where\nx :: Int\nx = 1"
           moduleContent2 = moduleContent1 <> "\ny :: Int\ny = 1"
-          optsWithDocs = P.defaultOptions { P.optionsCodegenTargets = Set.fromList [P.JS, P.Docs] }
+          optsWithDocs = P.defaultOptions { P.optionsCodegenTargets = Set.fromList [P.CoreFn, P.Docs] }
           go opts = compileWithOptions opts [modulePath] >>= assertSuccess
           oneSecond = 10 ^ (6::Int) -- microseconds.
 
diff --git a/tests/TestPurus.hs b/tests/TestPurus.hs
new file mode 100644
index 000000000..48567dae9
--- /dev/null
+++ b/tests/TestPurus.hs
@@ -0,0 +1,115 @@
+{-# LANGUAGE TypeApplications #-}
+module TestPurus where
+
+import Prelude
+import Command.Compile ( compileForTests, PSCMakeOptions(..) )
+import Control.Monad (when,unless,void)
+import System.FilePath
+import Language.PureScript qualified as P
+import Data.Set qualified as S
+import Data.Foldable (traverse_)
+import System.Directory (removeDirectoryRecursive, doesDirectoryExist, createDirectory)
+import System.FilePath.Glob qualified as Glob
+import Data.Function (on)
+import Data.List (sort, sortBy, stripPrefix, groupBy, find)
+import Control.Exception.Base
+
+
+shouldPassTests :: IO ()
+shouldPassTests = traverse_ runPurusDefault shouldPass
+
+runPurus :: P.CodegenTarget -> FilePath ->  IO ()
+runPurus target dir =  do
+    outDirExists <- doesDirectoryExist outputDir
+    when (target /= P.CheckCoreFn) $ do
+      when outDirExists $ removeDirectoryRecursive outputDir
+      unless outDirExists $ createDirectory outputDir
+    files <- concat <$> getTestFiles dir
+    print files
+    print ("Compiling " <> dir)
+    compileForTests (makeOpts files)
+    print ("Done with " <> dir)
+  where
+    outputDir = "tests" </> "purus" </> dir </> "output"
+
+    makeOpts :: [FilePath] -> PSCMakeOptions
+    makeOpts files = PSCMakeOptions {
+      pscmInput = files,
+      pscmExclude = [],
+      pscmOutputDir = outputDir,
+      pscmOpts = purusOpts,
+      pscmUsePrefix = False,
+      pscmJSONErrors = False
+    }
+
+    purusOpts :: P.Options
+    purusOpts = P.Options {
+      optionsVerboseErrors = True,
+      optionsNoComments = True,
+      optionsCodegenTargets = S.singleton target
+    }
+
+runPurusDefault :: FilePath -> IO ()
+runPurusDefault path = runPurus P.CoreFn path
+
+runPurusGolden :: FilePath -> IO ()
+runPurusGolden path = runPurus P.CheckCoreFn path
+
+
+shouldPass :: [FilePath]
+shouldPass = map (prefix </>) paths
+  where
+    prefix = "passing"
+    paths = [
+        "2018",
+        "2138",
+        "2609",
+        "4035",
+        "4101",
+        "4105",
+        "4200",
+        "4310",
+        "ClassRefSyntax",
+        "Coercible",
+        "DctorOperatorAlias",
+        "ExplicitImportReExport",
+        "ExportExplicit",
+        "ExportExplicit2",
+        "ForeignKind",
+        "Import",
+        "ImportExplicit",
+        "ImportQualified",
+        "InstanceUnnamedSimilarClassName",
+        "ModuleDeps",
+        "NonOrphanInstanceFunDepExtra",
+        "NonOrphanInstanceMulti"
+
+      ]
+
+
+getTestFiles :: FilePath -> IO [[FilePath]]
+getTestFiles testDir = do
+  let dir = "tests" </> "purus" </> testDir
+  getFiles dir <$> testGlob dir
+  where
+  -- A glob for all purs and js files within a test directory
+  testGlob :: FilePath -> IO [FilePath]
+  testGlob = Glob.globDir1 (Glob.compile "**/*.purs")
+  -- Groups the test files so that a top-level file can have dependencies in a
+  -- subdirectory of the same name. The inner tuple contains a list of the
+  -- .purs files and the .js files for the test case.
+  getFiles :: FilePath -> [FilePath] -> [[FilePath]]
+  getFiles baseDir
+    = map (filter ((== ".purs") . takeExtensions) . map (baseDir </>))
+    . groupBy ((==) `on` extractPrefix)
+    . sortBy (compare `on` extractPrefix)
+    . map (makeRelative baseDir)
+  -- Extracts the filename part of a .purs file, or if the file is in a
+  -- subdirectory, the first part of that directory path.
+  extractPrefix :: FilePath -> FilePath
+  extractPrefix fp =
+    let dir = takeDirectory fp
+        ext = reverse ".purs"
+    in if dir == "."
+       then maybe fp reverse $ stripPrefix ext $ reverse fp
+       else dir
diff --git a/tests/TestSourceMaps.hs b/tests/TestSourceMaps.hs
index 5b91017d5..ae931b886 100644
--- a/tests/TestSourceMaps.hs
+++ b/tests/TestSourceMaps.hs
@@ -67,7 +67,7 @@ assertCompilesToExpectedValidOutput support inputFiles = do
 
   where
     compilationOptions :: P.Options
-    compilationOptions = P.defaultOptions { P.optionsCodegenTargets = Set.fromList [P.JS, P.JSSourceMap] }
+    compilationOptions = P.defaultOptions { P.optionsCodegenTargets = Set.fromList [P.CoreFn] }
 
 -- | Fails the test if the produced source maps are not valid.
 sourceMapIsValid :: FilePath -> Expectation
diff --git a/tests/purus/passing/2018/A.purs b/tests/purus/passing/2018/A.purs
new file mode 100644
index 000000000..bff4cd039
--- /dev/null
+++ b/tests/purus/passing/2018/A.purs
@@ -0,0 +1,7 @@
+module A where
+
+import B as Main
+
+-- Prior to the 2018 fix this would be detected as a cycle between A and Main.
+foo ∷ Main.Foo → Main.Foo
+foo x = x
diff --git a/tests/purus/passing/2018/B.purs b/tests/purus/passing/2018/B.purs
new file mode 100644
index 000000000..c87647d4c
--- /dev/null
+++ b/tests/purus/passing/2018/B.purs
@@ -0,0 +1,3 @@
+module B where
+
+data Foo = X | Y
diff --git a/tests/purus/passing/2138/Lib.purs b/tests/purus/passing/2138/Lib.purs
new file mode 100644
index 000000000..3c433e0b1
--- /dev/null
+++ b/tests/purus/passing/2138/Lib.purs
@@ -0,0 +1,3 @@
+module Lib (A(..), A) where
+
+data A = B | C
diff --git a/tests/purus/passing/2609/Eg.purs b/tests/purus/passing/2609/Eg.purs
new file mode 100644
index 000000000..cd6e73d34
--- /dev/null
+++ b/tests/purus/passing/2609/Eg.purs
@@ -0,0 +1,5 @@
+module Eg (Foo'(Bar'), (:->)) where
+
+data Foo' = Bar' Int Int
+
+infix 4 Bar' as :->
diff --git a/tests/purus/passing/4035/Other.purs b/tests/purus/passing/4035/Other.purs
new file mode 100644
index 000000000..055b3c783
--- /dev/null
+++ b/tests/purus/passing/4035/Other.purs
@@ -0,0 +1,4 @@
+module Other where
+
+type Id :: forall k. k -> k
+type Id a = a
diff --git a/tests/purus/passing/4101/Lib.purs b/tests/purus/passing/4101/Lib.purs
new file mode 100644
index 000000000..fc5f850e7
--- /dev/null
+++ b/tests/purus/passing/4101/Lib.purs
@@ -0,0 +1,9 @@
+module Lib where
+
+newtype Const :: forall k. Type -> k -> Type
+newtype Const a b = Const a
+
+data Unit = Unit
+
+type CONST = Const
+type UNIT = CONST Unit
diff --git a/tests/purus/passing/4105/Lib.purs b/tests/purus/passing/4105/Lib.purs
new file mode 100644
index 000000000..89ccc3043
--- /dev/null
+++ b/tests/purus/passing/4105/Lib.purs
@@ -0,0 +1,5 @@
+module Lib where
+
+type Template col = { bio :: col String }
+type Identity a = a
+type Patch = Template Identity
diff --git a/tests/purus/passing/4200/Lib.purs b/tests/purus/passing/4200/Lib.purs
new file mode 100644
index 000000000..645940a23
--- /dev/null
+++ b/tests/purus/passing/4200/Lib.purs
@@ -0,0 +1,7 @@
+module Lib where
+
+data T :: forall m. m -> Type
+data T msg = E
+
+type TAlias :: forall k. k -> Type
+type TAlias msg = T msg
diff --git a/tests/purus/passing/4310/Lib.purs b/tests/purus/passing/4310/Lib.purs
new file mode 100644
index 000000000..2c5b87070
--- /dev/null
+++ b/tests/purus/passing/4310/Lib.purs
@@ -0,0 +1,20 @@
+module Lib where
+
+data Tuple a b = Tuple a b
+
+infixr 6 Tuple as /\
+infixr 6 type Tuple as /\
+
+mappend :: String -> String -> String
+mappend _ _ = "mappend"
+
+infixr 5 mappend as <>
+
+class Test a where
+  runTest :: a -> String
+
+instance Test Int where
+  runTest _ = "4"
+
+instance (Test a, Test b) => Test (a /\ b) where
+  runTest (a /\ b) = runTest a <> runTest b
diff --git a/tests/purus/passing/ClassRefSyntax/Lib.purs b/tests/purus/passing/ClassRefSyntax/Lib.purs
new file mode 100644
index 000000000..c9eca67a7
--- /dev/null
+++ b/tests/purus/passing/ClassRefSyntax/Lib.purs
@@ -0,0 +1,5 @@
+module Lib (class X, go) where
+
+class X a where
+  go :: a -> a
+
diff --git a/tests/purus/passing/Coercible/Lib.purs b/tests/purus/passing/Coercible/Lib.purs
new file mode 100644
index 000000000..cca268cfb
--- /dev/null
+++ b/tests/purus/passing/Coercible/Lib.purs
@@ -0,0 +1,12 @@
+module Coercible.Lib
+  ( module Coercible.Lib2
+  , NTLib1 (..)
+  , NTLib3 (..)
+  ) where
+
+import Coercible.Lib2
+
+newtype NTLib1 a = NTLib1 a
+
+newtype NTLib3 a b = NTLib3 a
+type role NTLib3 representational representational
diff --git a/tests/purus/passing/Coercible/Lib2.purs b/tests/purus/passing/Coercible/Lib2.purs
new file mode 100644
index 000000000..3fdef618d
--- /dev/null
+++ b/tests/purus/passing/Coercible/Lib2.purs
@@ -0,0 +1,3 @@
+module Coercible.Lib2 where
+
+newtype NTLib2 a = NTLib2 a
diff --git a/tests/purus/passing/DctorOperatorAlias/List.purs b/tests/purus/passing/DctorOperatorAlias/List.purs
new file mode 100644
index 000000000..a428343a2
--- /dev/null
+++ b/tests/purus/passing/DctorOperatorAlias/List.purs
@@ -0,0 +1,5 @@
+module List where
+
+data List a = Cons a (List a) | Nil
+
+infixr 6 Cons as :
diff --git a/tests/purus/passing/ExplicitImportReExport/Bar.purs b/tests/purus/passing/ExplicitImportReExport/Bar.purs
new file mode 100644
index 000000000..5f8ef12ae
--- /dev/null
+++ b/tests/purus/passing/ExplicitImportReExport/Bar.purs
@@ -0,0 +1,3 @@
+module Bar (module Foo) where
+
+import Foo
diff --git a/tests/purus/passing/ExplicitImportReExport/Foo.purs b/tests/purus/passing/ExplicitImportReExport/Foo.purs
new file mode 100644
index 000000000..d2c06e960
--- /dev/null
+++ b/tests/purus/passing/ExplicitImportReExport/Foo.purs
@@ -0,0 +1,4 @@
+module Foo where
+
+foo :: Int
+foo = 3
diff --git a/tests/purus/passing/ExportExplicit/M1.purs b/tests/purus/passing/ExportExplicit/M1.purs
new file mode 100644
index 000000000..5195d0e96
--- /dev/null
+++ b/tests/purus/passing/ExportExplicit/M1.purs
@@ -0,0 +1,10 @@
+module M1 (X(X, Y), Z(..), foo) where
+
+data X = X | Y
+data Z = Z
+
+foo :: Int
+foo = 0
+
+bar :: Int
+bar = 1
diff --git a/tests/purus/passing/ExportExplicit2/M1.purs b/tests/purus/passing/ExportExplicit2/M1.purs
new file mode 100644
index 000000000..aa78149f1
--- /dev/null
+++ b/tests/purus/passing/ExportExplicit2/M1.purs
@@ -0,0 +1,7 @@
+module M1 (bar) where
+
+foo :: Int
+foo = 0
+
+bar :: Int
+bar = foo
diff --git a/tests/purus/passing/ForeignKind/Lib.purs b/tests/purus/passing/ForeignKind/Lib.purs
new file mode 100644
index 000000000..d28a9a5cc
--- /dev/null
+++ b/tests/purus/passing/ForeignKind/Lib.purs
@@ -0,0 +1,60 @@
+module ForeignKinds.Lib (Nat, Kinded, Zero, Succ, N0, N1, N2, N3, NatProxy(..), class AddNat, addNat, proxy1, proxy2) where
+
+-- declaration
+
+data Nat
+
+-- use in foreign data
+
+foreign import data Zero :: Nat
+foreign import data Succ :: Nat -> Nat
+
+-- use in data
+
+data NatProxy (t :: Nat) = NatProxy
+
+-- use in type sig
+
+succProxy :: forall n. NatProxy n -> NatProxy (Succ n)
+succProxy _ = NatProxy
+
+-- use in alias
+
+type Kinded f = f :: Nat
+
+type KindedZero = Kinded Zero
+
+type N0 = Zero
+type N1 = Succ N0
+type N2 = Succ N1
+type N3 = Succ N2
+
+-- use of alias
+
+proxy0 :: NatProxy N0
+proxy0 = NatProxy
+
+proxy1 :: NatProxy N1
+proxy1 = NatProxy
+
+proxy2 :: NatProxy N2
+proxy2 = NatProxy
+
+proxy3 :: NatProxy N3
+proxy3 = NatProxy
+
+-- use in class
+
+class AddNat (l :: Nat) (r :: Nat) (o :: Nat) | l -> r o
+
+instance addNatZero
+  :: AddNat Zero r r
+
+instance addNatSucc
+  :: AddNat l r o
+  => AddNat (Succ l) r (Succ o)
+
+-- use of class
+
+addNat :: forall l r o. AddNat l r o => NatProxy l -> NatProxy r -> NatProxy o
+addNat _ _ = NatProxy
diff --git a/tests/purus/passing/Import/M1.purs b/tests/purus/passing/Import/M1.purs
new file mode 100644
index 000000000..ec5358550
--- /dev/null
+++ b/tests/purus/passing/Import/M1.purs
@@ -0,0 +1,6 @@
+module M1 where
+
+id :: forall a. a -> a
+id = \x -> x
+
+foo = id
diff --git a/tests/purus/passing/Import/M2.purs b/tests/purus/passing/Import/M2.purs
new file mode 100644
index 000000000..a6a9846e7
--- /dev/null
+++ b/tests/purus/passing/Import/M2.purs
@@ -0,0 +1,5 @@
+module M2 where
+
+import M1
+
+main = \_ -> foo 42
diff --git a/tests/purus/passing/ImportExplicit/M1.purs b/tests/purus/passing/ImportExplicit/M1.purs
new file mode 100644
index 000000000..cf27f2df6
--- /dev/null
+++ b/tests/purus/passing/ImportExplicit/M1.purs
@@ -0,0 +1,4 @@
+module M1 where
+
+data X = X | Y
+data Z = Z
diff --git a/tests/purus/passing/ImportQualified/M1.purs b/tests/purus/passing/ImportQualified/M1.purs
new file mode 100644
index 000000000..719a1a03e
--- /dev/null
+++ b/tests/purus/passing/ImportQualified/M1.purs
@@ -0,0 +1,3 @@
+module M1 where
+
+log x = x
diff --git a/tests/purus/passing/InstanceUnnamedSimilarClassName/ImportedClassName.purs b/tests/purus/passing/InstanceUnnamedSimilarClassName/ImportedClassName.purs
new file mode 100644
index 000000000..c96669335
--- /dev/null
+++ b/tests/purus/passing/InstanceUnnamedSimilarClassName/ImportedClassName.purs
@@ -0,0 +1,4 @@
+module ImportedClassName where
+
+class ClassName a where
+  foo :: a -> Int
diff --git a/tests/purus/passing/ModuleDeps/M1.purs b/tests/purus/passing/ModuleDeps/M1.purs
new file mode 100644
index 000000000..535aa287c
--- /dev/null
+++ b/tests/purus/passing/ModuleDeps/M1.purs
@@ -0,0 +1,5 @@
+module M1 where
+
+import M2 as M2
+
+foo = M2.bar
diff --git a/tests/purus/passing/ModuleDeps/M2.purs b/tests/purus/passing/ModuleDeps/M2.purs
new file mode 100644
index 000000000..017e70e3f
--- /dev/null
+++ b/tests/purus/passing/ModuleDeps/M2.purs
@@ -0,0 +1,5 @@
+module M2 where
+
+import M3 as M3
+
+bar = M3.baz
diff --git a/tests/purus/passing/ModuleDeps/M3.purs b/tests/purus/passing/ModuleDeps/M3.purs
new file mode 100644
index 000000000..f07167b71
--- /dev/null
+++ b/tests/purus/passing/ModuleDeps/M3.purs
@@ -0,0 +1,3 @@
+module M3 where
+
+baz = 1
diff --git a/tests/purus/passing/NonOrphanInstanceFunDepExtra/Lib.purs b/tests/purus/passing/NonOrphanInstanceFunDepExtra/Lib.purs
new file mode 100644
index 000000000..590977109
--- /dev/null
+++ b/tests/purus/passing/NonOrphanInstanceFunDepExtra/Lib.purs
@@ -0,0 +1,4 @@
+module Lib where
+-- covering sets: {{f, l}}
+class C f l r | l -> r
+data L
diff --git a/tests/purus/passing/NonOrphanInstanceMulti/Lib.purs b/tests/purus/passing/NonOrphanInstanceMulti/Lib.purs
new file mode 100644
index 000000000..49b5b73e0
--- /dev/null
+++ b/tests/purus/passing/NonOrphanInstanceMulti/Lib.purs
@@ -0,0 +1,4 @@
+module Lib where
+-- covering sets: {{l, r}}
+class C l r
+data R

From 5a834377ef832b1cf297ba295d7258c1bb1c3cd5 Mon Sep 17 00:00:00 2001
From: gnumonik <gnumonik@protonmail.com>
Date: Tue, 27 Feb 2024 00:51:41 -0500
Subject: [PATCH 03/20] Fixed bug discovered in test #4301 (I hope...)

---
 src/Language/PureScript/CoreFn/Desugar.hs     | 144 +++++++++-----
 .../PureScript/CoreFn/Desugar/Utils.hs        |  99 ++++++++--
 src/Language/PureScript/CoreFn/Expr.hs        |   4 +-
 src/Language/PureScript/CoreFn/Pretty.hs      |  10 +-
 src/Language/PureScript/Environment.hs        |   6 +-
 src/Language/PureScript/Make/Actions.hs       |   5 +-
 tests/purus/passing/Misc/Lib.purs             | 177 ++++++++++++++++++
 7 files changed, 374 insertions(+), 71 deletions(-)
 create mode 100644 tests/purus/passing/Misc/Lib.purs

diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs
index 9e72366ef..d52a00fea 100644
--- a/src/Language/PureScript/CoreFn/Desugar.hs
+++ b/src/Language/PureScript/CoreFn/Desugar.hs
@@ -4,14 +4,14 @@
 module Language.PureScript.CoreFn.Desugar(moduleToCoreFn) where
 
 import Prelude
-import Protolude (ordNub, orEmpty, zipWithM, MonadError (..), sortOn)
+import Protolude (ordNub, orEmpty, zipWithM, MonadError (..), sortOn, (<=<), Bifunctor (bimap))
 
 import Data.Maybe (mapMaybe)
 import Data.List.NonEmpty qualified as NEL
 import Data.Map qualified as M
 
 import Language.PureScript.AST.Literals (Literal(..))
-import Language.PureScript.AST.SourcePos (pattern NullSourceSpan, SourceSpan(..))
+import Language.PureScript.AST.SourcePos (pattern NullSourceSpan, SourceSpan(..), SourceAnn)
 import Language.PureScript.CoreFn.Ann (Ann, ssAnn)
 import Language.PureScript.CoreFn.Binders (Binder(..))
 import Language.PureScript.CoreFn.Expr (Bind(..), CaseAlternative(..), Expr(..), Guard, exprType)
@@ -34,7 +34,7 @@ import Language.PureScript.Environment (
   tyString,
   tyChar,
   tyInt,
-  tyNumber )
+  tyNumber, function, pattern (:$),pattern RecordT )
 import Language.PureScript.Label (Label(..))
 import Language.PureScript.Names (
   pattern ByNullSourcePos, Ident(..),
@@ -47,13 +47,13 @@ import Language.PureScript.Names (
   runIdent,
   coerceProperName,
   Name (DctorName))
-import Language.PureScript.PSString (PSString)
+import Language.PureScript.PSString (PSString, prettyPrintString)
 import Language.PureScript.Types (
   pattern REmptyKinded,
   SourceType,
   Type(..),
   srcTypeConstructor,
-  srcTypeVar, srcTypeApp, quantify, eqType, containsUnknowns)
+  srcTypeVar, srcTypeApp, quantify, eqType, containsUnknowns, replaceTypeVars, rowToList, RowListItem (..), freeTypeVariables)
 import Language.PureScript.AST.Binders qualified as A
 import Language.PureScript.AST.Declarations qualified as A
 import Language.PureScript.AST.SourcePos qualified as A
@@ -66,14 +66,14 @@ import Language.PureScript.TypeChecker.Types
       SplitBindingGroup(SplitBindingGroup),
       TypedValue'(TypedValue'),
       typeDictionaryForBindingGroup,
-      infer )
+      infer, instantiatePolyTypeWithUnknowns, inferBinder, instantiateForBinders )
 import Data.List.NonEmpty qualified as NE
 import Language.PureScript.TypeChecker.Unify (unifyTypes)
-import Control.Monad (forM, (>=>))
+import Control.Monad (forM, (>=>), foldM)
 import Language.PureScript.Errors
     ( MultipleErrors, errorMessage', SimpleErrorMessage(..))
 import Debug.Trace (traceM)
-import Language.PureScript.CoreFn.Pretty ( ppType )
+import Language.PureScript.CoreFn.Pretty ( ppType, renderExpr )
 import Data.Text qualified as T
 import Language.PureScript.Pretty.Values (renderValue)
 import Language.PureScript.TypeChecker.Monad
@@ -108,11 +108,14 @@ import Language.PureScript.CoreFn.Desugar.Utils
       toReExportRef,
       traverseLit,
       wrapTrace,
-      M, unwrapRecord, withInstantiatedFunType,
+      desugarConstraintTypes,
+      M, unwrapRecord, withInstantiatedFunType, desugarConstraintsInDecl, analyzeCtor, instantiate, ctorArgs
       )
 import Text.Pretty.Simple (pShow)
 import Data.Text.Lazy qualified as LT
 import Data.Set qualified as S
+import Language.PureScript.TypeChecker (replaceAllTypeSynonyms)
+import Language.PureScript.TypeChecker.Skolems (introduceSkolemScope)
 
 {-
     CONVERSION MACHINERY
@@ -131,9 +134,11 @@ import Data.Set qualified as S
 moduleToCoreFn :: forall m. M m => A.Module -> m (Module Ann)
 moduleToCoreFn  (A.Module _ _ _ _ Nothing) =
   internalError "Module exports were not elaborated before moduleToCoreFn"
-moduleToCoreFn (A.Module modSS coms mn decls (Just exps)) = do
+moduleToCoreFn (A.Module modSS coms mn _decls (Just exps)) = do
   setModuleName
-  let importHelper ds = fmap (ssAnn modSS,) (findQualModules ds)
+  desugarConstraintTypes
+  let decls = desugarConstraintsInDecl <$> _decls
+      importHelper ds = fmap (ssAnn modSS,) (findQualModules ds)
       imports = dedupeImports $ mapMaybe importToCoreFn decls ++ importHelper decls
       exps' = ordNub $ concatMap exportToCoreFn exps
       reExps = M.map ordNub $ M.unionsWith (++) (mapMaybe (fmap reExportsToCoreFn . toReExportRef) exps)
@@ -156,7 +161,7 @@ lookupType :: forall m. M m => A.SourcePos -> Ident -> m (SourceType,NameVisibil
 lookupType sp tn = do
   mn <- getModuleName
   env <- gets checkEnv
-  case M.lookup  (Qualified (BySourcePos sp) tn) (names env) of
+  case M.lookup (Qualified (BySourcePos sp) tn) (names env) of
     Nothing -> case M.lookup (mkQualified tn mn) (names env) of
       Nothing -> do
         pEnv <- printEnv
@@ -178,7 +183,7 @@ declToCoreFn :: forall m. M m => ModuleName -> A.Declaration -> m [Bind Ann]
 declToCoreFn _ (A.DataDeclaration (ss, com) Newtype name _ [ctor]) = wrapTrace ("decltoCoreFn NEWTYPE " <> show name) $ case A.dataCtorFields ctor of
   [(_,wrappedTy)] -> do
     -- traceM (show ctor)
-    let innerFunTy = quantify $ purusFun wrappedTy wrappedTy
+    let innerFunTy = quantify $ function wrappedTy wrappedTy
     pure [NonRec (ss, [], declMeta) (properToIdent $ A.dataCtorName ctor) $
       Abs (ss, com, Just IsNewtype) innerFunTy (Ident "x") (Var (ssAnn ss) (purusTy wrappedTy) $ Qualified ByNullSourcePos (Ident "x"))]
   _ -> error "Found newtype with multiple fields"
@@ -201,6 +206,7 @@ declToCoreFn mn (A.DataBindingGroupDeclaration ds) = wrapTrace  "declToCoreFn DA
 -- Essentially a wrapper over `exprToCoreFn`. Not 100% sure if binding the type of the declaration is necessary here?
 -- NOTE: Should be impossible to have a guarded expr here, make it an error
 declToCoreFn  mn (A.ValueDecl (ss, _) name _ _ [A.MkUnguarded e]) = wrapTrace ("decltoCoreFn VALDEC " <> show name) $ do
+  traceM $ renderValue 100 e
   (valDeclTy,nv) <- lookupType (spanStart ss) name
   bindLocalVariables [(ss,name,valDeclTy,nv)] $ do
       expr <- exprToCoreFn mn ss (Just valDeclTy) e -- maybe wrong? might need to bind something here?
@@ -226,9 +232,27 @@ declToCoreFn _ _ = pure []
 
 -- Desugars expressions from AST to typed CoreFn representation.
 exprToCoreFn :: forall m. M m => ModuleName -> SourceSpan -> Maybe SourceType -> A.Expr -> m (Expr Ann)
+exprToCoreFn mn ss (Just arrT@(ArrayT ty)) astlit@(A.Literal ss' (ArrayLiteral ts)) = wrapTrace ("exprToCoreFn ARRAYLIT " <> renderValue 100 astlit) $ do
+  arr <- ArrayLiteral <$> traverse (exprToCoreFn mn ss (Just ty)) ts
+  pure $ Literal (ss,[],Nothing) arrT  arr
+exprToCoreFn mn ss (Just recTy@(RecordT row)) astlit@(A.Literal ss' (ObjectLiteral objFields)) = wrapTrace ("exprToCoreFn OBJECTLIT " <> renderValue 100 astlit) $ do
+  traceM $ "ObjLitTy: " <> show row
+  let (tyFields,_) = rowToList row
+      tyMap = M.fromList $ (\x -> (runLabel (rowListLabel x),x)) <$> tyFields
+  resolvedFields <- foldM (go tyMap) [] objFields
+  pure $ Literal (ss,[],Nothing) recTy (ObjectLiteral resolvedFields)
+ where
+   go :: M.Map PSString (RowListItem SourceAnn) -> [(PSString, Expr Ann)] -> (PSString, A.Expr) -> m [(PSString, Expr Ann)]
+   go tyMap acc (lbl,expr) = case M.lookup lbl tyMap of
+     Just rowListItem -> do
+       let fieldTy = rowListType rowListItem
+       expr' <- exprToCoreFn mn ss (Just fieldTy) expr
+       pure $ (lbl,expr'):acc
+     Nothing -> error $ "row type missing field " <> T.unpack (prettyPrintString lbl)
 -- Literal case is straightforward
 exprToCoreFn mn _ mTy astLit@(A.Literal ss lit) = wrapTrace ("exprToCoreFn LIT " <> renderValue 100 astLit) $ do
   litT <- purusTy <$> inferType mTy astLit
+  traceM $ "LIT TY: " <> ppType 1000 litT
   lit' <- traverseLit (exprToCoreFn mn ss Nothing) lit
   pure $ Literal (ss, [], Nothing)  litT lit'
 -- Accessor case is straightforward
@@ -264,30 +288,65 @@ exprToCoreFn mn ss mTy objUpd@(A.ObjectUpdate obj vs) = wrapTrace ("exprToCoreFn
 exprToCoreFn mn _ (Just t) (A.Abs (A.VarBinder ssb name) v) = wrapTrace ("exprToCoreFn " <> showIdent' name) $
   withInstantiatedFunType mn t $ \a b -> do
       body <-  bindLocalVariables [(ssb,name,a,Defined)] $ exprToCoreFn mn ssb (Just b) v
-      pure $ Abs (ssA ssb) (purusFun a b) name body
+      pure $ Abs (ssA ssb) (function a b) name body
 
 -- By the time we receive the AST, only Lambdas w/ a VarBinder should remain
 -- TODO: Better failure message if we pass in 'Nothing' as the (Maybe Type) arg for an Abstraction
 exprToCoreFn _  _ t lam@(A.Abs _ _) =
-  internalError $ "Abs with Binder argument was not desugared before exprToCoreFn mn: \n" <> show lam <> "\n\n" <> show (const () <$> t)
+  internalError $ "Abs with Binder argument was not desugared before exprToCoreFn: \n" <> show lam <> "\n\n" <> show (const () <$> t)
 -- Ad hoc machinery for handling desugared type class dictionaries. As noted above, the types "lie" in generated code.
 -- NOTE: Not 100% sure this is necessary anymore now that we have instantiatePolyType
 -- TODO: Investigate whether still necessary
-exprToCoreFn mn ss mTy app@(A.App v1 v2)
-  | isDictCtor v2 && isDictInstCase v1 = wrapTrace "exprToCoreFn APP DICT" $ do
-      v2' <- exprToCoreFn mn ss Nothing v2
-      toBind <- mkDictInstBinder v1
-      v1' <- bindLocalVariables toBind $ exprToCoreFn mn ss Nothing v1
-      appT <- inferType mTy app
-      pure $ App (ss, [], Just IsSyntheticApp) (purusTy appT) v1' v2'
+-- FIXME: Something's off here, see output for 4310
+exprToCoreFn mn ss mTy app@(A.App fun arg)
+  | isDictCtor fun = wrapTrace "exprToCoreFn APP DICT " $ do
+      let analyzed = mTy >>= analyzeCtor
+          prettyAnalyzed = bimap (ppType 100) (fmap (ppType 100)) <$> analyzed
+      traceM $ "APP DICT analyzed:\n" <> show prettyAnalyzed
+      case analyzed of
+        Just (TypeConstructor ann ctor@(Qualified qb nm), args) -> do
+          traceM $ "APP Dict name: " <> T.unpack (runProperName nm)
+          env <- getEnv
+          case M.lookup (Qualified qb $ coerceProperName nm) (dataConstructors env) of
+            Just (_, _, ty, _) -> do
+                traceM $ "APP Dict original type:\n" <> ppType 100 ty
+                case instantiate ty args  of
+                  iFun@(iArg :-> iRes) -> do
+                    traceM $ "APP Dict iArg:\n" <> ppType 100 iArg
+                    traceM $ "APP Dict iRes:\n" <> ppType 100 iRes
+                    fun' <- exprToCoreFn mn ss (Just iFun) fun
+                    arg' <- exprToCoreFn mn ss (Just iArg) arg
+                    pure $ App (ss,[],Nothing) iRes fun' arg'
+                  _ -> error "dict ctor has to have a function type"
+            _ -> throwError . errorMessage' ss . UnknownName . fmap DctorName $ (Qualified qb $ coerceProperName nm)
+        Just (other,_) -> error $ error $ "APP Dict not a constructor type (impossible?): \n" <> ppType 100 other
+        Nothing -> error $ "APP Dict w/o type passed in:\n" <> renderValue 100 app
 
+          -- type should be something like: Test$Dict (Tuple a b)
+          -- lookup the type of the Dict ctor (should have one quantified record arg), i.e.
+          --   forall a.  { runTest :: a -> String  }  -> { runTest :: a -> String }
+          -- instantiate the args, giving something like:
+          --  {runTest :: Tuple a b -> String}
 
-  | otherwise  = wrapTrace "exprToCoreFn APP" $ do
+  | otherwise =  wrapTrace "exprToCoreFn APP" $ do
+      {-
       appT <- inferType mTy app
-      v1' <- exprToCoreFn mn ss Nothing v1
-      v2' <- exprToCoreFn mn ss Nothing v2
-      pure $ App (ss, [], (isDictCtor v1 || isSynthetic v2) `orEmpty` IsSyntheticApp) (purusTy appT) v1' v2'
+      fun' <- exprToCoreFn mn ss Nothing fun
+      arg' <- exprToCoreFn mn ss Nothing arg
+      pure $ App (ss, [], Nothing) appT fun' arg'
+      -}
+      fun' <- exprToCoreFn mn ss Nothing fun
+      let funTy = exprType fun'
+      traceM $ "app fun:\n" <> (ppType 100  funTy) <> "\n" <> renderExpr 100 fun'
+      withInstantiatedFunType mn  funTy $ \a b -> do
+        -- fun'' <- exprToCoreFn mn ss (Just $ function a b) fun
+        arg' <- exprToCoreFn mn ss (Just a) arg
+        traceM $ "app arg:\n" <> ppType 100 (exprType arg') <> "\n" <> renderExpr 100 arg'
+        -- unifyTypes b appT
+        pure $ App (ss, [], Nothing) b fun' arg'
+
   where
+  {-
   mkDictInstBinder = \case
     A.TypedValue _ e _ -> mkDictInstBinder e
     A.Abs (A.VarBinder _ss1 (Ident "dict")) (A.Case [A.Var _ (Qualified _ (Ident "dict"))] [A.CaseAlternative [A.ConstructorBinder _ cn@(Qualified _ _) _] [A.MkUnguarded _acsr]]) -> do
@@ -302,11 +361,12 @@ exprToCoreFn mn ss mTy app@(A.App v1 v2)
 
   isDictInstCase = \case
     A.TypedValue _ e _ -> isDictInstCase e
-    A.Abs (A.VarBinder _ss1 (Ident "dict")) (A.Case [A.Var _ (Qualified ByNullSourcePos (Ident "dict"))] [A.CaseAlternative [A.ConstructorBinder _ (Qualified _ name) _] [A.MkUnguarded _acsr]]) -> isDictTypeName name
+    A.Abs (A.VarBinder _ss1 (Ident "dict")) (A.Case [A.Var _ (Qualified _ (Ident "dict"))] [A.CaseAlternative [A.ConstructorBinder _ (Qualified _ name) _] [A.MkUnguarded _acsr]]) -> isDictTypeName name
     _ -> False
-
+-}
   isDictCtor = \case
     A.Constructor _ (Qualified _ name) -> isDictTypeName name
+    A.TypedValue _ e _ -> isDictCtor e
     _ -> False
   isSynthetic = \case
     A.App v3 v4            -> isDictCtor v3 || isSynthetic v3 && isSynthetic v4
@@ -346,14 +406,13 @@ exprToCoreFn _ _  mTy ctor@(A.Constructor ss name) = wrapTrace ("exprToCoreFn CT
   pure $ Var (ss, [], Just ctorMeta) (purusTy ctorType) $ fmap properToIdent name
 -- Case expressions
 exprToCoreFn mn ss mTy astCase@(A.Case vs alts) = wrapTrace "exprToCoreFn CASE" $ do
-  traceM $ renderValue 100 astCase
+  traceM $ "CASE:\n" <> renderValue 100 astCase
+  traceM $ "CASE TY:\n" <> show (ppType 100 <$> mTy)
   caseTy <- inferType mTy astCase -- the return type of the branches. This will usually be passed in.
-  traceM "CASE.1"
   ts <- traverse (infer >=> pure . tvType)  vs -- extract type information for the *scrutinees* (need this to properly type the binders. still not sure why exactly this is a list)
-  traceM $ ppType 100 caseTy
-  pTrace vs
-  vs' <- traverse (exprToCoreFn mn ss Nothing) vs -- maybe zipWithM
+  --(vs_,ts) <- instantiateForBinders vs alts  -- maybe zipWithM
   alts' <- traverse (altToCoreFn mn ss caseTy ts) alts -- see explanation in altToCoreFn. We pass in the types of the scrutinee(s)
+  vs' <- traverse (exprToCoreFn mn ss Nothing) vs
   pure $ Case (ssA ss) (purusTy caseTy) vs' alts'
  where
    tvType (TypedValue' _ _ t) = t
@@ -419,10 +478,6 @@ altToCoreFn  mn ss ret boundTypes (A.CaseAlternative bs vs) = wrapTrace "altToCo
    an unknown type is correct *during the initial typechecking phase*, but it is disastrous for us
    because we need to preserve the quantifiers explicitly in the typed AST.
 
-   Both of these functions work for reasonably simple examples, but may fail in more complex cases.
-   The primary reason for this is: I'm not sure how to write PS source that contains some of the
-   weirder cases in the AST. We'll have to deal with any problems once we have examples that
-   clearly isolate the problematic syntax nodes.
 -}
 transformLetBindings :: forall m. M m => ModuleName -> SourceSpan -> [Bind Ann] -> [A.Declaration] -> A.Expr -> m ([Bind Ann], Expr Ann)
 transformLetBindings mn ss seen [] ret = (seen,) <$> withBindingGroupVisible (exprToCoreFn mn ss Nothing ret)
@@ -481,23 +536,26 @@ inferBinder' val (A.LiteralBinder _ (NumericLiteral (Right _))) = wrapTrace "inf
 inferBinder' val (A.LiteralBinder _ (BooleanLiteral _)) = wrapTrace "inferBinder' BOOLLIT" $ unifyTypes val tyBoolean >> return M.empty
 inferBinder' val (A.VarBinder ss name) = wrapTrace ("inferBinder' VAR " <> T.unpack (runIdent name))  $ return $ M.singleton name (ss, val)
 inferBinder' val (A.ConstructorBinder ss ctor binders) = wrapTrace ("inferBinder' CTOR: " <> show ctor) $ do
+  traceM $ "InferBinder VAL:\n" <>  ppType 100 val
   env <- getEnv
+  let cArgs = ctorArgs val
+  traceM $ "InferBinder CTOR ARGS:\n" <> concatMap (\x -> ppType 100 x <> "\n") cArgs
   case M.lookup ctor (dataConstructors env) of
-    Just (_, _, ty, _) -> do
-      traceM (ppType 100 ty)
-      let (args, ret) = peelArgs ty
-      -- unifyTypes ret val -- TODO: Check whether necesseary?
+    Just (_, _, _ty, _) -> do
+      let ty = instantiate _ty cArgs
+      traceM $ "InferBinder CTOR TY:\n" <> ppType 100 ty
+      let (args, _) = peelArgs ty
+      traceM $ "InferBinder ARGS:\n" <> concatMap (\x -> ppType 100 x <> "\n") args
       M.unions <$> zipWithM inferBinder' (reverse args) binders
     _ -> throwError . errorMessage' ss . UnknownName . fmap DctorName $ ctor
   where
-  -- REVIEW: Instantiating the quantifier might not be safe here?
   peelArgs :: Type a -> ([Type a], Type a) -- NOTE: Not sure if we want to "peel constraints" too. Need to think of an example to test.
   peelArgs = go []
     where
-    go args (ForAll _ _ _ _ innerTy _) = go args innerTy
     go args (TypeApp _ (TypeApp _ fn arg) ret) | eqType fn tyFunction = go (arg : args) ret
     go args ret = (args, ret)
 inferBinder' val (A.LiteralBinder _ (ObjectLiteral props)) = wrapTrace "inferBinder' OBJECTLIT" $ do
+  traceM $ ppType 100 val
   let props' = sortOn fst props
   case unwrapRecord val of
     Left notARecord -> error
diff --git a/src/Language/PureScript/CoreFn/Desugar/Utils.hs b/src/Language/PureScript/CoreFn/Desugar/Utils.hs
index d92ed3e88..9bc92bcc1 100644
--- a/src/Language/PureScript/CoreFn/Desugar/Utils.hs
+++ b/src/Language/PureScript/CoreFn/Desugar/Utils.hs
@@ -11,9 +11,10 @@ import Data.Function (on)
 import Data.Tuple (swap)
 import Data.Map qualified as M
 
+import Language.PureScript.AST qualified as A
 import Language.PureScript.AST.Literals (Literal(..))
 import Language.PureScript.AST.SourcePos (pattern NullSourceSpan, SourceSpan(..))
-import Language.PureScript.AST.Traversals (everythingOnValues)
+import Language.PureScript.AST.Traversals (everythingOnValues, overTypes)
 import Language.PureScript.CoreFn.Ann (Ann)
 import Language.PureScript.CoreFn.Binders (Binder(..))
 import Language.PureScript.CoreFn.Expr (Expr(..), PurusType)
@@ -30,9 +31,9 @@ import Language.PureScript.Environment (
   dictTypeName,
   TypeClassData (typeClassArguments),
   function,
-  pattern (:->))
+  pattern (:->), pattern (:$), isDictTypeName)
 import Language.PureScript.Names (Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), disqualify, getQual, runIdent, coerceProperName)
-import Language.PureScript.Types (SourceType, Type(..), Constraint (..), srcTypeConstructor, srcTypeApp, rowToSortedList, RowListItem(..))
+import Language.PureScript.Types (SourceType, Type(..), Constraint (..), srcTypeConstructor, srcTypeApp, rowToSortedList, RowListItem(..), replaceTypeVars, everywhereOnTypes)
 import Language.PureScript.AST.Binders qualified as A
 import Language.PureScript.AST.Declarations qualified as A
 import Control.Monad.Supply.Class (MonadSupply)
@@ -57,6 +58,7 @@ import Language.PureScript.TypeChecker.Monad
 import Language.PureScript.Pretty.Values (renderValue)
 import Language.PureScript.PSString (PSString)
 import Language.PureScript.Label (Label(..))
+import Data.Bifunctor (Bifunctor(..))
 
 
 {- UTILITIES -}
@@ -64,6 +66,28 @@ import Language.PureScript.Label (Label(..))
 -- | Type synonym for a monad that has all of the required typechecker functionality
 type M m = (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
 
+ctorArgs :: SourceType -> [SourceType]
+ctorArgs (TypeApp _ t1 t2) = ctorArgs t1 <> [t2]
+ctorArgs _  = []
+
+ctorFun :: SourceType -> Maybe SourceType
+ctorFun (TypeApp _ t1 _) = go t1
+  where
+    go (TypeApp _ tx _) = case ctorFun tx of
+      Nothing -> Just tx
+      Just tx' -> Just tx'
+    go other = Just other
+ctorFun _ = Nothing
+
+analyzeCtor :: SourceType -> Maybe (SourceType,[SourceType])
+analyzeCtor t = (,ctorArgs t) <$> ctorFun t
+
+
+instantiate :: SourceType -> [SourceType] -> SourceType
+instantiate ty [] = ty
+instantiate (ForAll _ _ var _ inner _) (t:ts) = replaceTypeVars var t $ instantiate inner ts
+instantiate other _ = other
+
 -- | Traverse a literal. Note that literals are usually have a type like `Literal (Expr a)`. That is: The `a` isn't typically an annotation, it's an expression type
 traverseLit :: forall m a b. Monad m => (a -> m b) -> Literal a -> m (Literal b)
 traverseLit f = \case
@@ -87,8 +111,8 @@ inferType Nothing e = traceM ("**********HAD TO INFER TYPE FOR: (" <> renderValu
 withInstantiatedFunType :: M m => ModuleName -> SourceType -> (SourceType -> SourceType -> m (Expr Ann)) -> m (Expr Ann)
 withInstantiatedFunType mn ty act = case instantiatePolyType mn ty of
   (a :-> b, replaceForalls, bindAct) -> bindAct $ replaceForalls <$> act a b
-  (other,_,_) -> error
-                 $ "Internal error. Expected a function type, but got: " <> ppType 1000 other
+  (other,_,_) -> let !showty = LT.unpack (pShow other)
+                 in error $ "Internal error. Expected a function type, but got: " <> showty
 {- This function more-or-less contains our strategy for handling polytypes (quantified or constrained types). It returns a tuple T such that:
      - T[0] is the inner type, where all of the quantifiers and constraints have been removed. We just instantiate the quantified type variables to themselves (I guess?) - the previous
        typchecker passes should ensure that quantifiers are all well scoped and that all essential renaming has been performed. Typically, the inner type should be a function.
@@ -105,22 +129,33 @@ withInstantiatedFunType mn ty act = case instantiatePolyType mn ty of
 -- TODO: Explicitly return two sourcetypes for arg/return types
 instantiatePolyType :: M m => ModuleName -> SourceType-> (SourceType, Expr b -> Expr b, m a -> m a)
 instantiatePolyType mn = \case
-  ForAll _ vis var mbk t mSkol -> case instantiatePolyType mn t of
+  ForAll ann vis var mbk t mSkol -> case instantiatePolyType mn t of
     (inner,g,act) ->
       let f = \case
                 Abs ann' ty' ident' expr' ->
-                  Abs ann' (ForAll () vis var (purusTy <$> mbk) (purusTy ty') mSkol) ident' expr'
+                  Abs ann' (ForAll ann vis var (purusTy <$> mbk) (purusTy ty') mSkol) ident' expr'
                 other -> other
           -- FIXME: kindType?
           act' ma = withScopedTypeVars mn [(var,kindType)] $ act ma -- NOTE: Might need to pattern match on mbk and use the real kind (though in practice this should always be of kind Type, I think?)
       in (inner, f . g, act')
-  ConstrainedType _  Constraint{..} t -> case instantiatePolyType mn t of
+  -- this branch should be deprecated
+  {-
+   ConstrainedType _  Constraint{..} t -> case instantiatePolyType mn t of
     (inner,g,act) ->
       let dictTyName :: Qualified (ProperName 'TypeName) = dictTypeName . coerceProperName <$> constraintClass
           dictTyCon = srcTypeConstructor dictTyName
           dictTy = foldl srcTypeApp dictTyCon constraintArgs
           act' ma = bindLocalVariables [(NullSourceSpan,Ident "dict",dictTy,Defined)] $ act ma
       in (function dictTy inner,g,act')
+   -}
+  fun@(a :-> r) ->  case analyzeCtor a of
+      Just (TypeConstructor ann ctor@(Qualified qb nm), args) ->
+        if isDictTypeName nm
+          then
+            let act' ma = bindLocalVariables [(NullSourceSpan,Ident "dict",a,Defined)] $ ma
+            in (fun,id,act')
+          else (fun,id,id)
+      other -> (fun,id,id)
   other -> (other,id,id)
 
 -- In a context where we expect a Record type (object literals, etc), unwrap the record and get at the underlying rowlist
@@ -132,6 +167,7 @@ unwrapRecord = \case
   go :: RowListItem a -> (PSString, Type a)
   go RowListItem{..} = (runLabel rowListLabel, rowListType)
 
+
 traceNameTypes :: M m => m ()
 traceNameTypes  = do
   nametypes <- getEnv >>= pure . debugNames
@@ -155,17 +191,41 @@ desugarConstraintType' = \case
     in function dictTy inner
   other -> other
 
-desugarConstraintType :: M m => Qualified Ident -> m ()
-desugarConstraintType i = do
+desugarConstraintTypes :: M m =>  m ()
+desugarConstraintTypes  = do
   env <- getEnv
-  let oldNameTypes = names env
-  case M.lookup i oldNameTypes of
-    Just (t,k,v) -> do
-      let newVal = (desugarConstraintType' t, k, v)
-          newNameTypes = M.insert i newVal oldNameTypes
-          newEnv = env {names = newNameTypes}
-      modify' $ \checkstate -> checkstate {checkEnv = newEnv}
+  let f = everywhereOnTypes desugarConstraintType'
 
+      oldNameTypes = names env
+      desugaredNameTypes = (\(st,nk,nv) -> (f st,nk,nv)) <$> oldNameTypes
+
+      oldTypes = types env
+      desugaredTypes = first f <$> oldTypes
+
+      oldCtors = dataConstructors env
+      desugaredCtors = (\(a,b,c,d) -> (a,b,f c,d)) <$> oldCtors
+
+      oldSynonyms = typeSynonyms env
+      desugaredSynonyms = second f <$> oldSynonyms
+
+      newEnv = env { names = desugaredNameTypes
+                   , types = desugaredTypes
+                   , dataConstructors = desugaredCtors
+                   , typeSynonyms = desugaredSynonyms }
+
+  modify' $ \checkstate -> checkstate {checkEnv = newEnv}
+
+desugarConstraintsInDecl :: A.Declaration -> A.Declaration
+desugarConstraintsInDecl = \case
+  A.BindingGroupDeclaration decls ->
+    A.BindingGroupDeclaration
+      $ (\(annIdent,nk,expr) -> (annIdent,nk,overTypes desugarConstraintType' expr)) <$> decls
+  A.ValueDecl ann name nk bs [A.MkUnguarded e] ->
+     A.ValueDecl ann name nk bs [A.MkUnguarded $ overTypes desugarConstraintType' e]
+  A.DataDeclaration ann declTy tName args ctorDecs ->
+    let fixCtor (A.DataConstructorDeclaration a nm fields) = A.DataConstructorDeclaration a nm (second (everywhereOnTypes desugarConstraintType') <$> fields)
+    in A.DataDeclaration ann declTy tName args (fixCtor <$> ctorDecs)
+  other -> other
 
 
 -- Gives much more readable output (with colors for brackets/parens!) than plain old `show`
@@ -200,8 +260,9 @@ showIdent' :: Ident -> String
 showIdent' = T.unpack . runIdent
 
 -- | Turns a `Type a` into a `Type ()`. We shouldn't need source position information for types.
-purusTy :: Type a -> PurusType
-purusTy = fmap (const ())
+-- NOTE: Deprecated (probably)
+purusTy :: SourceType -> PurusType
+purusTy = id -- fmap (const ())
 
 -- | Given a class name, return the TypeClassData associated with the name.
 getTypeClassData :: M m => Qualified (ProperName 'ClassName) -> m TypeClassData
diff --git a/src/Language/PureScript/CoreFn/Expr.hs b/src/Language/PureScript/CoreFn/Expr.hs
index f243761e1..9b9591808 100644
--- a/src/Language/PureScript/CoreFn/Expr.hs
+++ b/src/Language/PureScript/CoreFn/Expr.hs
@@ -11,10 +11,10 @@ import Language.PureScript.AST.Literals (Literal)
 import Language.PureScript.CoreFn.Binders (Binder)
 import Language.PureScript.Names (Ident, ProperName, ProperNameType(..), Qualified)
 import Language.PureScript.PSString (PSString)
-import Language.PureScript.Types (Type)
+import Language.PureScript.Types (Type, SourceType)
 
 
-type PurusType = Type ()
+type PurusType = SourceType -- Type ()
 
 -- |
 -- Data type for expressions and terms
diff --git a/src/Language/PureScript/CoreFn/Pretty.hs b/src/Language/PureScript/CoreFn/Pretty.hs
index 60975d76b..90c86c097 100644
--- a/src/Language/PureScript/CoreFn/Pretty.hs
+++ b/src/Language/PureScript/CoreFn/Pretty.hs
@@ -74,7 +74,7 @@ prettyPrintValue :: Int -> Expr a -> Box
 -- prettyPrintValue d _ | d < 0 = text "..."
 prettyPrintValue d (Accessor _ ty prop val) = prettyPrintValueAtom (d - 1) val `before` textT ("." Monoid.<> prettyPrintObjectKey prop)
 prettyPrintValue d (ObjectUpdate ann _ty o _copyFields ps) = prettyPrintValueAtom (d - 1) o `beforeWithSpace` list '{' '}' (uncurry (prettyPrintUpdateEntry d)) ps
-prettyPrintValue d (App ann _ val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg
+prettyPrintValue d (App ann ty val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg
 prettyPrintValue d (Abs ann ty arg val) = text (oneLine $ '\\' : "(" ++ T.unpack (showIdent arg) ++ ": " ++ ppType (d) (getFunArgTy ty) ++ ") -> ") //  (prettyPrintValue (d-1)  val)
 prettyPrintValue d (Case ann ty values binders) =
   (text "case " <> foldr beforeWithSpace (text "of") (map (prettyPrintValueAtom (d - 1)) values)) //
@@ -110,14 +110,14 @@ prettyPrintDeclaration d b = case b of
   NonRec _ ident expr ->
     vcat left [
       text (oneLine $ T.unpack (showIdent ident) ++ " :: " ++ ppType 0 (exprType expr)  ),
-      text (T.unpack (showIdent ident) ++ " = ") <> prettyPrintValue d expr, -- not sure about the d here
-      text "\n"
+      text (T.unpack (showIdent ident) ++ " = ") <> prettyPrintValue d expr -- not sure about the d here
+
     ]
   Rec bindings -> vsep 1 left $ map (\((_,ident),expr) ->
         vcat left [
           text (oneLine $ T.unpack (showIdent ident) ++ " :: " ++ ppType 0 (exprType expr)  ),
-          text (T.unpack (showIdent ident) ++ " = ") <> prettyPrintValue (d-1) expr,
-          text "\n"
+          text (T.unpack (showIdent ident) ++ " = ") <> prettyPrintValue (d-1) expr
+
       ]) bindings
 
 prettyPrintCaseAlternative :: Int -> CaseAlternative a -> Box
diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
index cab4e45f5..88fd5f1fa 100644
--- a/src/Language/PureScript/Environment.hs
+++ b/src/Language/PureScript/Environment.hs
@@ -379,6 +379,10 @@ pattern ArrayT :: Type a -> Type a
 pattern ArrayT a <-
   TypeApp _ (TypeConstructor _ C.Array) a
 
+pattern (:$) :: Type a -> Type a -> Type a
+pattern f :$ a <-
+  TypeApp _ f a
+
 arrayT :: Type a -> Type ()
 arrayT = TypeApp () (TypeConstructor () C.Array) . fmap (const ())
 
@@ -388,7 +392,7 @@ pattern RecordT a <-
 
 
 
-getFunArgTy :: Type () -> Type ()
+getFunArgTy :: Type a -> Type a
 getFunArgTy = \case
   a :-> _ -> a
   ForAll _ _ _ _ t  _ -> getFunArgTy t
diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs
index 4162faa00..a1e13c321 100644
--- a/src/Language/PureScript/Make/Actions.hs
+++ b/src/Language/PureScript/Make/Actions.hs
@@ -60,6 +60,7 @@ import System.FilePath ((</>), makeRelative, splitPath, normalise, splitDirector
 import System.FilePath.Posix qualified as Posix
 import System.IO (stderr)
 import Language.PureScript.CoreFn.ToJSON (moduleToJSON)
+import Language.PureScript.CoreFn.Pretty (prettyPrintModule')
 
 -- | Determines when to rebuild a module
 data RebuildPolicy
@@ -263,7 +264,9 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
     when (S.member Docs codegenTargets) $ do
       lift $ writeJSONFile (outputFilename mn "docs.json") docs
     when (S.member CoreFn codegenTargets) $ do
-      lift $ writeJSONFile (targetFilename mn CoreFn) (moduleToJSON (makeVersion [0,0,1]) m)
+      let targetFile = (targetFilename mn CoreFn)
+      lift $ writeJSONFile targetFile (moduleToJSON (makeVersion [0,0,1]) m)
+      lift $ makeIO "write pretty core" $ writeFile (targetFile <> ".pretty") (prettyPrintModule' m)
     when (S.member CheckCoreFn codegenTargets) $ do
       let mn' = T.unpack (runModuleName mn)
       mabOldModule <- lift $ readJSONFile  (targetFilename mn CoreFn)
diff --git a/tests/purus/passing/Misc/Lib.purs b/tests/purus/passing/Misc/Lib.purs
new file mode 100644
index 000000000..99f05ec45
--- /dev/null
+++ b/tests/purus/passing/Misc/Lib.purs
@@ -0,0 +1,177 @@
+module Lib where
+
+{- Type Classes -}
+-- Single Param
+class Eq a where
+  eq :: a -> a -> Boolean
+
+minus :: Int -> Int -> Int
+minus _ _ = 42
+
+instance Eq Int where
+  eq _ _ = true
+
+testEq :: Boolean
+testEq = eq 1 2
+
+{- Tomasz's Counterexample -}
+workingEven :: Int -> Int
+workingEven n =
+    if n `eq` 0 then 1
+    else 42
+
+brokenEven :: Int -> Int -- N.B. shouldn't be broken anymore :)
+brokenEven n =
+    if n `eq` 0 then 1
+    else brokenEven (n `minus` 2)
+
+-- Multi Param
+class Eq2 a b where
+  eq2 :: a -> b -> Boolean
+
+instance Eq2 Int Boolean where
+  eq2 _ _ = true
+
+testEq2 :: Boolean
+testEq2 = eq2 101 false
+
+{- Binders (also tests a bunch of other things by happenstance) -}
+
+-- Unit test type for inferBinder'
+data TestBinderSum =
+    ConInt Int
+  | ConInts (Array Int)
+  | ConBoolean Boolean
+  | ConString String
+  | ConChar Char
+  | ConNested TestBinderSum
+  | ConQuantified (forall x. x -> Int)
+  | ConConstrained (forall x. Eq x => x -> Int) -- kind of nonsensical
+  | ConObject {objField :: Int}
+  | ConObjectQuantified {objFieldQ :: forall x. x -> Int}
+
+testBinders :: TestBinderSum  -> Int
+testBinders x = case x of
+  a@(ConInt 3)  -> 1   -- NamedBinder, ConstructorBinder, Int LitBinder
+  ConInt a -> a -- ConstructorBinder enclosing VarBinder
+  ConInts ([3] :: Array Int) -> 2  -- Array LitBinder, TypedBinder
+  ConInts [a,b] -> b  -- VarBinders enclosed in Array LitBinder
+  ConBoolean true ->  4 -- Bool LitBinder
+  ConChar '\n' -> 5 -- Char LitBinder
+  ConNested (ConInt 2) -> 6 -- Nested ConstructorBinders
+  ConQuantified f -> f "hello"
+  ConConstrained f -> f 2
+  ConNested other -> 7
+  ConObject obj -> obj.objField
+  ConObjectQuantified objQ -> objQ.objFieldQ "world"
+  ConObject {objField: f} -> f
+  _         -> 0
+
+
+{- Binding groups (with and w/o type anns) -}
+mutuallyRecursiveBindingGroup :: Int
+mutuallyRecursiveBindingGroup =
+  let f :: Int -> Int
+      f x = g 2
+      h :: Int -> Int -> Int
+      h x y = y
+      g :: Int -> Int
+      g y = h (f y) 3
+  in g 3
+
+{- TODO: Make this a shouldfail test
+mutuallyRecursiveBindingGroupNoTypes :: Int
+mutuallyRecursiveBindingGroupNoTypes =
+  let f' x = g' 2
+      h' x y = y
+      g' y = h' (f' y) 3
+  in g' 3
+-}
+nestedBinds :: Int
+nestedBinds =
+  let  f :: Int -> Int
+       f _ = 4
+
+       g :: forall (a :: Type). a -> Int
+       g _ = 5
+
+       h = let i = g "hello"
+               j = f i
+           in f j
+  in h
+
+{- Data declarations -}
+data ADataRec = ADataRec {hello :: Int, world :: Boolean}
+
+newtype ANewtypeRec = ANewTypeRec {foo :: Int}
+
+data ASum = Constr1 Int | Constr2 Boolean
+
+{- lits -}
+anIntLit :: Int
+anIntLit = 1
+
+aStringLit :: String
+aStringLit = "woop"
+
+aVal :: Int
+aVal = 1
+
+
+aBool :: Boolean
+aBool = true
+
+aList :: Array Int
+aList = [1,2,3,4,5]
+
+{- Functions -}
+
+aFunction :: forall x. x -> (forall y. y -> Int) -> Int
+aFunction any f = f any
+
+aFunction2 :: Int -> Array Int
+aFunction2 x = [x,1]
+
+aFunction3 :: Int -> Int
+aFunction3 x = if (eq x 2) then 4 else 1
+
+aFunction4 :: forall (r :: Row Type). {a :: Int | r} -> Int
+aFunction4 r = r.a
+
+aFunction5 :: Int
+aFunction5 = aFunction4 {a: 2}
+
+aFunction6 :: Int
+aFunction6 = aFunction [] go
+  where
+    go :: forall (z :: Type). z -> Int
+    go _ = 10
+
+{- Objects -}
+
+anObj :: {foo :: Int}
+anObj = {foo: 3}
+
+objUpdate :: {foo :: Int}
+objUpdate = anObj {foo = 4}
+
+polyInObj :: {bar :: forall x. x -> Int, baz :: Int}
+polyInObj = {bar: go, baz : 100}
+  where
+    go :: forall y. y -> Int
+    go _ = 5
+
+polyInObjMatch :: Int
+polyInObjMatch = case polyInObj of
+  {bar: f, baz: _} -> f "hello"
+
+aPred :: Int -> Boolean
+aPred _ = true
+
+{- We should probably just remove guarded case branches, see slack msg
+guardedCase :: Int
+guardedCase = case polyInObj of
+  {bar: _, baz: x}
+              | eq @Int x 4 -> x
+  _ -> 0
+-}

From c99c476f7c4021f7990525c243bc897402a7d460 Mon Sep 17 00:00:00 2001
From: gnumonik <gnumonik@protonmail.com>
Date: Wed, 28 Feb 2024 23:35:16 -0500
Subject: [PATCH 04/20] Fixed issue w/ transitive imports resulting from
 explicitly desguaring dictionary types, (sort of) fixed let-generalization,
 ported over more tests

---
 src/Language/PureScript/CoreFn/Desugar.hs     | 175 ++++++++----------
 .../PureScript/CoreFn/Desugar/Utils.hs        |  46 +++--
 src/Language/PureScript/Environment.hs        |   4 +-
 src/Language/PureScript/Make.hs               |  16 +-
 src/Language/PureScript/Sugar.hs              |   1 +
 src/Language/PureScript/Sugar/TypeClasses.hs  |   6 +-
 src/Language/PureScript/TypeChecker/Monad.hs  |   1 +
 src/Language/PureScript/TypeChecker/Types.hs  |   7 +-
 tests/TestPurus.hs                            |  13 +-
 tests/purus/passing/Misc/Lib.purs             |   4 +-
 .../passing/PendingConflictingImports/A.purs  |   4 +
 .../passing/PendingConflictingImports/B.purs  |   4 +
 .../PendingConflictingImports.purs            |   8 +
 .../passing/PendingConflictingImports2/A.purs |   4 +
 .../PendingConflictingImports2.purs           |   9 +
 tests/purus/passing/ReExportQualified/A.purs  |   3 +
 tests/purus/passing/ReExportQualified/B.purs  |   3 +
 tests/purus/passing/ReExportQualified/C.purs  |   4 +
 .../ReExportQualified/ReExportQualified.purs  |   9 +
 tests/purus/passing/RedefinedFixity/M1.purs   |   6 +
 tests/purus/passing/RedefinedFixity/M2.purs   |   3 +
 tests/purus/passing/RedefinedFixity/M3.purs   |   4 +
 .../RedefinedFixity/RedefinedFixity.purs      |   5 +
 .../passing/ResolvableScopeConflict/A.purs    |   4 +
 .../passing/ResolvableScopeConflict/B.purs    |   7 +
 .../ResolvableScopeConflict.purs              |  12 ++
 .../passing/ResolvableScopeConflict2/A.purs   |   7 +
 .../ResolvableScopeConflict2.purs             |  14 ++
 .../passing/ResolvableScopeConflict3/A.purs   |   4 +
 .../ResolvableScopeConflict3.purs             |   9 +
 .../ShadowedModuleName.purs                   |   7 +
 .../passing/ShadowedModuleName/Test.purs      |   6 +
 .../passing/TransitiveImport/Middle.purs      |   9 +
 .../purus/passing/TransitiveImport/Test.purs  |   9 +
 .../TransitiveImport/TransitiveImport.purs    |   6 +
 35 files changed, 304 insertions(+), 129 deletions(-)
 create mode 100644 tests/purus/passing/PendingConflictingImports/A.purs
 create mode 100644 tests/purus/passing/PendingConflictingImports/B.purs
 create mode 100644 tests/purus/passing/PendingConflictingImports/PendingConflictingImports.purs
 create mode 100644 tests/purus/passing/PendingConflictingImports2/A.purs
 create mode 100644 tests/purus/passing/PendingConflictingImports2/PendingConflictingImports2.purs
 create mode 100644 tests/purus/passing/ReExportQualified/A.purs
 create mode 100644 tests/purus/passing/ReExportQualified/B.purs
 create mode 100644 tests/purus/passing/ReExportQualified/C.purs
 create mode 100644 tests/purus/passing/ReExportQualified/ReExportQualified.purs
 create mode 100644 tests/purus/passing/RedefinedFixity/M1.purs
 create mode 100644 tests/purus/passing/RedefinedFixity/M2.purs
 create mode 100644 tests/purus/passing/RedefinedFixity/M3.purs
 create mode 100644 tests/purus/passing/RedefinedFixity/RedefinedFixity.purs
 create mode 100644 tests/purus/passing/ResolvableScopeConflict/A.purs
 create mode 100644 tests/purus/passing/ResolvableScopeConflict/B.purs
 create mode 100644 tests/purus/passing/ResolvableScopeConflict/ResolvableScopeConflict.purs
 create mode 100644 tests/purus/passing/ResolvableScopeConflict2/A.purs
 create mode 100644 tests/purus/passing/ResolvableScopeConflict2/ResolvableScopeConflict2.purs
 create mode 100644 tests/purus/passing/ResolvableScopeConflict3/A.purs
 create mode 100644 tests/purus/passing/ResolvableScopeConflict3/ResolvableScopeConflict3.purs
 create mode 100644 tests/purus/passing/ShadowedModuleName/ShadowedModuleName.purs
 create mode 100644 tests/purus/passing/ShadowedModuleName/Test.purs
 create mode 100644 tests/purus/passing/TransitiveImport/Middle.purs
 create mode 100644 tests/purus/passing/TransitiveImport/Test.purs
 create mode 100644 tests/purus/passing/TransitiveImport/TransitiveImport.purs

diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs
index d52a00fea..27259b840 100644
--- a/src/Language/PureScript/CoreFn/Desugar.hs
+++ b/src/Language/PureScript/CoreFn/Desugar.hs
@@ -1,17 +1,17 @@
 {- HLINT ignore "Use void" -}
 {- HLINT ignore "Use <$" -}
-{-# LANGUAGE TypeApplications #-}
+
 module Language.PureScript.CoreFn.Desugar(moduleToCoreFn) where
 
 import Prelude
-import Protolude (ordNub, orEmpty, zipWithM, MonadError (..), sortOn, (<=<), Bifunctor (bimap))
+import Protolude (ordNub, orEmpty, zipWithM, MonadError (..), sortOn, Bifunctor (bimap))
 
 import Data.Maybe (mapMaybe)
 import Data.List.NonEmpty qualified as NEL
 import Data.Map qualified as M
 
 import Language.PureScript.AST.Literals (Literal(..))
-import Language.PureScript.AST.SourcePos (pattern NullSourceSpan, SourceSpan(..), SourceAnn)
+import Language.PureScript.AST.SourcePos (SourceSpan(..), SourceAnn)
 import Language.PureScript.CoreFn.Ann (Ann, ssAnn)
 import Language.PureScript.CoreFn.Binders (Binder(..))
 import Language.PureScript.CoreFn.Expr (Bind(..), CaseAlternative(..), Expr(..), Guard, exprType)
@@ -27,20 +27,20 @@ import Language.PureScript.Environment (
   isDictTypeName,
   lookupConstructor,
   lookupValue,
-  purusFun,
   NameVisibility (..),
   tyBoolean,
   tyFunction,
   tyString,
   tyChar,
   tyInt,
-  tyNumber, function, pattern (:$),pattern RecordT )
+  tyNumber,
+  function,
+  pattern RecordT )
 import Language.PureScript.Label (Label(..))
 import Language.PureScript.Names (
   pattern ByNullSourcePos, Ident(..),
   ModuleName,
   ProperName(..),
-  ProperNameType(..),
   Qualified(..),
   QualifiedBy(..),
   mkQualified,
@@ -51,9 +51,7 @@ import Language.PureScript.PSString (PSString, prettyPrintString)
 import Language.PureScript.Types (
   pattern REmptyKinded,
   SourceType,
-  Type(..),
-  srcTypeConstructor,
-  srcTypeVar, srcTypeApp, quantify, eqType, containsUnknowns, replaceTypeVars, rowToList, RowListItem (..), freeTypeVariables)
+  Type(..), quantify, eqType, containsUnknowns, rowToList, RowListItem (..))
 import Language.PureScript.AST.Binders qualified as A
 import Language.PureScript.AST.Declarations qualified as A
 import Language.PureScript.AST.SourcePos qualified as A
@@ -65,8 +63,7 @@ import Language.PureScript.TypeChecker.Types
     ( checkTypeKind,
       SplitBindingGroup(SplitBindingGroup),
       TypedValue'(TypedValue'),
-      typeDictionaryForBindingGroup,
-      infer, instantiatePolyTypeWithUnknowns, inferBinder, instantiateForBinders )
+      typeDictionaryForBindingGroup )
 import Data.List.NonEmpty qualified as NE
 import Language.PureScript.TypeChecker.Unify (unifyTypes)
 import Control.Monad (forM, (>=>), foldM)
@@ -93,12 +90,9 @@ import Language.PureScript.CoreFn.Desugar.Utils
       getConstructorMeta,
       getLetMeta,
       getModuleName,
-      getTypeClassArgs,
       getValueMeta,
       importToCoreFn,
       inferType,
-      instantiatePolyType,
-      pTrace,
       printEnv,
       properToIdent,
       purusTy,
@@ -109,13 +103,11 @@ import Language.PureScript.CoreFn.Desugar.Utils
       traverseLit,
       wrapTrace,
       desugarConstraintTypes,
-      M, unwrapRecord, withInstantiatedFunType, desugarConstraintsInDecl, analyzeCtor, instantiate, ctorArgs
+      M, unwrapRecord, withInstantiatedFunType, desugarConstraintsInDecl, analyzeCtor, instantiate, ctorArgs, instantiatePolyType, lookupDictType
       )
 import Text.Pretty.Simple (pShow)
 import Data.Text.Lazy qualified as LT
 import Data.Set qualified as S
-import Language.PureScript.TypeChecker (replaceAllTypeSynonyms)
-import Language.PureScript.TypeChecker.Skolems (introduceSkolemScope)
 
 {-
     CONVERSION MACHINERY
@@ -193,8 +185,7 @@ declToCoreFn _ (A.DataDeclaration (ss, com) Newtype name _ [ctor]) = wrapTrace (
 declToCoreFn _ d@(A.DataDeclaration _ Newtype _ _ _) =
   error $ "Found newtype with multiple constructors: " ++ show d
 -- Data declarations get turned into value declarations for the constructor(s)
-declToCoreFn  mn (A.DataDeclaration (ss, com) Data tyName _ ctors) = wrapTrace ("declToCoreFn DATADEC " <>  T.unpack (runProperName tyName)) $ do
-  traverse go ctors
+declToCoreFn  mn (A.DataDeclaration (ss, com) Data tyName _ ctors) = wrapTrace ("declToCoreFn DATADEC " <>  T.unpack (runProperName tyName)) $ traverse go ctors
  where
   go ctorDecl = do
     env <- gets checkEnv
@@ -208,6 +199,7 @@ declToCoreFn mn (A.DataBindingGroupDeclaration ds) = wrapTrace  "declToCoreFn DA
 declToCoreFn  mn (A.ValueDecl (ss, _) name _ _ [A.MkUnguarded e]) = wrapTrace ("decltoCoreFn VALDEC " <> show name) $ do
   traceM $ renderValue 100 e
   (valDeclTy,nv) <- lookupType (spanStart ss) name
+  traceM (ppType 100 valDeclTy)
   bindLocalVariables [(ss,name,valDeclTy,nv)] $ do
       expr <- exprToCoreFn mn ss (Just valDeclTy) e -- maybe wrong? might need to bind something here?
       pure [NonRec (ssA ss) name expr]
@@ -221,10 +213,10 @@ declToCoreFn  mn (A.BindingGroupDeclaration ds) = wrapTrace "declToCoreFn BINDIN
    -- If we only ever call this on a top-level binding group then this should be OK, all the exprs should be explicitly typed
    extractTypeAndPrepareBind :: ((A.SourceAnn, Ident), NameKind,  A.Expr) -> (A.Expr, (SourceSpan,Ident,SourceType,NameVisibility))
    extractTypeAndPrepareBind (((ss',_),ident),_,A.TypedValue _ e ty) = (e,(ss',ident,ty,Defined))
-   extractTypeAndPrepareBind (((ss',_),ident),_,_) = error $ "Top level declaration " <> (showIdent' ident) <> " should have a type annotation, but does not"
+   extractTypeAndPrepareBind (((_,_),ident),_,_) = error $ "Top level declaration " <> showIdent' ident <> " should have a type annotation, but does not"
 
    goRecBindings :: (A.Expr, (SourceSpan,Ident,SourceType,NameVisibility)) -> m ((Ann, Ident), Expr Ann)
-   goRecBindings (expr,(ss',ident,ty,nv)) = do
+   goRecBindings (expr,(ss',ident,ty,_)) = do
      expr' <- exprToCoreFn mn ss' (Just ty) expr
      pure ((ssA ss',ident), expr')
 -- TODO: Avoid catchall case
@@ -232,10 +224,10 @@ declToCoreFn _ _ = pure []
 
 -- Desugars expressions from AST to typed CoreFn representation.
 exprToCoreFn :: forall m. M m => ModuleName -> SourceSpan -> Maybe SourceType -> A.Expr -> m (Expr Ann)
-exprToCoreFn mn ss (Just arrT@(ArrayT ty)) astlit@(A.Literal ss' (ArrayLiteral ts)) = wrapTrace ("exprToCoreFn ARRAYLIT " <> renderValue 100 astlit) $ do
+exprToCoreFn mn ss (Just arrT@(ArrayT ty)) astlit@(A.Literal _ (ArrayLiteral ts)) = wrapTrace ("exprToCoreFn ARRAYLIT " <> renderValue 100 astlit) $ do
   arr <- ArrayLiteral <$> traverse (exprToCoreFn mn ss (Just ty)) ts
   pure $ Literal (ss,[],Nothing) arrT  arr
-exprToCoreFn mn ss (Just recTy@(RecordT row)) astlit@(A.Literal ss' (ObjectLiteral objFields)) = wrapTrace ("exprToCoreFn OBJECTLIT " <> renderValue 100 astlit) $ do
+exprToCoreFn mn ss (Just recTy@(RecordT row)) astlit@(A.Literal _ (ObjectLiteral objFields)) = wrapTrace ("exprToCoreFn OBJECTLIT " <> renderValue 100 astlit) $ do
   traceM $ "ObjLitTy: " <> show row
   let (tyFields,_) = rowToList row
       tyMap = M.fromList $ (\x -> (runLabel (rowListLabel x),x)) <$> tyFields
@@ -293,34 +285,46 @@ exprToCoreFn mn _ (Just t) (A.Abs (A.VarBinder ssb name) v) = wrapTrace ("exprTo
 -- By the time we receive the AST, only Lambdas w/ a VarBinder should remain
 -- TODO: Better failure message if we pass in 'Nothing' as the (Maybe Type) arg for an Abstraction
 exprToCoreFn _  _ t lam@(A.Abs _ _) =
-  internalError $ "Abs with Binder argument was not desugared before exprToCoreFn: \n" <> show lam <> "\n\n" <> show (const () <$> t)
+  internalError $ "Abs with Binder argument was not desugared before exprToCoreFn: \n" <> renderValue 100  lam <> "\n\n" <> show (ppType 100 <$>  t)
 -- Ad hoc machinery for handling desugared type class dictionaries. As noted above, the types "lie" in generated code.
 -- NOTE: Not 100% sure this is necessary anymore now that we have instantiatePolyType
 -- TODO: Investigate whether still necessary
 -- FIXME: Something's off here, see output for 4310
 exprToCoreFn mn ss mTy app@(A.App fun arg)
   | isDictCtor fun = wrapTrace "exprToCoreFn APP DICT " $ do
+      traceM $ "APP Dict type" <> show (ppType 100 <$> mTy)
+      traceM $ "APP Dict expr:\n" <> renderValue 100 app
       let analyzed = mTy >>= analyzeCtor
           prettyAnalyzed = bimap (ppType 100) (fmap (ppType 100)) <$> analyzed
       traceM $ "APP DICT analyzed:\n" <> show prettyAnalyzed
-      case analyzed of
-        Just (TypeConstructor ann ctor@(Qualified qb nm), args) -> do
-          traceM $ "APP Dict name: " <> T.unpack (runProperName nm)
-          env <- getEnv
-          case M.lookup (Qualified qb $ coerceProperName nm) (dataConstructors env) of
-            Just (_, _, ty, _) -> do
-                traceM $ "APP Dict original type:\n" <> ppType 100 ty
-                case instantiate ty args  of
-                  iFun@(iArg :-> iRes) -> do
-                    traceM $ "APP Dict iArg:\n" <> ppType 100 iArg
-                    traceM $ "APP Dict iRes:\n" <> ppType 100 iRes
-                    fun' <- exprToCoreFn mn ss (Just iFun) fun
-                    arg' <- exprToCoreFn mn ss (Just iArg) arg
-                    pure $ App (ss,[],Nothing) iRes fun' arg'
-                  _ -> error "dict ctor has to have a function type"
-            _ -> throwError . errorMessage' ss . UnknownName . fmap DctorName $ (Qualified qb $ coerceProperName nm)
-        Just (other,_) -> error $ error $ "APP Dict not a constructor type (impossible?): \n" <> ppType 100 other
-        Nothing -> error $ "APP Dict w/o type passed in:\n" <> renderValue 100 app
+      case mTy of
+        Just iTy ->
+          case analyzed of
+            Just (TypeConstructor _ (Qualified qb nm), args) -> do
+              traceM $ "APP Dict name: " <> T.unpack (runProperName nm)
+              env <- getEnv
+              case M.lookup (Qualified qb $ coerceProperName nm) (dataConstructors env) of
+                Just (_, _, ty, _) -> do
+                    traceM $ "APP Dict original type:\n" <> ppType 100 ty
+                    case instantiate ty args  of
+                      iFun@(iArg :-> iRes) -> do
+                        traceM $ "APP Dict iArg:\n" <> ppType 100 iArg
+                        traceM $ "APP Dict iRes:\n" <> ppType 100 iRes
+                        fun' <- exprToCoreFn mn ss (Just iFun) fun
+                        arg' <- exprToCoreFn mn ss (Just iArg) arg
+                        pure $ App (ss,[],Nothing) iTy fun' arg'
+                      _ -> error "dict ctor has to have a function type"
+                _ -> throwError . errorMessage' ss . UnknownName . fmap DctorName $ Qualified qb (coerceProperName nm)
+            Just (other,_) -> error $  "APP Dict not a constructor type (impossible here?): \n" <> ppType 100 other
+            Nothing ->  do
+              -- REVIEW: This might be the one place where `kindType` in instantiatePolyType is wrong, check the kinds
+              --         in the output
+              let (inner,g,act) = instantiatePolyType mn iTy
+              act (exprToCoreFn mn ss (Just inner) app) >>= \case
+                 App ann' _ e1 e2 -> pure . g $ App ann' iTy e1 e2
+                 other -> error "An application desguared to something else. This should not be possible."
+        Nothing ->  error $ "APP Dict w/o type passed in (impossible to infer):\n" <> renderValue 100 app
+
 
           -- type should be something like: Test$Dict (Tuple a b)
           -- lookup the type of the Dict ctor (should have one quantified record arg), i.e.
@@ -329,51 +333,29 @@ exprToCoreFn mn ss mTy app@(A.App fun arg)
           --  {runTest :: Tuple a b -> String}
 
   | otherwise =  wrapTrace "exprToCoreFn APP" $ do
-      {-
-      appT <- inferType mTy app
-      fun' <- exprToCoreFn mn ss Nothing fun
-      arg' <- exprToCoreFn mn ss Nothing arg
-      pure $ App (ss, [], Nothing) appT fun' arg'
-      -}
-      fun' <- exprToCoreFn mn ss Nothing fun
-      let funTy = exprType fun'
-      traceM $ "app fun:\n" <> (ppType 100  funTy) <> "\n" <> renderExpr 100 fun'
-      withInstantiatedFunType mn  funTy $ \a b -> do
-        -- fun'' <- exprToCoreFn mn ss (Just $ function a b) fun
-        arg' <- exprToCoreFn mn ss (Just a) arg
-        traceM $ "app arg:\n" <> ppType 100 (exprType arg') <> "\n" <> renderExpr 100 arg'
-        -- unifyTypes b appT
-        pure $ App (ss, [], Nothing) b fun' arg'
-
+      traceM $ renderValue 100 app
+      case mTy of
+        Just appT -> do
+          fun' <- exprToCoreFn mn ss Nothing fun
+          let funTy = exprType fun'
+          traceM $ "app fun:\n" <> ppType 100  funTy <> "\n" <> renderExpr 100 fun'
+          withInstantiatedFunType mn  funTy $ \a b -> do
+            arg' <- exprToCoreFn mn ss (Just a) arg
+            traceM $ "app arg:\n" <> ppType 100 (exprType arg') <> "\n" <> renderExpr 100 arg'
+            pure $ App (ss, [], Nothing) appT fun' arg'
+        Nothing -> do
+          fun' <- exprToCoreFn mn ss Nothing fun
+          let funTy = exprType fun'
+          traceM $ "app fun:\n" <> ppType 100  funTy <> "\n" <> renderExpr 100 fun'
+          withInstantiatedFunType mn  funTy $ \a b -> do
+            arg' <- exprToCoreFn mn ss (Just a) arg
+            traceM $ "app arg:\n" <> ppType 100 (exprType arg') <> "\n" <> renderExpr 100 arg'
+            pure $ App (ss, [], Nothing) b fun' arg'
   where
-  {-
-  mkDictInstBinder = \case
-    A.TypedValue _ e _ -> mkDictInstBinder e
-    A.Abs (A.VarBinder _ss1 (Ident "dict")) (A.Case [A.Var _ (Qualified _ (Ident "dict"))] [A.CaseAlternative [A.ConstructorBinder _ cn@(Qualified _ _) _] [A.MkUnguarded _acsr]]) -> do
-      let className :: Qualified (ProperName 'ClassName) = coerceProperName <$> cn
-      args' <- getTypeClassArgs className
-      let args = zipWith (\i _ -> srcTypeVar $ "dictArg" <> T.pack (show @Int i)) [1..] args'
-          dictTyCon = srcTypeConstructor  (coerceProperName <$> cn)
-          dictTyFreeVars = foldl srcTypeApp dictTyCon args
-          ty = quantify dictTyFreeVars
-      pure [(A.NullSourceSpan,Ident "dict",ty,Defined)]
-    _ -> error "invalid dict accesor expr"
-
-  isDictInstCase = \case
-    A.TypedValue _ e _ -> isDictInstCase e
-    A.Abs (A.VarBinder _ss1 (Ident "dict")) (A.Case [A.Var _ (Qualified _ (Ident "dict"))] [A.CaseAlternative [A.ConstructorBinder _ (Qualified _ name) _] [A.MkUnguarded _acsr]]) -> isDictTypeName name
-    _ -> False
--}
   isDictCtor = \case
     A.Constructor _ (Qualified _ name) -> isDictTypeName name
     A.TypedValue _ e _ -> isDictCtor e
     _ -> False
-  isSynthetic = \case
-    A.App v3 v4            -> isDictCtor v3 || isSynthetic v3 && isSynthetic v4
-    A.Accessor _ v3        -> isSynthetic v3
-    A.Var NullSourceSpan _ -> True
-    A.Unused{}             -> True
-    _                      -> False
 -- Dunno what to do here. Haven't encountered an Unused so far, will need to see one to figure out how to handle them
 exprToCoreFn _ _  _ (A.Unused _) = -- ????? need to figure out what this _is_
   error "Don't know what to do w/ exprToCoreFn A.Unused"
@@ -382,10 +364,12 @@ exprToCoreFn _ _  _ (A.Unused _) = -- ????? need to figure out what this _is_
 exprToCoreFn _ _ _ (A.Var ss ident) = wrapTrace ("exprToCoreFn VAR " <> show ident) $
   gets checkEnv >>= \env -> case lookupValue env ident of
     Just (ty,_,_) -> pure $ Var (ss, [], getValueMeta env ident) (purusTy ty) ident
-    Nothing -> do
+    Nothing -> lookupDictType ident >>= \case
+      Just ty -> pure $  Var (ss, [], getValueMeta env ident) (purusTy ty) ident
+      Nothing -> do
       -- pEnv <- printEnv
-      traceM $ "No known type for identifier " <> show ident -- <> "\n    in:\n" <> LT.unpack (pShow $ names env)
-      error "boom"
+        traceM $ "No known type for identifier " <> show ident -- <> "\n    in:\n" <> LT.unpack (pShow $ names env)
+        error "boom"
 -- If-Then-Else Turns into a case expression
 exprToCoreFn mn ss mTy ifte@(A.IfThenElse cond th el) = wrapTrace "exprToCoreFn IFTE" $ do
   -- NOTE/TODO: Don't need to call infer separately here
@@ -409,15 +393,11 @@ exprToCoreFn mn ss mTy astCase@(A.Case vs alts) = wrapTrace "exprToCoreFn CASE"
   traceM $ "CASE:\n" <> renderValue 100 astCase
   traceM $ "CASE TY:\n" <> show (ppType 100 <$> mTy)
   caseTy <- inferType mTy astCase -- the return type of the branches. This will usually be passed in.
-  ts <- traverse (infer >=> pure . tvType)  vs -- extract type information for the *scrutinees* (need this to properly type the binders. still not sure why exactly this is a list)
-  --(vs_,ts) <- instantiateForBinders vs alts  -- maybe zipWithM
+  (vs',ts) <- unzip <$> traverse (exprToCoreFn mn ss Nothing >=> (\ e -> pure (e, exprType e))) vs -- extract type information for the *scrutinees*
   alts' <- traverse (altToCoreFn mn ss caseTy ts) alts -- see explanation in altToCoreFn. We pass in the types of the scrutinee(s)
-  vs' <- traverse (exprToCoreFn mn ss Nothing) vs
   pure $ Case (ssA ss) (purusTy caseTy) vs' alts'
- where
-   tvType (TypedValue' _ _ t) = t
+
 -- We prioritize the supplied type over the inferred type, since a type should only ever be passed when known to be correct.
--- (I think we have to do this - the inferred type is "wrong" if it contains a class constraint)
 exprToCoreFn  mn ss  (Just ty) (A.TypedValue _ v _) = wrapTrace "exprToCoreFn TV1" $
   exprToCoreFn mn ss (Just ty) v
 exprToCoreFn mn ss Nothing (A.TypedValue _ v ty) = wrapTrace "exprToCoreFn TV2" $
@@ -489,10 +469,12 @@ transformLetBindings mn _ss seen ((A.ValueDecl sa@(ss,_) ident nameKind [] [A.Mk
     transformLetBindings mn _ss seen' rest ret
 -- TODO: Write a question where I ask what can legitimately be inferred as a type in a let binding context
 transformLetBindings mn _ss seen (A.ValueDecl sa@(ss,_) ident nameKind [] [A.MkUnguarded val] : rest) ret = wrapTrace ("transformLetBindings VALDEC " <> showIdent' ident <> " = " <> renderValue 100 val) $ do
-  ty <- inferType Nothing val {- FIXME: This sometimes gives us a type w/ unknowns, but we don't have any other way to get at the type -}
-  if not (containsUnknowns ty)
+  -- ty <- inferType Nothing val {- FIXME: This sometimes gives us a type w/ unknowns, but we don't have any other way to get at the type -}
+  e <- exprToCoreFn mn ss Nothing val
+  let ty = exprType e
+  if not (containsUnknowns ty) -- TODO: Don't need this anymore (shouldn't ever contain unknowns)
     then bindNames (M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (ty, nameKind, Defined)) $ do
-      thisDecl <- declToCoreFn mn (A.ValueDecl sa ident nameKind [] [A.MkUnguarded (A.TypedValue False val ty)])
+      let thisDecl = [NonRec (ssA ss) ident e]
       let seen' = seen ++ thisDecl
       transformLetBindings mn _ss seen' rest ret
     else  error
@@ -572,7 +554,7 @@ inferBinder' val (A.LiteralBinder _ (ObjectLiteral props)) = wrapTrace "inferBin
         else error $ "Error. Object literal in a pattern match is missing fields: " <> show diff
   where
   deduceRowProperties :: M.Map PSString SourceType -> [(PSString,A.Binder)] -> m (M.Map Ident (SourceSpan,SourceType))
-  deduceRowProperties types [] = pure M.empty
+  deduceRowProperties _ [] = pure M.empty
   deduceRowProperties types ((lbl,bndr):rest) = case M.lookup lbl types of
     Nothing -> error $ "Cannot deduce type information for record with label " <> show lbl -- should be impossible after typechecking
     Just ty -> do
@@ -580,8 +562,7 @@ inferBinder' val (A.LiteralBinder _ (ObjectLiteral props)) = wrapTrace "inferBin
       xs <- deduceRowProperties types rest
       pure $ M.union x xs
 -- TODO: Remove ArrayT pattern synonym
-inferBinder' (ArrayT val) (A.LiteralBinder _ (ArrayLiteral binders)) = wrapTrace "inferBinder' ARRAYLIT" $  do
-  M.unions <$> traverse (inferBinder' val) binders
+inferBinder' (ArrayT val) (A.LiteralBinder _ (ArrayLiteral binders)) = wrapTrace "inferBinder' ARRAYLIT" $  M.unions <$> traverse (inferBinder' val) binders
 inferBinder' _ (A.LiteralBinder _ (ArrayLiteral _)) = internalError "bad type in array binder "
 inferBinder' val (A.NamedBinder ss name binder) = wrapTrace ("inferBinder' NAMEDBINDER " <> T.unpack (runIdent name)) $
   warnAndRethrowWithPositionTC ss $ do
diff --git a/src/Language/PureScript/CoreFn/Desugar/Utils.hs b/src/Language/PureScript/CoreFn/Desugar/Utils.hs
index 9bc92bcc1..f3f37e860 100644
--- a/src/Language/PureScript/CoreFn/Desugar/Utils.hs
+++ b/src/Language/PureScript/CoreFn/Desugar/Utils.hs
@@ -59,6 +59,9 @@ import Language.PureScript.Pretty.Values (renderValue)
 import Language.PureScript.PSString (PSString)
 import Language.PureScript.Label (Label(..))
 import Data.Bifunctor (Bifunctor(..))
+import Data.List.NonEmpty qualified as NEL
+import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope (..))
+import Data.List (foldl')
 
 
 {- UTILITIES -}
@@ -66,10 +69,12 @@ import Data.Bifunctor (Bifunctor(..))
 -- | Type synonym for a monad that has all of the required typechecker functionality
 type M m = (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
 
+-- Extract all of the arguments to a type constructor
 ctorArgs :: SourceType -> [SourceType]
 ctorArgs (TypeApp _ t1 t2) = ctorArgs t1 <> [t2]
 ctorArgs _  = []
 
+-- Extract the TyCon ("function") part of an applied Type Constructor
 ctorFun :: SourceType -> Maybe SourceType
 ctorFun (TypeApp _ t1 _) = go t1
   where
@@ -82,7 +87,6 @@ ctorFun _ = Nothing
 analyzeCtor :: SourceType -> Maybe (SourceType,[SourceType])
 analyzeCtor t = (,ctorArgs t) <$> ctorFun t
 
-
 instantiate :: SourceType -> [SourceType] -> SourceType
 instantiate ty [] = ty
 instantiate (ForAll _ _ var _ inner _) (t:ts) = replaceTypeVars var t $ instantiate inner ts
@@ -101,7 +105,7 @@ traverseLit f = \case
 -- | When we call `exprToCoreFn` we sometimes know the type, and sometimes have to infer it. This just simplifies the process of getting the type we want (cuts down on duplicated code)
 inferType :: M m => Maybe SourceType -> A.Expr -> m SourceType
 inferType (Just t) _ = pure t
-inferType Nothing e = traceM ("**********HAD TO INFER TYPE FOR: (" <> renderValue 100 e <> ")") >>
+inferType Nothing e = pTrace ("**********HAD TO INFER TYPE FOR: (" <> renderValue 100 e <> ")") >>
   infer e >>= \case
     TypedValue' _ _ t -> do
       traceM ("TYPE: " <> ppType 100 t)
@@ -138,24 +142,14 @@ instantiatePolyType mn = \case
           -- FIXME: kindType?
           act' ma = withScopedTypeVars mn [(var,kindType)] $ act ma -- NOTE: Might need to pattern match on mbk and use the real kind (though in practice this should always be of kind Type, I think?)
       in (inner, f . g, act')
-  -- this branch should be deprecated
-  {-
-   ConstrainedType _  Constraint{..} t -> case instantiatePolyType mn t of
-    (inner,g,act) ->
-      let dictTyName :: Qualified (ProperName 'TypeName) = dictTypeName . coerceProperName <$> constraintClass
-          dictTyCon = srcTypeConstructor dictTyName
-          dictTy = foldl srcTypeApp dictTyCon constraintArgs
-          act' ma = bindLocalVariables [(NullSourceSpan,Ident "dict",dictTy,Defined)] $ act ma
-      in (function dictTy inner,g,act')
-   -}
-  fun@(a :-> r) ->  case analyzeCtor a of
-      Just (TypeConstructor ann ctor@(Qualified qb nm), args) ->
+  fun@(a :-> r) -> case analyzeCtor a of
+      Just (TypeConstructor _ (Qualified _ nm), _) ->
         if isDictTypeName nm
           then
             let act' ma = bindLocalVariables [(NullSourceSpan,Ident "dict",a,Defined)] $ ma
             in (fun,id,act')
           else (fun,id,id)
-      other -> (fun,id,id)
+      _ -> (fun,id,id)
   other -> (other,id,id)
 
 -- In a context where we expect a Record type (object literals, etc), unwrap the record and get at the underlying rowlist
@@ -245,6 +239,28 @@ wrapTrace msg act = do
    startMsg = pad $ "BEGIN " <> msg
    endMsg = pad $ "END " <> msg
 
+
+
+-- NOTE: Grotesqely inefficient, but since the scope can change I'm not sure what else we can do.
+--       If this ends up matters, we have to rework the environment somehow
+lookupDictType :: M m => Qualified Ident -> m (Maybe SourceType)
+lookupDictType nm = do
+  tyClassDicts <- typeClassDictionaries <$> getEnv
+  let dictMap = dictionaryIdentMap tyClassDicts
+  pure $ M.lookup nm dictMap
+ where
+  dictionaryIdentMap :: M.Map QualifiedBy (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict)))
+                     -> M.Map (Qualified Ident) SourceType
+  dictionaryIdentMap m =  foldl' go M.empty inner
+    where
+      -- duplicates?
+      inner =  concatMap NEL.toList . M.elems $ M.unions $ concatMap M.elems $ M.elems m
+      go :: M.Map (Qualified Ident) SourceType -> NamedDict -> M.Map (Qualified Ident) SourceType
+      go acc TypeClassDictionaryInScope{..} = M.insert tcdValue dictTy acc
+        where
+          dictTy = foldl' srcTypeApp dictTyCon tcdInstanceTypes
+          dictTyCon = srcTypeConstructor $ coerceProperName . dictTypeName <$> tcdClassName
+
 -- | Generates a pretty (ish) representation of the type environment/context. For debugging.
 printEnv :: M m => m String
 printEnv = do
diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
index 88fd5f1fa..df2cc9147 100644
--- a/src/Language/PureScript/Environment.hs
+++ b/src/Language/PureScript/Environment.hs
@@ -383,8 +383,8 @@ pattern (:$) :: Type a -> Type a -> Type a
 pattern f :$ a <-
   TypeApp _ f a
 
-arrayT :: Type a -> Type ()
-arrayT = TypeApp () (TypeConstructor () C.Array) . fmap (const ())
+arrayT :: SourceType -> SourceType
+arrayT = TypeApp NullSourceAnn (TypeConstructor NullSourceAnn C.Array)
 
 pattern RecordT :: Type a -> Type a
 pattern RecordT a <-
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index b041af6aa..dec70c72f 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -56,6 +56,7 @@ import System.FilePath (replaceExtension)
 -- Temporary
 import Debug.Trace (traceM)
 import Language.PureScript.CoreFn.Pretty (ppType)
+import Language.PureScript.CoreFn.Desugar.Utils (pTrace)
 
 -- | Rebuild a single module.
 --
@@ -96,17 +97,17 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _
       withPrim = importPrim m
   lint withPrim
 
-  ((Module ss coms _ elaborated exps, env'), nextVar) <- runSupplyT 0 $ do
+  ((Module ss coms _ elaborated exps, env', chkSt), nextVar) <- runSupplyT 0 $ do
     (desugared, (exEnv', usedImports)) <- runStateT (desugar externs withPrim) (exEnv, mempty)
     let modulesExports = (\(_, _, exports) -> exports) <$> exEnv'
-    (checked, CheckState{..}) <- runStateT (typeCheckModule modulesExports desugared) $ emptyCheckState env
+    (checked, chkSt@CheckState{..}) <- runStateT (typeCheckModule modulesExports desugared) $ emptyCheckState env
     let usedImports' = foldl' (flip $ \(fromModuleName, newtypeCtorName) ->
           M.alter (Just . (fmap DctorName newtypeCtorName :) . fold) fromModuleName) usedImports checkConstructorImportsForCoercible
     -- Imports cannot be linted before type checking because we need to
     -- known which newtype constructors are used to solve Coercible
     -- constraints in order to not report them as unused.
     censor (addHint (ErrorInModule moduleName)) $ lintImports checked exEnv' usedImports'
-    return (checked, checkEnv)
+    return (checked, checkEnv, chkSt)
 
   -- desugar case declarations *after* type- and exhaustiveness checking
   -- since pattern guards introduces cases which the exhaustiveness checker
@@ -117,14 +118,17 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _
   regrouped <- createBindingGroups moduleName . collapseBindingGroups $ deguarded
 
   let mod' = Module ss coms moduleName regrouped exps
-  traceM "PURUS START HERE"
-  ((coreFn,chkSt),nextVar'') <- runSupplyT nextVar' $ runStateT (CFT.moduleToCoreFn mod') (emptyCheckState env')
-  traceM $ prettyEnv (checkEnv chkSt)
+  traceM $ "PURUS START HERE: " <> T.unpack (runModuleName moduleName)
+  -- pTrace regrouped
+  -- pTrace exps
+  ((coreFn,chkSt'),nextVar'') <- runSupplyT nextVar' $ runStateT (CFT.moduleToCoreFn mod') chkSt -- (emptyCheckState env')
+
   traceM $ CFT.prettyPrintModule'  coreFn
   let corefn = coreFn
       (optimized, nextVar''') = runSupply nextVar'' $ CF.optimizeCoreFn corefn
       (renamedIdents, renamed) = renameInModule optimized
       exts = moduleToExternsFile mod' env' renamedIdents
+  --pTrace exts
   ffiCodegen renamed
 
   -- It may seem more obvious to write `docs <- Docs.convertModule m env' here,
diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs
index 4d713d541..fdaf44fd8 100644
--- a/src/Language/PureScript/Sugar.hs
+++ b/src/Language/PureScript/Sugar.hs
@@ -73,3 +73,4 @@ desugar externs =
     >=> deriveInstances
     >=> desugarTypeClasses externs
     >=> createBindingGroupsModule
+
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index 7c2fc0134..ccb699db2 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -226,7 +226,7 @@ desugarDecl mn exps = go
           dictTy = foldl srcTypeApp (srcTypeConstructor (fmap (coerceProperName . dictTypeName) className)) tys
           constrainedTy = quantify (foldr srcConstrainedType dictTy deps)
         in
-          return $ ValueDecl sa name' Private [] [MkUnguarded (TypedValue True dict constrainedTy)]
+          return $ ValueDecl sa name' Public [] [MkUnguarded (TypedValue True dict constrainedTy)]
     return (expRef name' className tys, [d, dictDecl])
   go other = return (Nothing, [other])
 
@@ -303,7 +303,7 @@ typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration (TypeDeclarati
       -- NOTE: changing this from ByNullSourcePos to the real source pos to hopefully make conversion to typed CoreFn AST work
       acsr = Accessor (mkString $ runIdent ident) (Var ss (Qualified {- -ByNullSourcePos -} (BySourcePos $ spanStart ss) dictObjIdent))
       visibility = second (const TypeVarVisible) <$> args
-  in ValueDecl sa ident Private []
+  in ValueDecl sa ident Public []
     [MkUnguarded (
      TypedValue False (Abs (VarBinder ss dictIdent) (Case [Var ss $ Qualified ByNullSourcePos dictIdent] [CaseAlternative [ctor] [MkUnguarded acsr]])) $
        addVisibility visibility (moveQuantifiersToFront NullSourceAnn (quantify (srcConstrainedType (srcConstraint className [] (map (srcTypeVar . fst) args) Nothing) ty)))
@@ -363,7 +363,7 @@ typeInstanceDictionaryDeclaration sa@(ss, _) name mn deps className tys decls =
       constrainedTy = quantify (foldr srcConstrainedType dictTy deps)
       dict = App (Constructor ss (fmap (coerceProperName . dictTypeName) className)) props
       mkTV = if unreachable then TypedValue False (Var nullSourceSpan C.I_undefined) else TypedValue True dict
-      result = ValueDecl sa name Private [] [MkUnguarded (mkTV constrainedTy)]
+      result = ValueDecl sa name Public [] [MkUnguarded (mkTV constrainedTy)]
   return result
 
   where
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index 396769a05..46be3f3e1 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -110,6 +110,7 @@ data CheckState = CheckState
 emptyCheckState :: Environment -> CheckState
 emptyCheckState env = CheckState env 0 0 0 Nothing [] emptySubstitution [] mempty
 
+
 -- | Unification variables
 type Unknown = Int
 
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index ddc38a416..9faf7830d 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -608,12 +608,15 @@ inferLetBinding seen (ValueDecl sa@(ss, _) ident nameKind [] [MkUnguarded (Typed
     $ inferLetBinding (seen ++ [ValueDecl sa ident nameKind [] [MkUnguarded (TypedValue checkType val' ty'')]]) rest ret j
 inferLetBinding seen (ValueDecl sa@(ss, _) ident nameKind [] [MkUnguarded val] : rest) ret j = do
   valTy <- freshTypeWithKind kindType
-  TypedValue' _ val' valTy' <- warnAndRethrowWithPositionTC ss $ do
+  TypedValue' chk val' valTy' <- warnAndRethrowWithPositionTC ss $ do
     let dict = M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (valTy, nameKind, Undefined)
     bindNames dict $ infer val
   warnAndRethrowWithPositionTC ss $ unifyTypes valTy valTy'
+  -- NOTE (from Sean): Returning a TypedValue gives us access to monomorphized types for un-annotated let bindings.
+  --                   I'm not sure why they don't do this, perhaps there is a reason to avoid doing so?
+  let val'' = TypedValue chk val' valTy'
   bindNames (M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (valTy', nameKind, Defined))
-    $ inferLetBinding (seen ++ [ValueDecl sa ident nameKind [] [MkUnguarded val']]) rest ret j
+    $ inferLetBinding (seen ++ [ValueDecl sa ident nameKind [] [MkUnguarded val'']]) rest ret j
 inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do
   moduleName <- unsafeCheckCurrentModule
   SplitBindingGroup untyped typed dict <- typeDictionaryForBindingGroup Nothing . NEL.toList $ fmap (\(i, _, v) -> (i, v)) ds
diff --git a/tests/TestPurus.hs b/tests/TestPurus.hs
index 48567dae9..d14d7ad0b 100644
--- a/tests/TestPurus.hs
+++ b/tests/TestPurus.hs
@@ -81,9 +81,18 @@ shouldPass = map (prefix </>) paths
         "ImportQualified",
         "InstanceUnnamedSimilarClassName",
         "ModuleDeps",
+        "Misc",
         "NonOrphanInstanceFunDepExtra",
-        "NonOrphanInstanceMulti"
-
+        "NonOrphanInstanceMulti",
+        "PendingConflictingImports",
+        "PendingConflictingImports2",
+        "RedefinedFixity",
+        "ReExportQualified",
+        "ResolvableScopeConflict",
+        "ResolvableScopeConflict2",
+        "ResolvableScopeConflict3",
+        "ShadowedModuleName",
+        "TransitiveImport"
       ]
 
 
diff --git a/tests/purus/passing/Misc/Lib.purs b/tests/purus/passing/Misc/Lib.purs
index 99f05ec45..17fc39006 100644
--- a/tests/purus/passing/Misc/Lib.purs
+++ b/tests/purus/passing/Misc/Lib.purs
@@ -79,14 +79,14 @@ mutuallyRecursiveBindingGroup =
       g y = h (f y) 3
   in g 3
 
-{- TODO: Make this a shouldfail test
+
 mutuallyRecursiveBindingGroupNoTypes :: Int
 mutuallyRecursiveBindingGroupNoTypes =
   let f' x = g' 2
       h' x y = y
       g' y = h' (f' y) 3
   in g' 3
--}
+
 nestedBinds :: Int
 nestedBinds =
   let  f :: Int -> Int
diff --git a/tests/purus/passing/PendingConflictingImports/A.purs b/tests/purus/passing/PendingConflictingImports/A.purs
new file mode 100644
index 000000000..302b0328d
--- /dev/null
+++ b/tests/purus/passing/PendingConflictingImports/A.purs
@@ -0,0 +1,4 @@
+module A where
+
+thing :: Int
+thing = 1
diff --git a/tests/purus/passing/PendingConflictingImports/B.purs b/tests/purus/passing/PendingConflictingImports/B.purs
new file mode 100644
index 000000000..076bf7ea5
--- /dev/null
+++ b/tests/purus/passing/PendingConflictingImports/B.purs
@@ -0,0 +1,4 @@
+module B where
+
+thing :: Int
+thing = 2
diff --git a/tests/purus/passing/PendingConflictingImports/PendingConflictingImports.purs b/tests/purus/passing/PendingConflictingImports/PendingConflictingImports.purs
new file mode 100644
index 000000000..b42cd06fd
--- /dev/null
+++ b/tests/purus/passing/PendingConflictingImports/PendingConflictingImports.purs
@@ -0,0 +1,8 @@
+module Main where
+
+-- No error as we never force `thing` to be resolved in `Main`
+import A
+import B
+
+
+main = "Done"
diff --git a/tests/purus/passing/PendingConflictingImports2/A.purs b/tests/purus/passing/PendingConflictingImports2/A.purs
new file mode 100644
index 000000000..302b0328d
--- /dev/null
+++ b/tests/purus/passing/PendingConflictingImports2/A.purs
@@ -0,0 +1,4 @@
+module A where
+
+thing :: Int
+thing = 1
diff --git a/tests/purus/passing/PendingConflictingImports2/PendingConflictingImports2.purs b/tests/purus/passing/PendingConflictingImports2/PendingConflictingImports2.purs
new file mode 100644
index 000000000..81c3d821d
--- /dev/null
+++ b/tests/purus/passing/PendingConflictingImports2/PendingConflictingImports2.purs
@@ -0,0 +1,9 @@
+module Main where
+
+import A
+
+-- No error as we never force `thing` to be resolved in `Main`
+thing :: Int
+thing = 2
+
+main =  "Done"
diff --git a/tests/purus/passing/ReExportQualified/A.purs b/tests/purus/passing/ReExportQualified/A.purs
new file mode 100644
index 000000000..ae231283a
--- /dev/null
+++ b/tests/purus/passing/ReExportQualified/A.purs
@@ -0,0 +1,3 @@
+module A where
+
+x = "Do"
diff --git a/tests/purus/passing/ReExportQualified/B.purs b/tests/purus/passing/ReExportQualified/B.purs
new file mode 100644
index 000000000..2e149222f
--- /dev/null
+++ b/tests/purus/passing/ReExportQualified/B.purs
@@ -0,0 +1,3 @@
+module B where
+
+y = "ne"
diff --git a/tests/purus/passing/ReExportQualified/C.purs b/tests/purus/passing/ReExportQualified/C.purs
new file mode 100644
index 000000000..589f37bc4
--- /dev/null
+++ b/tests/purus/passing/ReExportQualified/C.purs
@@ -0,0 +1,4 @@
+module C (module A, module M2) where
+
+import A
+import B as M2
diff --git a/tests/purus/passing/ReExportQualified/ReExportQualified.purs b/tests/purus/passing/ReExportQualified/ReExportQualified.purs
new file mode 100644
index 000000000..af2f8d272
--- /dev/null
+++ b/tests/purus/passing/ReExportQualified/ReExportQualified.purs
@@ -0,0 +1,9 @@
+module Main where
+
+import C
+
+
+concat :: String -> String -> String
+concat _ _ = "concat"
+
+main = x `concat` y
diff --git a/tests/purus/passing/RedefinedFixity/M1.purs b/tests/purus/passing/RedefinedFixity/M1.purs
new file mode 100644
index 000000000..703e37bfb
--- /dev/null
+++ b/tests/purus/passing/RedefinedFixity/M1.purs
@@ -0,0 +1,6 @@
+module M1 where
+
+applyFn :: forall a b. (forall c d. c -> d) -> a -> b
+applyFn f a = f a
+
+infixr 1000 applyFn as $
diff --git a/tests/purus/passing/RedefinedFixity/M2.purs b/tests/purus/passing/RedefinedFixity/M2.purs
new file mode 100644
index 000000000..f7ddf1946
--- /dev/null
+++ b/tests/purus/passing/RedefinedFixity/M2.purs
@@ -0,0 +1,3 @@
+module M2 where
+
+import M1
diff --git a/tests/purus/passing/RedefinedFixity/M3.purs b/tests/purus/passing/RedefinedFixity/M3.purs
new file mode 100644
index 000000000..cd62cc115
--- /dev/null
+++ b/tests/purus/passing/RedefinedFixity/M3.purs
@@ -0,0 +1,4 @@
+module M3 where
+
+import M1
+import M2
diff --git a/tests/purus/passing/RedefinedFixity/RedefinedFixity.purs b/tests/purus/passing/RedefinedFixity/RedefinedFixity.purs
new file mode 100644
index 000000000..a796c5790
--- /dev/null
+++ b/tests/purus/passing/RedefinedFixity/RedefinedFixity.purs
@@ -0,0 +1,5 @@
+module Main where
+
+import M3
+
+main = "Done"
diff --git a/tests/purus/passing/ResolvableScopeConflict/A.purs b/tests/purus/passing/ResolvableScopeConflict/A.purs
new file mode 100644
index 000000000..302b0328d
--- /dev/null
+++ b/tests/purus/passing/ResolvableScopeConflict/A.purs
@@ -0,0 +1,4 @@
+module A where
+
+thing :: Int
+thing = 1
diff --git a/tests/purus/passing/ResolvableScopeConflict/B.purs b/tests/purus/passing/ResolvableScopeConflict/B.purs
new file mode 100644
index 000000000..4ad4bb6f4
--- /dev/null
+++ b/tests/purus/passing/ResolvableScopeConflict/B.purs
@@ -0,0 +1,7 @@
+module B where
+
+thing :: Int
+thing = 2
+
+zing :: Int
+zing = 3
diff --git a/tests/purus/passing/ResolvableScopeConflict/ResolvableScopeConflict.purs b/tests/purus/passing/ResolvableScopeConflict/ResolvableScopeConflict.purs
new file mode 100644
index 000000000..aa2bed42e
--- /dev/null
+++ b/tests/purus/passing/ResolvableScopeConflict/ResolvableScopeConflict.purs
@@ -0,0 +1,12 @@
+module Main where
+
+import A (thing)
+import B
+
+-- Not an error as although we have `thing` in scope from both A and B, it is
+-- imported explicitly from A, giving it a resolvable solution.
+what :: Boolean -> Int
+what true = thing
+what false = zing
+
+main = "Done"
diff --git a/tests/purus/passing/ResolvableScopeConflict2/A.purs b/tests/purus/passing/ResolvableScopeConflict2/A.purs
new file mode 100644
index 000000000..943011cd7
--- /dev/null
+++ b/tests/purus/passing/ResolvableScopeConflict2/A.purs
@@ -0,0 +1,7 @@
+module A where
+
+thing :: Int
+thing = 2
+
+zing :: Int
+zing = 3
diff --git a/tests/purus/passing/ResolvableScopeConflict2/ResolvableScopeConflict2.purs b/tests/purus/passing/ResolvableScopeConflict2/ResolvableScopeConflict2.purs
new file mode 100644
index 000000000..899fadecb
--- /dev/null
+++ b/tests/purus/passing/ResolvableScopeConflict2/ResolvableScopeConflict2.purs
@@ -0,0 +1,14 @@
+module Main where
+
+import A
+
+thing :: Int
+thing = 1
+
+-- Not an error as although we have `thing` in scope from both Main and A,
+-- as the local declaration takes precedence over the implicit import
+what :: Boolean -> Int
+what true = thing
+what false = zing
+
+main = "Done"
diff --git a/tests/purus/passing/ResolvableScopeConflict3/A.purs b/tests/purus/passing/ResolvableScopeConflict3/A.purs
new file mode 100644
index 000000000..302b0328d
--- /dev/null
+++ b/tests/purus/passing/ResolvableScopeConflict3/A.purs
@@ -0,0 +1,4 @@
+module A where
+
+thing :: Int
+thing = 1
diff --git a/tests/purus/passing/ResolvableScopeConflict3/ResolvableScopeConflict3.purs b/tests/purus/passing/ResolvableScopeConflict3/ResolvableScopeConflict3.purs
new file mode 100644
index 000000000..204008202
--- /dev/null
+++ b/tests/purus/passing/ResolvableScopeConflict3/ResolvableScopeConflict3.purs
@@ -0,0 +1,9 @@
+module Main (thing, main, module A) where
+
+import A
+
+
+thing :: Int
+thing = 2
+
+main = "Done"
diff --git a/tests/purus/passing/ShadowedModuleName/ShadowedModuleName.purs b/tests/purus/passing/ShadowedModuleName/ShadowedModuleName.purs
new file mode 100644
index 000000000..80061b5fb
--- /dev/null
+++ b/tests/purus/passing/ShadowedModuleName/ShadowedModuleName.purs
@@ -0,0 +1,7 @@
+module Main where
+
+import Test
+
+data Test = Test
+
+main = runZ (Z "Done")
diff --git a/tests/purus/passing/ShadowedModuleName/Test.purs b/tests/purus/passing/ShadowedModuleName/Test.purs
new file mode 100644
index 000000000..b30eb2dfd
--- /dev/null
+++ b/tests/purus/passing/ShadowedModuleName/Test.purs
@@ -0,0 +1,6 @@
+module Test where
+
+data Z = Z String
+
+runZ :: Z -> String
+runZ (Z s) = s
diff --git a/tests/purus/passing/TransitiveImport/Middle.purs b/tests/purus/passing/TransitiveImport/Middle.purs
new file mode 100644
index 000000000..57e2a2b10
--- /dev/null
+++ b/tests/purus/passing/TransitiveImport/Middle.purs
@@ -0,0 +1,9 @@
+module Middle (module Test, unit, middle) where
+
+import Test
+
+unit :: Unit
+unit = Unit
+
+middle :: forall a. TestCls a => a -> a
+middle = test
diff --git a/tests/purus/passing/TransitiveImport/Test.purs b/tests/purus/passing/TransitiveImport/Test.purs
new file mode 100644
index 000000000..2d735b509
--- /dev/null
+++ b/tests/purus/passing/TransitiveImport/Test.purs
@@ -0,0 +1,9 @@
+module Test  where
+
+data Unit = Unit
+
+class TestCls a where
+  test :: a -> a
+
+instance unitTestCls :: TestCls Unit where
+  test _ = Unit
diff --git a/tests/purus/passing/TransitiveImport/TransitiveImport.purs b/tests/purus/passing/TransitiveImport/TransitiveImport.purs
new file mode 100644
index 000000000..5d7ad43c4
--- /dev/null
+++ b/tests/purus/passing/TransitiveImport/TransitiveImport.purs
@@ -0,0 +1,6 @@
+module Main where
+
+  import Middle
+
+  main :: Unit
+  main =  (middle unit)

From 293acc930c757acad23ddf5e43a1d763382e8561 Mon Sep 17 00:00:00 2001
From: gnumonik <gnumonik@protonmail.com>
Date: Thu, 29 Feb 2024 16:42:58 -0500
Subject: [PATCH 05/20] Documenting/Explaining the use of new utils

---
 .../PureScript/CoreFn/Desugar/Utils.hs        | 196 +++++++++++++++++-
 1 file changed, 190 insertions(+), 6 deletions(-)

diff --git a/src/Language/PureScript/CoreFn/Desugar/Utils.hs b/src/Language/PureScript/CoreFn/Desugar/Utils.hs
index f3f37e860..aa777e9c1 100644
--- a/src/Language/PureScript/CoreFn/Desugar/Utils.hs
+++ b/src/Language/PureScript/CoreFn/Desugar/Utils.hs
@@ -65,10 +65,111 @@ import Data.List (foldl')
 
 
 {- UTILITIES -}
+--TODO: Explain purpose of every function
+
 
 -- | Type synonym for a monad that has all of the required typechecker functionality
 type M m = (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
 
+
+
+{- "Type Constructor analysis" machinery. (This requires some explaining)
+
+   In the course of converting to typed CoreFn, we always proceed "top-down"
+   from top-level declarations which must have a type annotation attached
+   (their typechecker enforces this - it will add an inferred annotation if
+   the user fails to annotate the type).
+
+   Because not all sub-expression (specifically, "synthetic applications" where a type class
+   dictionary constructor is applied to its argument in an instance declaration) are typed,
+   we may run into situations where the inferred or reconstructed type for a sub-expression
+   is universally quantified, even though we know (via our "top-down" approach) that the
+   quantified type variables should be instantiated (either to concrete types or to
+   type variables which are introduced in the outer lexical scope).
+
+   An example (from test 4310) makes the problem clearer. Suppose we have:
+
+   ```
+   data Tuple a b = Tuple a b
+
+   infixr 6 Tuple as /\
+   infixr 6 type Tuple as /\
+
+   mappend :: String -> String -> String
+   mappend _ _ = "mappend"
+
+   infixr 5 mappend as <>
+
+   class Test a where
+     runTest :: a -> String
+
+   instance Test Int where
+     runTest _ = "4"
+
+   instance (Test a, Test b) => Test (a /\ b) where
+     runTest (a /\ b) = runTest a <> runTest b
+
+   ```
+
+   The generated code for the typeclass declaration gives us (in part):
+
+  ```
+  Test$Dict :: forall a.  { runTest :: a -> String  }  -> { runTest :: a -> String }
+  Test$Dict = \(x: { runTest :: a -> String} ) ->
+            (x: { runTest :: a -> String} )
+
+  runTest :: forall (@a :: Type). Test$Dict a -> a -> String
+  runTest = \(dict: Test$Dict a) ->
+          case (dict: Test$Dict a) of
+            (Test$Dict v) -> (v: { runTest :: a -> String} ).runTest
+  ```
+
+  Because the Tuple instance for Test uses `runTest` (the function), and because
+  `runTest` is universally quantified, if we did not instantiate those quantifiers,
+  a new skolem scope will be introduced at each application of `runTest`, giving us
+  type variables that cannot be unified with the outermost type variables.
+
+  That is, without using this machiner (and `instantiate`), we end up with something like
+  this for the tuple instance:
+
+  ```
+  test/\ :: forall (a :: Type) (b :: Type). Test$Dict a -> Test$Dict b -> Test$Dict (Tuple a b)
+  test/\ = \(dictTest: Test$Dict a) ->
+         \(dictTest1: Test$Dict b) ->
+         (Test$Dict: { runTest :: a -> String} -> Test$Dict a ) { runTest: \(v: Tuple a0 b1) ->                                                                                                                                                                                                                                   }
+           case (v: Tuple a0 b1) of
+             (Tuple a b) ->
+               ((mappend: String -> String -> String)
+               (((runTest: forall (@a :: Type). Test$Dict a -> a -> String) (dictTest: Test$Dict a)) (a: t1)))
+               (((runTest: forall (@a :: Type). Test$Dict a -> a -> String) (dictTest1: Test$Dict b)) (b: t2))
+  ```
+
+  By using this machinery in `inferBinder'`, we can instantiate the quantifiers to the
+  lexically scoped type variables in the top-level signature, and get output that is properly typed:
+
+  ```
+  test/\ :: forall (a :: Type) (b :: Type). Test$Dict a -> Test$Dict b -> Test$Dict (Tuple a b)                                                                                                                                                                                                                                                      
+  test/\ = \(dictTest: Test$Dict a) ->                                                                                                                                                                                                                                                                                                               
+         \(dictTest1: Test$Dict b) ->
+         (Test$Dict: { runTest :: Tuple a b -> String} -> Test$Dict (Tuple a b) ) { runTest: \(v: Tuple a b) ->                                                                                                                                                                                                                                   }
+            case (v: Tuple a b) of
+               (Tuple a b) ->
+                ((mappend: String -> String -> String)
+                (((runTest: forall (@a :: Type). Test$Dict a -> a -> String) (dictTest: Test$Dict a)) (a: a)))
+                (((runTest: forall (@a :: Type). Test$Dict a -> a -> String) (dictTest1: Test$Dict b)) (b: b))
+
+  ```
+
+  We also use this in the branch of the `App` case of `exprToCoreFn` that handles dictionary applications
+  (in the same manner and for the same purpose).
+
+-}
+
+-- Given a type (which we expect to be a TyCon applied to type args),
+-- extract (TyCon,[Args]) (returning Nothing if the input type is not a TyCon)
+analyzeCtor :: SourceType -> Maybe (SourceType,[SourceType])
+analyzeCtor t = (,ctorArgs t) <$> ctorFun t
+
 -- Extract all of the arguments to a type constructor
 ctorArgs :: SourceType -> [SourceType]
 ctorArgs (TypeApp _ t1 t2) = ctorArgs t1 <> [t2]
@@ -84,9 +185,20 @@ ctorFun (TypeApp _ t1 _) = go t1
     go other = Just other
 ctorFun _ = Nothing
 
-analyzeCtor :: SourceType -> Maybe (SourceType,[SourceType])
-analyzeCtor t = (,ctorArgs t) <$> ctorFun t
 
+{- Instantiation machinery. This differs from `instantiatePolyType` and
+   `withInstantiatedFunType` in that those functions are used to "peek under"
+   the quantifier in a universally quantified type (i.e. those functions
+   *put the quantifier back* after temporarily instantiating the quantified variables
+   *to type variables* for the purposes of type reconstruction).
+
+   This instantiates a quantified type (the first arg) and *does not* replace the
+   quantifier. This is primarily used when we encounter an expression with a universally
+   quantified type (either as an annotation in a AST.TypedValue or as the result of looking up
+   the type in the typechecking environment) in a context where we know (from our top-down approach)
+   that the instantiated type must be instantiated to something "concrete" (where, again,
+   a "concrete" type can either be an explicit type or a tyvar from the outer scope).
+-}
 instantiate :: SourceType -> [SourceType] -> SourceType
 instantiate ty [] = ty
 instantiate (ForAll _ _ var _ inner _) (t:ts) = replaceTypeVars var t $ instantiate inner ts
@@ -102,7 +214,12 @@ traverseLit f = \case
   ArrayLiteral xs  -> ArrayLiteral <$> traverse f xs
   ObjectLiteral xs -> ObjectLiteral <$> traverse (\(str,x) -> f x >>= \b -> pure (str,b)) xs
 
--- | When we call `exprToCoreFn` we sometimes know the type, and sometimes have to infer it. This just simplifies the process of getting the type we want (cuts down on duplicated code)
+{- `exprtoCoreFn` takes a `Maybe SourceType` argument. While in principle we should never need to infer the type
+    using PS type inference machinery (we should always be able to reconstruct it w/ recursive applications of
+    `exprToCoreFn` on the components), I have to get around to rewriting the corefn desugaring code to avoid this.
+
+    Should be DEPRECATED eventually.
+-}
 inferType :: M m => Maybe SourceType -> A.Expr -> m SourceType
 inferType (Just t) _ = pure t
 inferType Nothing e = pTrace ("**********HAD TO INFER TYPE FOR: (" <> renderValue 100 e <> ")") >>
@@ -240,9 +357,76 @@ wrapTrace msg act = do
    endMsg = pad $ "END " <> msg
 
 
-
--- NOTE: Grotesqely inefficient, but since the scope can change I'm not sure what else we can do.
---       If this ends up matters, we have to rework the environment somehow
+{-
+  This is used to solve a problem that arises with re-exported instances.
+
+  We diverge from PureScript by "desugaring" constrained types to types that contain
+  explicit type class dictionaries. (We have to do this for PIR conversion - we have to type
+  all nodes of the AST.)
+
+  During PureScript's initial desugaring phase, type class declarations, instance declarations, and
+  expressions that contain type class constaints are transformed into generated value declarations. For example:
+
+  ```
+    class Eq a where
+      eq a :: a -> a -> Bool
+
+    f :: forall a. Eq a => a -> a -> Boolean
+    f x y = eq x y
+  ```
+
+  Is transformed into (something like, I'm ommitting the full generated code for brevity):
+
+  ```
+    Eq$Dict :: forall a. {eq :: a -> a -> Boolean } -> {eq :: a -> a -> Boolean}
+    Eq$Dict x = x
+
+    eq :: forall a. Eq$Dict a -> a -> a -> Boolean
+    eq  = \dict ->  case dict of
+      (v :: {eq :: a -> a -> Boolean}) -> v.eq
+
+    f :: forall a. Eq a => a -> a -> Boolean
+    f = \dict x y -> (eq dict) x y
+  ```
+
+  Three important things to note here:
+   - PureScript does *not* transform constrained types into types that contain explicit dictionaries,
+     even though the expressions are desugared to contain those dictionaries. (We do this ourselves
+     after the PS typechecking phase)
+   - Generated declarations for type classes and instances are not (and cannot be) exported,
+     because typeclass desugaring takes place *after* import/export resolution
+     in their desugaring pipeline. (This would be difficult to fix, each step of the desugaring pipeline
+     expects input that conforms to the output of the previous step).
+   - Generated code relating to typeclass dictionaries is ignored by the PureScript typechecker.
+     Ordinarily, we can rely on the typechecker to insert the type annotation for most
+     expressions, but we cannot do so here.
+
+  These factors give rise to a problem: Our desugared constraint types (where we transform
+  type annotations of the form `C a => (..)` into `C$Dict a -> (...)`) no longer contain constraints,
+  and therefore we cannot use the constraint solving machinery directly to infer the types of
+  identifiers that refer to type class dictionaries. Because generated type class code cannot be exported
+  by the user in the source (and would not ordinarily be implicitly re-exported even if it could be exported),
+  we cannot rely upon normal import resolution to provide the types corresponding to dictionary identifiers.
+
+  This solves the problem. Because we use the same state/module scope as the PS typechecker, we
+  have access to all of the type class dictionaries (including their identifiers) that are in scope.
+  When we encounter an identifier that cannot be assigned a type by the normal type lookup process,
+  we extract a map from identifiers to source types, and lookup the identifier in the map, allowing us to
+  resolve the types of dictionary expressions.
+
+  These identifiers are always qualified by module in the AST, so cannot clash with local definitions, which
+  are qualified by SourcePos.
+
+  NOTE: In theory (at least), this component of the type checker environment  can change if we
+        make any calls to `infer` or any of the type checking functions in the
+        TypeChecker.X namespace. So for now, we rebuild this map every time we fail to
+        lookup the type for an identifier in the normal way. (Which is grossly
+        inefficient)
+
+        In principle, we should be able to totally reconstruct the types w/o making
+        any calls to `infer` or the typechecker machinery. Once that is done, we can
+        construct this map only once for each module, which will greatly improve performance.
+-}
 lookupDictType :: M m => Qualified Ident -> m (Maybe SourceType)
 lookupDictType nm = do
   tyClassDicts <- typeClassDictionaries <$> getEnv

From 1e178045aae683aa45b01be0ff14982f7713c100 Mon Sep 17 00:00:00 2001
From: gnumonik <gnumonik@protonmail.com>
Date: Thu, 29 Feb 2024 21:05:31 -0500
Subject: [PATCH 06/20] Type inference/checking machinery removed from CoreFn
 desugaring machinery. (We're now properly *reconstructing* the types)

---
 src/Language/PureScript/CoreFn/Desugar.hs     | 210 ++++++++++--------
 .../PureScript/CoreFn/Desugar/Utils.hs        |  45 ++--
 src/Language/PureScript/CoreFn/Pretty.hs      |   2 +-
 src/Language/PureScript/Environment.hs        |   4 +-
 4 files changed, 135 insertions(+), 126 deletions(-)

diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs
index 27259b840..2da586ded 100644
--- a/src/Language/PureScript/CoreFn/Desugar.hs
+++ b/src/Language/PureScript/CoreFn/Desugar.hs
@@ -6,7 +6,7 @@ module Language.PureScript.CoreFn.Desugar(moduleToCoreFn) where
 import Prelude
 import Protolude (ordNub, orEmpty, zipWithM, MonadError (..), sortOn, Bifunctor (bimap))
 
-import Data.Maybe (mapMaybe)
+import Data.Maybe (mapMaybe, fromMaybe)
 import Data.List.NonEmpty qualified as NEL
 import Data.Map qualified as M
 
@@ -59,13 +59,7 @@ import Language.PureScript.Constants.Prim qualified as C
 import Control.Monad.State.Strict (MonadState, gets, modify)
 import Control.Monad.Writer.Class ( MonadWriter )
 import Language.PureScript.TypeChecker.Kinds ( kindOf )
-import Language.PureScript.TypeChecker.Types
-    ( checkTypeKind,
-      SplitBindingGroup(SplitBindingGroup),
-      TypedValue'(TypedValue'),
-      typeDictionaryForBindingGroup )
 import Data.List.NonEmpty qualified as NE
-import Language.PureScript.TypeChecker.Unify (unifyTypes)
 import Control.Monad (forM, (>=>), foldM)
 import Language.PureScript.Errors
     ( MultipleErrors, errorMessage', SimpleErrorMessage(..))
@@ -92,7 +86,6 @@ import Language.PureScript.CoreFn.Desugar.Utils
       getModuleName,
       getValueMeta,
       importToCoreFn,
-      inferType,
       printEnv,
       properToIdent,
       purusTy,
@@ -100,7 +93,6 @@ import Language.PureScript.CoreFn.Desugar.Utils
       showIdent',
       ssA,
       toReExportRef,
-      traverseLit,
       wrapTrace,
       desugarConstraintTypes,
       M, unwrapRecord, withInstantiatedFunType, desugarConstraintsInDecl, analyzeCtor, instantiate, ctorArgs, instantiatePolyType, lookupDictType
@@ -108,6 +100,7 @@ import Language.PureScript.CoreFn.Desugar.Utils
 import Text.Pretty.Simple (pShow)
 import Data.Text.Lazy qualified as LT
 import Data.Set qualified as S
+import Data.Either (lefts)
 
 {-
     CONVERSION MACHINERY
@@ -224,9 +217,18 @@ declToCoreFn _ _ = pure []
 
 -- Desugars expressions from AST to typed CoreFn representation.
 exprToCoreFn :: forall m. M m => ModuleName -> SourceSpan -> Maybe SourceType -> A.Expr -> m (Expr Ann)
+-- Array & Object literals can contain non-literal expressions. Both of these types should always be tagged
+-- (i.e. returned as an AST.TypedValue) after the initial typechecking phase, so we expect the type to be passed in
 exprToCoreFn mn ss (Just arrT@(ArrayT ty)) astlit@(A.Literal _ (ArrayLiteral ts)) = wrapTrace ("exprToCoreFn ARRAYLIT " <> renderValue 100 astlit) $ do
+  traceM $ ppType 100 arrT
   arr <- ArrayLiteral <$> traverse (exprToCoreFn mn ss (Just ty)) ts
   pure $ Literal (ss,[],Nothing) arrT  arr
+-- An empty list could either have a TyVar or a quantified type (or a concrete type, which is handled by the previous case)
+exprToCoreFn mn ss (Just tyVar) astlit@(A.Literal _ (ArrayLiteral [])) = wrapTrace ("exprToCoreFn ARRAYLIT EMPTY " <> renderValue 100 astlit) $ do
+  pure $ Literal (ss,[],Nothing) tyVar (ArrayLiteral [])
+exprToCoreFn _ _ Nothing astlit@(A.Literal _ (ArrayLiteral _)) =
+  internalError $ "Error while desugaring Array Literal. No type provided for literal:\n" <> renderValue 100 astlit
+
 exprToCoreFn mn ss (Just recTy@(RecordT row)) astlit@(A.Literal _ (ObjectLiteral objFields)) = wrapTrace ("exprToCoreFn OBJECTLIT " <> renderValue 100 astlit) $ do
   traceM $ "ObjLitTy: " <> show row
   let (tyFields,_) = rowToList row
@@ -241,28 +243,37 @@ exprToCoreFn mn ss (Just recTy@(RecordT row)) astlit@(A.Literal _ (ObjectLiteral
        expr' <- exprToCoreFn mn ss (Just fieldTy) expr
        pure $ (lbl,expr'):acc
      Nothing -> error $ "row type missing field " <> T.unpack (prettyPrintString lbl)
--- Literal case is straightforward
-exprToCoreFn mn _ mTy astLit@(A.Literal ss lit) = wrapTrace ("exprToCoreFn LIT " <> renderValue 100 astLit) $ do
-  litT <- purusTy <$> inferType mTy astLit
-  traceM $ "LIT TY: " <> ppType 1000 litT
-  lit' <- traverseLit (exprToCoreFn mn ss Nothing) lit
-  pure $ Literal (ss, [], Nothing)  litT lit'
--- Accessor case is straightforward
-exprToCoreFn mn ss mTy accessor@(A.Accessor name v) = wrapTrace ("exprToCoreFn ACCESSOR " <> renderValue 100 accessor) $ do
-  expT <- purusTy <$> inferType mTy accessor
-  expr  <- exprToCoreFn mn ss Nothing v
-  pure $ Accessor (ssA ss) expT name expr
--- Object update is straightforward (this is basically a monadic wrapper around the old non-typed exprToCoreFn)
-exprToCoreFn mn ss mTy objUpd@(A.ObjectUpdate obj vs) = wrapTrace ("exprToCoreFn OBJ UPDATE " <> renderValue 100 objUpd) $ do
-  expT <- purusTy <$> inferType mTy objUpd
+exprToCoreFn _ _ Nothing astlit@(A.Literal _ (ObjectLiteral _)) =
+  internalError $ "Error while desugaring Object Literal. No type provided for literal:\n" <> renderValue 100 astlit
+
+-- Literals that aren't objects or arrays have deterministic types
+exprToCoreFn _ _ _ (A.Literal ss (NumericLiteral (Left int))) =
+  pure $ Literal (ss,[],Nothing) tyInt (NumericLiteral (Left int))
+exprToCoreFn _ _ _ (A.Literal ss (NumericLiteral (Right number))) =
+  pure $ Literal (ss,[],Nothing) tyNumber (NumericLiteral (Right number))
+exprToCoreFn _ _ _ (A.Literal ss (CharLiteral char)) =
+  pure $ Literal (ss,[],Nothing) tyChar (CharLiteral char)
+exprToCoreFn _ _ _ (A.Literal ss (BooleanLiteral boolean)) =
+  pure $ Literal (ss,[],Nothing) tyBoolean (BooleanLiteral boolean)
+exprToCoreFn _ _ _ (A.Literal ss (StringLiteral string)) =
+  pure $ Literal (ss,[],Nothing) tyString (StringLiteral string)
+
+-- Accessor case is straightforward (these should always be typed explicitly)
+exprToCoreFn mn ss (Just accT) accessor@(A.Accessor name v) = wrapTrace ("exprToCoreFn ACCESSOR " <> renderValue 100 accessor) $ do
+  v'  <- exprToCoreFn mn ss Nothing v -- v should always have a type assigned during typechecking (i.e. it will be a TypedValue that will be unwrapped)
+  pure $ Accessor (ssA ss) accT name v'
+exprToCoreFn _ _ Nothing accessor@(A.Accessor _ _) =
+  internalError $ "Error while desugaring record accessor. No type provided for expression: \n" <> renderValue 100 accessor
+
+exprToCoreFn mn ss (Just recT) objUpd@(A.ObjectUpdate obj vs) = wrapTrace ("exprToCoreFn OBJ UPDATE " <> renderValue 100 objUpd) $ do
   obj' <- exprToCoreFn mn ss Nothing obj
   vs' <- traverse (\(lbl,val) -> exprToCoreFn mn ss Nothing val >>= \val' -> pure (lbl,val')) vs
   pure $
     ObjectUpdate
       (ssA ss)
-      expT
+      recT
       obj'
-      (mTy >>= unchangedRecordFields (fmap fst vs))
+      (unchangedRecordFields (fmap fst vs) recT)
       vs'
   where
   -- TODO: Optimize/Refactor Using Data.Set
@@ -276,20 +287,30 @@ exprToCoreFn mn ss mTy objUpd@(A.ObjectUpdate obj vs) = wrapTrace ("exprToCoreFn
       collect (RCons _ (Label l) _ r) = (if l `elem` updated then id else (l :)) <$> collect r
       collect _ = Nothing
   unchangedRecordFields _ _ = Nothing
+exprToCoreFn _ _ Nothing objUpd@(A.ObjectUpdate _ _) =
+  internalError $ "Error while desugaring object update. No type provided for expression:\n" <> renderValue 100 objUpd
+
 -- Lambda abstraction. See the comments on `instantiatePolyType` above for an explanation of the strategy here.
 exprToCoreFn mn _ (Just t) (A.Abs (A.VarBinder ssb name) v) = wrapTrace ("exprToCoreFn " <> showIdent' name) $
   withInstantiatedFunType mn t $ \a b -> do
       body <-  bindLocalVariables [(ssb,name,a,Defined)] $ exprToCoreFn mn ssb (Just b) v
       pure $ Abs (ssA ssb) (function a b) name body
-
 -- By the time we receive the AST, only Lambdas w/ a VarBinder should remain
 -- TODO: Better failure message if we pass in 'Nothing' as the (Maybe Type) arg for an Abstraction
 exprToCoreFn _  _ t lam@(A.Abs _ _) =
   internalError $ "Abs with Binder argument was not desugared before exprToCoreFn: \n" <> renderValue 100  lam <> "\n\n" <> show (ppType 100 <$>  t)
--- Ad hoc machinery for handling desugared type class dictionaries. As noted above, the types "lie" in generated code.
--- NOTE: Not 100% sure this is necessary anymore now that we have instantiatePolyType
--- TODO: Investigate whether still necessary
--- FIXME: Something's off here, see output for 4310
+
+{- The App case is substantially complicated by our need to correctly type
+   expressions that contain type class dictionary constructors, specifically expressions like:
+
+   ```
+   (C$Dict :: forall x. {method :: x -> (...)}) -> {method :: x -> (..)}) ({method: f})
+   ````
+
+   Because the dictionary ctor and record of methods it is being applied to
+   are untouched by the PS typechecker, we have to instantiate the
+   quantified variables to conform with the supplied type.
+-}
 exprToCoreFn mn ss mTy app@(A.App fun arg)
   | isDictCtor fun = wrapTrace "exprToCoreFn APP DICT " $ do
       traceM $ "APP Dict type" <> show (ppType 100 <$> mTy)
@@ -300,6 +321,7 @@ exprToCoreFn mn ss mTy app@(A.App fun arg)
       case mTy of
         Just iTy ->
           case analyzed of
+            -- Branch for a "normal" (i.e. non-empty) typeclass dictionary application
             Just (TypeConstructor _ (Qualified qb nm), args) -> do
               traceM $ "APP Dict name: " <> T.unpack (runProperName nm)
               env <- getEnv
@@ -315,42 +337,29 @@ exprToCoreFn mn ss mTy app@(A.App fun arg)
                         pure $ App (ss,[],Nothing) iTy fun' arg'
                       _ -> error "dict ctor has to have a function type"
                 _ -> throwError . errorMessage' ss . UnknownName . fmap DctorName $ Qualified qb (coerceProperName nm)
+            -- This should actually be impossible here, so long as we desugared all the constrained types properly
             Just (other,_) -> error $  "APP Dict not a constructor type (impossible here?): \n" <> ppType 100 other
+            -- Case for handling empty dictionaries (with no methods)
             Nothing ->  do
-              -- REVIEW: This might be the one place where `kindType` in instantiatePolyType is wrong, check the kinds
-              --         in the output
+              -- REVIEW: This might be the one place where `kindType` in instantiatePolyType is wrong, check the kinds in the output
+              -- REVIEW: We might want to match more specifically on both/either the expression and type level to
+              --         ensure that we are working only with empty dictionaries here. (Though anything else should be caught be the previous case)
               let (inner,g,act) = instantiatePolyType mn iTy
               act (exprToCoreFn mn ss (Just inner) app) >>= \case
                  App ann' _ e1 e2 -> pure . g $ App ann' iTy e1 e2
-                 other -> error "An application desguared to something else. This should not be possible."
+                 _ -> error "An application desguared to something else. This should not be possible."
         Nothing ->  error $ "APP Dict w/o type passed in (impossible to infer):\n" <> renderValue 100 app
 
-
-          -- type should be something like: Test$Dict (Tuple a b)
-          -- lookup the type of the Dict ctor (should have one quantified record arg), i.e.
-          --   forall a.  { runTest :: a -> String  }  -> { runTest :: a -> String }
-          -- instantiate the args, giving something like:
-          --  {runTest :: Tuple a b -> String}
-
   | otherwise =  wrapTrace "exprToCoreFn APP" $ do
       traceM $ renderValue 100 app
-      case mTy of
-        Just appT -> do
-          fun' <- exprToCoreFn mn ss Nothing fun
-          let funTy = exprType fun'
-          traceM $ "app fun:\n" <> ppType 100  funTy <> "\n" <> renderExpr 100 fun'
-          withInstantiatedFunType mn  funTy $ \a b -> do
-            arg' <- exprToCoreFn mn ss (Just a) arg
-            traceM $ "app arg:\n" <> ppType 100 (exprType arg') <> "\n" <> renderExpr 100 arg'
-            pure $ App (ss, [], Nothing) appT fun' arg'
-        Nothing -> do
-          fun' <- exprToCoreFn mn ss Nothing fun
-          let funTy = exprType fun'
-          traceM $ "app fun:\n" <> ppType 100  funTy <> "\n" <> renderExpr 100 fun'
-          withInstantiatedFunType mn  funTy $ \a b -> do
-            arg' <- exprToCoreFn mn ss (Just a) arg
-            traceM $ "app arg:\n" <> ppType 100 (exprType arg') <> "\n" <> renderExpr 100 arg'
-            pure $ App (ss, [], Nothing) b fun' arg'
+      fun' <- exprToCoreFn mn ss Nothing fun
+      let funTy = exprType fun'
+      traceM $ "app fun:\n" <> ppType 100  funTy <> "\n" <> renderExpr 100 fun'
+      withInstantiatedFunType mn  funTy $ \a b -> do
+        arg' <- exprToCoreFn mn ss (Just a) arg
+        traceM $ "app arg:\n" <> ppType 100 (exprType arg') <> "\n" <> renderExpr 100 arg'
+        pure $ App (ss, [], Nothing) (fromMaybe b mTy) fun' arg'
+
   where
   isDictCtor = \case
     A.Constructor _ (Qualified _ name) -> isDictTypeName name
@@ -371,47 +380,60 @@ exprToCoreFn _ _ _ (A.Var ss ident) = wrapTrace ("exprToCoreFn VAR " <> show ide
         traceM $ "No known type for identifier " <> show ident -- <> "\n    in:\n" <> LT.unpack (pShow $ names env)
         error "boom"
 -- If-Then-Else Turns into a case expression
-exprToCoreFn mn ss mTy ifte@(A.IfThenElse cond th el) = wrapTrace "exprToCoreFn IFTE" $ do
-  -- NOTE/TODO: Don't need to call infer separately here
-  ifteTy <- inferType mTy ifte
+exprToCoreFn mn ss (Just resT) (A.IfThenElse cond th el) = wrapTrace "exprToCoreFn IFTE" $ do
   condE <- exprToCoreFn mn ss (Just tyBoolean) cond
-  thE <- exprToCoreFn mn ss Nothing th
-  elE <- exprToCoreFn mn ss Nothing  el
-  pure $ Case (ss, [], Nothing) (purusTy ifteTy) [condE]
+  thE <- exprToCoreFn mn ss (Just resT) th
+  elE <- exprToCoreFn mn ss (Just resT) el
+  pure $ Case (ss, [], Nothing) resT [condE]
     [ CaseAlternative [LiteralBinder (ssAnn ss) $ BooleanLiteral True]
                       (Right thE)
     , CaseAlternative [NullBinder (ssAnn ss)]
                       (Right elE) ]
+exprToCoreFn _ _ Nothing ifte@(A.IfThenElse _ _ _) =
+  internalError $ "Error while desugaring If-then-else expression. No type provided for:\n " <> renderValue 100 ifte
+
 -- Constructor case is straightforward, we should already have all of the type info
-exprToCoreFn _ _  mTy ctor@(A.Constructor ss name) = wrapTrace ("exprToCoreFn CTOR " <> show name) $ do
-  env <- gets checkEnv
-  let ctorMeta = getConstructorMeta env name
-  ctorType <- inferType mTy ctor
-  pure $ Var (ss, [], Just ctorMeta) (purusTy ctorType) $ fmap properToIdent name
+exprToCoreFn _ _  (Just ctorTy) (A.Constructor ss name) = wrapTrace ("exprToCoreFn CTOR " <> show name) $ do
+  ctorMeta <- flip getConstructorMeta name <$> getEnv
+  pure $ Var (ss, [], Just ctorMeta) (purusTy ctorTy) $ fmap properToIdent name
+exprToCoreFn _ _ Nothing ctor@(A.Constructor _ _) =
+  internalError $ "Error while desugaring Constructor expression. No type provided for:\n" <> renderValue 100 ctor
+
 -- Case expressions
-exprToCoreFn mn ss mTy astCase@(A.Case vs alts) = wrapTrace "exprToCoreFn CASE" $ do
+exprToCoreFn mn ss (Just caseTy) astCase@(A.Case vs alts) = wrapTrace "exprToCoreFn CASE" $ do
   traceM $ "CASE:\n" <> renderValue 100 astCase
-  traceM $ "CASE TY:\n" <> show (ppType 100 <$> mTy)
-  caseTy <- inferType mTy astCase -- the return type of the branches. This will usually be passed in.
+  traceM $ "CASE TY:\n" <> show (ppType 100 caseTy)
   (vs',ts) <- unzip <$> traverse (exprToCoreFn mn ss Nothing >=> (\ e -> pure (e, exprType e))) vs -- extract type information for the *scrutinees*
   alts' <- traverse (altToCoreFn mn ss caseTy ts) alts -- see explanation in altToCoreFn. We pass in the types of the scrutinee(s)
   pure $ Case (ssA ss) (purusTy caseTy) vs' alts'
+exprToCoreFn _ _ Nothing astCase@(A.Case _ _) =
+  internalError $ "Error while desugaring Case expression. No type provided for:\n" <> renderValue 100 astCase
 
 -- We prioritize the supplied type over the inferred type, since a type should only ever be passed when known to be correct.
 exprToCoreFn  mn ss  (Just ty) (A.TypedValue _ v _) = wrapTrace "exprToCoreFn TV1" $
   exprToCoreFn mn ss (Just ty) v
+-- If we encounter a TypedValue w/o a supplied type, we use the annotated type
 exprToCoreFn mn ss Nothing (A.TypedValue _ v ty) = wrapTrace "exprToCoreFn TV2" $
   exprToCoreFn mn ss (Just ty) v
--- Let bindings. Complicated.
+
+-- Complicated. See `transformLetBindings`
 exprToCoreFn  mn ss _ (A.Let w ds v) = wrapTrace "exprToCoreFn LET" $ case NE.nonEmpty ds of
   Nothing -> error "declarations in a let binding can't be empty"
   Just _ -> do
-    (decls,expr) <- transformLetBindings mn ss [] ds v -- see transformLetBindings
+    (decls,expr) <- transformLetBindings mn ss [] ds v
     pure $ Let (ss, [], getLetMeta w) (exprType expr) decls expr
+
+-- Pretty sure we should prefer the positioned SourceSpan
 exprToCoreFn  mn _ ty (A.PositionedValue ss _ v) = wrapTrace "exprToCoreFn POSVAL" $
   exprToCoreFn mn ss ty v
-exprToCoreFn _ _   _ e =
-  error $ "Unexpected value in exprToCoreFn mn: " ++ show e
+-- Function should never reach this case, but there are a lot of AST Expressions that shouldn't ever appear here, so
+-- we use a catchall case.
+exprToCoreFn _ ss   _ e =
+  internalError
+    $ "Unexpected value in exprToCoreFn:\n"
+      <> renderValue 100 e
+      <> "at position:\n"
+      <> show ss
 
 -- Desugars case alternatives from AST to CoreFn representation.
 altToCoreFn ::  forall m
@@ -467,9 +489,7 @@ transformLetBindings mn _ss seen ((A.ValueDecl sa@(ss,_) ident nameKind [] [A.Mk
     thisDecl <- declToCoreFn mn (A.ValueDecl sa ident nameKind [] [A.MkUnguarded (A.TypedValue checkType val ty)])
     let seen' = seen ++ thisDecl
     transformLetBindings mn _ss seen' rest ret
--- TODO: Write a question where I ask what can legitimately be inferred as a type in a let binding context
-transformLetBindings mn _ss seen (A.ValueDecl sa@(ss,_) ident nameKind [] [A.MkUnguarded val] : rest) ret = wrapTrace ("transformLetBindings VALDEC " <> showIdent' ident <> " = " <> renderValue 100 val) $ do
-  -- ty <- inferType Nothing val {- FIXME: This sometimes gives us a type w/ unknowns, but we don't have any other way to get at the type -}
+transformLetBindings mn _ss seen (A.ValueDecl (ss,_) ident nameKind [] [A.MkUnguarded val] : rest) ret = wrapTrace ("transformLetBindings VALDEC " <> showIdent' ident <> " = " <> renderValue 100 val) $ do
   e <- exprToCoreFn mn ss Nothing val
   let ty = exprType e
   if not (containsUnknowns ty) -- TODO: Don't need this anymore (shouldn't ever contain unknowns)
@@ -486,19 +506,27 @@ transformLetBindings mn _ss seen (A.ValueDecl sa@(ss,_) ident nameKind [] [A.MkU
               <> "\nIf the identifier occurs in a compiler-generated `let-binding` with guards (e.g. in a guarded case branch), try removing the guarded expression (e.g. use a normal if-then expression)"
 -- NOTE/TODO: This is super hack-ey. Ugh.
 transformLetBindings mn _ss seen (A.BindingGroupDeclaration ds : rest) ret = wrapTrace "transformLetBindings BINDINGGROUPDEC" $ do
-  SplitBindingGroup untyped typed dict <- typeDictionaryForBindingGroup Nothing . NEL.toList $ fmap (\(i, _, v) -> (i, v)) ds
-  if null untyped
-    then do
-      let ds' =  flip map typed $ \((sann,iden),(expr,_,ty,_)) -> A.ValueDecl sann iden Private [] [A.MkUnguarded (A.TypedValue False expr ty)]
+  -- All of the types in the binding group should be TypedValues (after my modifications to the typechecker)
+  -- NOTE: We re-implement part of TypeChecker.Types.typeDictionaryForBindingGroup here because it *could* try to do
+  --       type checking/inference, which we want to avoid (because it mangles our types)
+  let types = go <$> NEL.toList ((\(i, _, v) -> (i, v)) <$> ds)
+  case sequence types  of
+    Right typed ->  do
+      let ds' =  flip map typed $ \((sann,iden),(expr,ty)) -> A.ValueDecl sann iden Private [] [A.MkUnguarded (A.TypedValue False expr ty)]
+          dict = M.fromList $ flip map typed $ \(((ss,_),ident),(_,ty)) -> (Qualified (BySourcePos $ spanStart ss) ident, (ty, Private, Undefined))
       bindNames dict $ do
         makeBindingGroupVisible
         thisDecl <- concat <$> traverse (declToCoreFn mn) ds'
         let seen' = seen ++ thisDecl
         transformLetBindings mn _ss seen' rest ret
     -- Because this has already been through the typechecker once, every value in the binding group should have an explicit type. I hope.
-    else error
+    Left _ -> error
          $ "untyped binding group element in mutually recursive LET binding group after initial typechecker pass: \n"
-         <> LT.unpack (pShow untyped)
+         <> LT.unpack (pShow $ lefts types)
+ where
+  go :: ((SourceAnn, Ident), A.Expr) -> Either ((SourceAnn,Ident), A.Expr) ((SourceAnn, Ident), (A.Expr, SourceType))
+  go  (annName,A.TypedValue _ expr ty)  = Right (annName,(expr,ty))
+  go  (annName,other) = Left (annName,other)
 transformLetBindings _ _ _ _ _ = error "Invalid argument to TransformLetBindings"
 
 
@@ -511,11 +539,11 @@ inferBinder'
   -> A.Binder
   -> m (M.Map Ident (SourceSpan, SourceType))
 inferBinder' _ A.NullBinder = return M.empty
-inferBinder' val (A.LiteralBinder _ (StringLiteral _)) = wrapTrace "inferBinder' STRLIT" $ unifyTypes val tyString >> return M.empty
-inferBinder' val (A.LiteralBinder _ (CharLiteral _)) = wrapTrace "inferBinder' CHARLIT" $ unifyTypes val tyChar >> return M.empty
-inferBinder' val (A.LiteralBinder _ (NumericLiteral (Left _))) = wrapTrace "inferBinder' LITINT" $ unifyTypes val tyInt >> return M.empty
-inferBinder' val (A.LiteralBinder _ (NumericLiteral (Right _))) = wrapTrace "inferBinder' NUMBERLIT" $ unifyTypes val tyNumber >> return M.empty
-inferBinder' val (A.LiteralBinder _ (BooleanLiteral _)) = wrapTrace "inferBinder' BOOLLIT" $ unifyTypes val tyBoolean >> return M.empty
+inferBinder' val (A.LiteralBinder _ (StringLiteral _)) = wrapTrace "inferBinder' STRLIT" $ return M.empty
+inferBinder' val (A.LiteralBinder _ (CharLiteral _)) = wrapTrace "inferBinder' CHARLIT" $  return M.empty
+inferBinder' val (A.LiteralBinder _ (NumericLiteral (Left _))) = wrapTrace "inferBinder' LITINT" $ return M.empty
+inferBinder' val (A.LiteralBinder _ (NumericLiteral (Right _))) = wrapTrace "inferBinder' NUMBERLIT" $ return M.empty
+inferBinder' val (A.LiteralBinder _ (BooleanLiteral _)) = wrapTrace "inferBinder' BOOLLIT" $ return M.empty
 inferBinder' val (A.VarBinder ss name) = wrapTrace ("inferBinder' VAR " <> T.unpack (runIdent name))  $ return $ M.singleton name (ss, val)
 inferBinder' val (A.ConstructorBinder ss ctor binders) = wrapTrace ("inferBinder' CTOR: " <> show ctor) $ do
   traceM $ "InferBinder VAL:\n" <>  ppType 100 val
@@ -572,8 +600,8 @@ inferBinder' val (A.PositionedBinder pos _ binder) = wrapTrace "inferBinder' POS
   warnAndRethrowWithPositionTC pos $ inferBinder' val binder
 inferBinder' val (A.TypedBinder ty binder) = wrapTrace "inferBinder' TYPEDBINDER" $ do
   (elabTy, kind) <- kindOf ty
-  checkTypeKind ty kind -- NOTE: Check whether we really need to do anything except inferBinder' the inner
-  unifyTypes val elabTy
+  -- checkTypeKind ty kind -- NOTE: Check whether we really need to do anything except inferBinder' the inner
+  -- unifyTypes val elabTy
   inferBinder' elabTy binder
 inferBinder' _ A.OpBinder{} =
   internalError "OpBinder should have been desugared before inferBinder'"
diff --git a/src/Language/PureScript/CoreFn/Desugar/Utils.hs b/src/Language/PureScript/CoreFn/Desugar/Utils.hs
index aa777e9c1..bf0d62cec 100644
--- a/src/Language/PureScript/CoreFn/Desugar/Utils.hs
+++ b/src/Language/PureScript/CoreFn/Desugar/Utils.hs
@@ -4,7 +4,6 @@
 module Language.PureScript.CoreFn.Desugar.Utils where
 
 import Prelude
-import Prelude qualified as P
 import Protolude (MonadError (..), traverse_)
 
 import Data.Function (on)
@@ -31,18 +30,15 @@ import Language.PureScript.Environment (
   dictTypeName,
   TypeClassData (typeClassArguments),
   function,
-  pattern (:->), pattern (:$), isDictTypeName)
+  pattern (:->),
+  isDictTypeName)
 import Language.PureScript.Names (Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), disqualify, getQual, runIdent, coerceProperName)
 import Language.PureScript.Types (SourceType, Type(..), Constraint (..), srcTypeConstructor, srcTypeApp, rowToSortedList, RowListItem(..), replaceTypeVars, everywhereOnTypes)
-import Language.PureScript.AST.Binders qualified as A
-import Language.PureScript.AST.Declarations qualified as A
 import Control.Monad.Supply.Class (MonadSupply)
 import Control.Monad.State.Strict (MonadState, gets, modify')
 import Control.Monad.Writer.Class ( MonadWriter )
 import Language.PureScript.TypeChecker.Types
-    ( kindType,
-      TypedValue'(TypedValue'),
-      infer )
+    ( kindType )
 import Language.PureScript.Errors
     ( MultipleErrors )
 import Debug.Trace (traceM, trace)
@@ -55,7 +51,6 @@ import Language.PureScript.TypeChecker.Monad
       getEnv,
       withScopedTypeVars,
       CheckState(checkCurrentModule, checkEnv), debugNames )
-import Language.PureScript.Pretty.Values (renderValue)
 import Language.PureScript.PSString (PSString)
 import Language.PureScript.Label (Label(..))
 import Data.Bifunctor (Bifunctor(..))
@@ -214,19 +209,6 @@ traverseLit f = \case
   ArrayLiteral xs  -> ArrayLiteral <$> traverse f xs
   ObjectLiteral xs -> ObjectLiteral <$> traverse (\(str,x) -> f x >>= \b -> pure (str,b)) xs
 
-{- `exprtoCoreFn` takes a `Maybe SourceType` argument. While in principle we should never need to infer the type
-    using PS type inference machinery (we should always be able to reconstruct it w/ recursive applications of
-    `exprToCoreFn` on the components), I have to get around to rewriting the corefn desugaring code to avoid this.
-
-    Should be DEPRECATED eventually.
--}
-inferType :: M m => Maybe SourceType -> A.Expr -> m SourceType
-inferType (Just t) _ = pure t
-inferType Nothing e = pTrace ("**********HAD TO INFER TYPE FOR: (" <> renderValue 100 e <> ")") >>
-  infer e >>= \case
-    TypedValue' _ _ t -> do
-      traceM ("TYPE: " <> ppType 100 t)
-      pure t
 
 -- Wrapper around instantiatePolyType to provide a better interface
 withInstantiatedFunType :: M m => ModuleName -> SourceType -> (SourceType -> SourceType -> m (Expr Ann)) -> m (Expr Ann)
@@ -259,11 +241,11 @@ instantiatePolyType mn = \case
           -- FIXME: kindType?
           act' ma = withScopedTypeVars mn [(var,kindType)] $ act ma -- NOTE: Might need to pattern match on mbk and use the real kind (though in practice this should always be of kind Type, I think?)
       in (inner, f . g, act')
-  fun@(a :-> r) -> case analyzeCtor a of
+  fun@(a :-> _) -> case analyzeCtor a of
       Just (TypeConstructor _ (Qualified _ nm), _) ->
         if isDictTypeName nm
           then
-            let act' ma = bindLocalVariables [(NullSourceSpan,Ident "dict",a,Defined)] $ ma
+            let act' ma = bindLocalVariables [(NullSourceSpan,Ident "dict",a,Defined)] ma
             in (fun,id,act')
           else (fun,id,id)
       _ -> (fun,id,id)
@@ -289,13 +271,13 @@ traceNameTypes  = do
    will always give us a "wrong" type. Let's try fixing them in the context!
 
 -}
-desugarConstraintType' :: SourceType -> SourceType
-desugarConstraintType' = \case
+desugarConstraintType :: SourceType -> SourceType
+desugarConstraintType = \case
   ForAll a vis var mbk t mSkol ->
-    let t' = desugarConstraintType' t
+    let t' = desugarConstraintType t
     in ForAll a vis var mbk t' mSkol
   ConstrainedType _ Constraint{..} t ->
-    let inner = desugarConstraintType' t
+    let inner = desugarConstraintType t
         dictTyName :: Qualified (ProperName 'TypeName) = dictTypeName . coerceProperName <$> constraintClass
         dictTyCon = srcTypeConstructor dictTyName
         dictTy = foldl srcTypeApp dictTyCon constraintArgs
@@ -305,7 +287,7 @@ desugarConstraintType' = \case
 desugarConstraintTypes :: M m =>  m ()
 desugarConstraintTypes  = do
   env <- getEnv
-  let f = everywhereOnTypes desugarConstraintType'
+  let f = everywhereOnTypes desugarConstraintType
 
       oldNameTypes = names env
       desugaredNameTypes = (\(st,nk,nv) -> (f st,nk,nv)) <$> oldNameTypes
@@ -330,11 +312,12 @@ desugarConstraintsInDecl :: A.Declaration -> A.Declaration
 desugarConstraintsInDecl = \case
   A.BindingGroupDeclaration decls ->
     A.BindingGroupDeclaration
-      $ (\(annIdent,nk,expr) -> (annIdent,nk,overTypes desugarConstraintType' expr)) <$> decls
+      $ (\(annIdent,nk,expr) -> (annIdent,nk,overTypes desugarConstraintType expr)) <$> decls
   A.ValueDecl ann name nk bs [A.MkUnguarded e] ->
-     A.ValueDecl ann name nk bs [A.MkUnguarded $ overTypes desugarConstraintType' e]
+     A.ValueDecl ann name nk bs [A.MkUnguarded $ overTypes desugarConstraintType e]
   A.DataDeclaration ann declTy tName args ctorDecs ->
-    let fixCtor (A.DataConstructorDeclaration a nm fields) = A.DataConstructorDeclaration a nm (second (everywhereOnTypes desugarConstraintType') <$> fields)
+    let fixCtor (A.DataConstructorDeclaration a nm fields)
+          = A.DataConstructorDeclaration a nm (second (everywhereOnTypes desugarConstraintType) <$> fields)
     in A.DataDeclaration ann declTy tName args (fixCtor <$> ctorDecs)
   other -> other
 
diff --git a/src/Language/PureScript/CoreFn/Pretty.hs b/src/Language/PureScript/CoreFn/Pretty.hs
index 90c86c097..8c1d308c6 100644
--- a/src/Language/PureScript/CoreFn/Pretty.hs
+++ b/src/Language/PureScript/CoreFn/Pretty.hs
@@ -84,7 +84,7 @@ prettyPrintValue d (Let _ _  ds val) =
     moveRight 2 (vcat left (map (prettyPrintDeclaration (d - 1)) ds)) //
     (text "in " <> prettyPrintValue (d - 1) val)
 -- TODO: constraint kind args
-prettyPrintValue d (Literal _ _ l) = prettyPrintLiteralValue d l
+prettyPrintValue d (Literal _ ty l) = text "(" <> prettyPrintLiteralValue d l <> ": " <> text (oneLine (ppType 100 ty)) <> text ")"
 prettyPrintValue d expr@Constructor{} = prettyPrintValueAtom d expr
 prettyPrintValue d expr@Var{} = prettyPrintValueAtom d expr
 
diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
index df2cc9147..561da8c75 100644
--- a/src/Language/PureScript/Environment.hs
+++ b/src/Language/PureScript/Environment.hs
@@ -379,9 +379,7 @@ pattern ArrayT :: Type a -> Type a
 pattern ArrayT a <-
   TypeApp _ (TypeConstructor _ C.Array) a
 
-pattern (:$) :: Type a -> Type a -> Type a
-pattern f :$ a <-
-  TypeApp _ f a
+
 
 arrayT :: SourceType -> SourceType
 arrayT = TypeApp NullSourceAnn (TypeConstructor NullSourceAnn C.Array)

From 161bdefa34ff719b393f9408f6da96ef679119a4 Mon Sep 17 00:00:00 2001
From: gnumonik <gnumonik@protonmail.com>
Date: Thu, 29 Feb 2024 21:06:06 -0500
Subject: [PATCH 07/20] Added some empty list tests

---
 tests/purus/passing/Misc/Lib.purs | 9 +++++++++
 1 file changed, 9 insertions(+)

diff --git a/tests/purus/passing/Misc/Lib.purs b/tests/purus/passing/Misc/Lib.purs
index 17fc39006..7f14dab31 100644
--- a/tests/purus/passing/Misc/Lib.purs
+++ b/tests/purus/passing/Misc/Lib.purs
@@ -168,6 +168,15 @@ polyInObjMatch = case polyInObj of
 aPred :: Int -> Boolean
 aPred _ = true
 
+cons :: forall a. a -> Array a -> Array a
+cons x xs = [x]
+
+emptyList = []
+
+consEmptyList1 = cons 1 emptyList
+
+consEmptyList2 = cons "hello" emptyList
+
 {- We should probably just remove guarded case branches, see slack msg
 guardedCase :: Int
 guardedCase = case polyInObj of

From f35cdb00ab93d0238d992deed6e158a2bb6133ea Mon Sep 17 00:00:00 2001
From: gnumonik <gnumonik@protonmail.com>
Date: Fri, 1 Mar 2024 21:06:30 -0500
Subject: [PATCH 08/20] Prettyprinter replacement implemented (still needs some
 tweaking)

---
 purescript.cabal                          |   4 +
 src/Language/PureScript/CoreFn/Desugar.hs |   6 +-
 src/Language/PureScript/CoreFn/Pretty.hs  | 455 ++++++++++++++--------
 src/Language/PureScript/Make.hs           |   3 +-
 src/Language/PureScript/Make/Actions.hs   |   8 +-
 5 files changed, 309 insertions(+), 167 deletions(-)

diff --git a/purescript.cabal b/purescript.cabal
index ae6ab30fc..4b57b9f73 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -86,6 +86,9 @@ common defaults
     -Wno-missing-export-lists
     -Wno-missing-kind-signatures
     -Wno-partial-fields
+
+    -- TODO: Remove
+    -O0
   default-language: Haskell2010
   default-extensions:
     BangPatterns
@@ -193,6 +196,7 @@ common defaults
     pattern-arrows >=0.0.2 && <0.1,
     process ==1.6.13.1,
     pretty-simple,
+    prettyprinter,
     protolude >=0.3.1 && <0.4,
     regex-tdfa >=1.3.1.2 && <1.4,
     safe >=0.3.19 && <0.4,
diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs
index 2da586ded..3e357c13c 100644
--- a/src/Language/PureScript/CoreFn/Desugar.hs
+++ b/src/Language/PureScript/CoreFn/Desugar.hs
@@ -64,7 +64,7 @@ import Control.Monad (forM, (>=>), foldM)
 import Language.PureScript.Errors
     ( MultipleErrors, errorMessage', SimpleErrorMessage(..))
 import Debug.Trace (traceM)
-import Language.PureScript.CoreFn.Pretty ( ppType, renderExpr )
+import Language.PureScript.CoreFn.Pretty ( ppType, renderExprStr )
 import Data.Text qualified as T
 import Language.PureScript.Pretty.Values (renderValue)
 import Language.PureScript.TypeChecker.Monad
@@ -354,10 +354,10 @@ exprToCoreFn mn ss mTy app@(A.App fun arg)
       traceM $ renderValue 100 app
       fun' <- exprToCoreFn mn ss Nothing fun
       let funTy = exprType fun'
-      traceM $ "app fun:\n" <> ppType 100  funTy <> "\n" <> renderExpr 100 fun'
+      traceM $ "app fun:\n" <> ppType 100  funTy <> "\n" <> renderExprStr fun'
       withInstantiatedFunType mn  funTy $ \a b -> do
         arg' <- exprToCoreFn mn ss (Just a) arg
-        traceM $ "app arg:\n" <> ppType 100 (exprType arg') <> "\n" <> renderExpr 100 arg'
+        traceM $ "app arg:\n" <> ppType 100 (exprType arg') <> "\n" <> renderExprStr arg'
         pure $ App (ss, [], Nothing) (fromMaybe b mTy) fun' arg'
 
   where
diff --git a/src/Language/PureScript/CoreFn/Pretty.hs b/src/Language/PureScript/CoreFn/Pretty.hs
index 8c1d308c6..be20a3756 100644
--- a/src/Language/PureScript/CoreFn/Pretty.hs
+++ b/src/Language/PureScript/CoreFn/Pretty.hs
@@ -1,8 +1,9 @@
+{-# LANGUAGE TypeApplications, ScopedTypeVariables #-}
 module Language.PureScript.CoreFn.Pretty where
 
 import Prelude hiding ((<>))
 
-import Control.Arrow (second)
+
 
 import Data.Text (Text)
 import Data.List.NonEmpty qualified as NEL
@@ -15,19 +16,61 @@ import Language.PureScript.CoreFn.Module
 import Language.PureScript.AST.Literals
 import Language.PureScript.CoreFn.Binders
 import Language.PureScript.Crash (internalError)
-import Language.PureScript.Names (OpName(..), ProperName(..), Qualified(..), disqualify, runModuleName, showIdent, Ident, ModuleName)
+import Language.PureScript.Names (OpName(..), ProperName(..), Qualified(..), disqualify, runModuleName, showIdent, Ident, ModuleName, showQualified)
 import Language.PureScript.Pretty.Common (before, beforeWithSpace, parensT)
-import Language.PureScript.Pretty.Types ( typeAsBox, typeAtomAsBox, prettyPrintObjectKey)
-import Language.PureScript.Types (Constraint(..), Type)
-import Language.PureScript.PSString (PSString, prettyPrintString)
+import Language.PureScript.Types (Constraint(..), Type (..), WildcardData (..), TypeVarVisibility (..), eqType)
+import Language.PureScript.PSString (PSString, prettyPrintString, decodeStringWithReplacement)
+import System.IO (Handle)
 
-import Text.PrettyPrint.Boxes (Box, left, moveRight, text, vcat, hcat, vsep, (//), (<>), render)
-import Language.PureScript.Pretty.Types
 import Data.Map qualified as M
 
+import Prettyprinter
+import Prettyprinter.Render.Text
+import qualified Prettyprinter.Render.String as STR
+import Data.Bifunctor (first, Bifunctor (..))
+import Language.PureScript.Label (Label (..))
+import Control.Monad (void)
+
+
+
+withOpenRow :: forall ann. Doc ann -> Doc ann -> ([Doc ann],Doc ann) -> Doc ann
+withOpenRow l r (fields,open) =  group $ align $ enclose (l <> softline) (softline <> r) $ hsep $ punctuate comma fields'
+  where
+    fields' =  foldr (\x acc -> case acc of
+                      [] -> [hsep [x,pipe <++> open]]
+                      xs -> x : xs
+                    ) [] fields
+
+openRow :: ([Doc ann], Doc ann) -> Doc ann
+openRow = withOpenRow lparen rparen
+
+openRecord :: ([Doc ann], Doc ann) -> Doc ann
+openRecord = withOpenRow lbrace rbrace
+
+recordLike ::  [Doc ann] -> Doc ann
+recordLike  fields  =
+  let fmtObj = encloseSep (lbrace <> softline) (softline <> rbrace) (comma <> softline)
+  in  group $ align (fmtObj fields)
+
+record :: [Doc ann] -> Doc ann
+record = recordLike
+
+object :: [Doc ann] -> Doc ann
+object = recordLike
+
+commaSep :: [Doc ann] -> Doc ann
+commaSep = vsep . punctuate comma
+
+indent' :: Int -> Doc ann -> Doc ann
+indent' i doc = group . align $ flatAlt (indent i doc) doc
+
+parens' :: Doc ann -> Doc ann
+parens' d = group $ align $ enclose (lparen <> softline) (rparen <> softline) d
+
+
 -- I can't figure out why their type pretty printer mangles record types, this is an incredibly stupid temporary hack
 ppType :: Int -> Type a -> String
-ppType i t = go [] $ prettyPrintType i t
+ppType i t = "<TYPE>" {- go [] $ prettyPrintType i t
   where
     go :: String -> String -> String
     go acc [] = acc
@@ -35,192 +78,284 @@ ppType i t = go [] $ prettyPrintType i t
       [] -> acc
       more -> go (acc `mappend` [' ']) more
     go acc (x:xs) = go (acc `mappend` [x]) xs
+-}
 
-textT :: Text -> Box
-textT = text . T.unpack
+instance Pretty Ident where
+  pretty = pretty . showIdent
 
-oneLine :: String -> String
-oneLine = filter (/= '\n')
+instance Pretty PSString where
+  pretty = pretty . decodeStringWithReplacement
 
--- | Render an aligned list of items separated with commas
-list :: Char -> Char -> (a -> Box) -> [a] -> Box
-list open close _ [] = text [open, close]
-list open close f xs = vcat left (zipWith toLine [0 :: Int ..] xs ++ [ text [ close ] ])
-  where
-  toLine i a = text [ if i == 0 then open else ',', ' ' ] <> f a
+instance Pretty ModuleName where
+  pretty = pretty . runModuleName
 
+instance Pretty Label where
+  pretty = pretty . runLabel
 
-hlist :: Char -> Char -> (a -> Box) -> [a] -> Box
-hlist open close _ [] = text [open, close]
-hlist open close f xs = hcat left (zipWith toLine [0 :: Int ..] xs ++ [ text [ close ] ])
-  where
-  toLine i a = text [ if i == 0 then open else ',', ' ' ] <> f a
+ellipsis :: Doc ann
+ellipsis =  "..."
+
+(<:>) :: Doc ann -> Doc ann -> Doc ann
+a <:> b = hcat [a,":"] <++> b
+
+(<::>) :: Doc ann -> Doc ann -> Doc ann
+a <::> b = a <++> "::" <++> b
+
+(<=>) :: Doc ann -> Doc ann -> Doc ann
+a <=> b = a <+> "=" <+> b
+
+(<//>) :: Doc ann -> Doc ann -> Doc ann
+a <//> b = a <+> line <+> b
+
+-- ensures the things being concatenated are always on the same line
+(<++>) :: Doc ann -> Doc ann -> Doc ann
+a <++> b = hsep [a,b]
 
+arrow :: Doc ann
+arrow = "->"
 
-ellipsis :: Box
-ellipsis = text "..."
+lam :: Doc ann
+lam = "\\"
 
-prettyPrintObject :: Int -> [(PSString, Maybe (Expr a))] -> Box
-prettyPrintObject d = hlist '{' '}' prettyPrintObjectProperty
+doubleColon :: Doc ann
+doubleColon = hcat [colon,colon]
+
+caseOf :: [Doc ann] -> [Doc ann] -> Doc ann
+caseOf scrutinees branches = "case" <+> group (hsep scrutinees) <+> "of" <//> indent 2 (vcat . map group $ branches) -- if wrong try hang instead of hang
+
+prettyPrintObjectKey :: PSString -> Doc ann
+prettyPrintObjectKey = pretty . decodeStringWithReplacement
+
+prettyPrintObject ::  [(PSString, Maybe (Expr a))] -> Doc ann
+prettyPrintObject  = encloseSep "{"  "}" "," . map prettyPrintObjectProperty
   where
-  prettyPrintObjectProperty :: (PSString, Maybe (Expr a)) -> Box
-  prettyPrintObjectProperty (key, value) = textT (prettyPrintObjectKey key Monoid.<> ": ") <> maybe (text "_") (prettyPrintValue (d - 1)) value
+  prettyPrintObjectProperty :: (PSString, Maybe (Expr a)) -> Doc ann
+  prettyPrintObjectProperty (key, value) = (prettyPrintObjectKey key Monoid.<> ": ") <> maybe (pretty @Text "_") prettyPrintValue value
 
-prettyPrintUpdateEntry :: Int -> PSString -> Expr a -> Box
-prettyPrintUpdateEntry d key val = textT (prettyPrintObjectKey key) <> text " = " <> prettyPrintValue (d - 1) val
+prettyPrintUpdateEntry :: PSString -> Expr a -> Doc ann
+prettyPrintUpdateEntry key val =  prettyPrintObjectKey key <+> "=" <+> prettyPrintValue val
 
 -- | Pretty-print an expression
-prettyPrintValue :: Int -> Expr a -> Box
--- prettyPrintValue d _ | d < 0 = text "..."
-prettyPrintValue d (Accessor _ ty prop val) = prettyPrintValueAtom (d - 1) val `before` textT ("." Monoid.<> prettyPrintObjectKey prop)
-prettyPrintValue d (ObjectUpdate ann _ty o _copyFields ps) = prettyPrintValueAtom (d - 1) o `beforeWithSpace` list '{' '}' (uncurry (prettyPrintUpdateEntry d)) ps
-prettyPrintValue d (App ann ty val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg
-prettyPrintValue d (Abs ann ty arg val) = text (oneLine $ '\\' : "(" ++ T.unpack (showIdent arg) ++ ": " ++ ppType (d) (getFunArgTy ty) ++ ") -> ") //  (prettyPrintValue (d-1)  val)
-prettyPrintValue d (Case ann ty values binders) =
-  (text "case " <> foldr beforeWithSpace (text "of") (map (prettyPrintValueAtom (d - 1)) values)) //
-    moveRight 2 (vcat left (map (prettyPrintCaseAlternative (d - 1)) binders))
-prettyPrintValue d (Let _ _  ds val) =
-  text "let" //
-    moveRight 2 (vcat left (map (prettyPrintDeclaration (d - 1)) ds)) //
-    (text "in " <> prettyPrintValue (d - 1) val)
--- TODO: constraint kind args
-prettyPrintValue d (Literal _ ty l) = text "(" <> prettyPrintLiteralValue d l <> ": " <> text (oneLine (ppType 100 ty)) <> text ")"
-prettyPrintValue d expr@Constructor{} = prettyPrintValueAtom d expr
-prettyPrintValue d expr@Var{} = prettyPrintValueAtom d expr
+prettyPrintValue ::  Expr a -> Doc ann
+-- prettyPrintValue _ | d < 0 = text "..."
+prettyPrintValue (Accessor _ ty prop val) = group . align $ vcat [prettyPrintValueAtom  val,hcat[dot,prettyPrintObjectKey prop]]
+prettyPrintValue (ObjectUpdate ann _ty o _copyFields ps) = prettyPrintValueAtom  o <+> encloseSep "{" "}" "," (uncurry prettyPrintUpdateEntry <$> ps)
+prettyPrintValue (App ann ty val arg) = group . align $ vsep [prettyPrintValueAtom  val,prettyPrintValueAtom  arg]
+prettyPrintValue (Abs ann ty arg val) = group . align $ flatAlt multiLine oneLine
+  where
+    multiLine = lam
+      <> parens (align $ pretty (showIdent arg) <:> prettyType (getFunArgTy ty))
+      <+> arrow
+      <> hardline
+      <> hang 2 (prettyPrintValue  val)
+
+    oneLine = lam
+      <> parens (align $ pretty (showIdent arg) <:> prettyType (getFunArgTy ty))
+      <+> arrow
+      <+> prettyPrintValue val
+
+prettyPrintValue (Case ann ty values binders) =
+  caseOf (prettyPrintValueAtom <$> values) (prettyPrintCaseAlternative <$> binders)
+prettyPrintValue (Let _ _  ds val) =  mappend line $ indent 2 $ vcat [
+  "let",
+  indent 2 $ vcat $  prettyPrintDeclaration <$> ds,
+  "in" <+> align (prettyPrintValue val)
+  ]
+
+prettyPrintValue (Literal _ ty l) = parens $  prettyPrintLiteralValue l <:> prettyType ty
+prettyPrintValue expr@Constructor{} = prettyPrintValueAtom  expr
+prettyPrintValue expr@Var{} = prettyPrintValueAtom  expr
 
 -- | Pretty-print an atomic expression, adding parentheses if necessary.
-prettyPrintValueAtom :: Int -> Expr a -> Box
-prettyPrintValueAtom d (Literal _  _ l) = prettyPrintLiteralValue d l
-prettyPrintValueAtom _ (Constructor _ _ _ name _) = text $ T.unpack $ runProperName name
-prettyPrintValueAtom d (Var ann ty ident) = text . oneLine $ "(" ++  T.unpack (showIdent (disqualify ident)) ++ ": " ++ ppType d ty ++  ")"
-prettyPrintValueAtom d expr = (text "(" <> prettyPrintValue d expr) `before` text ")"
-
-prettyPrintLiteralValue :: Int -> Literal (Expr a) -> Box
-prettyPrintLiteralValue _ (NumericLiteral n) = text $ either show show n
-prettyPrintLiteralValue _ (StringLiteral s) = text $ T.unpack $ prettyPrintString s
-prettyPrintLiteralValue _ (CharLiteral c) = text $ show c
-prettyPrintLiteralValue _ (BooleanLiteral True) = text "true"
-prettyPrintLiteralValue _ (BooleanLiteral False) = text "false"
-prettyPrintLiteralValue d (ArrayLiteral xs) = list '[' ']' (prettyPrintValue (d - 1)) xs
-prettyPrintLiteralValue d (ObjectLiteral ps) = prettyPrintObject (d - 1) $ second Just `map` ps
-
-prettyPrintDeclaration :: Int -> Bind a -> Box
+prettyPrintValueAtom :: Expr a -> Doc ann
+prettyPrintValueAtom (Literal _  _ l) = prettyPrintLiteralValue l
+prettyPrintValueAtom (Constructor _ _ _ name _) = pretty $ T.unpack $ runProperName name
+prettyPrintValueAtom (Var ann ty ident) =  parens $   pretty  (showIdent (disqualify ident)) <:> prettyType ty
+prettyPrintValueAtom expr =  (prettyPrintValue expr)
+
+prettyPrintLiteralValue :: Literal (Expr a) -> Doc ann
+prettyPrintLiteralValue (NumericLiteral n) = pretty $ either show show n
+prettyPrintLiteralValue (StringLiteral s) = pretty . T.unpack $ prettyPrintString s
+prettyPrintLiteralValue (CharLiteral c) = viaShow . show $ c
+prettyPrintLiteralValue (BooleanLiteral True) = "true"
+prettyPrintLiteralValue (BooleanLiteral False) = "false"
+prettyPrintLiteralValue (ArrayLiteral xs) = list $ prettyPrintValue <$>  xs
+prettyPrintLiteralValue (ObjectLiteral ps) = prettyPrintObject  $ second Just `map` ps
+
+prettyPrintDeclaration :: Bind a -> Doc ann
 -- prettyPrintDeclaration d _ | d < 0 = ellipsis
-prettyPrintDeclaration d b = case b of
-  NonRec _ ident expr ->
-    vcat left [
-      text (oneLine $ T.unpack (showIdent ident) ++ " :: " ++ ppType 0 (exprType expr)  ),
-      text (T.unpack (showIdent ident) ++ " = ") <> prettyPrintValue d expr -- not sure about the d here
-
+prettyPrintDeclaration b = case b of
+  NonRec _ ident expr -> vcat  [
+       pretty ident <::> prettyType (exprType expr),
+       pretty ident <=>  prettyPrintValue expr -- not sure about the d here
     ]
-  Rec bindings -> vsep 1 left $ map (\((_,ident),expr) ->
-        vcat left [
-          text (oneLine $ T.unpack (showIdent ident) ++ " :: " ++ ppType 0 (exprType expr)  ),
-          text (T.unpack (showIdent ident) ++ " = ") <> prettyPrintValue (d-1) expr
-
+  Rec bindings -> vcat $ concatMap (\((_,ident),expr) -> [
+          pretty ident <::> prettyType (exprType expr),
+          pretty ident <=> prettyPrintValue  expr
       ]) bindings
 
-prettyPrintCaseAlternative :: Int -> CaseAlternative a -> Box
+prettyPrintCaseAlternative ::  forall a ann. CaseAlternative a -> Doc ann
 -- prettyPrintCaseAlternative d _ | d < 0 = ellipsis
-prettyPrintCaseAlternative d (CaseAlternative binders result) =
-  text (T.unpack (T.unwords (map prettyPrintBinderAtom binders))) <> prettyPrintResult result
+prettyPrintCaseAlternative (CaseAlternative binders result) =
+  hsep (map prettyPrintBinderAtom binders) <> prettyPrintResult result
   where
-  prettyPrintResult :: Either [(Guard a, Expr a)] (Expr a) -> Box
+  prettyPrintResult :: Either [(Guard a, Expr a)] (Expr a) -> Doc ann
   prettyPrintResult = \case
-    Left ges -> vcat left $  map (prettyPrintGuardedValueSep' (text " | ")) ges
-    Right exp -> text " -> " <> prettyPrintValue (d-1) exp
+    Left ges -> vcat $  map prettyPrintGuardedValueSep'  ges
+    Right exp' -> space <> arrow <+> prettyPrintValue  exp'
 
-  prettyPrintGuardedValueSep' :: Box -> (Guard a, Expr a) -> Box
-  prettyPrintGuardedValueSep' sep (guardE, resultE) =
-    prettyPrintValue (d-1) guardE <> text " -> " <> prettyPrintValue (d-1) resultE
+  prettyPrintGuardedValueSep' ::  (Guard a, Expr a) -> Doc ann
+  prettyPrintGuardedValueSep'  (guardE, resultE) =
+    " | " <> prettyPrintValue  guardE <+> arrow  <+> prettyPrintValue  resultE
 
 
-prettyPrintModule :: Module a -> Box
+prettyPrintModule :: Module a -> Doc ann
 prettyPrintModule (Module modSS modComments modName modPath modImports modExports modReExports modForeign modDecls) =
-  vcat left $
-    [text (show modName ++ " (" ++ modPath ++ ")")]
-    ++ ["Imported Modules: "]
-    ++ map (moveRight 2 . text . show . snd) modImports
-    ++ ["Exports: "]
-    ++ map (moveRight 2 . text . T.unpack . showIdent) modExports
-    ++ ["Re-Exports: "]
-    ++ map (moveRight 2 . goReExport) (M.toList modReExports)
-    ++ ["Foreign: "]
-    ++ map (moveRight 2. text . T.unpack . showIdent) modForeign
-    ++ ["Declarations: "]
-    ++ map (prettyPrintDeclaration 0) modDecls
- where
-   goReExport :: (ModuleName,[Ident]) -> Box
-   goReExport (mn,idents) = vcat left $ flip map idents $ \i -> text (show mn ++ "." ++ T.unpack (showIdent i))
-
-prettyPrintModule' :: Module a -> String
-prettyPrintModule' = render . prettyPrintModule
-
-renderExpr :: Int -> Expr a -> String
-renderExpr i e = render $ prettyPrintValue i e
-{-
-  prettyPrintResult [GuardedExpr [] v] = text " -> " <> prettyPrintValue (d - 1) v
-  prettyPrintResult gs =
-    vcat left (map (prettyPrintGuardedValueSep (text " | ")) gs)
-
-  prettyPrintGuardedValueSep :: Box -> GuardedExpr -> Box
-  prettyPrintGuardedValueSep _ (GuardedExpr [] val) =
-    text " -> " <> prettyPrintValue (d - 1) val
-
-  prettyPrintGuardedValueSep sep (GuardedExpr [guard] val) =
-    foldl1 before [ sep
-                  , prettyPrintGuard guard
-                  , prettyPrintGuardedValueSep sep (GuardedExpr [] val)
-                  ]
-
-  prettyPrintGuardedValueSep sep (GuardedExpr (guard : guards) val) =
-    vcat left [ foldl1 before
-                [ sep
-                , prettyPrintGuard guard
-                ]
-              , prettyPrintGuardedValueSep (text " , ") (GuardedExpr guards val)
-              ]
-
-  prettyPrintGuard (ConditionGuard cond) =
-    prettyPrintValue (d - 1) cond
-  prettyPrintGuard (PatternGuard binder val) =
-    foldl1 before
-    [ text (T.unpack (prettyPrintBinder binder))
-    , text " <- "
-    , prettyPrintValue (d - 1) val
+  vsep  $
+    [ pretty modName <+>  parens (pretty modPath)
+    , "Imported Modules: "
+    , indent 2 . commaSep $ pretty . snd  <$>  modImports
+    ,"Exports: "
+    , indent 2 . commaSep $ pretty <$> modExports -- hang 2?
+    , "Re-Exports: "
+    , indent 2 . commaSep $ goReExport <$> M.toList modReExports
+    , "Foreign: "
+    , indent 2 . commaSep . map pretty $  modForeign
+    , "Declarations: "
+    , vcat . punctuate line $  prettyPrintDeclaration  <$> modDecls
     ]
--}
+ where
+   goReExport :: (ModuleName,[Ident]) -> Doc ann
+   goReExport (mn',idents) = vcat $ flip map idents $ \i -> pretty mn' <> "." <> pretty i
+
+smartRender ::  Doc ann -> Text
+smartRender = renderStrict . layoutPretty defaultLayoutOptions
+
+writeModule :: Handle -> Module a -> IO ()
+writeModule h m = renderIO h
+                . layoutSmart defaultLayoutOptions
+                $ prettyPrintModule m
+
+prettyPrintModuleTxt :: Module a -> Text
+prettyPrintModuleTxt = renderStrict  . layoutPretty defaultLayoutOptions .  prettyPrintModule
+
+prettyPrintModuleStr :: Module a -> String
+prettyPrintModuleStr = STR.renderString . layoutPretty defaultLayoutOptions . prettyPrintModule
+
+renderExpr :: Expr a -> Text
+renderExpr = smartRender . prettyPrintValue
+
+renderExprStr :: Expr a -> String
+renderExprStr = T.unpack . renderExpr
 
-prettyPrintBinderAtom :: Binder a -> Text
+prettyTypeStr :: forall a. Show a => Type a -> String
+prettyTypeStr = T.unpack . smartRender . prettyType
+
+prettyPrintBinderAtom :: Binder a -> Doc ann
 prettyPrintBinderAtom (NullBinder _) = "_"
 prettyPrintBinderAtom (LiteralBinder _ l) = prettyPrintLiteralBinder l
-prettyPrintBinderAtom (VarBinder _ ident) = showIdent ident
-prettyPrintBinderAtom (ConstructorBinder _ _ ctor []) = runProperName (disqualify ctor)
-prettyPrintBinderAtom b@ConstructorBinder{} = parensT (prettyPrintBinder b)
-prettyPrintBinderAtom (NamedBinder _ ident binder) = showIdent ident Monoid.<> "@" Monoid.<> prettyPrintBinder binder
-
-prettyPrintLiteralBinder :: Literal (Binder a) -> Text
-prettyPrintLiteralBinder (StringLiteral str) = prettyPrintString str
-prettyPrintLiteralBinder (CharLiteral c) = T.pack (show c)
-prettyPrintLiteralBinder (NumericLiteral num) = either (T.pack . show) (T.pack . show) num
+prettyPrintBinderAtom (VarBinder _ ident) = pretty ident
+prettyPrintBinderAtom (ConstructorBinder _ _ ctor []) = pretty $ runProperName (disqualify ctor)
+prettyPrintBinderAtom b@ConstructorBinder{} = prettyPrintBinder b
+prettyPrintBinderAtom (NamedBinder _ ident binder) = pretty ident <> "@" <> prettyPrintBinder binder
+
+prettyPrintLiteralBinder :: Literal (Binder a) -> Doc ann
+prettyPrintLiteralBinder (StringLiteral str) = pretty $ prettyPrintString str
+prettyPrintLiteralBinder (CharLiteral c) = viaShow c
+prettyPrintLiteralBinder (NumericLiteral num) = either pretty pretty num
 prettyPrintLiteralBinder (BooleanLiteral True) = "true"
 prettyPrintLiteralBinder (BooleanLiteral False) = "false"
-prettyPrintLiteralBinder (ObjectLiteral bs) =
-  "{ "
-  Monoid.<> T.intercalate ", " (map prettyPrintObjectPropertyBinder bs)
-  Monoid.<> " }"
+prettyPrintLiteralBinder (ObjectLiteral bs) = object $ prettyPrintObjectPropertyBinder <$> bs
   where
-  prettyPrintObjectPropertyBinder :: (PSString, Binder a) -> Text
-  prettyPrintObjectPropertyBinder (key, binder) = prettyPrintObjectKey key Monoid.<> ": " Monoid.<> prettyPrintBinder binder
-prettyPrintLiteralBinder (ArrayLiteral bs) =
-  "[ "
-  Monoid.<> T.intercalate ", " (map prettyPrintBinder bs)
-  Monoid.<> " ]"
+  prettyPrintObjectPropertyBinder :: (PSString, Binder a) -> Doc ann
+  prettyPrintObjectPropertyBinder (key, binder) = prettyPrintObjectKey key <:> prettyPrintBinder binder
+prettyPrintLiteralBinder (ArrayLiteral bs) = list (prettyPrintBinder <$> bs)
 
 -- |
 -- Generate a pretty-printed string representing a Binder
 --
-prettyPrintBinder :: Binder a -> Text
-prettyPrintBinder (ConstructorBinder _ _ ctor []) = runProperName (disqualify ctor)
-prettyPrintBinder (ConstructorBinder _ _ ctor args) = runProperName (disqualify ctor) Monoid.<> " " Monoid.<> T.unwords (map prettyPrintBinderAtom args)
+prettyPrintBinder :: Binder a -> Doc ann
+prettyPrintBinder (ConstructorBinder _ _ ctor []) = pretty $ runProperName (disqualify ctor)
+prettyPrintBinder (ConstructorBinder _ _ ctor args) =
+  pretty (runProperName (disqualify ctor)) <+> hcat (prettyPrintBinderAtom <$> args)
 prettyPrintBinder b = prettyPrintBinderAtom b
+
+
+{- TYPES (move later) -}
+
+prettyType :: forall a ann. Show a => Type a -> Doc ann
+prettyType t=  group $ case t of
+  TUnknown _ n -> "t" <> pretty n
+
+  TypeVar _ txt -> pretty txt
+
+  TypeLevelString _ pss -> pretty . prettyPrintString $ pss
+
+  TypeLevelInt _ i -> pretty i
+
+  TypeWildcard _ wcd -> case wcd of
+    HoleWildcard txt -> "?" <> pretty txt
+    _ -> "_"
+
+  TypeConstructor _ qPropName -> pretty . runProperName . disqualify $ qPropName
+
+  TypeOp a opName -> pretty $ showQualified runOpName opName
+
+  TypeApp _ t1 t2 -> goTypeApp t1 t2
+
+  KindApp a k1 k2 -> prettyType k1 <> ("@" <> prettyType k2)
+
+  ForAll _ vis var mKind inner' _ -> case stripQuantifiers inner' of
+    (quantified,inner) ->  goForall ([(vis,var,mKind)] <> quantified) inner
+
+  ConstrainedType _ constraint inner -> error "TODO: ConstrainedType"
+
+  Skolem _ txt mKind inner mSkolScope -> error "TODO: Skolem"
+
+  REmpty _ -> "{}"
+
+  rcons@RCons{} -> either openRow tupled $ rowFields rcons
+
+  -- this might be backwards
+  KindedType a ty kind -> parens $ prettyType ty <::> prettyType kind
+
+  -- not sure what this is?
+  BinaryNoParensType a op l r -> prettyType l <++> prettyType op <++> prettyType r
+
+  ParensInType _ ty -> parens (prettyType ty)
+ where
+   goForall :: [(TypeVarVisibility,Text,Maybe (Type a))] -> Type a -> Doc ann
+   goForall xs inner = "forall" <++> hcat (renderBoundVar <$> xs) <> "." <++> prettyType inner
+
+   prefixVis :: TypeVarVisibility -> Doc ann -> Doc ann
+   prefixVis vis tv = case vis of
+     TypeVarVisible -> hcat ["@",tv]
+     TypeVarInvisible -> tv
+
+   renderBoundVar :: (TypeVarVisibility, Text, Maybe (Type a)) -> Doc ann
+   renderBoundVar (vis,var,mk) =  case mk of
+     Just k -> parens $ prefixVis vis (pretty var) <::> prettyType k
+     Nothing -> prefixVis vis (pretty var)
+
+   stripQuantifiers :: Type a -> ([(TypeVarVisibility,Text,Maybe (Type a))],Type a)
+   stripQuantifiers = \case
+     ForAll _ vis var mk inner _ -> first ((vis,var,mk):) $ stripQuantifiers inner
+     other -> ([],other)
+
+   goTypeApp :: Type a -> Type a -> Doc ann
+   goTypeApp (TypeApp _ f a) b
+     | eqType f tyFunction = prettyType a <++> arrow <++> prettyType b
+     | otherwise = parens $ goTypeApp f a  <++> prettyType b
+   goTypeApp o ty@RCons{}
+     | eqType o tyRecord = either openRecord record $ rowFields ty
+   goTypeApp a b =  prettyType a <++> prettyType b
+
+   rowFields :: Type a -> Either ([Doc ann], Doc ann) [Doc ann]
+   rowFields = \case
+         RCons _ lbl ty rest ->
+           let f = ((pretty lbl <::> prettyType ty):)
+           in bimap (first f) f $ rowFields rest
+         REmpty _ -> Right []
+         KindApp _ REmpty{} _  -> Right [] -- REmpty is sometimes wrapped in a kind app?
+         TypeVar _ txt -> Left ([],pretty txt)
+         other -> error $ "Malformed row fields: \n" <> show other
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index dec70c72f..6c7788875 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -52,6 +52,7 @@ import Language.PureScript.CoreFn qualified as CFT
 import Language.PureScript.CoreFn.Pretty qualified as CFT
 import System.Directory (doesFileExist)
 import System.FilePath (replaceExtension)
+import Prettyprinter.Util (putDocW)
 
 -- Temporary
 import Debug.Trace (traceM)
@@ -123,7 +124,7 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _
   -- pTrace exps
   ((coreFn,chkSt'),nextVar'') <- runSupplyT nextVar' $ runStateT (CFT.moduleToCoreFn mod') chkSt -- (emptyCheckState env')
 
-  traceM $ CFT.prettyPrintModule'  coreFn
+  traceM . T.unpack $ CFT.prettyPrintModuleTxt  coreFn
   let corefn = coreFn
       (optimized, nextVar''') = runSupply nextVar'' $ CF.optimizeCoreFn corefn
       (renamedIdents, renamed) = renameInModule optimized
diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs
index a1e13c321..512fea593 100644
--- a/src/Language/PureScript/Make/Actions.hs
+++ b/src/Language/PureScript/Make/Actions.hs
@@ -58,9 +58,10 @@ import SourceMap.Types (Mapping(..), Pos(..), SourceMapping(..))
 import System.Directory (getCurrentDirectory)
 import System.FilePath ((</>), makeRelative, splitPath, normalise, splitDirectories)
 import System.FilePath.Posix qualified as Posix
-import System.IO (stderr)
+import System.IO (stderr, withFile, IOMode(WriteMode))
 import Language.PureScript.CoreFn.ToJSON (moduleToJSON)
-import Language.PureScript.CoreFn.Pretty (prettyPrintModule')
+import Language.PureScript.CoreFn.Pretty (writeModule, prettyPrintModule)
+
 
 -- | Determines when to rebuild a module
 data RebuildPolicy
@@ -266,7 +267,8 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
     when (S.member CoreFn codegenTargets) $ do
       let targetFile = (targetFilename mn CoreFn)
       lift $ writeJSONFile targetFile (moduleToJSON (makeVersion [0,0,1]) m)
-      lift $ makeIO "write pretty core" $ writeFile (targetFile <> ".pretty") (prettyPrintModule' m)
+      lift $ makeIO "write pretty core" $ withFile (targetFile <> ".pretty") WriteMode $ \handle ->
+        writeModule  handle m
     when (S.member CheckCoreFn codegenTargets) $ do
       let mn' = T.unpack (runModuleName mn)
       mabOldModule <- lift $ readJSONFile  (targetFilename mn CoreFn)

From b4f557e19fb1052bee06b2bcacb428f32c916b20 Mon Sep 17 00:00:00 2001
From: gnumonik <gnumonik@protonmail.com>
Date: Sat, 2 Mar 2024 01:16:46 -0500
Subject: [PATCH 09/20] prettyprinter improvements

---
 src/Language/PureScript/CoreFn/Pretty.hs | 341 ++++++++++++++---------
 src/Language/PureScript/Make.hs          |   2 +-
 src/Language/PureScript/Make/Actions.hs  |   2 +-
 3 files changed, 209 insertions(+), 136 deletions(-)

diff --git a/src/Language/PureScript/CoreFn/Pretty.hs b/src/Language/PureScript/CoreFn/Pretty.hs
index be20a3756..b1b2ebe7a 100644
--- a/src/Language/PureScript/CoreFn/Pretty.hs
+++ b/src/Language/PureScript/CoreFn/Pretty.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TypeApplications, ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications, ScopedTypeVariables, RecordWildCards #-}
 module Language.PureScript.CoreFn.Pretty where
 
 import Prelude hiding ((<>))
@@ -31,31 +31,84 @@ import Data.Bifunctor (first, Bifunctor (..))
 import Language.PureScript.Label (Label (..))
 import Control.Monad (void)
 
+data LineFormat
+  = OneLine --  *DEFINITELY* Print on one line, even if doing so exceeds the page width
+  | MultiLine --  *Possibly* Print multiple lines.
+  deriving (Show, Eq)
 
+-- TODO: Refactor to reader monad?
+type Printer ann =  LineFormat  -> Doc ann
 
-withOpenRow :: forall ann. Doc ann -> Doc ann -> ([Doc ann],Doc ann) -> Doc ann
-withOpenRow l r (fields,open) =  group $ align $ enclose (l <> softline) (softline <> r) $ hsep $ punctuate comma fields'
+type Formatter = forall a ann. (a -> Printer ann) -> a -> Doc ann
+
+runPrinter :: LineFormat -> Printer ann -> Doc ann
+runPrinter fmt p = p fmt
+
+asFmt :: LineFormat -> (a -> Printer ann) -> a -> Doc ann
+asFmt fmt f x = case fmt of
+  OneLine -> asOneLine f x
+  MultiLine -> asDynamic f x
+
+asOneLine :: Formatter
+asOneLine p x = runPrinter OneLine (p x)
+
+asDynamic :: Formatter
+asDynamic p x = group $ align $ flatAlt (runPrinter MultiLine (p x)) (runPrinter OneLine (p x))
+
+ignoreFmt :: Doc ann -> Printer ann
+ignoreFmt doc = printer doc doc
+
+fmtSep :: LineFormat -> [Doc ann] -> Doc ann
+fmtSep = \case
+  OneLine -> hsep
+  MultiLine -> vsep
+
+fmtCat :: LineFormat -> [Doc ann] -> Doc ann
+fmtCat = \case
+  OneLine -> hcat
+  MultiLine -> vcat
+
+fmtSpacer :: LineFormat -> Doc ann
+fmtSpacer = \case
+  OneLine -> space
+  MultiLine -> softline
+
+
+printer :: Doc ann -> Doc ann -> Printer ann
+printer one multi = \case
+  OneLine -> one
+  MultiLine -> multi
+
+withOpenRow :: forall ann. Doc ann -> Doc ann -> ([Doc ann],Doc ann) -> Printer ann
+withOpenRow l r (fields,open) fmt =  group $ align $ enclose (l <> spacer) (spacer <> r) $ fmtSep fmt  $ punctuate comma fields'
   where
+    spacer = fmtSpacer fmt
     fields' =  foldr (\x acc -> case acc of
                       [] -> [hsep [x,pipe <++> open]]
                       xs -> x : xs
                     ) [] fields
 
-openRow :: ([Doc ann], Doc ann) -> Doc ann
+openRow :: ([Doc ann], Doc ann) -> Printer ann
 openRow = withOpenRow lparen rparen
 
-openRecord :: ([Doc ann], Doc ann) -> Doc ann
+openRecord :: ([Doc ann], Doc ann) -> Printer ann
 openRecord = withOpenRow lbrace rbrace
 
-recordLike ::  [Doc ann] -> Doc ann
-recordLike  fields  =
-  let fmtObj = encloseSep (lbrace <> softline) (softline <> rbrace) (comma <> softline)
-  in  group $ align (fmtObj fields)
+recordLike ::  [Doc ann] -> Printer ann
+recordLike  fields fmt   =
+  enclose (lbrace <> spacer) (rbrace <> spacer)
+  . fmtSep fmt
+  . punctuate comma
+  $ fields
+ where
+   spacer = fmtSpacer fmt
+-- let fmtObj = encloseSep (lbrace <> softline) (softline <> rbrace) (comma <> softline)
+-- in  group $ align (fmtObj fields)
 
-record :: [Doc ann] -> Doc ann
+record :: [Doc ann] -> Printer ann
 record = recordLike
 
-object :: [Doc ann] -> Doc ann
+object :: [Doc ann] -> Printer ann
 object = recordLike
 
 commaSep :: [Doc ann] -> Doc ann
@@ -70,7 +123,7 @@ parens' d = group $ align $ enclose (lparen <> softline) (rparen <> softline) d
 
 -- I can't figure out why their type pretty printer mangles record types, this is an incredibly stupid temporary hack
 ppType :: Int -> Type a -> String
-ppType i t = "<TYPE>" {- go [] $ prettyPrintType i t
+ppType i t = "<TYPE>" {- go [] $ prettyType i t
   where
     go :: String -> String -> String
     go acc [] = acc
@@ -105,7 +158,7 @@ a <::> b = a <++> "::" <++> b
 a <=> b = a <+> "=" <+> b
 
 (<//>) :: Doc ann -> Doc ann -> Doc ann
-a <//> b = a <+> line <+> b
+a <//> b = a <+> hardline <+> b
 
 -- ensures the things being concatenated are always on the same line
 (<++>) :: Doc ann -> Doc ann -> Doc ann
@@ -117,100 +170,119 @@ arrow = "->"
 lam :: Doc ann
 lam = "\\"
 
+oneLineList :: [Doc ann] -> Doc ann
+oneLineList = brackets . hcat . punctuate (comma <> space)
+
 doubleColon :: Doc ann
 doubleColon = hcat [colon,colon]
 
-caseOf :: [Doc ann] -> [Doc ann] -> Doc ann
-caseOf scrutinees branches = "case" <+> group (hsep scrutinees) <+> "of" <//> indent 2 (vcat . map group $ branches) -- if wrong try hang instead of hang
-
-prettyPrintObjectKey :: PSString -> Doc ann
-prettyPrintObjectKey = pretty . decodeStringWithReplacement
+prettyObjectKey :: PSString -> Doc ann
+prettyObjectKey = pretty . decodeStringWithReplacement
 
-prettyPrintObject ::  [(PSString, Maybe (Expr a))] -> Doc ann
-prettyPrintObject  = encloseSep "{"  "}" "," . map prettyPrintObjectProperty
+prettyObject ::  [(PSString, Maybe (Expr a))] -> Printer ann
+prettyObject fields fmt = recordLike (prettyProperty  <$> fields) fmt
   where
-  prettyPrintObjectProperty :: (PSString, Maybe (Expr a)) -> Doc ann
-  prettyPrintObjectProperty (key, value) = (prettyPrintObjectKey key Monoid.<> ": ") <> maybe (pretty @Text "_") prettyPrintValue value
+    prettyProperty :: (PSString, Maybe (Expr a)) -> Doc ann
+    prettyProperty  (key, value) = prettyObjectKey key <:> maybe (pretty @Text "_") (flip prettyValue fmt) value
 
-prettyPrintUpdateEntry :: PSString -> Expr a -> Doc ann
-prettyPrintUpdateEntry key val =  prettyPrintObjectKey key <+> "=" <+> prettyPrintValue val
+prettyUpdateEntry :: PSString -> Expr a -> Printer ann
+prettyUpdateEntry key val fmt =  prettyObjectKey key <=> prettyValue val fmt
 
 -- | Pretty-print an expression
-prettyPrintValue ::  Expr a -> Doc ann
--- prettyPrintValue _ | d < 0 = text "..."
-prettyPrintValue (Accessor _ ty prop val) = group . align $ vcat [prettyPrintValueAtom  val,hcat[dot,prettyPrintObjectKey prop]]
-prettyPrintValue (ObjectUpdate ann _ty o _copyFields ps) = prettyPrintValueAtom  o <+> encloseSep "{" "}" "," (uncurry prettyPrintUpdateEntry <$> ps)
-prettyPrintValue (App ann ty val arg) = group . align $ vsep [prettyPrintValueAtom  val,prettyPrintValueAtom  arg]
-prettyPrintValue (Abs ann ty arg val) = group . align $ flatAlt multiLine oneLine
+prettyValue :: Expr a -> Printer ann
+-- prettyValue _ | d < 0 = text "..."
+prettyValue (Accessor _ ty prop val) fmt =  fmtCat fmt [prettyValueAtom val fmt,hcat[dot,prettyObjectKey prop]]
+prettyValue (ObjectUpdate ann _ty o _copyFields ps) fmt = asFmt fmt prettyValueAtom o   <+> recordLike ( goUpdateEntry  <$> ps) fmt
   where
-    multiLine = lam
-      <> parens (align $ pretty (showIdent arg) <:> prettyType (getFunArgTy ty))
-      <+> arrow
-      <> hardline
-      <> hang 2 (prettyPrintValue  val)
+    goUpdateEntry (str,e) =  prettyUpdateEntry str e fmt
+prettyValue (App ann ty val arg) fmt =  group . align $ fmtSep fmt  [prettyValueAtom val fmt, prettyValueAtom arg fmt]
 
-    oneLine = lam
-      <> parens (align $ pretty (showIdent arg) <:> prettyType (getFunArgTy ty))
+prettyValue (Abs ann ty arg val) fmt  =
+         lam
+      <> parens (align $ pretty (showIdent arg) <:> prettyType (getFunArgTy ty) fmt)
       <+> arrow
-      <+> prettyPrintValue val
-
-prettyPrintValue (Case ann ty values binders) =
-  caseOf (prettyPrintValueAtom <$> values) (prettyPrintCaseAlternative <$> binders)
-prettyPrintValue (Let _ _  ds val) =  mappend line $ indent 2 $ vcat [
+      <> fmtSpacer fmt
+      <> hang 2 (asFmt fmt prettyValue val)
+
+-- TODO: Actually implement the one line bracketed format for case exps (I think PS is the same as Haskell?)
+prettyValue (Case ann ty values binders) _ =
+  "case"
+  <+> group (hsep scrutinees)
+  <+> "of"
+  <//> indent 2 (vcat $ map group branches)
+ where
+   scrutinees = asOneLine prettyValueAtom <$> values
+   branches = group . asDynamic  prettyCaseAlternative <$> binders
+-- technically we could have a one line version of this but that's ugly af
+prettyValue (Let _ _  ds val) fmt = align $ vcat [
   "let",
-  indent 2 $ vcat $  prettyPrintDeclaration <$> ds,
-  "in" <+> align (prettyPrintValue val)
+  indent 2 . vcat $ asDynamic prettyDeclaration <$> ds,
+  "in" <+> align (asDynamic  prettyValue val)
   ]
-
-prettyPrintValue (Literal _ ty l) = parens $  prettyPrintLiteralValue l <:> prettyType ty
-prettyPrintValue expr@Constructor{} = prettyPrintValueAtom  expr
-prettyPrintValue expr@Var{} = prettyPrintValueAtom  expr
+ where
+   prefix = case fmt of
+     OneLine -> align
+     MultiLine -> (line <>) . indent 2
+prettyValue (Literal _ ty l) fmt =  case fmt of {OneLine -> oneLine; MultiLine -> multiLine}
+  where
+    oneLine = parens $ hcat [
+      asOneLine prettyLiteralValue l,
+      colon,
+      space,
+      asOneLine prettyType ty
+      ]
+    multiLine = parens $ asDynamic prettyLiteralValue l <:> asDynamic prettyType ty
+prettyValue expr@Constructor{} fmt = prettyValueAtom  expr fmt
+prettyValue expr@Var{} fmt = prettyValueAtom  expr fmt
 
 -- | Pretty-print an atomic expression, adding parentheses if necessary.
-prettyPrintValueAtom :: Expr a -> Doc ann
-prettyPrintValueAtom (Literal _  _ l) = prettyPrintLiteralValue l
-prettyPrintValueAtom (Constructor _ _ _ name _) = pretty $ T.unpack $ runProperName name
-prettyPrintValueAtom (Var ann ty ident) =  parens $   pretty  (showIdent (disqualify ident)) <:> prettyType ty
-prettyPrintValueAtom expr =  (prettyPrintValue expr)
-
-prettyPrintLiteralValue :: Literal (Expr a) -> Doc ann
-prettyPrintLiteralValue (NumericLiteral n) = pretty $ either show show n
-prettyPrintLiteralValue (StringLiteral s) = pretty . T.unpack $ prettyPrintString s
-prettyPrintLiteralValue (CharLiteral c) = viaShow . show $ c
-prettyPrintLiteralValue (BooleanLiteral True) = "true"
-prettyPrintLiteralValue (BooleanLiteral False) = "false"
-prettyPrintLiteralValue (ArrayLiteral xs) = list $ prettyPrintValue <$>  xs
-prettyPrintLiteralValue (ObjectLiteral ps) = prettyPrintObject  $ second Just `map` ps
-
-prettyPrintDeclaration :: Bind a -> Doc ann
--- prettyPrintDeclaration d _ | d < 0 = ellipsis
-prettyPrintDeclaration b = case b of
-  NonRec _ ident expr -> vcat  [
-       pretty ident <::> prettyType (exprType expr),
-       pretty ident <=>  prettyPrintValue expr -- not sure about the d here
-    ]
-  Rec bindings -> vcat $ concatMap (\((_,ident),expr) -> [
-          pretty ident <::> prettyType (exprType expr),
-          pretty ident <=> prettyPrintValue  expr
-      ]) bindings
-
-prettyPrintCaseAlternative ::  forall a ann. CaseAlternative a -> Doc ann
--- prettyPrintCaseAlternative d _ | d < 0 = ellipsis
-prettyPrintCaseAlternative (CaseAlternative binders result) =
-  hsep (map prettyPrintBinderAtom binders) <> prettyPrintResult result
+prettyValueAtom :: Expr a -> Printer ann
+prettyValueAtom (Literal _  _ l) fmt = prettyLiteralValue l fmt
+prettyValueAtom (Constructor _ _ _ name _) _ = pretty $ T.unpack $ runProperName name
+prettyValueAtom (Var ann ty ident) fmt  =   parens $  pretty  (showIdent (disqualify ident)) <:> prettyType ty fmt
+prettyValueAtom expr fmt =  prettyValue expr fmt
+
+prettyLiteralValue :: Literal (Expr a) -> Printer ann
+prettyLiteralValue (NumericLiteral n) = ignoreFmt $ pretty $ either show show n
+prettyLiteralValue (StringLiteral s) = ignoreFmt $ pretty . T.unpack $ prettyPrintString s
+prettyLiteralValue (CharLiteral c) = ignoreFmt $ viaShow . show $ c
+prettyLiteralValue (BooleanLiteral True) = ignoreFmt "true"
+prettyLiteralValue (BooleanLiteral False) = ignoreFmt "false"
+prettyLiteralValue (ArrayLiteral xs) = printer oneLine multiLine
   where
-  prettyPrintResult :: Either [(Guard a, Expr a)] (Expr a) -> Doc ann
-  prettyPrintResult = \case
-    Left ges -> vcat $  map prettyPrintGuardedValueSep'  ges
-    Right exp' -> space <> arrow <+> prettyPrintValue  exp'
+    oneLine = oneLineList $  asOneLine prettyValue <$>  xs
+    -- N.B. I think it makes more sense to ensure that list *elements* are always oneLine
+    multiLine = list $ asOneLine prettyValue <$> xs
+prettyLiteralValue (ObjectLiteral ps) = prettyObject  $ second Just `map` ps
+
+prettyDeclaration :: forall a ann. Bind a -> Printer ann
+-- REVIEW: Maybe we don't want to ignore the format?
+prettyDeclaration b = ignoreFmt $ case b of
+  NonRec _ ident expr -> goBind ident expr
+  Rec bindings -> vcat $ map  (\((_,ident),expr) -> goBind ident expr) bindings
+ where
+   goBind :: Ident -> Expr a -> Doc ann
+   goBind ident expr =
+     pretty ident <::> asOneLine prettyType (exprType expr)
+     <> hardline
+     <> pretty ident <=> asDynamic prettyValue  expr
+
+prettyCaseAlternative ::  forall a ann. CaseAlternative a -> Printer ann
+-- prettyCaseAlternative d _ | d < 0 = ellipsis
+prettyCaseAlternative (CaseAlternative binders result) fmt =
+  hsep ( asFmt fmt prettyBinderAtom  <$> binders) <> prettyResult result
+  where
+  prettyResult :: Either [(Guard a, Expr a)] (Expr a) -> Doc ann
+  prettyResult = \case
+    Left ges -> vcat $  map prettyGuardedValueSep'   ges
+    Right exp' -> space <> arrow <+> prettyValue  exp' fmt
 
-  prettyPrintGuardedValueSep' ::  (Guard a, Expr a) -> Doc ann
-  prettyPrintGuardedValueSep'  (guardE, resultE) =
-    " | " <> prettyPrintValue  guardE <+> arrow  <+> prettyPrintValue  resultE
+  prettyGuardedValueSep' :: (Guard a, Expr a) -> Doc ann
+  prettyGuardedValueSep' (guardE, resultE) = " | " <> prettyValue  guardE fmt <+> arrow  <+> prettyValue  resultE fmt
 
 
-prettyPrintModule :: Module a -> Doc ann
-prettyPrintModule (Module modSS modComments modName modPath modImports modExports modReExports modForeign modDecls) =
+prettyModule :: Module a -> Doc ann
+prettyModule (Module modSS modComments modName modPath modImports modExports modReExports modForeign modDecls) =
   vsep  $
     [ pretty modName <+>  parens (pretty modPath)
     , "Imported Modules: "
@@ -222,7 +294,7 @@ prettyPrintModule (Module modSS modComments modName modPath modImports modExport
     , "Foreign: "
     , indent 2 . commaSep . map pretty $  modForeign
     , "Declarations: "
-    , vcat . punctuate line $  prettyPrintDeclaration  <$> modDecls
+    , vcat . punctuate line $  asDynamic prettyDeclaration  <$> modDecls
     ]
  where
    goReExport :: (ModuleName,[Ident]) -> Doc ann
@@ -234,57 +306,57 @@ smartRender = renderStrict . layoutPretty defaultLayoutOptions
 writeModule :: Handle -> Module a -> IO ()
 writeModule h m = renderIO h
                 . layoutSmart defaultLayoutOptions
-                $ prettyPrintModule m
+                $ prettyModule m
 
-prettyPrintModuleTxt :: Module a -> Text
-prettyPrintModuleTxt = renderStrict  . layoutPretty defaultLayoutOptions .  prettyPrintModule
+prettyModuleTxt :: Module a -> Text
+prettyModuleTxt = renderStrict  . layoutPretty defaultLayoutOptions .  prettyModule
 
-prettyPrintModuleStr :: Module a -> String
-prettyPrintModuleStr = STR.renderString . layoutPretty defaultLayoutOptions . prettyPrintModule
+prettyModuleStr :: Module a -> String
+prettyModuleStr = STR.renderString . layoutPretty defaultLayoutOptions . prettyModule
 
 renderExpr :: Expr a -> Text
-renderExpr = smartRender . prettyPrintValue
+renderExpr = smartRender . asDynamic prettyValue
 
 renderExprStr :: Expr a -> String
 renderExprStr = T.unpack . renderExpr
 
 prettyTypeStr :: forall a. Show a => Type a -> String
-prettyTypeStr = T.unpack . smartRender . prettyType
-
-prettyPrintBinderAtom :: Binder a -> Doc ann
-prettyPrintBinderAtom (NullBinder _) = "_"
-prettyPrintBinderAtom (LiteralBinder _ l) = prettyPrintLiteralBinder l
-prettyPrintBinderAtom (VarBinder _ ident) = pretty ident
-prettyPrintBinderAtom (ConstructorBinder _ _ ctor []) = pretty $ runProperName (disqualify ctor)
-prettyPrintBinderAtom b@ConstructorBinder{} = prettyPrintBinder b
-prettyPrintBinderAtom (NamedBinder _ ident binder) = pretty ident <> "@" <> prettyPrintBinder binder
-
-prettyPrintLiteralBinder :: Literal (Binder a) -> Doc ann
-prettyPrintLiteralBinder (StringLiteral str) = pretty $ prettyPrintString str
-prettyPrintLiteralBinder (CharLiteral c) = viaShow c
-prettyPrintLiteralBinder (NumericLiteral num) = either pretty pretty num
-prettyPrintLiteralBinder (BooleanLiteral True) = "true"
-prettyPrintLiteralBinder (BooleanLiteral False) = "false"
-prettyPrintLiteralBinder (ObjectLiteral bs) = object $ prettyPrintObjectPropertyBinder <$> bs
+prettyTypeStr = T.unpack . smartRender . asOneLine prettyType
+
+prettyBinderAtom :: Binder a -> Printer ann
+prettyBinderAtom (NullBinder _) _ = "_"
+prettyBinderAtom (LiteralBinder _ l) fmt = prettyLiteralBinder l fmt
+prettyBinderAtom (VarBinder _ ident) _ = pretty ident
+prettyBinderAtom (ConstructorBinder _ _ ctor []) _ = pretty $ runProperName (disqualify ctor)
+prettyBinderAtom b@ConstructorBinder{} fmt = prettyBinder b fmt
+prettyBinderAtom (NamedBinder _ ident binder) fmt = pretty ident <> "@" <> prettyBinder binder fmt
+
+prettyLiteralBinder ::  Literal (Binder a) -> Printer ann
+prettyLiteralBinder (StringLiteral str) _  = pretty $ prettyPrintString str
+prettyLiteralBinder (CharLiteral c) _ = viaShow c
+prettyLiteralBinder (NumericLiteral num) _ = either pretty pretty num
+prettyLiteralBinder (BooleanLiteral True) _ = "true"
+prettyLiteralBinder (BooleanLiteral False) _ = "false"
+prettyLiteralBinder (ObjectLiteral bs) fmt = asFmt fmt object $ prettyObjectPropertyBinder <$> bs
   where
-  prettyPrintObjectPropertyBinder :: (PSString, Binder a) -> Doc ann
-  prettyPrintObjectPropertyBinder (key, binder) = prettyPrintObjectKey key <:> prettyPrintBinder binder
-prettyPrintLiteralBinder (ArrayLiteral bs) = list (prettyPrintBinder <$> bs)
+  prettyObjectPropertyBinder :: (PSString, Binder a) -> Doc ann
+  prettyObjectPropertyBinder (key, binder) = prettyObjectKey key <:> prettyBinder binder fmt
+prettyLiteralBinder (ArrayLiteral bs) fmt = list (asFmt fmt prettyBinder  <$> bs)
 
 -- |
 -- Generate a pretty-printed string representing a Binder
 --
-prettyPrintBinder :: Binder a -> Doc ann
-prettyPrintBinder (ConstructorBinder _ _ ctor []) = pretty $ runProperName (disqualify ctor)
-prettyPrintBinder (ConstructorBinder _ _ ctor args) =
-  pretty (runProperName (disqualify ctor)) <+> hcat (prettyPrintBinderAtom <$> args)
-prettyPrintBinder b = prettyPrintBinderAtom b
+prettyBinder :: Binder a -> Printer ann
+prettyBinder (ConstructorBinder _ _ ctor []) fmt = pretty $ runProperName (disqualify ctor)
+prettyBinder (ConstructorBinder _ _ ctor args) fmt =
+  pretty (runProperName (disqualify ctor)) <+> fmtSep fmt (asFmt fmt prettyBinderAtom <$> args)
+prettyBinder b fmt= prettyBinderAtom b fmt
 
 
 {- TYPES (move later) -}
 
-prettyType :: forall a ann. Show a => Type a -> Doc ann
-prettyType t=  group $ case t of
+prettyType :: forall a ann. Show a => Type a -> Printer ann
+prettyType t fmt =  group $ case t of
   TUnknown _ n -> "t" <> pretty n
 
   TypeVar _ txt -> pretty txt
@@ -303,7 +375,7 @@ prettyType t=  group $ case t of
 
   TypeApp _ t1 t2 -> goTypeApp t1 t2
 
-  KindApp a k1 k2 -> prettyType k1 <> ("@" <> prettyType k2)
+  KindApp a k1 k2 -> prettyType k1 fmt <> ("@" <> prettyType k2 fmt)
 
   ForAll _ vis var mKind inner' _ -> case stripQuantifiers inner' of
     (quantified,inner) ->  goForall ([(vis,var,mKind)] <> quantified) inner
@@ -314,18 +386,19 @@ prettyType t=  group $ case t of
 
   REmpty _ -> "{}"
 
-  rcons@RCons{} -> either openRow tupled $ rowFields rcons
+  rcons@RCons{} -> either (asFmt fmt openRow) tupled $ rowFields rcons
 
   -- this might be backwards
-  KindedType a ty kind -> parens $ prettyType ty <::> prettyType kind
+  KindedType a ty kind -> parens $ prettyType ty fmt <::> prettyType kind fmt
 
   -- not sure what this is?
-  BinaryNoParensType a op l r -> prettyType l <++> prettyType op <++> prettyType r
+  BinaryNoParensType a op l r -> prettyType l fmt <+> prettyType op fmt  <+> prettyType r fmt
 
-  ParensInType _ ty -> parens (prettyType ty)
+  ParensInType _ ty -> parens (prettyType ty fmt)
  where
+
    goForall :: [(TypeVarVisibility,Text,Maybe (Type a))] -> Type a -> Doc ann
-   goForall xs inner = "forall" <++> hcat (renderBoundVar <$> xs) <> "." <++> prettyType inner
+   goForall xs inner = "forall" <+> fmtCat fmt (renderBoundVar <$> xs) <> "." <+> prettyType inner fmt
 
    prefixVis :: TypeVarVisibility -> Doc ann -> Doc ann
    prefixVis vis tv = case vis of
@@ -334,7 +407,7 @@ prettyType t=  group $ case t of
 
    renderBoundVar :: (TypeVarVisibility, Text, Maybe (Type a)) -> Doc ann
    renderBoundVar (vis,var,mk) =  case mk of
-     Just k -> parens $ prefixVis vis (pretty var) <::> prettyType k
+     Just k -> parens $ prefixVis vis (pretty var) <::> prettyType k fmt
      Nothing -> prefixVis vis (pretty var)
 
    stripQuantifiers :: Type a -> ([(TypeVarVisibility,Text,Maybe (Type a))],Type a)
@@ -344,16 +417,16 @@ prettyType t=  group $ case t of
 
    goTypeApp :: Type a -> Type a -> Doc ann
    goTypeApp (TypeApp _ f a) b
-     | eqType f tyFunction = prettyType a <++> arrow <++> prettyType b
-     | otherwise = parens $ goTypeApp f a  <++> prettyType b
+     | eqType f tyFunction = fmtSep fmt [prettyType a fmt <+> arrow, prettyType b fmt]
+     | otherwise = parens $ goTypeApp f a  <+> prettyType b fmt
    goTypeApp o ty@RCons{}
-     | eqType o tyRecord = either openRecord record $ rowFields ty
-   goTypeApp a b =  prettyType a <++> prettyType b
+     | eqType o tyRecord = either (asFmt fmt openRecord) (asFmt fmt record) $ rowFields ty
+   goTypeApp a b =  fmtSep fmt [prettyType a fmt,prettyType b fmt]
 
    rowFields :: Type a -> Either ([Doc ann], Doc ann) [Doc ann]
    rowFields = \case
          RCons _ lbl ty rest ->
-           let f = ((pretty lbl <::> prettyType ty):)
+           let f = ((pretty lbl <::> prettyType ty fmt):)
            in bimap (first f) f $ rowFields rest
          REmpty _ -> Right []
          KindApp _ REmpty{} _  -> Right [] -- REmpty is sometimes wrapped in a kind app?
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index 6c7788875..145f76b1c 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -124,7 +124,7 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _
   -- pTrace exps
   ((coreFn,chkSt'),nextVar'') <- runSupplyT nextVar' $ runStateT (CFT.moduleToCoreFn mod') chkSt -- (emptyCheckState env')
 
-  traceM . T.unpack $ CFT.prettyPrintModuleTxt  coreFn
+  traceM . T.unpack $ CFT.prettyModuleTxt  coreFn
   let corefn = coreFn
       (optimized, nextVar''') = runSupply nextVar'' $ CF.optimizeCoreFn corefn
       (renamedIdents, renamed) = renameInModule optimized
diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs
index 512fea593..bd5c2ff5f 100644
--- a/src/Language/PureScript/Make/Actions.hs
+++ b/src/Language/PureScript/Make/Actions.hs
@@ -60,7 +60,7 @@ import System.FilePath ((</>), makeRelative, splitPath, normalise, splitDirector
 import System.FilePath.Posix qualified as Posix
 import System.IO (stderr, withFile, IOMode(WriteMode))
 import Language.PureScript.CoreFn.ToJSON (moduleToJSON)
-import Language.PureScript.CoreFn.Pretty (writeModule, prettyPrintModule)
+import Language.PureScript.CoreFn.Pretty (writeModule)
 
 
 -- | Determines when to rebuild a module

From 7876fdb6038f2d5349b5d6ece595578c877f1801 Mon Sep 17 00:00:00 2001
From: gnumonik <gnumonik@protonmail.com>
Date: Sat, 2 Mar 2024 01:48:57 -0500
Subject: [PATCH 10/20] even prettier

---
 src/Language/PureScript/CoreFn/Pretty.hs | 23 ++++++++++++++++-------
 1 file changed, 16 insertions(+), 7 deletions(-)

diff --git a/src/Language/PureScript/CoreFn/Pretty.hs b/src/Language/PureScript/CoreFn/Pretty.hs
index b1b2ebe7a..4b798424b 100644
--- a/src/Language/PureScript/CoreFn/Pretty.hs
+++ b/src/Language/PureScript/CoreFn/Pretty.hs
@@ -73,6 +73,10 @@ fmtSpacer = \case
   OneLine -> space
   MultiLine -> softline
 
+fmtIndent :: LineFormat -> Doc ann -> Doc ann
+fmtIndent = \case
+  OneLine -> id
+  MultiLine -> \doc -> line <> indent 2 doc
 
 printer :: Doc ann -> Doc ann -> Printer ann
 printer one multi = \case
@@ -96,7 +100,7 @@ openRecord = withOpenRow lbrace rbrace
 
 recordLike ::  [Doc ann] -> Printer ann
 recordLike  fields fmt   =
-  enclose (lbrace <> spacer) (rbrace <> spacer)
+  enclose (lbrace <> spacer) (space <> rbrace)
   . fmtSep fmt
   . punctuate comma
   $ fields
@@ -201,8 +205,9 @@ prettyValue (Abs ann ty arg val) fmt  =
          lam
       <> parens (align $ pretty (showIdent arg) <:> prettyType (getFunArgTy ty) fmt)
       <+> arrow
-      <> fmtSpacer fmt
-      <> hang 2 (asFmt fmt prettyValue val)
+      <+> fmtIndent fmt (asFmt fmt prettyValue val)
+     -- <> fmtSpacer fmt
+     -- <> hang 2 (asFmt fmt prettyValue val)
 
 -- TODO: Actually implement the one line bracketed format for case exps (I think PS is the same as Haskell?)
 prettyValue (Case ann ty values binders) _ =
@@ -257,7 +262,7 @@ prettyLiteralValue (ObjectLiteral ps) = prettyObject  $ second Just `map` ps
 
 prettyDeclaration :: forall a ann. Bind a -> Printer ann
 -- REVIEW: Maybe we don't want to ignore the format?
-prettyDeclaration b = ignoreFmt $ case b of
+prettyDeclaration b fmt = case b of
   NonRec _ ident expr -> goBind ident expr
   Rec bindings -> vcat $ map  (\((_,ident),expr) -> goBind ident expr) bindings
  where
@@ -265,17 +270,21 @@ prettyDeclaration b = ignoreFmt $ case b of
    goBind ident expr =
      pretty ident <::> asOneLine prettyType (exprType expr)
      <> hardline
-     <> pretty ident <=> asDynamic prettyValue  expr
+     <> goInner ident expr
+   goInner :: Ident -> Expr a -> Doc ann
+   goInner ident expr =
+     let f g = pretty ident <=> g (asDynamic prettyValue  expr)
+     in group $ flatAlt (f  (fmtIndent fmt))  (f id)
 
 prettyCaseAlternative ::  forall a ann. CaseAlternative a -> Printer ann
 -- prettyCaseAlternative d _ | d < 0 = ellipsis
 prettyCaseAlternative (CaseAlternative binders result) fmt =
-  hsep ( asFmt fmt prettyBinderAtom  <$> binders) <> prettyResult result
+  hsep (asFmt fmt prettyBinderAtom  <$> binders) <> prettyResult result
   where
   prettyResult :: Either [(Guard a, Expr a)] (Expr a) -> Doc ann
   prettyResult = \case
     Left ges -> vcat $  map prettyGuardedValueSep'   ges
-    Right exp' -> space <> arrow <+> prettyValue  exp' fmt
+    Right exp' -> space <> arrow <+> fmtIndent fmt (prettyValue  exp' fmt)
 
   prettyGuardedValueSep' :: (Guard a, Expr a) -> Doc ann
   prettyGuardedValueSep' (guardE, resultE) = " | " <> prettyValue  guardE fmt <+> arrow  <+> prettyValue  resultE fmt

From c862bd5586fc5c419acc0025504831668b5f70bc Mon Sep 17 00:00:00 2001
From: gnumonik <gnumonik@protonmail.com>
Date: Sat, 2 Mar 2024 02:47:26 -0500
Subject: [PATCH 11/20] extremely pretty

---
 src/Language/PureScript/CoreFn/Pretty.hs | 65 ++++++++++++++----------
 tests/purus/passing/Misc/Lib.purs        | 10 ++++
 2 files changed, 48 insertions(+), 27 deletions(-)

diff --git a/src/Language/PureScript/CoreFn/Pretty.hs b/src/Language/PureScript/CoreFn/Pretty.hs
index 4b798424b..8889af413 100644
--- a/src/Language/PureScript/CoreFn/Pretty.hs
+++ b/src/Language/PureScript/CoreFn/Pretty.hs
@@ -1,5 +1,11 @@
 {-# LANGUAGE TypeApplications, ScopedTypeVariables, RecordWildCards #-}
-module Language.PureScript.CoreFn.Pretty where
+module Language.PureScript.CoreFn.Pretty (
+  writeModule,
+  ppType,
+  prettyTypeStr,
+  renderExprStr,
+  prettyModuleTxt
+) where
 
 import Prelude hiding ((<>))
 
@@ -125,17 +131,9 @@ parens' :: Doc ann -> Doc ann
 parens' d = group $ align $ enclose (lparen <> softline) (rparen <> softline) d
 
 
--- I can't figure out why their type pretty printer mangles record types, this is an incredibly stupid temporary hack
-ppType :: Int -> Type a -> String
-ppType i t = "<TYPE>" {- go [] $ prettyType i t
-  where
-    go :: String -> String -> String
-    go acc [] = acc
-    go acc (' ':xs) = case dropWhile (== ' ') xs of
-      [] -> acc
-      more -> go (acc `mappend` [' ']) more
-    go acc (x:xs) = go (acc `mappend` [x]) xs
--}
+-- TODO: Remove
+ppType :: Show a => Int -> Type a -> String
+ppType i t = prettyTypeStr t
 
 instance Pretty Ident where
   pretty = pretty . showIdent
@@ -177,8 +175,24 @@ lam = "\\"
 oneLineList :: [Doc ann] -> Doc ann
 oneLineList = brackets . hcat . punctuate (comma <> space)
 
-doubleColon :: Doc ann
-doubleColon = hcat [colon,colon]
+-- helpers to ensure even formatting of applications
+
+analyzeApp :: Expr a -> Maybe (Expr a,[Expr a])
+analyzeApp t = (,appArgs t) <$> appFun t
+  where
+    appArgs :: Expr a -> [Expr a]
+    appArgs (App _ _ t1 t2) = appArgs t1 <> [t2]
+    appArgs _  = []
+
+    appFun :: Expr a -> Maybe (Expr a)
+    appFun (App _ _ t1 _) = go t1
+      where
+        go (App _ _ tx _) = case appFun tx of
+          Nothing -> Just tx
+          Just tx' -> Just tx'
+        go other = Just other
+    appFun _ = Nothing
+
 
 prettyObjectKey :: PSString -> Doc ann
 prettyObjectKey = pretty . decodeStringWithReplacement
@@ -199,15 +213,17 @@ prettyValue (Accessor _ ty prop val) fmt =  fmtCat fmt [prettyValueAtom val fmt,
 prettyValue (ObjectUpdate ann _ty o _copyFields ps) fmt = asFmt fmt prettyValueAtom o   <+> recordLike ( goUpdateEntry  <$> ps) fmt
   where
     goUpdateEntry (str,e) =  prettyUpdateEntry str e fmt
-prettyValue (App ann ty val arg) fmt =  group . align $ fmtSep fmt  [prettyValueAtom val fmt, prettyValueAtom arg fmt]
+prettyValue app@(App ann ty val arg) fmt = case analyzeApp app of
+  Just (fun,args) -> case fmt of
+    OneLine -> group . align . hsep .  map (asOneLine prettyValueAtom) $ (fun:args)
+    MultiLine -> group . align . vcat . map (asDynamic prettyValueAtom) $ (fun:args)
+  Nothing -> error "App isn't an App (impossible)"
 
 prettyValue (Abs ann ty arg val) fmt  =
          lam
       <> parens (align $ pretty (showIdent arg) <:> prettyType (getFunArgTy ty) fmt)
       <+> arrow
       <+> fmtIndent fmt (asFmt fmt prettyValue val)
-     -- <> fmtSpacer fmt
-     -- <> hang 2 (asFmt fmt prettyValue val)
 
 -- TODO: Actually implement the one line bracketed format for case exps (I think PS is the same as Haskell?)
 prettyValue (Case ann ty values binders) _ =
@@ -224,10 +240,6 @@ prettyValue (Let _ _  ds val) fmt = align $ vcat [
   indent 2 . vcat $ asDynamic prettyDeclaration <$> ds,
   "in" <+> align (asDynamic  prettyValue val)
   ]
- where
-   prefix = case fmt of
-     OneLine -> align
-     MultiLine -> (line <>) . indent 2
 prettyValue (Literal _ ty l) fmt =  case fmt of {OneLine -> oneLine; MultiLine -> multiLine}
   where
     oneLine = parens $ hcat [
@@ -244,8 +256,8 @@ prettyValue expr@Var{} fmt = prettyValueAtom  expr fmt
 prettyValueAtom :: Expr a -> Printer ann
 prettyValueAtom (Literal _  _ l) fmt = prettyLiteralValue l fmt
 prettyValueAtom (Constructor _ _ _ name _) _ = pretty $ T.unpack $ runProperName name
-prettyValueAtom (Var ann ty ident) fmt  =   parens $  pretty  (showIdent (disqualify ident)) <:> prettyType ty fmt
-prettyValueAtom expr fmt =  prettyValue expr fmt
+prettyValueAtom (Var ann ty ident) fmt  =  parens $ pretty  (showIdent (disqualify ident)) <:> prettyType ty fmt
+prettyValueAtom expr fmt =  parens $ prettyValue expr fmt
 
 prettyLiteralValue :: Literal (Expr a) -> Printer ann
 prettyLiteralValue (NumericLiteral n) = ignoreFmt $ pretty $ either show show n
@@ -389,9 +401,9 @@ prettyType t fmt =  group $ case t of
   ForAll _ vis var mKind inner' _ -> case stripQuantifiers inner' of
     (quantified,inner) ->  goForall ([(vis,var,mKind)] <> quantified) inner
 
-  ConstrainedType _ constraint inner -> error "TODO: ConstrainedType"
+  ConstrainedType _ constraint inner -> error "TODO: ConstrainedType (shouldn't ever appear in Purus CoreFn)"
 
-  Skolem _ txt mKind inner mSkolScope -> error "TODO: Skolem"
+  Skolem _ txt mKind inner mSkolScope -> error "TODO: Skolem (shouldn't ever appear in Purus CoreFn)"
 
   REmpty _ -> "{}"
 
@@ -405,9 +417,8 @@ prettyType t fmt =  group $ case t of
 
   ParensInType _ ty -> parens (prettyType ty fmt)
  where
-
    goForall :: [(TypeVarVisibility,Text,Maybe (Type a))] -> Type a -> Doc ann
-   goForall xs inner = "forall" <+> fmtCat fmt (renderBoundVar <$> xs) <> "." <+> prettyType inner fmt
+   goForall xs inner = "forall" <+> fmtSep fmt (renderBoundVar <$> xs) <> "." <+> prettyType inner fmt
 
    prefixVis :: TypeVarVisibility -> Doc ann -> Doc ann
    prefixVis vis tv = case vis of
diff --git a/tests/purus/passing/Misc/Lib.purs b/tests/purus/passing/Misc/Lib.purs
index 7f14dab31..11a29e12a 100644
--- a/tests/purus/passing/Misc/Lib.purs
+++ b/tests/purus/passing/Misc/Lib.purs
@@ -147,6 +147,16 @@ aFunction6 = aFunction [] go
     go :: forall (z :: Type). z -> Int
     go _ = 10
 
+nestedApplications :: Int
+nestedApplications = i (f (g (h 2))) 4
+  where
+    i x _ = x
+    f x = x
+    g _ = 5
+    h = case _ of
+      2 -> 3
+      _ -> 5
+
 {- Objects -}
 
 anObj :: {foo :: Int}

From 4b6112c5f89792c51c345d5630d36a07fc69d58c Mon Sep 17 00:00:00 2001
From: gnumonik <gnumonik@protonmail.com>
Date: Tue, 5 Mar 2024 17:32:48 -0500
Subject: [PATCH 12/20] Refactored pretty printer update to use Reader monad
 (hopefully makes easier to read)

---
 src/Language/PureScript/CoreFn/Pretty.hs | 403 ++++++++++++++---------
 1 file changed, 252 insertions(+), 151 deletions(-)

diff --git a/src/Language/PureScript/CoreFn/Pretty.hs b/src/Language/PureScript/CoreFn/Pretty.hs
index 8889af413..4964ad265 100644
--- a/src/Language/PureScript/CoreFn/Pretty.hs
+++ b/src/Language/PureScript/CoreFn/Pretty.hs
@@ -9,33 +9,75 @@ module Language.PureScript.CoreFn.Pretty (
 
 import Prelude hiding ((<>))
 
-
-
 import Data.Text (Text)
-import Data.List.NonEmpty qualified as NEL
-import Data.Monoid qualified as Monoid ((<>))
 import Data.Text qualified as T
+import Data.Map qualified as M
+import Data.Bifunctor (first, Bifunctor (..))
+import Control.Monad.Reader
 
 import Language.PureScript.Environment
+    ( tyRecord, tyFunction, getFunArgTy )
 import Language.PureScript.CoreFn.Expr
-import Language.PureScript.CoreFn.Module
-import Language.PureScript.AST.Literals
-import Language.PureScript.CoreFn.Binders
-import Language.PureScript.Crash (internalError)
-import Language.PureScript.Names (OpName(..), ProperName(..), Qualified(..), disqualify, runModuleName, showIdent, Ident, ModuleName, showQualified)
-import Language.PureScript.Pretty.Common (before, beforeWithSpace, parensT)
-import Language.PureScript.Types (Constraint(..), Type (..), WildcardData (..), TypeVarVisibility (..), eqType)
+    ( exprType,
+      Guard,
+      Bind(..),
+      CaseAlternative(CaseAlternative),
+      Expr(..) )
+import Language.PureScript.CoreFn.Module ( Module(Module) )
+import Language.PureScript.AST.Literals ( Literal(..) )
+import Language.PureScript.CoreFn.Binders ( Binder(..) )
+import Language.PureScript.Label (Label (..))
+import Language.PureScript.Names (OpName(..), ProperName(..), disqualify, runModuleName, showIdent, Ident, ModuleName, showQualified)
+import Language.PureScript.Types (Type (..), WildcardData (..), TypeVarVisibility (..), eqType)
 import Language.PureScript.PSString (PSString, prettyPrintString, decodeStringWithReplacement)
 import System.IO (Handle)
 
-import Data.Map qualified as M
-
 import Prettyprinter
-import Prettyprinter.Render.Text
-import qualified Prettyprinter.Render.String as STR
-import Data.Bifunctor (first, Bifunctor (..))
-import Language.PureScript.Label (Label (..))
-import Control.Monad (void)
+    ( (<>),
+      tupled,
+      layoutSmart,
+      defaultLayoutOptions,
+      layoutPretty,
+      list,
+      viaShow,
+      colon,
+      parens,
+      dot,
+      brackets,
+      hardline,
+      (<+>),
+      rbrace,
+      lbrace,
+      rparen,
+      lparen,
+      pipe,
+      comma,
+      punctuate,
+      enclose,
+      indent,
+      line,
+      softline,
+      space,
+      vcat,
+      hcat,
+      vsep,
+      hsep,
+      flatAlt,
+      align,
+      group,
+      Doc,
+      Pretty(pretty) )
+import Prettyprinter.Render.Text ( renderIO, renderStrict )
+
+{- Rewritten prettyprinter that uses a modern printer library & is less convoluted.
+
+   We primarily need this for writing the "prettified" CoreFn files for development purposes.
+   The existing printer is extremely difficult to modify for our needs (e.g. there isn't a clear way to force
+   an expression or type to print on one line). Because reading the CoreFn output is necessary
+   to ensure correctness, it's important that we get get something legible.
+
+-}
+
 
 data LineFormat
   = OneLine --  *DEFINITELY* Print on one line, even if doing so exceeds the page width
@@ -43,12 +85,12 @@ data LineFormat
   deriving (Show, Eq)
 
 -- TODO: Refactor to reader monad?
-type Printer ann =  LineFormat  -> Doc ann
+type Printer ann =  Reader LineFormat (Doc ann)
 
 type Formatter = forall a ann. (a -> Printer ann) -> a -> Doc ann
 
 runPrinter :: LineFormat -> Printer ann -> Doc ann
-runPrinter fmt p = p fmt
+runPrinter fmt p = runReader p fmt
 
 asFmt :: LineFormat -> (a -> Printer ann) -> a -> Doc ann
 asFmt fmt f x = case fmt of
@@ -64,35 +106,37 @@ asDynamic p x = group $ align $ flatAlt (runPrinter MultiLine (p x)) (runPrinter
 ignoreFmt :: Doc ann -> Printer ann
 ignoreFmt doc = printer doc doc
 
-fmtSep :: LineFormat -> [Doc ann] -> Doc ann
-fmtSep = \case
-  OneLine -> hsep
-  MultiLine -> vsep
+fmtSep :: [Doc ann] -> Printer ann
+fmtSep docs = ask >>= \case
+  OneLine -> pure $ hsep docs
+  MultiLine -> pure $ vsep docs
 
-fmtCat :: LineFormat -> [Doc ann] -> Doc ann
-fmtCat = \case
-  OneLine -> hcat
-  MultiLine -> vcat
+fmtCat :: [Doc ann] -> Printer ann
+fmtCat docs = ask >>= \case
+  OneLine -> pure $ hcat docs
+  MultiLine -> pure $ vcat docs
 
-fmtSpacer :: LineFormat -> Doc ann
-fmtSpacer = \case
-  OneLine -> space
-  MultiLine -> softline
+fmtSpacer :: Printer  ann
+fmtSpacer = ask >>= \case
+  OneLine -> pure space
+  MultiLine -> pure softline
 
-fmtIndent :: LineFormat -> Doc ann -> Doc ann
-fmtIndent = \case
-  OneLine -> id
-  MultiLine -> \doc -> line <> indent 2 doc
+fmtIndent :: Doc ann -> Printer ann
+fmtIndent doc = ask >>= \case
+  OneLine -> pure doc
+  MultiLine -> pure $ line <> indent 2 doc
 
 printer :: Doc ann -> Doc ann -> Printer ann
-printer one multi = \case
-  OneLine -> one
-  MultiLine -> multi
+printer one multi = ask >>= \case
+  OneLine ->  pure one
+  MultiLine ->  pure multi
 
 withOpenRow :: forall ann. Doc ann -> Doc ann -> ([Doc ann],Doc ann) -> Printer ann
-withOpenRow l r (fields,open) fmt =  group $ align $ enclose (l <> spacer) (spacer <> r) $ fmtSep fmt  $ punctuate comma fields'
+withOpenRow l r (fields,open) = do
+  spacer <- fmtSpacer
+  fmtFields <- fmtSep $ punctuate comma fields'
+  pure . group . align $ enclose (l <> spacer) (spacer <> r) fmtFields
   where
-    spacer = fmtSpacer fmt
     fields' =  foldr (\x acc -> case acc of
                       [] -> [hsep [x,pipe <++> open]]
                       xs -> x : xs
@@ -105,15 +149,10 @@ openRecord :: ([Doc ann], Doc ann) -> Printer ann
 openRecord = withOpenRow lbrace rbrace
 
 recordLike ::  [Doc ann] -> Printer ann
-recordLike  fields fmt   =
-  enclose (lbrace <> spacer) (space <> rbrace)
-  . fmtSep fmt
-  . punctuate comma
-  $ fields
- where
-   spacer = fmtSpacer fmt
--- let fmtObj = encloseSep (lbrace <> softline) (softline <> rbrace) (comma <> softline)
--- in  group $ align (fmtObj fields)
+recordLike  fields  = do
+  spacer <- fmtSpacer
+  fields' <- fmtSep $ punctuate comma fields
+  pure $ enclose (lbrace <> spacer) (space <> rbrace) fields'
 
 record :: [Doc ann] -> Printer ann
 record = recordLike
@@ -147,9 +186,6 @@ instance Pretty ModuleName where
 instance Pretty Label where
   pretty = pretty . runLabel
 
-ellipsis :: Doc ann
-ellipsis =  "..."
-
 (<:>) :: Doc ann -> Doc ann -> Doc ann
 a <:> b = hcat [a,":"] <++> b
 
@@ -176,7 +212,6 @@ oneLineList :: [Doc ann] -> Doc ann
 oneLineList = brackets . hcat . punctuate (comma <> space)
 
 -- helpers to ensure even formatting of applications
-
 analyzeApp :: Expr a -> Maybe (Expr a,[Expr a])
 analyzeApp t = (,appArgs t) <$> appFun t
   where
@@ -194,39 +229,60 @@ analyzeApp t = (,appArgs t) <$> appFun t
     appFun _ = Nothing
 
 
-prettyObjectKey :: PSString -> Doc ann
-prettyObjectKey = pretty . decodeStringWithReplacement
+-- Is a printer for consistency mainly
+prettyObjectKey :: PSString -> Printer ann
+prettyObjectKey = pure . pretty . decodeStringWithReplacement
 
 prettyObject ::  [(PSString, Maybe (Expr a))] -> Printer ann
-prettyObject fields fmt = recordLike (prettyProperty  <$> fields) fmt
+prettyObject fields  = do
+  fields' <- traverse prettyProperty fields
+  recordLike fields'
   where
-    prettyProperty :: (PSString, Maybe (Expr a)) -> Doc ann
-    prettyProperty  (key, value) = prettyObjectKey key <:> maybe (pretty @Text "_") (flip prettyValue fmt) value
+    prettyProperty :: (PSString, Maybe (Expr a)) -> Printer ann
+    prettyProperty  (key, value) = do
+      key' <- prettyObjectKey key
+      props' <- maybe (pure $ pretty @Text "_") prettyValue value
+      pure (key' <:> props') --  prettyObjectKey key <:> maybe (pretty @Text "_") (flip prettyValue fmt) value
 
 prettyUpdateEntry :: PSString -> Expr a -> Printer ann
-prettyUpdateEntry key val fmt =  prettyObjectKey key <=> prettyValue val fmt
+prettyUpdateEntry key val  = do
+  key' <- prettyObjectKey key
+  val' <- prettyValue val
+  pure $ key' <=> val'
 
 -- | Pretty-print an expression
 prettyValue :: Expr a -> Printer ann
 -- prettyValue _ | d < 0 = text "..."
-prettyValue (Accessor _ ty prop val) fmt =  fmtCat fmt [prettyValueAtom val fmt,hcat[dot,prettyObjectKey prop]]
-prettyValue (ObjectUpdate ann _ty o _copyFields ps) fmt = asFmt fmt prettyValueAtom o   <+> recordLike ( goUpdateEntry  <$> ps) fmt
+prettyValue (Accessor _ ty prop val)  =  do
+  prop' <- prettyObjectKey prop
+  val' <- prettyValueAtom val
+  fmtCat [val',hcat[dot,prop']]
+prettyValue (ObjectUpdate ann _ty o _copyFields ps)  = do
+  obj <- prettyValueAtom o
+  updateEntries <- traverse goUpdateEntry ps >>= recordLike
+  pure $ obj <+> updateEntries -- prettyValueAtom o   <+> recordLike ( goUpdateEntry  <$> ps) fmt
   where
-    goUpdateEntry (str,e) =  prettyUpdateEntry str e fmt
-prettyValue app@(App ann ty val arg) fmt = case analyzeApp app of
-  Just (fun,args) -> case fmt of
-    OneLine -> group . align . hsep .  map (asOneLine prettyValueAtom) $ (fun:args)
-    MultiLine -> group . align . vcat . map (asDynamic prettyValueAtom) $ (fun:args)
+    goUpdateEntry = uncurry prettyUpdateEntry
+prettyValue app@(App ann ty val arg)  = case analyzeApp app of
+  Just (fun,args) -> ask >>= \case
+    OneLine -> pure . group . align . hsep .  map (asOneLine prettyValueAtom) $ (fun:args)
+    MultiLine -> pure . group . align . vcat . map (asDynamic prettyValueAtom) $ (fun:args)
   Nothing -> error "App isn't an App (impossible)"
 
-prettyValue (Abs ann ty arg val) fmt  =
-         lam
+prettyValue (Abs ann ty arg val) = do
+  ty' <- prettyType (getFunArgTy ty)
+  body' <- fmtIndent =<< prettyValue val
+  pure $ lam
+         <> parens (align $ pretty (showIdent arg) <:> ty')
+         <+> arrow
+         <+> body'
+      {-   lam
       <> parens (align $ pretty (showIdent arg) <:> prettyType (getFunArgTy ty) fmt)
       <+> arrow
       <+> fmtIndent fmt (asFmt fmt prettyValue val)
-
+      -}
 -- TODO: Actually implement the one line bracketed format for case exps (I think PS is the same as Haskell?)
-prettyValue (Case ann ty values binders) _ =
+prettyValue (Case ann ty values binders) = pure $
   "case"
   <+> group (hsep scrutinees)
   <+> "of"
@@ -235,12 +291,12 @@ prettyValue (Case ann ty values binders) _ =
    scrutinees = asOneLine prettyValueAtom <$> values
    branches = group . asDynamic  prettyCaseAlternative <$> binders
 -- technically we could have a one line version of this but that's ugly af
-prettyValue (Let _ _  ds val) fmt = align $ vcat [
+prettyValue (Let _ _  ds val)  = pure . align $ vcat [
   "let",
   indent 2 . vcat $ asDynamic prettyDeclaration <$> ds,
   "in" <+> align (asDynamic  prettyValue val)
   ]
-prettyValue (Literal _ ty l) fmt =  case fmt of {OneLine -> oneLine; MultiLine -> multiLine}
+prettyValue (Literal _ ty l)  = ask >>= \case {OneLine -> pure oneLine; MultiLine -> pure multiLine}
   where
     oneLine = parens $ hcat [
       asOneLine prettyLiteralValue l,
@@ -249,15 +305,16 @@ prettyValue (Literal _ ty l) fmt =  case fmt of {OneLine -> oneLine; MultiLine -
       asOneLine prettyType ty
       ]
     multiLine = parens $ asDynamic prettyLiteralValue l <:> asDynamic prettyType ty
-prettyValue expr@Constructor{} fmt = prettyValueAtom  expr fmt
-prettyValue expr@Var{} fmt = prettyValueAtom  expr fmt
+prettyValue expr@Constructor{}  = prettyValueAtom  expr
+prettyValue expr@Var{}  = prettyValueAtom  expr
 
 -- | Pretty-print an atomic expression, adding parentheses if necessary.
 prettyValueAtom :: Expr a -> Printer ann
-prettyValueAtom (Literal _  _ l) fmt = prettyLiteralValue l fmt
-prettyValueAtom (Constructor _ _ _ name _) _ = pretty $ T.unpack $ runProperName name
-prettyValueAtom (Var ann ty ident) fmt  =  parens $ pretty  (showIdent (disqualify ident)) <:> prettyType ty fmt
-prettyValueAtom expr fmt =  parens $ prettyValue expr fmt
+prettyValueAtom (Literal _  _ l)  = prettyLiteralValue l
+prettyValueAtom (Constructor _ _ _ name _) = pure . pretty $ T.unpack $ runProperName name
+prettyValueAtom (Var ann ty ident)  =  prettyType ty >>= \ty' ->
+  pure . parens $ pretty  (showIdent (disqualify ident)) <:> ty'
+prettyValueAtom expr =  parens <$> prettyValue expr
 
 prettyLiteralValue :: Literal (Expr a) -> Printer ann
 prettyLiteralValue (NumericLiteral n) = ignoreFmt $ pretty $ either show show n
@@ -274,32 +331,45 @@ prettyLiteralValue (ObjectLiteral ps) = prettyObject  $ second Just `map` ps
 
 prettyDeclaration :: forall a ann. Bind a -> Printer ann
 -- REVIEW: Maybe we don't want to ignore the format?
-prettyDeclaration b fmt = case b of
+prettyDeclaration b  = case b of
   NonRec _ ident expr -> goBind ident expr
-  Rec bindings -> vcat $ map  (\((_,ident),expr) -> goBind ident expr) bindings
+  Rec bindings -> vcat <$> traverse  (\((_,ident),expr) -> goBind ident expr) bindings
  where
-   goBind :: Ident -> Expr a -> Doc ann
-   goBind ident expr =
-     pretty ident <::> asOneLine prettyType (exprType expr)
-     <> hardline
-     <> goInner ident expr
-   goInner :: Ident -> Expr a -> Doc ann
-   goInner ident expr =
-     let f g = pretty ident <=> g (asDynamic prettyValue  expr)
-     in group $ flatAlt (f  (fmtIndent fmt))  (f id)
+   goBind :: Ident -> Expr a -> Printer ann
+   goBind ident expr = do
+     inner' <- goInner ident expr
+     let ty' = asOneLine prettyType (exprType expr)
+     pure $
+        pretty ident <::> ty'
+        <> hardline
+        <> inner'
+   goInner :: Ident -> Expr a -> Printer ann
+   goInner ident expr = do
+     fmt <- ask
+     let ind docs =  runReader (fmtIndent docs) fmt
+         f g = pretty ident <=> g (asDynamic prettyValue  expr)
+     pure $ group $ flatAlt (f ind)  (f id)
 
 prettyCaseAlternative ::  forall a ann. CaseAlternative a -> Printer ann
 -- prettyCaseAlternative d _ | d < 0 = ellipsis
-prettyCaseAlternative (CaseAlternative binders result) fmt =
-  hsep (asFmt fmt prettyBinderAtom  <$> binders) <> prettyResult result
+prettyCaseAlternative (CaseAlternative binders result)  = do
+  binders' <- traverse prettyBinderAtom binders
+  result'  <- prettyResult result
+  pure $ hsep binders' <> result' -- hsep (asFmt fmt prettyBinderAtom  <$> binders) <> prettyResult result
   where
-  prettyResult :: Either [(Guard a, Expr a)] (Expr a) -> Doc ann
+  prettyResult :: Either [(Guard a, Expr a)] (Expr a) -> Printer ann
   prettyResult = \case
-    Left ges -> vcat $  map prettyGuardedValueSep'   ges
-    Right exp' -> space <> arrow <+> fmtIndent fmt (prettyValue  exp' fmt)
+    Left ges -> vcat <$>  traverse prettyGuardedValueSep'   ges
+    Right exp' -> do
+      body' <- prettyValue exp' >>= fmtIndent
+      pure $ space <> arrow <+> body'
+      -- space <> arrow <+> fmtIndent fmt (prettyValue  exp' fmt)
 
-  prettyGuardedValueSep' :: (Guard a, Expr a) -> Doc ann
-  prettyGuardedValueSep' (guardE, resultE) = " | " <> prettyValue  guardE fmt <+> arrow  <+> prettyValue  resultE fmt
+  prettyGuardedValueSep' :: (Guard a, Expr a) -> Printer ann
+  prettyGuardedValueSep' (guardE, resultE) = do
+    guardE' <- prettyValue guardE
+    resultE' <- prettyValue resultE
+    pure $ " | " <> guardE'  <+> arrow  <+> resultE'
 
 
 prettyModule :: Module a -> Doc ann
@@ -332,9 +402,6 @@ writeModule h m = renderIO h
 prettyModuleTxt :: Module a -> Text
 prettyModuleTxt = renderStrict  . layoutPretty defaultLayoutOptions .  prettyModule
 
-prettyModuleStr :: Module a -> String
-prettyModuleStr = STR.renderString . layoutPretty defaultLayoutOptions . prettyModule
-
 renderExpr :: Expr a -> Text
 renderExpr = smartRender . asDynamic prettyValue
 
@@ -345,58 +412,67 @@ prettyTypeStr :: forall a. Show a => Type a -> String
 prettyTypeStr = T.unpack . smartRender . asOneLine prettyType
 
 prettyBinderAtom :: Binder a -> Printer ann
-prettyBinderAtom (NullBinder _) _ = "_"
-prettyBinderAtom (LiteralBinder _ l) fmt = prettyLiteralBinder l fmt
-prettyBinderAtom (VarBinder _ ident) _ = pretty ident
-prettyBinderAtom (ConstructorBinder _ _ ctor []) _ = pretty $ runProperName (disqualify ctor)
-prettyBinderAtom b@ConstructorBinder{} fmt = prettyBinder b fmt
-prettyBinderAtom (NamedBinder _ ident binder) fmt = pretty ident <> "@" <> prettyBinder binder fmt
+prettyBinderAtom (NullBinder _) = pure "_"
+prettyBinderAtom (LiteralBinder _ l) = prettyLiteralBinder l
+prettyBinderAtom (VarBinder _ ident) = pure $ pretty ident
+prettyBinderAtom (ConstructorBinder _ _ ctor []) = pure . pretty $ runProperName (disqualify ctor)
+prettyBinderAtom b@ConstructorBinder{} = prettyBinder b
+prettyBinderAtom (NamedBinder _ ident binder)= do
+  binder' <- prettyBinder binder
+  pure $ pretty ident <> "@" <> binder'
 
 prettyLiteralBinder ::  Literal (Binder a) -> Printer ann
-prettyLiteralBinder (StringLiteral str) _  = pretty $ prettyPrintString str
-prettyLiteralBinder (CharLiteral c) _ = viaShow c
-prettyLiteralBinder (NumericLiteral num) _ = either pretty pretty num
-prettyLiteralBinder (BooleanLiteral True) _ = "true"
-prettyLiteralBinder (BooleanLiteral False) _ = "false"
-prettyLiteralBinder (ObjectLiteral bs) fmt = asFmt fmt object $ prettyObjectPropertyBinder <$> bs
+prettyLiteralBinder (StringLiteral str)  = pure . pretty $ prettyPrintString str
+prettyLiteralBinder (CharLiteral c) = pure $ viaShow c
+prettyLiteralBinder (NumericLiteral num) = pure $ either pretty pretty num
+prettyLiteralBinder (BooleanLiteral True) = pure "true"
+prettyLiteralBinder (BooleanLiteral False) = pure "false"
+prettyLiteralBinder (ObjectLiteral bs) =  object =<< traverse prettyObjectPropertyBinder bs
   where
-  prettyObjectPropertyBinder :: (PSString, Binder a) -> Doc ann
-  prettyObjectPropertyBinder (key, binder) = prettyObjectKey key <:> prettyBinder binder fmt
-prettyLiteralBinder (ArrayLiteral bs) fmt = list (asFmt fmt prettyBinder  <$> bs)
+  prettyObjectPropertyBinder :: (PSString, Binder a) -> Printer ann
+  prettyObjectPropertyBinder (key, binder) = do
+    key' <- prettyObjectKey key
+    binder' <- prettyBinder binder
+    pure $ key' <:> binder'
+prettyLiteralBinder (ArrayLiteral bs) = list <$> traverse prettyBinder bs
 
 -- |
 -- Generate a pretty-printed string representing a Binder
 --
 prettyBinder :: Binder a -> Printer ann
-prettyBinder (ConstructorBinder _ _ ctor []) fmt = pretty $ runProperName (disqualify ctor)
-prettyBinder (ConstructorBinder _ _ ctor args) fmt =
-  pretty (runProperName (disqualify ctor)) <+> fmtSep fmt (asFmt fmt prettyBinderAtom <$> args)
-prettyBinder b fmt= prettyBinderAtom b fmt
+prettyBinder (ConstructorBinder _ _ ctor [])  = pure . pretty $ runProperName (disqualify ctor)
+prettyBinder (ConstructorBinder _ _ ctor args) = do
+  args' <- fmtSep =<< traverse prettyBinderAtom args
+  pure $ pretty (runProperName (disqualify ctor)) <+> args' -- fmtSep fmt (asFmt fmt prettyBinderAtom <$> args)
+prettyBinder b = prettyBinderAtom b
 
 
 {- TYPES (move later) -}
 
 prettyType :: forall a ann. Show a => Type a -> Printer ann
-prettyType t fmt =  group $ case t of
-  TUnknown _ n -> "t" <> pretty n
+prettyType t  =  group <$> case t of
+  TUnknown _ n -> pure $ "t" <> pretty n
 
-  TypeVar _ txt -> pretty txt
+  TypeVar _ txt -> pure $ pretty txt
 
-  TypeLevelString _ pss -> pretty . prettyPrintString $ pss
+  TypeLevelString _ pss -> pure . pretty . prettyPrintString $ pss
 
-  TypeLevelInt _ i -> pretty i
+  TypeLevelInt _ i -> pure $ pretty i
 
   TypeWildcard _ wcd -> case wcd of
-    HoleWildcard txt -> "?" <> pretty txt
-    _ -> "_"
+    HoleWildcard txt -> pure $ "?" <> pretty txt
+    _ -> pure "_"
 
-  TypeConstructor _ qPropName -> pretty . runProperName . disqualify $ qPropName
+  TypeConstructor _ qPropName -> pure . pretty . runProperName . disqualify $ qPropName
 
-  TypeOp a opName -> pretty $ showQualified runOpName opName
+  TypeOp a opName -> pure . pretty $ showQualified runOpName opName
 
   TypeApp _ t1 t2 -> goTypeApp t1 t2
 
-  KindApp a k1 k2 -> prettyType k1 fmt <> ("@" <> prettyType k2 fmt)
+  KindApp a k1 k2 -> do
+    k1' <- prettyType k1
+    k2' <- prettyType k2
+    pure $ k1' <> ("@" <> k2' )
 
   ForAll _ vis var mKind inner' _ -> case stripQuantifiers inner' of
     (quantified,inner) ->  goForall ([(vis,var,mKind)] <> quantified) inner
@@ -405,50 +481,75 @@ prettyType t fmt =  group $ case t of
 
   Skolem _ txt mKind inner mSkolScope -> error "TODO: Skolem (shouldn't ever appear in Purus CoreFn)"
 
-  REmpty _ -> "{}"
+  REmpty _ -> pure "{}"
 
-  rcons@RCons{} -> either (asFmt fmt openRow) tupled $ rowFields rcons
+  rcons@RCons{} -> either openRow (pure . tupled) =<< rowFields rcons
 
   -- this might be backwards
-  KindedType a ty kind -> parens $ prettyType ty fmt <::> prettyType kind fmt
+  KindedType a ty kind -> do
+    ty' <- prettyType ty
+    kind' <- prettyType kind
+    pure .  parens $  ty' <::> kind' -- prettyType ty fmt <::> prettyType kind fmt
 
   -- not sure what this is?
-  BinaryNoParensType a op l r -> prettyType l fmt <+> prettyType op fmt  <+> prettyType r fmt
+  BinaryNoParensType a op l r -> do
+    l' <- prettyType l
+    op' <- prettyType op
+    r' <- prettyType r
+    pure $ l' <+> op' <+> r' -- prettyType l fmt <+> prettyType op fmt  <+> prettyType r fmt
 
-  ParensInType _ ty -> parens (prettyType ty fmt)
+  ParensInType _ ty -> parens <$> prettyType ty
  where
-   goForall :: [(TypeVarVisibility,Text,Maybe (Type a))] -> Type a -> Doc ann
-   goForall xs inner = "forall" <+> fmtSep fmt (renderBoundVar <$> xs) <> "." <+> prettyType inner fmt
+   goForall :: [(TypeVarVisibility,Text,Maybe (Type a))] -> Type a -> Printer ann
+   goForall xs inner = do
+     boundVars <- fmtSep =<< traverse renderBoundVar xs
+     inner'    <- prettyType inner
+     pure $
+       "forall" <+> boundVars <> "." <+> inner'
 
    prefixVis :: TypeVarVisibility -> Doc ann -> Doc ann
    prefixVis vis tv = case vis of
      TypeVarVisible -> hcat ["@",tv]
      TypeVarInvisible -> tv
 
-   renderBoundVar :: (TypeVarVisibility, Text, Maybe (Type a)) -> Doc ann
+   renderBoundVar :: (TypeVarVisibility, Text, Maybe (Type a)) -> Printer ann
    renderBoundVar (vis,var,mk) =  case mk of
-     Just k -> parens $ prefixVis vis (pretty var) <::> prettyType k fmt
-     Nothing -> prefixVis vis (pretty var)
+     Just k -> do
+       ty' <- prettyType k
+       pure . parens $ prefixVis vis (pretty var) <::> ty'
+     Nothing -> pure $ prefixVis vis (pretty var)
 
    stripQuantifiers :: Type a -> ([(TypeVarVisibility,Text,Maybe (Type a))],Type a)
    stripQuantifiers = \case
      ForAll _ vis var mk inner _ -> first ((vis,var,mk):) $ stripQuantifiers inner
      other -> ([],other)
 
-   goTypeApp :: Type a -> Type a -> Doc ann
+   goTypeApp :: Type a -> Type a -> Printer ann
    goTypeApp (TypeApp _ f a) b
-     | eqType f tyFunction = fmtSep fmt [prettyType a fmt <+> arrow, prettyType b fmt]
-     | otherwise = parens $ goTypeApp f a  <+> prettyType b fmt
+     | eqType f tyFunction = do
+         a' <- prettyType a
+         b' <- prettyType b
+         fmtSep [a' <+> arrow,b']
+         -- fmtSep fmt [prettyType a fmt <+> arrow, prettyType b fmt]
+     | otherwise = do
+         f' <- goTypeApp f a
+         b' <- prettyType b
+         pure $ parens $ f' <+> b'
    goTypeApp o ty@RCons{}
-     | eqType o tyRecord = either (asFmt fmt openRecord) (asFmt fmt record) $ rowFields ty
-   goTypeApp a b =  fmtSep fmt [prettyType a fmt,prettyType b fmt]
+     | eqType o tyRecord =
+         -- TODO: Rows aren't records -_-
+         either openRecord record =<< rowFields ty
+
+   goTypeApp a b =  fmtSep =<< traverse prettyType [a,b] -- [prettyType a fmt,prettyType b fmt]
 
-   rowFields :: Type a -> Either ([Doc ann], Doc ann) [Doc ann]
+   rowFields :: Type a -> Reader LineFormat (Either ([Doc ann], Doc ann) [Doc ann])
    rowFields = \case
-         RCons _ lbl ty rest ->
-           let f = ((pretty lbl <::> prettyType ty fmt):)
-           in bimap (first f) f $ rowFields rest
-         REmpty _ -> Right []
-         KindApp _ REmpty{} _  -> Right [] -- REmpty is sometimes wrapped in a kind app?
-         TypeVar _ txt -> Left ([],pretty txt)
+         RCons _ lbl ty rest -> do
+           fmt <- ask
+           let f = ((pretty lbl <::> runPrinter fmt (prettyType ty)):)
+           rest' <- rowFields rest
+           pure $ bimap (first f) f rest'
+         REmpty _ -> pure $ Right []
+         KindApp _ REmpty{} _  -> pure $ Right [] -- REmpty is sometimes wrapped in a kind app?
+         TypeVar _ txt -> pure $ Left ([],pretty txt)
          other -> error $ "Malformed row fields: \n" <> show other

From cb11738d48fdf4c565dbaa0e50fb9b700b8146c1 Mon Sep 17 00:00:00 2001
From: gnumonik <gnumonik@protonmail.com>
Date: Tue, 5 Mar 2024 18:06:44 -0500
Subject: [PATCH 13/20] Final cleanup/tweaks to pretty printer

---
 src/Language/PureScript/CoreFn/Pretty.hs | 124 ++++++++---------------
 1 file changed, 45 insertions(+), 79 deletions(-)

diff --git a/src/Language/PureScript/CoreFn/Pretty.hs b/src/Language/PureScript/CoreFn/Pretty.hs
index 4964ad265..268aa7f06 100644
--- a/src/Language/PureScript/CoreFn/Pretty.hs
+++ b/src/Language/PureScript/CoreFn/Pretty.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TypeApplications, ScopedTypeVariables, RecordWildCards #-}
+{-# LANGUAGE TypeApplications, ScopedTypeVariables #-}
 module Language.PureScript.CoreFn.Pretty (
   writeModule,
   ppType,
@@ -53,10 +53,8 @@ import Prettyprinter
       pipe,
       comma,
       punctuate,
-      enclose,
       indent,
       line,
-      softline,
       space,
       vcat,
       hcat,
@@ -75,7 +73,6 @@ import Prettyprinter.Render.Text ( renderIO, renderStrict )
    The existing printer is extremely difficult to modify for our needs (e.g. there isn't a clear way to force
    an expression or type to print on one line). Because reading the CoreFn output is necessary
    to ensure correctness, it's important that we get get something legible.
-
 -}
 
 
@@ -92,17 +89,17 @@ type Formatter = forall a ann. (a -> Printer ann) -> a -> Doc ann
 runPrinter :: LineFormat -> Printer ann -> Doc ann
 runPrinter fmt p = runReader p fmt
 
-asFmt :: LineFormat -> (a -> Printer ann) -> a -> Doc ann
-asFmt fmt f x = case fmt of
-  OneLine -> asOneLine f x
-  MultiLine -> asDynamic f x
-
 asOneLine :: Formatter
 asOneLine p x = runPrinter OneLine (p x)
 
 asDynamic :: Formatter
 asDynamic p x = group $ align $ flatAlt (runPrinter MultiLine (p x)) (runPrinter OneLine (p x))
 
+onMultiline :: (Doc ann -> Doc ann) -> Doc ann -> Printer ann
+onMultiline f doc = ask >>= \case
+  OneLine -> pure doc
+  MultiLine -> pure . f $ doc
+
 ignoreFmt :: Doc ann -> Printer ann
 ignoreFmt doc = printer doc doc
 
@@ -116,11 +113,6 @@ fmtCat docs = ask >>= \case
   OneLine -> pure $ hcat docs
   MultiLine -> pure $ vcat docs
 
-fmtSpacer :: Printer  ann
-fmtSpacer = ask >>= \case
-  OneLine -> pure space
-  MultiLine -> pure softline
-
 fmtIndent :: Doc ann -> Printer ann
 fmtIndent doc = ask >>= \case
   OneLine -> pure doc
@@ -133,9 +125,8 @@ printer one multi = ask >>= \case
 
 withOpenRow :: forall ann. Doc ann -> Doc ann -> ([Doc ann],Doc ann) -> Printer ann
 withOpenRow l r (fields,open) = do
-  spacer <- fmtSpacer
-  fmtFields <- fmtSep $ punctuate comma fields'
-  pure . group . align $ enclose (l <> spacer) (spacer <> r) fmtFields
+  fmtFields <- onMultiline (indent 2) =<< fmtSep (punctuate comma fields')
+  group . align <$> fmtSep [l,fmtFields, r] -- fmtFields
   where
     fields' =  foldr (\x acc -> case acc of
                       [] -> [hsep [x,pipe <++> open]]
@@ -150,30 +141,17 @@ openRecord = withOpenRow lbrace rbrace
 
 recordLike ::  [Doc ann] -> Printer ann
 recordLike  fields  = do
-  spacer <- fmtSpacer
-  fields' <- fmtSep $ punctuate comma fields
-  pure $ enclose (lbrace <> spacer) (space <> rbrace) fields'
-
-record :: [Doc ann] -> Printer ann
-record = recordLike
-
-object :: [Doc ann] -> Printer ann
-object = recordLike
+  fields' <- onMultiline (indent 2) =<< fmtSep (punctuate comma fields)
+  group . align <$> fmtSep  [lbrace,fields',rbrace]
 
 commaSep :: [Doc ann] -> Doc ann
 commaSep = vsep . punctuate comma
 
-indent' :: Int -> Doc ann -> Doc ann
-indent' i doc = group . align $ flatAlt (indent i doc) doc
-
-parens' :: Doc ann -> Doc ann
-parens' d = group $ align $ enclose (lparen <> softline) (rparen <> softline) d
-
-
 -- TODO: Remove
 ppType :: Show a => Int -> Type a -> String
-ppType i t = prettyTypeStr t
+ppType _ t = prettyTypeStr t
 
+-- TODO: Move to modules where types are defined
 instance Pretty Ident where
   pretty = pretty . showIdent
 
@@ -253,36 +231,31 @@ prettyUpdateEntry key val  = do
 -- | Pretty-print an expression
 prettyValue :: Expr a -> Printer ann
 -- prettyValue _ | d < 0 = text "..."
-prettyValue (Accessor _ ty prop val)  =  do
+prettyValue (Accessor _ _ prop val)  =  do
   prop' <- prettyObjectKey prop
   val' <- prettyValueAtom val
   fmtCat [val',hcat[dot,prop']]
-prettyValue (ObjectUpdate ann _ty o _copyFields ps)  = do
+prettyValue (ObjectUpdate _ _ty o _copyFields ps)  = do
   obj <- prettyValueAtom o
   updateEntries <- traverse goUpdateEntry ps >>= recordLike
   pure $ obj <+> updateEntries -- prettyValueAtom o   <+> recordLike ( goUpdateEntry  <$> ps) fmt
   where
     goUpdateEntry = uncurry prettyUpdateEntry
-prettyValue app@(App ann ty val arg)  = case analyzeApp app of
+prettyValue app@(App _ _ _ _)  = case analyzeApp app of
   Just (fun,args) -> ask >>= \case
     OneLine -> pure . group . align . hsep .  map (asOneLine prettyValueAtom) $ (fun:args)
     MultiLine -> pure . group . align . vcat . map (asDynamic prettyValueAtom) $ (fun:args)
   Nothing -> error "App isn't an App (impossible)"
 
-prettyValue (Abs ann ty arg val) = do
+prettyValue (Abs _ ty arg val) = do
   ty' <- prettyType (getFunArgTy ty)
   body' <- fmtIndent =<< prettyValue val
   pure $ lam
          <> parens (align $ pretty (showIdent arg) <:> ty')
          <+> arrow
          <+> body'
-      {-   lam
-      <> parens (align $ pretty (showIdent arg) <:> prettyType (getFunArgTy ty) fmt)
-      <+> arrow
-      <+> fmtIndent fmt (asFmt fmt prettyValue val)
-      -}
 -- TODO: Actually implement the one line bracketed format for case exps (I think PS is the same as Haskell?)
-prettyValue (Case ann ty values binders) = pure $
+prettyValue (Case _ _ values binders) = pure $
   "case"
   <+> group (hsep scrutinees)
   <+> "of"
@@ -296,15 +269,20 @@ prettyValue (Let _ _  ds val)  = pure . align $ vcat [
   indent 2 . vcat $ asDynamic prettyDeclaration <$> ds,
   "in" <+> align (asDynamic  prettyValue val)
   ]
-prettyValue (Literal _ ty l)  = ask >>= \case {OneLine -> pure oneLine; MultiLine -> pure multiLine}
+prettyValue (Literal _ ty l)  = ask >>= \case {OneLine ->  oneLine; MultiLine -> multiLine}
   where
-    oneLine = parens $ hcat [
-      asOneLine prettyLiteralValue l,
-      colon,
-      space,
-      asOneLine prettyType ty
-      ]
-    multiLine = parens $ asDynamic prettyLiteralValue l <:> asDynamic prettyType ty
+    -- No type anns for object literals (already annotated in the fields, makes too ugly)
+    oneLine = case l of
+      ObjectLiteral{} ->  prettyLiteralValue l
+      _ -> pure . parens $ hcat [
+        asOneLine prettyLiteralValue l,
+        colon,
+        space,
+        asOneLine prettyType ty
+        ]
+    multiLine = case l of
+      ObjectLiteral{} -> prettyLiteralValue l
+      _ -> pure . parens $ asDynamic prettyLiteralValue l <:> asDynamic prettyType ty
 prettyValue expr@Constructor{}  = prettyValueAtom  expr
 prettyValue expr@Var{}  = prettyValueAtom  expr
 
@@ -312,7 +290,7 @@ prettyValue expr@Var{}  = prettyValueAtom  expr
 prettyValueAtom :: Expr a -> Printer ann
 prettyValueAtom (Literal _  _ l)  = prettyLiteralValue l
 prettyValueAtom (Constructor _ _ _ name _) = pure . pretty $ T.unpack $ runProperName name
-prettyValueAtom (Var ann ty ident)  =  prettyType ty >>= \ty' ->
+prettyValueAtom (Var _ ty ident)  =  prettyType ty >>= \ty' ->
   pure . parens $ pretty  (showIdent (disqualify ident)) <:> ty'
 prettyValueAtom expr =  parens <$> prettyValue expr
 
@@ -330,7 +308,6 @@ prettyLiteralValue (ArrayLiteral xs) = printer oneLine multiLine
 prettyLiteralValue (ObjectLiteral ps) = prettyObject  $ second Just `map` ps
 
 prettyDeclaration :: forall a ann. Bind a -> Printer ann
--- REVIEW: Maybe we don't want to ignore the format?
 prettyDeclaration b  = case b of
   NonRec _ ident expr -> goBind ident expr
   Rec bindings -> vcat <$> traverse  (\((_,ident),expr) -> goBind ident expr) bindings
@@ -351,11 +328,10 @@ prettyDeclaration b  = case b of
      pure $ group $ flatAlt (f ind)  (f id)
 
 prettyCaseAlternative ::  forall a ann. CaseAlternative a -> Printer ann
--- prettyCaseAlternative d _ | d < 0 = ellipsis
 prettyCaseAlternative (CaseAlternative binders result)  = do
-  binders' <- traverse prettyBinderAtom binders
+  let binders' =  asOneLine prettyBinderAtom <$> binders
   result'  <- prettyResult result
-  pure $ hsep binders' <> result' -- hsep (asFmt fmt prettyBinderAtom  <$> binders) <> prettyResult result
+  pure $ hsep binders' <> result'
   where
   prettyResult :: Either [(Guard a, Expr a)] (Expr a) -> Printer ann
   prettyResult = \case
@@ -363,7 +339,6 @@ prettyCaseAlternative (CaseAlternative binders result)  = do
     Right exp' -> do
       body' <- prettyValue exp' >>= fmtIndent
       pure $ space <> arrow <+> body'
-      -- space <> arrow <+> fmtIndent fmt (prettyValue  exp' fmt)
 
   prettyGuardedValueSep' :: (Guard a, Expr a) -> Printer ann
   prettyGuardedValueSep' (guardE, resultE) = do
@@ -371,10 +346,9 @@ prettyCaseAlternative (CaseAlternative binders result)  = do
     resultE' <- prettyValue resultE
     pure $ " | " <> guardE'  <+> arrow  <+> resultE'
 
-
 prettyModule :: Module a -> Doc ann
-prettyModule (Module modSS modComments modName modPath modImports modExports modReExports modForeign modDecls) =
-  vsep  $
+prettyModule (Module _ _ modName modPath modImports modExports modReExports modForeign modDecls) =
+  vsep
     [ pretty modName <+>  parens (pretty modPath)
     , "Imported Modules: "
     , indent 2 . commaSep $ pretty . snd  <$>  modImports
@@ -427,7 +401,7 @@ prettyLiteralBinder (CharLiteral c) = pure $ viaShow c
 prettyLiteralBinder (NumericLiteral num) = pure $ either pretty pretty num
 prettyLiteralBinder (BooleanLiteral True) = pure "true"
 prettyLiteralBinder (BooleanLiteral False) = pure "false"
-prettyLiteralBinder (ObjectLiteral bs) =  object =<< traverse prettyObjectPropertyBinder bs
+prettyLiteralBinder (ObjectLiteral bs) =  recordLike =<< traverse prettyObjectPropertyBinder bs
   where
   prettyObjectPropertyBinder :: (PSString, Binder a) -> Printer ann
   prettyObjectPropertyBinder (key, binder) = do
@@ -436,9 +410,6 @@ prettyLiteralBinder (ObjectLiteral bs) =  object =<< traverse prettyObjectProper
     pure $ key' <:> binder'
 prettyLiteralBinder (ArrayLiteral bs) = list <$> traverse prettyBinder bs
 
--- |
--- Generate a pretty-printed string representing a Binder
---
 prettyBinder :: Binder a -> Printer ann
 prettyBinder (ConstructorBinder _ _ ctor [])  = pure . pretty $ runProperName (disqualify ctor)
 prettyBinder (ConstructorBinder _ _ ctor args) = do
@@ -446,9 +417,7 @@ prettyBinder (ConstructorBinder _ _ ctor args) = do
   pure $ pretty (runProperName (disqualify ctor)) <+> args' -- fmtSep fmt (asFmt fmt prettyBinderAtom <$> args)
 prettyBinder b = prettyBinderAtom b
 
-
 {- TYPES (move later) -}
-
 prettyType :: forall a ann. Show a => Type a -> Printer ann
 prettyType t  =  group <$> case t of
   TUnknown _ n -> pure $ "t" <> pretty n
@@ -465,11 +434,11 @@ prettyType t  =  group <$> case t of
 
   TypeConstructor _ qPropName -> pure . pretty . runProperName . disqualify $ qPropName
 
-  TypeOp a opName -> pure . pretty $ showQualified runOpName opName
+  TypeOp _ opName -> pure . pretty $ showQualified runOpName opName
 
   TypeApp _ t1 t2 -> goTypeApp t1 t2
 
-  KindApp a k1 k2 -> do
+  KindApp _ k1 k2 -> do
     k1' <- prettyType k1
     k2' <- prettyType k2
     pure $ k1' <> ("@" <> k2' )
@@ -477,22 +446,22 @@ prettyType t  =  group <$> case t of
   ForAll _ vis var mKind inner' _ -> case stripQuantifiers inner' of
     (quantified,inner) ->  goForall ([(vis,var,mKind)] <> quantified) inner
 
-  ConstrainedType _ constraint inner -> error "TODO: ConstrainedType (shouldn't ever appear in Purus CoreFn)"
+  ConstrainedType _ _ _ -> error "TODO: ConstrainedType (shouldn't ever appear in Purus CoreFn)"
 
-  Skolem _ txt mKind inner mSkolScope -> error "TODO: Skolem (shouldn't ever appear in Purus CoreFn)"
+  Skolem _ _ _ _ _ -> error "TODO: Skolem (shouldn't ever appear in Purus CoreFn)"
 
   REmpty _ -> pure "{}"
 
   rcons@RCons{} -> either openRow (pure . tupled) =<< rowFields rcons
 
   -- this might be backwards
-  KindedType a ty kind -> do
+  KindedType _ ty kind -> do
     ty' <- prettyType ty
     kind' <- prettyType kind
     pure .  parens $  ty' <::> kind' -- prettyType ty fmt <::> prettyType kind fmt
 
   -- not sure what this is?
-  BinaryNoParensType a op l r -> do
+  BinaryNoParensType _ op l r -> do
     l' <- prettyType l
     op' <- prettyType op
     r' <- prettyType r
@@ -530,17 +499,14 @@ prettyType t  =  group <$> case t of
          a' <- prettyType a
          b' <- prettyType b
          fmtSep [a' <+> arrow,b']
-         -- fmtSep fmt [prettyType a fmt <+> arrow, prettyType b fmt]
      | otherwise = do
          f' <- goTypeApp f a
          b' <- prettyType b
          pure $ parens $ f' <+> b'
    goTypeApp o ty@RCons{}
      | eqType o tyRecord =
-         -- TODO: Rows aren't records -_-
-         either openRecord record =<< rowFields ty
-
-   goTypeApp a b =  fmtSep =<< traverse prettyType [a,b] -- [prettyType a fmt,prettyType b fmt]
+         either openRecord recordLike =<< rowFields ty
+   goTypeApp a b =  fmtSep =<< traverse prettyType [a,b]
 
    rowFields :: Type a -> Reader LineFormat (Either ([Doc ann], Doc ann) [Doc ann])
    rowFields = \case
@@ -550,6 +516,6 @@ prettyType t  =  group <$> case t of
            rest' <- rowFields rest
            pure $ bimap (first f) f rest'
          REmpty _ -> pure $ Right []
-         KindApp _ REmpty{} _  -> pure $ Right [] -- REmpty is sometimes wrapped in a kind app?
+         KindApp _ REmpty{} _  -> pure $ Right [] -- REmpty is sometimes wrapped in a kind app
          TypeVar _ txt -> pure $ Left ([],pretty txt)
          other -> error $ "Malformed row fields: \n" <> show other

From d295a011208f083f2bbb977987f1c4bb994bec5c Mon Sep 17 00:00:00 2001
From: gnumonik <gnumonik@protonmail.com>
Date: Tue, 5 Mar 2024 19:06:07 -0500
Subject: [PATCH 14/20] Module-ized prettyprinter + some small tweaks

---
 purescript.cabal                              |   3 +
 src/Language/PureScript/CoreFn/Pretty.hs      | 488 +-----------------
 .../PureScript/CoreFn/Pretty/Common.hs        | 201 ++++++++
 src/Language/PureScript/CoreFn/Pretty/Expr.hs | 261 ++++++++++
 .../PureScript/CoreFn/Pretty/Types.hs         | 135 +++++
 5 files changed, 620 insertions(+), 468 deletions(-)
 create mode 100644 src/Language/PureScript/CoreFn/Pretty/Common.hs
 create mode 100644 src/Language/PureScript/CoreFn/Pretty/Expr.hs
 create mode 100644 src/Language/PureScript/CoreFn/Pretty/Types.hs

diff --git a/purescript.cabal b/purescript.cabal
index 4b57b9f73..6fed7b2a0 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -252,6 +252,9 @@ library
     Language.PureScript.CoreFn.Module
     Language.PureScript.CoreFn.Optimizer
     Language.PureScript.CoreFn.Pretty
+    Language.PureScript.CoreFn.Pretty.Common
+    Language.PureScript.CoreFn.Pretty.Expr
+    Language.PureScript.CoreFn.Pretty.Types
     Language.PureScript.CoreFn.ToJSON
     Language.PureScript.CoreFn.Traversals
     Language.PureScript.CoreImp
diff --git a/src/Language/PureScript/CoreFn/Pretty.hs b/src/Language/PureScript/CoreFn/Pretty.hs
index 268aa7f06..bb2af5892 100644
--- a/src/Language/PureScript/CoreFn/Pretty.hs
+++ b/src/Language/PureScript/CoreFn/Pretty.hs
@@ -1,72 +1,38 @@
-{-# LANGUAGE TypeApplications, ScopedTypeVariables #-}
 module Language.PureScript.CoreFn.Pretty (
-  writeModule,
+  module PRETTY,
   ppType,
-  prettyTypeStr,
+  smartRender,
+  writeModule,
+  prettyModuleTxt,
+  renderExpr,
   renderExprStr,
-  prettyModuleTxt
+  prettyTypeStr
 ) where
 
 import Prelude hiding ((<>))
 
 import Data.Text (Text)
 import Data.Text qualified as T
-import Data.Map qualified as M
-import Data.Bifunctor (first, Bifunctor (..))
-import Control.Monad.Reader
 
-import Language.PureScript.Environment
-    ( tyRecord, tyFunction, getFunArgTy )
-import Language.PureScript.CoreFn.Expr
-    ( exprType,
-      Guard,
-      Bind(..),
-      CaseAlternative(CaseAlternative),
-      Expr(..) )
-import Language.PureScript.CoreFn.Module ( Module(Module) )
-import Language.PureScript.AST.Literals ( Literal(..) )
-import Language.PureScript.CoreFn.Binders ( Binder(..) )
-import Language.PureScript.Label (Label (..))
-import Language.PureScript.Names (OpName(..), ProperName(..), disqualify, runModuleName, showIdent, Ident, ModuleName, showQualified)
-import Language.PureScript.Types (Type (..), WildcardData (..), TypeVarVisibility (..), eqType)
-import Language.PureScript.PSString (PSString, prettyPrintString, decodeStringWithReplacement)
 import System.IO (Handle)
 
+import Language.PureScript.CoreFn.Expr
+    ( Expr(..) )
+import Language.PureScript.Types (Type (..))
+import Language.PureScript.CoreFn.Module (Module)
+
+import Language.PureScript.CoreFn.Pretty.Common as PRETTY
+import Language.PureScript.CoreFn.Pretty.Expr as PRETTY
+import Language.PureScript.CoreFn.Pretty.Types as PRETTY
+
 import Prettyprinter
-    ( (<>),
-      tupled,
-      layoutSmart,
+    ( layoutSmart,
       defaultLayoutOptions,
       layoutPretty,
-      list,
-      viaShow,
-      colon,
-      parens,
-      dot,
-      brackets,
-      hardline,
-      (<+>),
-      rbrace,
-      lbrace,
-      rparen,
-      lparen,
-      pipe,
-      comma,
-      punctuate,
-      indent,
-      line,
-      space,
-      vcat,
-      hcat,
-      vsep,
-      hsep,
-      flatAlt,
-      align,
-      group,
-      Doc,
-      Pretty(pretty) )
+      Doc )
 import Prettyprinter.Render.Text ( renderIO, renderStrict )
 
+
 {- Rewritten prettyprinter that uses a modern printer library & is less convoluted.
 
    We primarily need this for writing the "prettified" CoreFn files for development purposes.
@@ -76,295 +42,13 @@ import Prettyprinter.Render.Text ( renderIO, renderStrict )
 -}
 
 
-data LineFormat
-  = OneLine --  *DEFINITELY* Print on one line, even if doing so exceeds the page width
-  | MultiLine --  *Possibly* Print multiple lines.
-  deriving (Show, Eq)
-
--- TODO: Refactor to reader monad?
-type Printer ann =  Reader LineFormat (Doc ann)
-
-type Formatter = forall a ann. (a -> Printer ann) -> a -> Doc ann
-
-runPrinter :: LineFormat -> Printer ann -> Doc ann
-runPrinter fmt p = runReader p fmt
-
-asOneLine :: Formatter
-asOneLine p x = runPrinter OneLine (p x)
-
-asDynamic :: Formatter
-asDynamic p x = group $ align $ flatAlt (runPrinter MultiLine (p x)) (runPrinter OneLine (p x))
-
-onMultiline :: (Doc ann -> Doc ann) -> Doc ann -> Printer ann
-onMultiline f doc = ask >>= \case
-  OneLine -> pure doc
-  MultiLine -> pure . f $ doc
-
-ignoreFmt :: Doc ann -> Printer ann
-ignoreFmt doc = printer doc doc
-
-fmtSep :: [Doc ann] -> Printer ann
-fmtSep docs = ask >>= \case
-  OneLine -> pure $ hsep docs
-  MultiLine -> pure $ vsep docs
-
-fmtCat :: [Doc ann] -> Printer ann
-fmtCat docs = ask >>= \case
-  OneLine -> pure $ hcat docs
-  MultiLine -> pure $ vcat docs
-
-fmtIndent :: Doc ann -> Printer ann
-fmtIndent doc = ask >>= \case
-  OneLine -> pure doc
-  MultiLine -> pure $ line <> indent 2 doc
-
-printer :: Doc ann -> Doc ann -> Printer ann
-printer one multi = ask >>= \case
-  OneLine ->  pure one
-  MultiLine ->  pure multi
-
-withOpenRow :: forall ann. Doc ann -> Doc ann -> ([Doc ann],Doc ann) -> Printer ann
-withOpenRow l r (fields,open) = do
-  fmtFields <- onMultiline (indent 2) =<< fmtSep (punctuate comma fields')
-  group . align <$> fmtSep [l,fmtFields, r] -- fmtFields
-  where
-    fields' =  foldr (\x acc -> case acc of
-                      [] -> [hsep [x,pipe <++> open]]
-                      xs -> x : xs
-                    ) [] fields
-
-openRow :: ([Doc ann], Doc ann) -> Printer ann
-openRow = withOpenRow lparen rparen
-
-openRecord :: ([Doc ann], Doc ann) -> Printer ann
-openRecord = withOpenRow lbrace rbrace
-
-recordLike ::  [Doc ann] -> Printer ann
-recordLike  fields  = do
-  fields' <- onMultiline (indent 2) =<< fmtSep (punctuate comma fields)
-  group . align <$> fmtSep  [lbrace,fields',rbrace]
-
-commaSep :: [Doc ann] -> Doc ann
-commaSep = vsep . punctuate comma
-
 -- TODO: Remove
 ppType :: Show a => Int -> Type a -> String
 ppType _ t = prettyTypeStr t
 
--- TODO: Move to modules where types are defined
-instance Pretty Ident where
-  pretty = pretty . showIdent
-
-instance Pretty PSString where
-  pretty = pretty . decodeStringWithReplacement
-
-instance Pretty ModuleName where
-  pretty = pretty . runModuleName
-
-instance Pretty Label where
-  pretty = pretty . runLabel
-
-(<:>) :: Doc ann -> Doc ann -> Doc ann
-a <:> b = hcat [a,":"] <++> b
-
-(<::>) :: Doc ann -> Doc ann -> Doc ann
-a <::> b = a <++> "::" <++> b
-
-(<=>) :: Doc ann -> Doc ann -> Doc ann
-a <=> b = a <+> "=" <+> b
-
-(<//>) :: Doc ann -> Doc ann -> Doc ann
-a <//> b = a <+> hardline <+> b
-
--- ensures the things being concatenated are always on the same line
-(<++>) :: Doc ann -> Doc ann -> Doc ann
-a <++> b = hsep [a,b]
-
-arrow :: Doc ann
-arrow = "->"
-
-lam :: Doc ann
-lam = "\\"
-
-oneLineList :: [Doc ann] -> Doc ann
-oneLineList = brackets . hcat . punctuate (comma <> space)
-
--- helpers to ensure even formatting of applications
-analyzeApp :: Expr a -> Maybe (Expr a,[Expr a])
-analyzeApp t = (,appArgs t) <$> appFun t
-  where
-    appArgs :: Expr a -> [Expr a]
-    appArgs (App _ _ t1 t2) = appArgs t1 <> [t2]
-    appArgs _  = []
-
-    appFun :: Expr a -> Maybe (Expr a)
-    appFun (App _ _ t1 _) = go t1
-      where
-        go (App _ _ tx _) = case appFun tx of
-          Nothing -> Just tx
-          Just tx' -> Just tx'
-        go other = Just other
-    appFun _ = Nothing
-
-
--- Is a printer for consistency mainly
-prettyObjectKey :: PSString -> Printer ann
-prettyObjectKey = pure . pretty . decodeStringWithReplacement
-
-prettyObject ::  [(PSString, Maybe (Expr a))] -> Printer ann
-prettyObject fields  = do
-  fields' <- traverse prettyProperty fields
-  recordLike fields'
-  where
-    prettyProperty :: (PSString, Maybe (Expr a)) -> Printer ann
-    prettyProperty  (key, value) = do
-      key' <- prettyObjectKey key
-      props' <- maybe (pure $ pretty @Text "_") prettyValue value
-      pure (key' <:> props') --  prettyObjectKey key <:> maybe (pretty @Text "_") (flip prettyValue fmt) value
-
-prettyUpdateEntry :: PSString -> Expr a -> Printer ann
-prettyUpdateEntry key val  = do
-  key' <- prettyObjectKey key
-  val' <- prettyValue val
-  pure $ key' <=> val'
-
--- | Pretty-print an expression
-prettyValue :: Expr a -> Printer ann
--- prettyValue _ | d < 0 = text "..."
-prettyValue (Accessor _ _ prop val)  =  do
-  prop' <- prettyObjectKey prop
-  val' <- prettyValueAtom val
-  fmtCat [val',hcat[dot,prop']]
-prettyValue (ObjectUpdate _ _ty o _copyFields ps)  = do
-  obj <- prettyValueAtom o
-  updateEntries <- traverse goUpdateEntry ps >>= recordLike
-  pure $ obj <+> updateEntries -- prettyValueAtom o   <+> recordLike ( goUpdateEntry  <$> ps) fmt
-  where
-    goUpdateEntry = uncurry prettyUpdateEntry
-prettyValue app@(App _ _ _ _)  = case analyzeApp app of
-  Just (fun,args) -> ask >>= \case
-    OneLine -> pure . group . align . hsep .  map (asOneLine prettyValueAtom) $ (fun:args)
-    MultiLine -> pure . group . align . vcat . map (asDynamic prettyValueAtom) $ (fun:args)
-  Nothing -> error "App isn't an App (impossible)"
-
-prettyValue (Abs _ ty arg val) = do
-  ty' <- prettyType (getFunArgTy ty)
-  body' <- fmtIndent =<< prettyValue val
-  pure $ lam
-         <> parens (align $ pretty (showIdent arg) <:> ty')
-         <+> arrow
-         <+> body'
--- TODO: Actually implement the one line bracketed format for case exps (I think PS is the same as Haskell?)
-prettyValue (Case _ _ values binders) = pure $
-  "case"
-  <+> group (hsep scrutinees)
-  <+> "of"
-  <//> indent 2 (vcat $ map group branches)
- where
-   scrutinees = asOneLine prettyValueAtom <$> values
-   branches = group . asDynamic  prettyCaseAlternative <$> binders
--- technically we could have a one line version of this but that's ugly af
-prettyValue (Let _ _  ds val)  = pure . align $ vcat [
-  "let",
-  indent 2 . vcat $ asDynamic prettyDeclaration <$> ds,
-  "in" <+> align (asDynamic  prettyValue val)
-  ]
-prettyValue (Literal _ ty l)  = ask >>= \case {OneLine ->  oneLine; MultiLine -> multiLine}
-  where
-    -- No type anns for object literals (already annotated in the fields, makes too ugly)
-    oneLine = case l of
-      ObjectLiteral{} ->  prettyLiteralValue l
-      _ -> pure . parens $ hcat [
-        asOneLine prettyLiteralValue l,
-        colon,
-        space,
-        asOneLine prettyType ty
-        ]
-    multiLine = case l of
-      ObjectLiteral{} -> prettyLiteralValue l
-      _ -> pure . parens $ asDynamic prettyLiteralValue l <:> asDynamic prettyType ty
-prettyValue expr@Constructor{}  = prettyValueAtom  expr
-prettyValue expr@Var{}  = prettyValueAtom  expr
-
--- | Pretty-print an atomic expression, adding parentheses if necessary.
-prettyValueAtom :: Expr a -> Printer ann
-prettyValueAtom (Literal _  _ l)  = prettyLiteralValue l
-prettyValueAtom (Constructor _ _ _ name _) = pure . pretty $ T.unpack $ runProperName name
-prettyValueAtom (Var _ ty ident)  =  prettyType ty >>= \ty' ->
-  pure . parens $ pretty  (showIdent (disqualify ident)) <:> ty'
-prettyValueAtom expr =  parens <$> prettyValue expr
-
-prettyLiteralValue :: Literal (Expr a) -> Printer ann
-prettyLiteralValue (NumericLiteral n) = ignoreFmt $ pretty $ either show show n
-prettyLiteralValue (StringLiteral s) = ignoreFmt $ pretty . T.unpack $ prettyPrintString s
-prettyLiteralValue (CharLiteral c) = ignoreFmt $ viaShow . show $ c
-prettyLiteralValue (BooleanLiteral True) = ignoreFmt "true"
-prettyLiteralValue (BooleanLiteral False) = ignoreFmt "false"
-prettyLiteralValue (ArrayLiteral xs) = printer oneLine multiLine
-  where
-    oneLine = oneLineList $  asOneLine prettyValue <$>  xs
-    -- N.B. I think it makes more sense to ensure that list *elements* are always oneLine
-    multiLine = list $ asOneLine prettyValue <$> xs
-prettyLiteralValue (ObjectLiteral ps) = prettyObject  $ second Just `map` ps
-
-prettyDeclaration :: forall a ann. Bind a -> Printer ann
-prettyDeclaration b  = case b of
-  NonRec _ ident expr -> goBind ident expr
-  Rec bindings -> vcat <$> traverse  (\((_,ident),expr) -> goBind ident expr) bindings
- where
-   goBind :: Ident -> Expr a -> Printer ann
-   goBind ident expr = do
-     inner' <- goInner ident expr
-     let ty' = asOneLine prettyType (exprType expr)
-     pure $
-        pretty ident <::> ty'
-        <> hardline
-        <> inner'
-   goInner :: Ident -> Expr a -> Printer ann
-   goInner ident expr = do
-     fmt <- ask
-     let ind docs =  runReader (fmtIndent docs) fmt
-         f g = pretty ident <=> g (asDynamic prettyValue  expr)
-     pure $ group $ flatAlt (f ind)  (f id)
-
-prettyCaseAlternative ::  forall a ann. CaseAlternative a -> Printer ann
-prettyCaseAlternative (CaseAlternative binders result)  = do
-  let binders' =  asOneLine prettyBinderAtom <$> binders
-  result'  <- prettyResult result
-  pure $ hsep binders' <> result'
-  where
-  prettyResult :: Either [(Guard a, Expr a)] (Expr a) -> Printer ann
-  prettyResult = \case
-    Left ges -> vcat <$>  traverse prettyGuardedValueSep'   ges
-    Right exp' -> do
-      body' <- prettyValue exp' >>= fmtIndent
-      pure $ space <> arrow <+> body'
-
-  prettyGuardedValueSep' :: (Guard a, Expr a) -> Printer ann
-  prettyGuardedValueSep' (guardE, resultE) = do
-    guardE' <- prettyValue guardE
-    resultE' <- prettyValue resultE
-    pure $ " | " <> guardE'  <+> arrow  <+> resultE'
-
-prettyModule :: Module a -> Doc ann
-prettyModule (Module _ _ modName modPath modImports modExports modReExports modForeign modDecls) =
-  vsep
-    [ pretty modName <+>  parens (pretty modPath)
-    , "Imported Modules: "
-    , indent 2 . commaSep $ pretty . snd  <$>  modImports
-    ,"Exports: "
-    , indent 2 . commaSep $ pretty <$> modExports -- hang 2?
-    , "Re-Exports: "
-    , indent 2 . commaSep $ goReExport <$> M.toList modReExports
-    , "Foreign: "
-    , indent 2 . commaSep . map pretty $  modForeign
-    , "Declarations: "
-    , vcat . punctuate line $  asDynamic prettyDeclaration  <$> modDecls
-    ]
- where
-   goReExport :: (ModuleName,[Ident]) -> Doc ann
-   goReExport (mn',idents) = vcat $ flip map idents $ \i -> pretty mn' <> "." <> pretty i
 
+-- TODO (maybe): It wouldn't be too hard to determine the terminal width and write a
+--               display function that prints correctly-formatted-for-the-size
 smartRender ::  Doc ann -> Text
 smartRender = renderStrict . layoutPretty defaultLayoutOptions
 
@@ -385,137 +69,5 @@ renderExprStr = T.unpack . renderExpr
 prettyTypeStr :: forall a. Show a => Type a -> String
 prettyTypeStr = T.unpack . smartRender . asOneLine prettyType
 
-prettyBinderAtom :: Binder a -> Printer ann
-prettyBinderAtom (NullBinder _) = pure "_"
-prettyBinderAtom (LiteralBinder _ l) = prettyLiteralBinder l
-prettyBinderAtom (VarBinder _ ident) = pure $ pretty ident
-prettyBinderAtom (ConstructorBinder _ _ ctor []) = pure . pretty $ runProperName (disqualify ctor)
-prettyBinderAtom b@ConstructorBinder{} = prettyBinder b
-prettyBinderAtom (NamedBinder _ ident binder)= do
-  binder' <- prettyBinder binder
-  pure $ pretty ident <> "@" <> binder'
-
-prettyLiteralBinder ::  Literal (Binder a) -> Printer ann
-prettyLiteralBinder (StringLiteral str)  = pure . pretty $ prettyPrintString str
-prettyLiteralBinder (CharLiteral c) = pure $ viaShow c
-prettyLiteralBinder (NumericLiteral num) = pure $ either pretty pretty num
-prettyLiteralBinder (BooleanLiteral True) = pure "true"
-prettyLiteralBinder (BooleanLiteral False) = pure "false"
-prettyLiteralBinder (ObjectLiteral bs) =  recordLike =<< traverse prettyObjectPropertyBinder bs
-  where
-  prettyObjectPropertyBinder :: (PSString, Binder a) -> Printer ann
-  prettyObjectPropertyBinder (key, binder) = do
-    key' <- prettyObjectKey key
-    binder' <- prettyBinder binder
-    pure $ key' <:> binder'
-prettyLiteralBinder (ArrayLiteral bs) = list <$> traverse prettyBinder bs
-
-prettyBinder :: Binder a -> Printer ann
-prettyBinder (ConstructorBinder _ _ ctor [])  = pure . pretty $ runProperName (disqualify ctor)
-prettyBinder (ConstructorBinder _ _ ctor args) = do
-  args' <- fmtSep =<< traverse prettyBinderAtom args
-  pure $ pretty (runProperName (disqualify ctor)) <+> args' -- fmtSep fmt (asFmt fmt prettyBinderAtom <$> args)
-prettyBinder b = prettyBinderAtom b
 
 {- TYPES (move later) -}
-prettyType :: forall a ann. Show a => Type a -> Printer ann
-prettyType t  =  group <$> case t of
-  TUnknown _ n -> pure $ "t" <> pretty n
-
-  TypeVar _ txt -> pure $ pretty txt
-
-  TypeLevelString _ pss -> pure . pretty . prettyPrintString $ pss
-
-  TypeLevelInt _ i -> pure $ pretty i
-
-  TypeWildcard _ wcd -> case wcd of
-    HoleWildcard txt -> pure $ "?" <> pretty txt
-    _ -> pure "_"
-
-  TypeConstructor _ qPropName -> pure . pretty . runProperName . disqualify $ qPropName
-
-  TypeOp _ opName -> pure . pretty $ showQualified runOpName opName
-
-  TypeApp _ t1 t2 -> goTypeApp t1 t2
-
-  KindApp _ k1 k2 -> do
-    k1' <- prettyType k1
-    k2' <- prettyType k2
-    pure $ k1' <> ("@" <> k2' )
-
-  ForAll _ vis var mKind inner' _ -> case stripQuantifiers inner' of
-    (quantified,inner) ->  goForall ([(vis,var,mKind)] <> quantified) inner
-
-  ConstrainedType _ _ _ -> error "TODO: ConstrainedType (shouldn't ever appear in Purus CoreFn)"
-
-  Skolem _ _ _ _ _ -> error "TODO: Skolem (shouldn't ever appear in Purus CoreFn)"
-
-  REmpty _ -> pure "{}"
-
-  rcons@RCons{} -> either openRow (pure . tupled) =<< rowFields rcons
-
-  -- this might be backwards
-  KindedType _ ty kind -> do
-    ty' <- prettyType ty
-    kind' <- prettyType kind
-    pure .  parens $  ty' <::> kind' -- prettyType ty fmt <::> prettyType kind fmt
-
-  -- not sure what this is?
-  BinaryNoParensType _ op l r -> do
-    l' <- prettyType l
-    op' <- prettyType op
-    r' <- prettyType r
-    pure $ l' <+> op' <+> r' -- prettyType l fmt <+> prettyType op fmt  <+> prettyType r fmt
-
-  ParensInType _ ty -> parens <$> prettyType ty
- where
-   goForall :: [(TypeVarVisibility,Text,Maybe (Type a))] -> Type a -> Printer ann
-   goForall xs inner = do
-     boundVars <- fmtSep =<< traverse renderBoundVar xs
-     inner'    <- prettyType inner
-     pure $
-       "forall" <+> boundVars <> "." <+> inner'
-
-   prefixVis :: TypeVarVisibility -> Doc ann -> Doc ann
-   prefixVis vis tv = case vis of
-     TypeVarVisible -> hcat ["@",tv]
-     TypeVarInvisible -> tv
-
-   renderBoundVar :: (TypeVarVisibility, Text, Maybe (Type a)) -> Printer ann
-   renderBoundVar (vis,var,mk) =  case mk of
-     Just k -> do
-       ty' <- prettyType k
-       pure . parens $ prefixVis vis (pretty var) <::> ty'
-     Nothing -> pure $ prefixVis vis (pretty var)
-
-   stripQuantifiers :: Type a -> ([(TypeVarVisibility,Text,Maybe (Type a))],Type a)
-   stripQuantifiers = \case
-     ForAll _ vis var mk inner _ -> first ((vis,var,mk):) $ stripQuantifiers inner
-     other -> ([],other)
-
-   goTypeApp :: Type a -> Type a -> Printer ann
-   goTypeApp (TypeApp _ f a) b
-     | eqType f tyFunction = do
-         a' <- prettyType a
-         b' <- prettyType b
-         fmtSep [a' <+> arrow,b']
-     | otherwise = do
-         f' <- goTypeApp f a
-         b' <- prettyType b
-         pure $ parens $ f' <+> b'
-   goTypeApp o ty@RCons{}
-     | eqType o tyRecord =
-         either openRecord recordLike =<< rowFields ty
-   goTypeApp a b =  fmtSep =<< traverse prettyType [a,b]
-
-   rowFields :: Type a -> Reader LineFormat (Either ([Doc ann], Doc ann) [Doc ann])
-   rowFields = \case
-         RCons _ lbl ty rest -> do
-           fmt <- ask
-           let f = ((pretty lbl <::> runPrinter fmt (prettyType ty)):)
-           rest' <- rowFields rest
-           pure $ bimap (first f) f rest'
-         REmpty _ -> pure $ Right []
-         KindApp _ REmpty{} _  -> pure $ Right [] -- REmpty is sometimes wrapped in a kind app
-         TypeVar _ txt -> pure $ Left ([],pretty txt)
-         other -> error $ "Malformed row fields: \n" <> show other
diff --git a/src/Language/PureScript/CoreFn/Pretty/Common.hs b/src/Language/PureScript/CoreFn/Pretty/Common.hs
new file mode 100644
index 000000000..0d8628d9b
--- /dev/null
+++ b/src/Language/PureScript/CoreFn/Pretty/Common.hs
@@ -0,0 +1,201 @@
+module Language.PureScript.CoreFn.Pretty.Common where
+
+import Prelude hiding ((<>))
+
+import Control.Monad.Reader ( MonadReader(ask), runReader, Reader )
+
+import Language.PureScript.CoreFn.Expr
+    ( Expr(..) )
+import Language.PureScript.Label (Label (..))
+import Language.PureScript.Names (runModuleName, showIdent, Ident, ModuleName)
+import Language.PureScript.PSString (PSString, decodeStringWithReplacement)
+
+import Prettyprinter
+    ( (<>),
+      brackets,
+      hardline,
+      (<+>),
+      rbrace,
+      lbrace,
+      rparen,
+      lparen,
+      pipe,
+      comma,
+      punctuate,
+      indent,
+      line,
+      space,
+      vcat,
+      hcat,
+      vsep,
+      hsep,
+      flatAlt,
+      align,
+      group,
+      Doc,
+      Pretty(pretty) )
+
+{- One thing that we often wish to do, but cannot easily do either with
+   the Prettyprinter library or the ancient lib PureScript uses, is to
+   *force* particular sub-expressions to print on a single line.
+
+   (`Prettyprinter.group` does give us the ability to express: "Try to
+   print this on one line, but if you can't, use the multi-line format", and we
+   use that when choosing between one- and multi-line formats.)
+
+   This gives us a nice little abstraction for convenient auto-formatting
+   (single line/multi line) where we want it, while also giving us the ability to
+   override particular locations in the AST that we want to force to one-line (e.g. case
+   expression binders, applied types, etc).
+-}
+data LineFormat
+  = OneLine --  *DEFINITELY* Print on one line, even if doing so exceeds the page width
+  | MultiLine --  *Possibly* Print multiple lines.
+  deriving (Show, Eq)
+
+-- A document with a structure that depends on a formatting context
+type Printer ann =  Reader LineFormat (Doc ann)
+
+-- Convenience type
+type Formatter = forall a ann. (a -> Printer ann) -> a -> Doc ann
+
+-- runReader with flipped arguments (how it should be!)
+runPrinter :: LineFormat -> Printer ann -> Doc ann
+runPrinter fmt p = runReader p fmt
+
+asOneLine :: Formatter
+asOneLine p x = runPrinter OneLine (p x)
+
+-- Helper for dynamic formatting. `asMultiLine` doesn't make sense (we always want to choose
+-- between single and multiline formats in a context where we aren't forcing a one-line format)
+asDynamic :: Formatter
+asDynamic p x = group $ align $ flatAlt (runPrinter MultiLine (p x)) (runPrinter OneLine (p x))
+
+-- Applies the supplied function to the Doc if we're in a Multiline context.
+-- Primarily used for correct formatting of Records/Rows/Objects
+onMultiline :: (Doc ann -> Doc ann) -> Doc ann -> Printer ann
+onMultiline f doc = ask >>= \case
+  OneLine -> pure doc
+  MultiLine -> pure . f $ doc
+
+-- For docs w/ a structure that does not vary based on the line format options
+-- Used primarily for `let` expressions (where we want uniformity)
+ignoreFmt :: Doc ann -> Printer ann
+ignoreFmt doc = printer doc doc
+
+-- Choose between hsep and vsep based on the context
+fmtSep :: [Doc ann] -> Printer ann
+fmtSep docs = ask >>= \case
+  OneLine -> pure $ hsep docs
+  MultiLine -> pure $ vsep docs
+
+-- Choose between hcat and vcat based on the context
+fmtCat :: [Doc ann] -> Printer ann
+fmtCat docs = ask >>= \case
+  OneLine -> pure $ hcat docs
+  MultiLine -> pure $ vcat docs
+
+-- Choose between newline + indent or no change, depending on the context.
+-- NOTE: This is kind of the whole reason we need LineFormat + the Reader monad.
+--       `group` isn't sufficient here
+fmtIndent :: Doc ann -> Printer ann
+fmtIndent doc = ask >>= \case
+  OneLine -> pure doc
+  MultiLine -> pure $ line <> indent 2 doc
+
+-- Helper function for constructing a printer expr
+printer :: Doc ann -> Doc ann -> Printer ann
+printer one multi = ask >>= \case
+  OneLine ->  pure one
+  MultiLine ->  pure multi
+
+{- Higher-order Printers for Row Types, Record Types, and Object lits -}
+
+-- Helper for open rows. The `| r` part requires special handling.
+withOpenRow :: forall ann. Doc ann -> Doc ann -> ([Doc ann],Doc ann) -> Printer ann
+withOpenRow l r (fields,open) = do
+  fmtFields <- onMultiline (indent 2) =<< fmtSep (punctuate comma fields')
+  group . align <$> fmtSep [l,fmtFields, r] -- fmtFields
+  where
+    fields' =  foldr (\x acc -> case acc of
+                      [] -> [hsep [x,pipe <+> open]]
+                      xs -> x : xs
+                    ) [] fields
+
+openRow :: ([Doc ann], Doc ann) -> Printer ann
+openRow = withOpenRow lparen rparen
+
+openRecord :: ([Doc ann], Doc ann) -> Printer ann
+openRecord = withOpenRow lbrace rbrace
+
+-- Printer for record like things (Object literals, record types)
+recordLike ::  [Doc ann] -> Printer ann
+recordLike  fields  = do
+  fields' <- onMultiline (indent 2) =<< fmtSep (punctuate comma fields)
+  group . align <$> fmtSep  [lbrace,fields',rbrace]
+
+{- Misc Utils and custom combinators.
+   Most of these are just for readability. (a <:> type),
+   to me anyway, is a lot easier on the eyes than
+   (a <> ":" <> space <> type)
+-}
+commaSep :: [Doc ann] -> Doc ann
+commaSep = vsep . punctuate comma
+
+-- Our "special" type annotations are indicated w/ a single colon.
+(<:>) :: Doc ann -> Doc ann -> Doc ann
+a <:> b = hcat [a,":"] <+> b
+
+-- Actual type annotations & signatures (that are in the source explicitly or
+-- inferred by the compiler before we get the AST) are indicated in the normal way,
+-- that is, with '::'
+(<::>) :: Doc ann -> Doc ann -> Doc ann
+a <::> b = a <+> "::" <+> b
+
+(<=>) :: Doc ann -> Doc ann -> Doc ann
+a <=> b = a <+> "=" <+> b
+
+-- Forces a line break. Shouldn't be used except in cases where we want to ignore
+-- the dynamic formatting (e.g. case expressions)
+(<//>) :: Doc ann -> Doc ann -> Doc ann
+a <//> b = a <+> hardline <+> b
+
+arrow :: Doc ann
+arrow = "->"
+
+lam :: Doc ann
+lam = "\\"
+
+-- Like `list` but forces one line format.
+oneLineList :: [Doc ann] -> Doc ann
+oneLineList = brackets . hcat . punctuate (comma <> space)
+
+-- Splits an `App` expr into a function/ctor and a list of arguments.
+analyzeApp :: Expr a -> Maybe (Expr a,[Expr a])
+analyzeApp t = (,appArgs t) <$> appFun t
+  where
+    appArgs :: Expr a -> [Expr a]
+    appArgs (App _ _ t1 t2) = appArgs t1 <> [t2]
+    appArgs _  = []
+
+    appFun :: Expr a -> Maybe (Expr a)
+    appFun (App _ _ t1 _) = go t1
+      where
+        go (App _ _ tx _) = case appFun tx of
+          Nothing -> Just tx
+          Just tx' -> Just tx'
+        go other = Just other
+    appFun _ = Nothing
+
+-- TODO: Move to modules where types are defined
+instance Pretty Ident where
+  pretty = pretty . showIdent
+
+instance Pretty PSString where
+  pretty = pretty . decodeStringWithReplacement
+
+instance Pretty ModuleName where
+  pretty = pretty . runModuleName
+
+instance Pretty Label where
+  pretty = pretty . runLabel
diff --git a/src/Language/PureScript/CoreFn/Pretty/Expr.hs b/src/Language/PureScript/CoreFn/Pretty/Expr.hs
new file mode 100644
index 000000000..b692092ec
--- /dev/null
+++ b/src/Language/PureScript/CoreFn/Pretty/Expr.hs
@@ -0,0 +1,261 @@
+{-# LANGUAGE TypeApplications, ScopedTypeVariables #-}
+module Language.PureScript.CoreFn.Pretty.Expr where
+
+
+import Prelude hiding ((<>))
+
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Map qualified as M
+import Data.Bifunctor (Bifunctor (..))
+import Control.Monad.Reader ( MonadReader(ask), runReader )
+
+import Language.PureScript.Environment
+    ( getFunArgTy )
+import Language.PureScript.CoreFn.Expr
+    ( exprType,
+      Guard,
+      Bind(..),
+      CaseAlternative(CaseAlternative),
+      Expr(..) )
+import Language.PureScript.CoreFn.Module ( Module(Module) )
+import Language.PureScript.AST.Literals ( Literal(..) )
+import Language.PureScript.CoreFn.Binders ( Binder(..) )
+import Language.PureScript.Names (ProperName(..), disqualify, showIdent, Ident, ModuleName)
+import Language.PureScript.PSString (PSString, prettyPrintString, decodeStringWithReplacement)
+
+import Prettyprinter
+    ( (<>),
+      list,
+      viaShow,
+      colon,
+      parens,
+      dot,
+      hardline,
+      (<+>),
+      punctuate,
+      indent,
+      line,
+      space,
+      vcat,
+      hcat,
+      vsep,
+      hsep,
+      flatAlt,
+      align,
+      group,
+      Doc,
+      Pretty(pretty) )
+import Language.PureScript.CoreFn.Pretty.Common
+    ( Printer,
+      LineFormat(MultiLine, OneLine),
+      asOneLine,
+      asDynamic,
+      ignoreFmt,
+      fmtSep,
+      fmtCat,
+      fmtIndent,
+      printer,
+      recordLike,
+      commaSep,
+      (<:>),
+      (<::>),
+      (<=>),
+      (<//>),
+      arrow,
+      lam,
+      oneLineList,
+      analyzeApp )
+import Language.PureScript.CoreFn.Pretty.Types ( prettyType )
+
+
+prettyModule :: Module a -> Doc ann
+prettyModule (Module _ _ modName modPath modImports modExports modReExports modForeign modDecls) =
+  vsep
+    [ pretty modName <+>  parens (pretty modPath)
+    , "Imported Modules: "
+    , indent 2 . commaSep $ pretty . snd  <$>  modImports
+    ,"Exports: "
+    , indent 2 . commaSep $ pretty <$> modExports -- hang 2?
+    , "Re-Exports: "
+    , indent 2 . commaSep $ goReExport <$> M.toList modReExports
+    , "Foreign: "
+    , indent 2 . commaSep . map pretty $  modForeign
+    , "Declarations: "
+    , vcat . punctuate line $  asDynamic prettyDeclaration  <$> modDecls
+    ]
+ where
+   goReExport :: (ModuleName,[Ident]) -> Doc ann
+   goReExport (mn',idents) = vcat $ flip map idents $ \i -> pretty mn' <> "." <> pretty i
+
+-- Is a printer for consistency mainly
+prettyObjectKey :: PSString -> Printer ann
+prettyObjectKey = pure . pretty . decodeStringWithReplacement
+
+prettyObject ::  [(PSString, Maybe (Expr a))] -> Printer ann
+prettyObject fields  = do
+  fields' <- traverse prettyProperty fields
+  recordLike fields'
+  where
+    prettyProperty :: (PSString, Maybe (Expr a)) -> Printer ann
+    prettyProperty  (key, value) = do
+      key' <- prettyObjectKey key
+      props' <- maybe (pure $ pretty @Text "_") prettyValue value
+      pure (key' <:> props')
+
+prettyUpdateEntry :: PSString -> Expr a -> Printer ann
+prettyUpdateEntry key val  = do
+  key' <- prettyObjectKey key
+  val' <- prettyValue val
+  pure $ key' <=> val'
+
+-- | Pretty-print an expression
+prettyValue :: Expr a -> Printer ann
+prettyValue (Accessor _ _ prop val)  =  do
+  prop' <- prettyObjectKey prop
+  val' <- prettyValueAtom val
+  fmtCat [val',hcat[dot,prop']]
+prettyValue (ObjectUpdate _ _ty o _copyFields ps)  = do
+  obj <- prettyValueAtom o
+  updateEntries <- traverse goUpdateEntry ps >>= recordLike
+  pure $ obj <+> updateEntries
+  where
+    goUpdateEntry = uncurry prettyUpdateEntry
+prettyValue app@(App _ _ _ _)  = case analyzeApp app of
+  Just (fun,args) -> ask >>= \case
+    OneLine -> pure . group . align . hsep .  map (asOneLine prettyValueAtom) $ (fun:args)
+    MultiLine -> pure . group . align . vsep . map (asDynamic prettyValueAtom) $ (fun:args)
+  Nothing -> error "App isn't an App (impossible)"
+prettyValue (Abs _ ty arg val) = do
+  ty' <- prettyType (getFunArgTy ty)
+  body' <- fmtIndent =<< prettyValue val
+  pure $ lam
+         <> parens (align $ pretty (showIdent arg) <:> ty')
+         <+> arrow
+         <+> body'
+-- TODO: Actually implement the one line bracketed format for case exps (I think PS is the same as Haskell?)
+prettyValue (Case _ _ values binders) = pure $
+  "case"
+  <+> group (hsep scrutinees)
+  <+> "of"
+  <//> indent 2 (vcat $ map group branches)
+ where
+   scrutinees = asOneLine prettyValueAtom <$> values
+   branches = group . asDynamic  prettyCaseAlternative <$> binders
+-- technically we could have a one line version of this but that's ugly af imo
+prettyValue (Let _ _  ds val)  = pure . align $ vcat [
+  "let",
+  indent 2 . vcat $ asDynamic prettyDeclaration <$> ds,
+  "in" <+> align (asDynamic  prettyValue val)
+  ]
+prettyValue (Literal _ ty l)  = ask >>= \case {OneLine ->  oneLine; MultiLine -> multiLine}
+  where
+    -- No type anns for object literals (already annotated in the fields, makes too ugly)
+    oneLine = case l of
+      ObjectLiteral{} ->  prettyLiteralValue l
+      _ -> pure . parens $ hcat [
+        asOneLine prettyLiteralValue l,
+        colon,
+        space,
+        asOneLine prettyType ty
+        ]
+    multiLine = case l of
+      ObjectLiteral{} -> prettyLiteralValue l
+      _ -> pure . parens $ asDynamic prettyLiteralValue l <:> asDynamic prettyType ty
+prettyValue expr@Constructor{}  = prettyValueAtom  expr
+prettyValue expr@Var{}  = prettyValueAtom expr
+
+-- | Pretty-print an atomic expression, adding parentheses if necessary.
+prettyValueAtom :: Expr a -> Printer ann
+prettyValueAtom (Literal _  _ l)  = prettyLiteralValue l
+prettyValueAtom (Constructor _ _ _ name _) = pure . pretty $ T.unpack $ runProperName name
+prettyValueAtom (Var _ ty ident)  =  prettyType ty >>= \ty' ->
+  pure . parens $ pretty  (showIdent (disqualify ident)) <:> ty'
+prettyValueAtom expr =  parens <$> prettyValue expr
+
+prettyLiteralValue :: Literal (Expr a) -> Printer ann
+prettyLiteralValue (NumericLiteral n) = ignoreFmt $ pretty $ either show show n
+prettyLiteralValue (StringLiteral s) = ignoreFmt $ pretty . T.unpack $ prettyPrintString s
+prettyLiteralValue (CharLiteral c) = ignoreFmt $ viaShow . show $ c
+prettyLiteralValue (BooleanLiteral True) = ignoreFmt "true"
+prettyLiteralValue (BooleanLiteral False) = ignoreFmt "false"
+prettyLiteralValue (ArrayLiteral xs) = printer oneLine multiLine
+  where
+    oneLine = oneLineList $  asOneLine prettyValue <$>  xs
+    -- N.B. I think it makes more sense to ensure that list *elements* are always oneLine
+    multiLine = list $ asOneLine prettyValue <$> xs
+prettyLiteralValue (ObjectLiteral ps) = prettyObject  $ second Just `map` ps
+
+prettyDeclaration :: forall a ann. Bind a -> Printer ann
+prettyDeclaration b  = case b of
+  NonRec _ ident expr -> goBind ident expr
+  Rec bindings -> vcat <$> traverse  (\((_,ident),expr) -> goBind ident expr) bindings
+ where
+   goBind :: Ident -> Expr a -> Printer ann
+   goBind ident expr = do
+     inner' <- goInner ident expr
+     let ty' = asOneLine prettyType (exprType expr)
+     pure $
+        pretty ident <::> ty'
+        <> hardline
+        <> inner'
+   goInner :: Ident -> Expr a -> Printer ann
+   goInner ident expr = do
+     fmt <- ask
+     let ind docs =  runReader (fmtIndent docs) fmt
+         f g = pretty ident <=> g (asDynamic prettyValue  expr)
+     pure $ group $ flatAlt (f ind)  (f id)
+
+prettyCaseAlternative ::  forall a ann. CaseAlternative a -> Printer ann
+prettyCaseAlternative (CaseAlternative binders result)  = do
+  let binders' =  asOneLine prettyBinderAtom <$> binders
+  result'  <- prettyResult result
+  pure $ hsep binders' <> result'
+  where
+  prettyResult :: Either [(Guard a, Expr a)] (Expr a) -> Printer ann
+  prettyResult = \case
+    Left ges -> vcat <$>  traverse prettyGuardedValueSep'   ges
+    Right exp' -> do
+      body' <- prettyValue exp' >>= fmtIndent
+      pure $ space <> arrow <+> body'
+
+  prettyGuardedValueSep' :: (Guard a, Expr a) -> Printer ann
+  prettyGuardedValueSep' (guardE, resultE) = do
+    guardE' <- prettyValue guardE
+    resultE' <- prettyValue resultE
+    pure $ " | " <> guardE'  <+> arrow  <+> resultE'
+
+
+
+
+prettyBinderAtom :: Binder a -> Printer ann
+prettyBinderAtom (NullBinder _) = pure "_"
+prettyBinderAtom (LiteralBinder _ l) = prettyLiteralBinder l
+prettyBinderAtom (VarBinder _ ident) = pure $ pretty ident
+prettyBinderAtom (ConstructorBinder _ _ ctor []) = pure . pretty $ runProperName (disqualify ctor)
+prettyBinderAtom b@ConstructorBinder{} = prettyBinder b
+prettyBinderAtom (NamedBinder _ ident binder)= do
+  binder' <- prettyBinder binder
+  pure $ pretty ident <> "@" <> binder'
+
+prettyLiteralBinder ::  Literal (Binder a) -> Printer ann
+prettyLiteralBinder (StringLiteral str)  = pure . pretty $ prettyPrintString str
+prettyLiteralBinder (CharLiteral c) = pure $ viaShow c
+prettyLiteralBinder (NumericLiteral num) = pure $ either pretty pretty num
+prettyLiteralBinder (BooleanLiteral True) = pure "true"
+prettyLiteralBinder (BooleanLiteral False) = pure "false"
+prettyLiteralBinder (ObjectLiteral bs) =  recordLike =<< traverse prettyObjectPropertyBinder bs
+  where
+  prettyObjectPropertyBinder :: (PSString, Binder a) -> Printer ann
+  prettyObjectPropertyBinder (key, binder) = do
+    key' <- prettyObjectKey key
+    binder' <- prettyBinder binder
+    pure $ key' <:> binder'
+prettyLiteralBinder (ArrayLiteral bs) = list <$> traverse prettyBinder bs
+
+prettyBinder :: Binder a -> Printer ann
+prettyBinder (ConstructorBinder _ _ ctor [])  = pure . pretty $ runProperName (disqualify ctor)
+prettyBinder (ConstructorBinder _ _ ctor args) = do
+  args' <- fmtSep =<< traverse prettyBinderAtom args
+  pure $ pretty (runProperName (disqualify ctor)) <+> args' -- fmtSep fmt (asFmt fmt prettyBinderAtom <$> args)
+prettyBinder b = prettyBinderAtom b
diff --git a/src/Language/PureScript/CoreFn/Pretty/Types.hs b/src/Language/PureScript/CoreFn/Pretty/Types.hs
new file mode 100644
index 000000000..b172ea11e
--- /dev/null
+++ b/src/Language/PureScript/CoreFn/Pretty/Types.hs
@@ -0,0 +1,135 @@
+module Language.PureScript.CoreFn.Pretty.Types where
+
+import Prelude hiding ((<>))
+
+import Data.Text (Text)
+import Data.Bifunctor (first, Bifunctor (..))
+import Control.Monad.Reader ( MonadReader(ask), Reader )
+
+import Language.PureScript.Environment
+    ( tyRecord, tyFunction )
+import Language.PureScript.Names (OpName(..), ProperName(..), disqualify, showQualified)
+import Language.PureScript.Types (Type (..), WildcardData (..), TypeVarVisibility (..), eqType)
+import Language.PureScript.PSString (prettyPrintString)
+
+import Prettyprinter
+    ( (<>),
+      tupled,
+      parens,
+      (<+>),
+      hcat,
+      group,
+      Doc,
+      Pretty(pretty) )
+import Language.PureScript.CoreFn.Pretty.Common
+    ( Printer,
+      LineFormat,
+      runPrinter,
+      fmtSep,
+      openRow,
+      openRecord,
+      recordLike,
+      (<::>),
+      arrow )
+
+prettyType :: forall a ann. Show a => Type a -> Printer ann
+prettyType t  =  group <$> case t of
+  TUnknown _ n -> pure $ "t" <> pretty n
+
+  TypeVar _ txt -> pure $ pretty txt
+
+  TypeLevelString _ pss -> pure . pretty . prettyPrintString $ pss
+
+  TypeLevelInt _ i -> pure $ pretty i
+
+  TypeWildcard _ wcd -> case wcd of
+    HoleWildcard txt -> pure $ "?" <> pretty txt
+    _ -> pure "_"
+
+  TypeConstructor _ qPropName -> pure . pretty . runProperName . disqualify $ qPropName
+
+  TypeOp _ opName -> pure . pretty $ showQualified runOpName opName
+
+  TypeApp _ t1 t2 -> goTypeApp t1 t2
+
+  KindApp _ k1 k2 -> do
+    k1' <- prettyType k1
+    k2' <- prettyType k2
+    pure $ k1' <> ("@" <> k2' )
+
+  ForAll _ vis var mKind inner' _ -> case stripQuantifiers inner' of
+    (quantified,inner) ->  goForall ([(vis,var,mKind)] <> quantified) inner
+
+  ConstrainedType _ _ _ -> error "TODO: ConstrainedType (shouldn't ever appear in Purus CoreFn)"
+
+  Skolem _ _ _ _ _ -> error "TODO: Skolem (shouldn't ever appear in Purus CoreFn)"
+
+  REmpty _ -> pure "{}"
+
+  rcons@RCons{} -> either openRow (pure . tupled) =<< rowFields rcons
+
+  -- this might be backwards
+  KindedType _ ty kind -> do
+    ty' <- prettyType ty
+    kind' <- prettyType kind
+    pure .  parens $  ty' <::> kind' -- prettyType ty fmt <::> prettyType kind fmt
+
+  -- not sure what this is?
+  BinaryNoParensType _ op l r -> do
+    l' <- prettyType l
+    op' <- prettyType op
+    r' <- prettyType r
+    pure $ l' <+> op' <+> r' -- prettyType l fmt <+> prettyType op fmt  <+> prettyType r fmt
+
+  ParensInType _ ty -> parens <$> prettyType ty
+ where
+   goForall :: [(TypeVarVisibility,Text,Maybe (Type a))] -> Type a -> Printer ann
+   goForall xs inner = do
+     boundVars <- fmtSep =<< traverse renderBoundVar xs
+     inner'    <- prettyType inner
+     pure $
+       "forall" <+> boundVars <> "." <+> inner'
+
+   prefixVis :: TypeVarVisibility -> Doc ann -> Doc ann
+   prefixVis vis tv = case vis of
+     TypeVarVisible -> hcat ["@",tv]
+     TypeVarInvisible -> tv
+
+   renderBoundVar :: (TypeVarVisibility, Text, Maybe (Type a)) -> Printer ann
+   renderBoundVar (vis,var,mk) =  case mk of
+     Just k -> do
+       ty' <- prettyType k
+       pure . parens $ prefixVis vis (pretty var) <::> ty'
+     Nothing -> pure $ prefixVis vis (pretty var)
+
+   stripQuantifiers :: Type a -> ([(TypeVarVisibility,Text,Maybe (Type a))],Type a)
+   stripQuantifiers = \case
+     ForAll _ vis var mk inner _ -> first ((vis,var,mk):) $ stripQuantifiers inner
+     other -> ([],other)
+
+   goTypeApp :: Type a -> Type a -> Printer ann
+   goTypeApp (TypeApp _ f a) b
+     | eqType f tyFunction = do
+         a' <- prettyType a
+         b' <- prettyType b
+         fmtSep [a' <+> arrow,b']
+     | otherwise = do
+         f' <- goTypeApp f a
+         b' <- prettyType b
+         pure $ parens $ f' <+> b'
+   goTypeApp o ty@RCons{}
+     | eqType o tyRecord =
+         either openRecord recordLike =<< rowFields ty
+   goTypeApp a b =  fmtSep =<< traverse prettyType [a,b]
+
+   rowFields :: Type a -> Reader LineFormat (Either ([Doc ann], Doc ann) [Doc ann])
+   rowFields = \case
+         RCons _ lbl ty rest -> do
+           fmt <- ask
+           let f = ((pretty lbl <::> runPrinter fmt (prettyType ty)):)
+           rest' <- rowFields rest
+           pure $ bimap (first f) f rest'
+         REmpty _ -> pure $ Right []
+         KindApp _ REmpty{} _  -> pure $ Right [] -- REmpty is sometimes wrapped in a kind app
+         TypeVar _ txt -> pure $ Left ([],pretty txt)
+         other -> error $ "Malformed row fields: \n" <> show other

From ae4f7030bdc9c834ec64daf5cf35396d38bbaa48 Mon Sep 17 00:00:00 2001
From: t4ccer <t4ccer@gmail.com>
Date: Sun, 18 Feb 2024 12:52:49 -0700
Subject: [PATCH 15/20] Nix setup

---
 .gitignore                 |   3 +
 cabal.project              |   4 +
 default.nix                |  20 +
 flake.lock                 | 813 +++++++++++++++++++++++++++++++++++++
 flake.nix                  | 107 +++++
 fourmolu.yaml              |   8 +
 nix/fourmolu/default.nix   |  13 +
 nix/haskell/default.nix    |  36 ++
 nix/haskell/lib.nix        |  91 +++++
 nix/haskell/mk-hackage.nix | 132 ++++++
 nix/plutarch/default.nix   |  28 ++
 nix/plutarch/lib.nix       |  44 ++
 nix/utils/default.nix      |  22 +
 nix/utils/lib.nix          |  39 ++
 purescript.cabal           |   2 +-
 shell.nix                  |  21 -
 16 files changed, 1361 insertions(+), 22 deletions(-)
 create mode 100644 default.nix
 create mode 100644 flake.lock
 create mode 100644 flake.nix
 create mode 100644 fourmolu.yaml
 create mode 100644 nix/fourmolu/default.nix
 create mode 100644 nix/haskell/default.nix
 create mode 100644 nix/haskell/lib.nix
 create mode 100644 nix/haskell/mk-hackage.nix
 create mode 100644 nix/plutarch/default.nix
 create mode 100644 nix/plutarch/lib.nix
 create mode 100644 nix/utils/default.nix
 create mode 100644 nix/utils/lib.nix
 delete mode 100644 shell.nix

diff --git a/.gitignore b/.gitignore
index 0454beffc..9b55e7393 100644
--- a/.gitignore
+++ b/.gitignore
@@ -38,3 +38,6 @@ TAGS
 *.ps
 *.svg
 tests/purs/make/
+.direnv/
+/.pre-commit-config.yaml
+/result*
diff --git a/cabal.project b/cabal.project
index aa859b8b7..29ca61bcc 100644
--- a/cabal.project
+++ b/cabal.project
@@ -12,3 +12,7 @@ repository cardano-haskell-packages
 
 packages:
   purescript.cabal
+
+-- HACK: plutus core cannot build without it, remove after bump.
+constraints:
+  nothunks < 0.2
diff --git a/default.nix b/default.nix
new file mode 100644
index 000000000..83f611fb1
--- /dev/null
+++ b/default.nix
@@ -0,0 +1,20 @@
+{
+  perSystem = { self', config, ... }:
+    let
+      purus = config.libPlutarch.mkPackage {
+        name = "purus";
+        src = ./.;
+      };
+    in
+    {
+      devShells.purus = purus.devShell;
+
+      packages = {
+        purs = purus.packages."purescript:exe:purs";
+      };
+
+      apps = {
+        purs.program = "${self'.packages.purs}/bin/purs";
+      };
+    };
+}
diff --git a/flake.lock b/flake.lock
new file mode 100644
index 000000000..34d0f876a
--- /dev/null
+++ b/flake.lock
@@ -0,0 +1,813 @@
+{
+  "nodes": {
+    "HTTP": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1451647621,
+        "narHash": "sha256-oHIyw3x0iKBexEo49YeUDV1k74ZtyYKGR2gNJXXRxts=",
+        "owner": "phadej",
+        "repo": "HTTP",
+        "rev": "9bc0996d412fef1787449d841277ef663ad9a915",
+        "type": "github"
+      },
+      "original": {
+        "owner": "phadej",
+        "repo": "HTTP",
+        "type": "github"
+      }
+    },
+    "cabal-32": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1603716527,
+        "narHash": "sha256-X0TFfdD4KZpwl0Zr6x+PLxUt/VyKQfX7ylXHdmZIL+w=",
+        "owner": "haskell",
+        "repo": "cabal",
+        "rev": "48bf10787e27364730dd37a42b603cee8d6af7ee",
+        "type": "github"
+      },
+      "original": {
+        "owner": "haskell",
+        "ref": "3.2",
+        "repo": "cabal",
+        "type": "github"
+      }
+    },
+    "cabal-34": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1645834128,
+        "narHash": "sha256-wG3d+dOt14z8+ydz4SL7pwGfe7SiimxcD/LOuPCV6xM=",
+        "owner": "haskell",
+        "repo": "cabal",
+        "rev": "5ff598c67f53f7c4f48e31d722ba37172230c462",
+        "type": "github"
+      },
+      "original": {
+        "owner": "haskell",
+        "ref": "3.4",
+        "repo": "cabal",
+        "type": "github"
+      }
+    },
+    "cabal-36": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1669081697,
+        "narHash": "sha256-I5or+V7LZvMxfbYgZATU4awzkicBwwok4mVoje+sGmU=",
+        "owner": "haskell",
+        "repo": "cabal",
+        "rev": "8fd619e33d34924a94e691c5fea2c42f0fc7f144",
+        "type": "github"
+      },
+      "original": {
+        "owner": "haskell",
+        "ref": "3.6",
+        "repo": "cabal",
+        "type": "github"
+      }
+    },
+    "cardano-shell": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1608537748,
+        "narHash": "sha256-PulY1GfiMgKVnBci3ex4ptk2UNYMXqGjJOxcPy2KYT4=",
+        "owner": "input-output-hk",
+        "repo": "cardano-shell",
+        "rev": "9392c75087cb9a3d453998f4230930dea3a95725",
+        "type": "github"
+      },
+      "original": {
+        "owner": "input-output-hk",
+        "repo": "cardano-shell",
+        "type": "github"
+      }
+    },
+    "flake-compat": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1672831974,
+        "narHash": "sha256-z9k3MfslLjWQfnjBtEtJZdq3H7kyi2kQtUThfTgdRk0=",
+        "owner": "input-output-hk",
+        "repo": "flake-compat",
+        "rev": "45f2638735f8cdc40fe302742b79f248d23eb368",
+        "type": "github"
+      },
+      "original": {
+        "owner": "input-output-hk",
+        "ref": "hkm/gitlab-fix",
+        "repo": "flake-compat",
+        "type": "github"
+      }
+    },
+    "flake-compat_2": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1696426674,
+        "narHash": "sha256-kvjfFW7WAETZlt09AgDn1MrtKzP7t90Vf7vypd3OL1U=",
+        "owner": "edolstra",
+        "repo": "flake-compat",
+        "rev": "0f9255e01c2351cc7d116c072cb317785dd33b33",
+        "type": "github"
+      },
+      "original": {
+        "owner": "edolstra",
+        "repo": "flake-compat",
+        "type": "github"
+      }
+    },
+    "flake-parts": {
+      "inputs": {
+        "nixpkgs-lib": [
+          "nixpkgs"
+        ]
+      },
+      "locked": {
+        "lastModified": 1706830856,
+        "narHash": "sha256-a0NYyp+h9hlb7ddVz4LUn1vT/PLwqfrWYcHMvFB1xYg=",
+        "owner": "hercules-ci",
+        "repo": "flake-parts",
+        "rev": "b253292d9c0a5ead9bc98c4e9a26c6312e27d69f",
+        "type": "github"
+      },
+      "original": {
+        "owner": "hercules-ci",
+        "repo": "flake-parts",
+        "type": "github"
+      }
+    },
+    "flake-utils": {
+      "inputs": {
+        "systems": "systems"
+      },
+      "locked": {
+        "lastModified": 1701680307,
+        "narHash": "sha256-kAuep2h5ajznlPMD9rnQyffWG8EM/C73lejGofXvdM8=",
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "rev": "4022d587cbbfd70fe950c1e2083a02621806a725",
+        "type": "github"
+      },
+      "original": {
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "type": "github"
+      }
+    },
+    "ghc-8.6.5-iohk": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1600920045,
+        "narHash": "sha256-DO6kxJz248djebZLpSzTGD6s8WRpNI9BTwUeOf5RwY8=",
+        "owner": "input-output-hk",
+        "repo": "ghc",
+        "rev": "95713a6ecce4551240da7c96b6176f980af75cae",
+        "type": "github"
+      },
+      "original": {
+        "owner": "input-output-hk",
+        "ref": "release/8.6.5-iohk",
+        "repo": "ghc",
+        "type": "github"
+      }
+    },
+    "ghc98X": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1696643148,
+        "narHash": "sha256-E02DfgISH7EvvNAu0BHiPvl1E5FGMDi0pWdNZtIBC9I=",
+        "ref": "ghc-9.8",
+        "rev": "443e870d977b1ab6fc05f47a9a17bc49296adbd6",
+        "revCount": 61642,
+        "submodules": true,
+        "type": "git",
+        "url": "https://gitlab.haskell.org/ghc/ghc"
+      },
+      "original": {
+        "ref": "ghc-9.8",
+        "submodules": true,
+        "type": "git",
+        "url": "https://gitlab.haskell.org/ghc/ghc"
+      }
+    },
+    "ghc99": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1701580282,
+        "narHash": "sha256-drA01r3JrXnkKyzI+owMZGxX0JameMzjK0W5jJE/+V4=",
+        "ref": "refs/heads/master",
+        "rev": "f5eb0f2982e9cf27515e892c4bdf634bcfb28459",
+        "revCount": 62197,
+        "submodules": true,
+        "type": "git",
+        "url": "https://gitlab.haskell.org/ghc/ghc"
+      },
+      "original": {
+        "submodules": true,
+        "type": "git",
+        "url": "https://gitlab.haskell.org/ghc/ghc"
+      }
+    },
+    "gitignore": {
+      "inputs": {
+        "nixpkgs": [
+          "pre-commit-hooks-nix",
+          "nixpkgs"
+        ]
+      },
+      "locked": {
+        "lastModified": 1703887061,
+        "narHash": "sha256-gGPa9qWNc6eCXT/+Z5/zMkyYOuRZqeFZBDbopNZQkuY=",
+        "owner": "hercules-ci",
+        "repo": "gitignore.nix",
+        "rev": "43e1aa1308018f37118e34d3a9cb4f5e75dc11d5",
+        "type": "github"
+      },
+      "original": {
+        "owner": "hercules-ci",
+        "repo": "gitignore.nix",
+        "type": "github"
+      }
+    },
+    "hackage": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1708215850,
+        "narHash": "sha256-jaxFHCObJ3uON5RNbeon795RmBG/SUFcFM77TAxx3hg=",
+        "owner": "input-output-hk",
+        "repo": "hackage.nix",
+        "rev": "f5c26f4307f80cdc8ba7b762e0738c09d40a4685",
+        "type": "github"
+      },
+      "original": {
+        "owner": "input-output-hk",
+        "repo": "hackage.nix",
+        "type": "github"
+      }
+    },
+    "haskell-nix": {
+      "inputs": {
+        "HTTP": "HTTP",
+        "cabal-32": "cabal-32",
+        "cabal-34": "cabal-34",
+        "cabal-36": "cabal-36",
+        "cardano-shell": "cardano-shell",
+        "flake-compat": "flake-compat",
+        "ghc-8.6.5-iohk": "ghc-8.6.5-iohk",
+        "ghc98X": "ghc98X",
+        "ghc99": "ghc99",
+        "hackage": "hackage",
+        "hls-1.10": "hls-1.10",
+        "hls-2.0": "hls-2.0",
+        "hls-2.2": "hls-2.2",
+        "hls-2.3": "hls-2.3",
+        "hls-2.4": "hls-2.4",
+        "hls-2.5": "hls-2.5",
+        "hls-2.6": "hls-2.6",
+        "hpc-coveralls": "hpc-coveralls",
+        "hydra": "hydra",
+        "iserv-proxy": "iserv-proxy",
+        "nix-tools-static": "nix-tools-static",
+        "nixpkgs": [
+          "haskell-nix",
+          "nixpkgs-unstable"
+        ],
+        "nixpkgs-2003": "nixpkgs-2003",
+        "nixpkgs-2105": "nixpkgs-2105",
+        "nixpkgs-2111": "nixpkgs-2111",
+        "nixpkgs-2205": "nixpkgs-2205",
+        "nixpkgs-2211": "nixpkgs-2211",
+        "nixpkgs-2305": "nixpkgs-2305",
+        "nixpkgs-2311": "nixpkgs-2311",
+        "nixpkgs-unstable": "nixpkgs-unstable",
+        "old-ghc-nix": "old-ghc-nix",
+        "stackage": "stackage"
+      },
+      "locked": {
+        "lastModified": 1708217408,
+        "narHash": "sha256-Ri9PXSAvg25bBvcJOCTsi6pRhaT8Wp37037KMfXYeOU=",
+        "owner": "input-output-hk",
+        "repo": "haskell.nix",
+        "rev": "2fb6466a23873e590ef96066ee18a75998830c7b",
+        "type": "github"
+      },
+      "original": {
+        "owner": "input-output-hk",
+        "repo": "haskell.nix",
+        "type": "github"
+      }
+    },
+    "hci-effects": {
+      "inputs": {
+        "flake-parts": [
+          "flake-parts"
+        ],
+        "nixpkgs": [
+          "nixpkgs"
+        ]
+      },
+      "locked": {
+        "lastModified": 1704029560,
+        "narHash": "sha256-a4Iu7x1OP+uSYpqadOu8VCPY+MPF3+f6KIi+MAxlgyw=",
+        "owner": "hercules-ci",
+        "repo": "hercules-ci-effects",
+        "rev": "d5cbf433a6ae9cae05400189a8dbc6412a03ba16",
+        "type": "github"
+      },
+      "original": {
+        "owner": "hercules-ci",
+        "repo": "hercules-ci-effects",
+        "type": "github"
+      }
+    },
+    "hls-1.10": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1680000865,
+        "narHash": "sha256-rc7iiUAcrHxwRM/s0ErEsSPxOR3u8t7DvFeWlMycWgo=",
+        "owner": "haskell",
+        "repo": "haskell-language-server",
+        "rev": "b08691db779f7a35ff322b71e72a12f6e3376fd9",
+        "type": "github"
+      },
+      "original": {
+        "owner": "haskell",
+        "ref": "1.10.0.0",
+        "repo": "haskell-language-server",
+        "type": "github"
+      }
+    },
+    "hls-2.0": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1687698105,
+        "narHash": "sha256-OHXlgRzs/kuJH8q7Sxh507H+0Rb8b7VOiPAjcY9sM1k=",
+        "owner": "haskell",
+        "repo": "haskell-language-server",
+        "rev": "783905f211ac63edf982dd1889c671653327e441",
+        "type": "github"
+      },
+      "original": {
+        "owner": "haskell",
+        "ref": "2.0.0.1",
+        "repo": "haskell-language-server",
+        "type": "github"
+      }
+    },
+    "hls-2.2": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1693064058,
+        "narHash": "sha256-8DGIyz5GjuCFmohY6Fa79hHA/p1iIqubfJUTGQElbNk=",
+        "owner": "haskell",
+        "repo": "haskell-language-server",
+        "rev": "b30f4b6cf5822f3112c35d14a0cba51f3fe23b85",
+        "type": "github"
+      },
+      "original": {
+        "owner": "haskell",
+        "ref": "2.2.0.0",
+        "repo": "haskell-language-server",
+        "type": "github"
+      }
+    },
+    "hls-2.3": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1695910642,
+        "narHash": "sha256-tR58doOs3DncFehHwCLczJgntyG/zlsSd7DgDgMPOkI=",
+        "owner": "haskell",
+        "repo": "haskell-language-server",
+        "rev": "458ccdb55c9ea22cd5d13ec3051aaefb295321be",
+        "type": "github"
+      },
+      "original": {
+        "owner": "haskell",
+        "ref": "2.3.0.0",
+        "repo": "haskell-language-server",
+        "type": "github"
+      }
+    },
+    "hls-2.4": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1699862708,
+        "narHash": "sha256-YHXSkdz53zd0fYGIYOgLt6HrA0eaRJi9mXVqDgmvrjk=",
+        "owner": "haskell",
+        "repo": "haskell-language-server",
+        "rev": "54507ef7e85fa8e9d0eb9a669832a3287ffccd57",
+        "type": "github"
+      },
+      "original": {
+        "owner": "haskell",
+        "ref": "2.4.0.1",
+        "repo": "haskell-language-server",
+        "type": "github"
+      }
+    },
+    "hls-2.5": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1701080174,
+        "narHash": "sha256-fyiR9TaHGJIIR0UmcCb73Xv9TJq3ht2ioxQ2mT7kVdc=",
+        "owner": "haskell",
+        "repo": "haskell-language-server",
+        "rev": "27f8c3d3892e38edaef5bea3870161815c4d014c",
+        "type": "github"
+      },
+      "original": {
+        "owner": "haskell",
+        "ref": "2.5.0.0",
+        "repo": "haskell-language-server",
+        "type": "github"
+      }
+    },
+    "hls-2.6": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1705325287,
+        "narHash": "sha256-+P87oLdlPyMw8Mgoul7HMWdEvWP/fNlo8jyNtwME8E8=",
+        "owner": "haskell",
+        "repo": "haskell-language-server",
+        "rev": "6e0b342fa0327e628610f2711f8c3e4eaaa08b1e",
+        "type": "github"
+      },
+      "original": {
+        "owner": "haskell",
+        "ref": "2.6.0.0",
+        "repo": "haskell-language-server",
+        "type": "github"
+      }
+    },
+    "hpc-coveralls": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1607498076,
+        "narHash": "sha256-8uqsEtivphgZWYeUo5RDUhp6bO9j2vaaProQxHBltQk=",
+        "owner": "sevanspowell",
+        "repo": "hpc-coveralls",
+        "rev": "14df0f7d229f4cd2e79f8eabb1a740097fdfa430",
+        "type": "github"
+      },
+      "original": {
+        "owner": "sevanspowell",
+        "repo": "hpc-coveralls",
+        "type": "github"
+      }
+    },
+    "hydra": {
+      "inputs": {
+        "nix": "nix",
+        "nixpkgs": [
+          "haskell-nix",
+          "hydra",
+          "nix",
+          "nixpkgs"
+        ]
+      },
+      "locked": {
+        "lastModified": 1671755331,
+        "narHash": "sha256-hXsgJj0Cy0ZiCiYdW2OdBz5WmFyOMKuw4zyxKpgUKm4=",
+        "owner": "NixOS",
+        "repo": "hydra",
+        "rev": "f48f00ee6d5727ae3e488cbf9ce157460853fea8",
+        "type": "github"
+      },
+      "original": {
+        "id": "hydra",
+        "type": "indirect"
+      }
+    },
+    "iserv-proxy": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1691634696,
+        "narHash": "sha256-MZH2NznKC/gbgBu8NgIibtSUZeJ00HTLJ0PlWKCBHb0=",
+        "ref": "hkm/remote-iserv",
+        "rev": "43a979272d9addc29fbffc2e8542c5d96e993d73",
+        "revCount": 14,
+        "type": "git",
+        "url": "https://gitlab.haskell.org/hamishmack/iserv-proxy.git"
+      },
+      "original": {
+        "ref": "hkm/remote-iserv",
+        "type": "git",
+        "url": "https://gitlab.haskell.org/hamishmack/iserv-proxy.git"
+      }
+    },
+    "lowdown-src": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1633514407,
+        "narHash": "sha256-Dw32tiMjdK9t3ETl5fzGrutQTzh2rufgZV4A/BbxuD4=",
+        "owner": "kristapsdz",
+        "repo": "lowdown",
+        "rev": "d2c2b44ff6c27b936ec27358a2653caaef8f73b8",
+        "type": "github"
+      },
+      "original": {
+        "owner": "kristapsdz",
+        "repo": "lowdown",
+        "type": "github"
+      }
+    },
+    "nix": {
+      "inputs": {
+        "lowdown-src": "lowdown-src",
+        "nixpkgs": "nixpkgs",
+        "nixpkgs-regression": "nixpkgs-regression"
+      },
+      "locked": {
+        "lastModified": 1661606874,
+        "narHash": "sha256-9+rpYzI+SmxJn+EbYxjGv68Ucp22bdFUSy/4LkHkkDQ=",
+        "owner": "NixOS",
+        "repo": "nix",
+        "rev": "11e45768b34fdafdcf019ddbd337afa16127ff0f",
+        "type": "github"
+      },
+      "original": {
+        "owner": "NixOS",
+        "ref": "2.11.0",
+        "repo": "nix",
+        "type": "github"
+      }
+    },
+    "nix-tools-static": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1706266250,
+        "narHash": "sha256-9t+GRk3eO9muCtKdNAwBtNBZ5dH1xHcnS17WaQyftwA=",
+        "owner": "input-output-hk",
+        "repo": "haskell-nix-example",
+        "rev": "580cb6db546a7777dad3b9c0fa487a366c045c4e",
+        "type": "github"
+      },
+      "original": {
+        "owner": "input-output-hk",
+        "ref": "nix",
+        "repo": "haskell-nix-example",
+        "type": "github"
+      }
+    },
+    "nixpkgs": {
+      "locked": {
+        "lastModified": 1657693803,
+        "narHash": "sha256-G++2CJ9u0E7NNTAi9n5G8TdDmGJXcIjkJ3NF8cetQB8=",
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "rev": "365e1b3a859281cf11b94f87231adeabbdd878a2",
+        "type": "github"
+      },
+      "original": {
+        "owner": "NixOS",
+        "ref": "nixos-22.05-small",
+        "repo": "nixpkgs",
+        "type": "github"
+      }
+    },
+    "nixpkgs-2003": {
+      "locked": {
+        "lastModified": 1620055814,
+        "narHash": "sha256-8LEHoYSJiL901bTMVatq+rf8y7QtWuZhwwpKE2fyaRY=",
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "rev": "1db42b7fe3878f3f5f7a4f2dc210772fd080e205",
+        "type": "github"
+      },
+      "original": {
+        "owner": "NixOS",
+        "ref": "nixpkgs-20.03-darwin",
+        "repo": "nixpkgs",
+        "type": "github"
+      }
+    },
+    "nixpkgs-2105": {
+      "locked": {
+        "lastModified": 1659914493,
+        "narHash": "sha256-lkA5X3VNMKirvA+SUzvEhfA7XquWLci+CGi505YFAIs=",
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "rev": "022caabb5f2265ad4006c1fa5b1ebe69fb0c3faf",
+        "type": "github"
+      },
+      "original": {
+        "owner": "NixOS",
+        "ref": "nixpkgs-21.05-darwin",
+        "repo": "nixpkgs",
+        "type": "github"
+      }
+    },
+    "nixpkgs-2111": {
+      "locked": {
+        "lastModified": 1659446231,
+        "narHash": "sha256-hekabNdTdgR/iLsgce5TGWmfIDZ86qjPhxDg/8TlzhE=",
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "rev": "eabc38219184cc3e04a974fe31857d8e0eac098d",
+        "type": "github"
+      },
+      "original": {
+        "owner": "NixOS",
+        "ref": "nixpkgs-21.11-darwin",
+        "repo": "nixpkgs",
+        "type": "github"
+      }
+    },
+    "nixpkgs-2205": {
+      "locked": {
+        "lastModified": 1685573264,
+        "narHash": "sha256-Zffu01pONhs/pqH07cjlF10NnMDLok8ix5Uk4rhOnZQ=",
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "rev": "380be19fbd2d9079f677978361792cb25e8a3635",
+        "type": "github"
+      },
+      "original": {
+        "owner": "NixOS",
+        "ref": "nixpkgs-22.05-darwin",
+        "repo": "nixpkgs",
+        "type": "github"
+      }
+    },
+    "nixpkgs-2211": {
+      "locked": {
+        "lastModified": 1688392541,
+        "narHash": "sha256-lHrKvEkCPTUO+7tPfjIcb7Trk6k31rz18vkyqmkeJfY=",
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "rev": "ea4c80b39be4c09702b0cb3b42eab59e2ba4f24b",
+        "type": "github"
+      },
+      "original": {
+        "owner": "NixOS",
+        "ref": "nixpkgs-22.11-darwin",
+        "repo": "nixpkgs",
+        "type": "github"
+      }
+    },
+    "nixpkgs-2305": {
+      "locked": {
+        "lastModified": 1701362232,
+        "narHash": "sha256-GVdzxL0lhEadqs3hfRLuj+L1OJFGiL/L7gCcelgBlsw=",
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "rev": "d2332963662edffacfddfad59ff4f709dde80ffe",
+        "type": "github"
+      },
+      "original": {
+        "owner": "NixOS",
+        "ref": "nixpkgs-23.05-darwin",
+        "repo": "nixpkgs",
+        "type": "github"
+      }
+    },
+    "nixpkgs-2311": {
+      "locked": {
+        "lastModified": 1701386440,
+        "narHash": "sha256-xI0uQ9E7JbmEy/v8kR9ZQan6389rHug+zOtZeZFiDJk=",
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "rev": "293822e55ec1872f715a66d0eda9e592dc14419f",
+        "type": "github"
+      },
+      "original": {
+        "owner": "NixOS",
+        "ref": "nixpkgs-23.11-darwin",
+        "repo": "nixpkgs",
+        "type": "github"
+      }
+    },
+    "nixpkgs-regression": {
+      "locked": {
+        "lastModified": 1643052045,
+        "narHash": "sha256-uGJ0VXIhWKGXxkeNnq4TvV3CIOkUJ3PAoLZ3HMzNVMw=",
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "rev": "215d4d0fd80ca5163643b03a33fde804a29cc1e2",
+        "type": "github"
+      },
+      "original": {
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "rev": "215d4d0fd80ca5163643b03a33fde804a29cc1e2",
+        "type": "github"
+      }
+    },
+    "nixpkgs-unstable": {
+      "locked": {
+        "lastModified": 1694822471,
+        "narHash": "sha256-6fSDCj++lZVMZlyqOe9SIOL8tYSBz1bI8acwovRwoX8=",
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "rev": "47585496bcb13fb72e4a90daeea2f434e2501998",
+        "type": "github"
+      },
+      "original": {
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "rev": "47585496bcb13fb72e4a90daeea2f434e2501998",
+        "type": "github"
+      }
+    },
+    "nixpkgs_2": {
+      "locked": {
+        "lastModified": 1708276637,
+        "narHash": "sha256-+gICdImzDvxULC/+iqsmLsvwEv5LQuFglxn2fk/VyQM=",
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "rev": "ec841889d30aabad381acfa9529fe6045268bdbd",
+        "type": "github"
+      },
+      "original": {
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "type": "github"
+      }
+    },
+    "old-ghc-nix": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1631092763,
+        "narHash": "sha256-sIKgO+z7tj4lw3u6oBZxqIhDrzSkvpHtv0Kki+lh9Fg=",
+        "owner": "angerman",
+        "repo": "old-ghc-nix",
+        "rev": "af48a7a7353e418119b6dfe3cd1463a657f342b8",
+        "type": "github"
+      },
+      "original": {
+        "owner": "angerman",
+        "ref": "master",
+        "repo": "old-ghc-nix",
+        "type": "github"
+      }
+    },
+    "pre-commit-hooks-nix": {
+      "inputs": {
+        "flake-compat": "flake-compat_2",
+        "flake-utils": "flake-utils",
+        "gitignore": "gitignore",
+        "nixpkgs": [
+          "nixpkgs"
+        ],
+        "nixpkgs-stable": [
+          "nixpkgs"
+        ]
+      },
+      "locked": {
+        "lastModified": 1708018599,
+        "narHash": "sha256-M+Ng6+SePmA8g06CmUZWi1AjG2tFBX9WCXElBHEKnyM=",
+        "owner": "cachix",
+        "repo": "pre-commit-hooks.nix",
+        "rev": "5df5a70ad7575f6601d91f0efec95dd9bc619431",
+        "type": "github"
+      },
+      "original": {
+        "owner": "cachix",
+        "repo": "pre-commit-hooks.nix",
+        "type": "github"
+      }
+    },
+    "root": {
+      "inputs": {
+        "flake-parts": "flake-parts",
+        "haskell-nix": "haskell-nix",
+        "hci-effects": "hci-effects",
+        "nixpkgs": "nixpkgs_2",
+        "pre-commit-hooks-nix": "pre-commit-hooks-nix"
+      }
+    },
+    "stackage": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1708214991,
+        "narHash": "sha256-PCVnVqnBctf/qkpTBnBxwDHvfZaxXeq0bO98LxoKfhY=",
+        "owner": "input-output-hk",
+        "repo": "stackage.nix",
+        "rev": "0a279134ea4ae6269b93f76638c4ed9ccd9a496a",
+        "type": "github"
+      },
+      "original": {
+        "owner": "input-output-hk",
+        "repo": "stackage.nix",
+        "type": "github"
+      }
+    },
+    "systems": {
+      "locked": {
+        "lastModified": 1681028828,
+        "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
+        "owner": "nix-systems",
+        "repo": "default",
+        "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
+        "type": "github"
+      },
+      "original": {
+        "owner": "nix-systems",
+        "repo": "default",
+        "type": "github"
+      }
+    }
+  },
+  "root": "root",
+  "version": 7
+}
diff --git a/flake.nix b/flake.nix
new file mode 100644
index 000000000..dbd6c47f4
--- /dev/null
+++ b/flake.nix
@@ -0,0 +1,107 @@
+{
+  description = "uplc-benchmark";
+  inputs = {
+    nixpkgs.url = "github:NixOS/nixpkgs";
+    flake-parts = {
+      url = "github:hercules-ci/flake-parts";
+      inputs.nixpkgs-lib.follows = "nixpkgs";
+    };
+    pre-commit-hooks-nix = {
+      url = "github:cachix/pre-commit-hooks.nix";
+      inputs.nixpkgs.follows = "nixpkgs";
+      inputs.nixpkgs-stable.follows = "nixpkgs";
+    };
+    hci-effects = {
+      url = "github:hercules-ci/hercules-ci-effects";
+      inputs.nixpkgs.follows = "nixpkgs";
+      inputs.flake-parts.follows = "flake-parts";
+    };
+    haskell-nix = {
+      url = "github:input-output-hk/haskell.nix";
+    };
+  };
+  outputs = inputs:
+    let
+      flakeModules = {
+        haskell = ./nix/haskell;
+        plutarch = ./nix/plutarch;
+        utils = ./nix/utils;
+      };
+    in
+    inputs.flake-parts.lib.mkFlake { inherit inputs; } ({ self, ... }: {
+      imports = [
+        inputs.pre-commit-hooks-nix.flakeModule
+        inputs.hci-effects.flakeModule
+        ./.
+      ] ++ (builtins.attrValues flakeModules);
+
+      # `nix flake show --impure` hack
+      systems =
+        if builtins.hasAttr "currentSystem" builtins
+        then [ builtins.currentSystem ]
+        else inputs.nixpkgs.lib.systems.flakeExposed;
+
+      herculesCI.ciSystems = [ "x86_64-linux" ];
+
+      flake.flakeModules = flakeModules;
+
+      perSystem =
+        { config
+        , pkgs
+        , lib
+        , system
+        , self'
+        , ...
+        }: {
+          _module.args.pkgs = import self.inputs.nixpkgs {
+            inherit system;
+            config.allowBroken = true;
+          };
+
+          pre-commit.settings = {
+            hooks = {
+              deadnix.enable = true;
+              # TODO: Enable in separate PR, causes mass changes.
+              # fourmolu.enable = true;
+              nixpkgs-fmt.enable = true;
+              typos.enable = true;
+            };
+
+            tools = {
+              fourmolu = lib.mkForce (pkgs.callPackage ./nix/fourmolu {
+                mkHaskellPackage = config.libHaskell.mkPackage;
+              });
+            };
+
+            settings = {
+              latexindent.flags = config.libUtils.mkCli {
+                yaml = "\"defaultIndent:'  ', onlyOneBackUp: 1\"";
+                local = true;
+                silent = true;
+                overwriteIfDifferent = true;
+                logfile = "/dev/null";
+              };
+              deadnix.edit = true;
+            };
+
+            excludes = [
+              ".materialized"
+            ];
+          };
+
+          devShells = {
+            default = pkgs.mkShell {
+              shellHook = config.pre-commit.installationScript;
+
+              inputsFrom = [
+                self'.devShells.purus
+              ];
+
+              nativeBuildInputs = [
+                pkgs.fd
+              ];
+            };
+          };
+        };
+    });
+}
diff --git a/fourmolu.yaml b/fourmolu.yaml
new file mode 100644
index 000000000..ed2de01bd
--- /dev/null
+++ b/fourmolu.yaml
@@ -0,0 +1,8 @@
+indentation: 2
+comma-style: leading
+record-brace-space: true
+indent-wheres: true
+diff-friendly-import-export: true
+respectful: true
+haddock-style: multi-line
+newlines-between-decls: 1
diff --git a/nix/fourmolu/default.nix b/nix/fourmolu/default.nix
new file mode 100644
index 000000000..954cbfaa0
--- /dev/null
+++ b/nix/fourmolu/default.nix
@@ -0,0 +1,13 @@
+{ mkHaskellPackage
+, fetchFromGitHub
+}:
+
+(mkHaskellPackage {
+  name = "fourmolu";
+  src = fetchFromGitHub {
+    owner = "fourmolu";
+    repo = "fourmolu";
+    rev = "v0.13.1.0";
+    hash = "sha256-abUK9KdvVI7di84X/L3vHZM97pOsciyx503aDjUnoc4=";
+  };
+}).packages."fourmolu:exe:fourmolu"
diff --git a/nix/haskell/default.nix b/nix/haskell/default.nix
new file mode 100644
index 000000000..fc5dd7400
--- /dev/null
+++ b/nix/haskell/default.nix
@@ -0,0 +1,36 @@
+{ self
+, lib
+, flake-parts-lib
+, ...
+}:
+let
+  inherit (flake-parts-lib) mkPerSystemOption;
+  inherit (lib) types mkOption;
+in
+{
+  options = {
+    perSystem = mkPerSystemOption ({ config, system, pkgs, ... }: {
+      options = {
+        libHaskell = mkOption {
+          type = types.anything;
+          default = { };
+        };
+      };
+
+      config =
+        let
+          mkHaskellPackage = pkgs.callPackage ./lib.nix {
+            inherit lib system;
+            haskellNixNixpkgs = self.inputs.haskell-nix.inputs.nixpkgs;
+            haskellNixOverlay = self.inputs.haskell-nix.overlay;
+          };
+
+        in
+        {
+          libHaskell = {
+            mkPackage = mkHaskellPackage;
+          };
+        };
+    });
+  };
+}
diff --git a/nix/haskell/lib.nix b/nix/haskell/lib.nix
new file mode 100644
index 000000000..2dcbb208b
--- /dev/null
+++ b/nix/haskell/lib.nix
@@ -0,0 +1,91 @@
+{ lib
+, fetchFromGitHub
+  # e.g. "x86_64-linux"
+, system # : string
+, haskellNixNixpkgs # : nixpkgs
+, haskellNixOverlay # : overlay
+}:
+
+let
+  iohk-nix = fetchFromGitHub {
+    owner = "input-output-hk";
+    repo = "iohk-nix";
+    rev = "4848df60660e21fbb3fe157d996a8bac0a9cf2d6";
+    hash = "sha256-ediFkDOBP7yVquw1XtHiYfuXKoEnvKGjTIAk9mC6qxo=";
+  };
+
+  pkgs = import haskellNixNixpkgs {
+    inherit system;
+    overlays = [
+      (import "${iohk-nix}/overlays/crypto")
+      haskellNixOverlay
+    ];
+  };
+in
+
+{ name # : string
+, src # : path
+, ghcVersion ? "ghc928" # : string
+, haskellModules ? [ ]
+, externalDependencies ? [ ]
+, externalRepositories ? { }
+}:
+let
+  mkHackage = pkgs.callPackage ./mk-hackage.nix {
+    nix-tools = pkgs.haskell-nix.nix-tools-set {
+      compiler-nix-name = ghcVersion;
+    };
+  };
+
+  # This looks like a noop but without it haskell.nix throws a runtime
+  # error about `pkgs` attribute not being present which is nonsense
+  # https://input-output-hk.github.io/haskell.nix/reference/library.html?highlight=cabalProject#modules
+  fixedHaskellModules = map (m: args @ { ... }: m args) haskellModules;
+
+  flatExternalDependencies =
+    lib.lists.concatMap
+      (dep: [ (dep.passthru or { }).src or dep ] ++
+        (flatExternalDependencies (dep.passthru or { }).externalDependencies or [ ]));
+
+  flattenedExternalDependencies = flatExternalDependencies externalDependencies;
+
+  customHackages = mkHackage {
+    srcs = map toString flattenedExternalDependencies;
+    inherit name;
+  };
+
+  project = pkgs.haskell-nix.cabalProject' {
+    inherit src;
+    name = name;
+
+    compiler-nix-name = ghcVersion;
+    inputMap = lib.mapAttrs (_: toString) externalRepositories;
+
+    modules = customHackages.modules ++ fixedHaskellModules;
+    inherit (customHackages) extra-hackages extra-hackage-tarballs;
+
+    shell = {
+      withHoogle = true;
+      exactDeps = true;
+
+      tools = {
+        cabal = { };
+        haskell-language-server = { };
+      };
+    };
+  };
+
+  projectFlake = project.flake { };
+
+  augmentedPackages = builtins.mapAttrs
+    (_: package:
+      package // {
+        passthru = (package.passthru or { }) // {
+          inherit src externalDependencies;
+        };
+      })
+    (projectFlake.packages or { });
+in
+projectFlake // {
+  packages = augmentedPackages;
+}
diff --git a/nix/haskell/mk-hackage.nix b/nix/haskell/mk-hackage.nix
new file mode 100644
index 000000000..9bd43db89
--- /dev/null
+++ b/nix/haskell/mk-hackage.nix
@@ -0,0 +1,132 @@
+{ gzip
+, runCommand
+, lib
+, nix-tools
+}:
+let
+  mkPackageSpec = src:
+    with lib;
+    let
+      cabalFiles = concatLists (mapAttrsToList
+        (name: type: if type == "regular" && hasSuffix ".cabal" name then [ name ] else [ ])
+        (builtins.readDir src));
+
+      cabalPath =
+        if length cabalFiles == 1
+        then src + "/${builtins.head cabalFiles}"
+        else builtins.abort "Could not find unique file with .cabal suffix in source: ${src}";
+      cabalFile = builtins.readFile cabalPath;
+      parse = field:
+        let
+          lines = filter (s: builtins.match "^${field} *:.*$" (toLower s) != null) (splitString "\n" cabalFile);
+          line =
+            if lines != [ ]
+            then head lines
+            else builtins.abort "Could not find line with prefix ''${field}:' in ${cabalPath}";
+        in
+        replaceStrings [ " " ] [ "" ] (head (tail (splitString ":" line)));
+      pname = parse "name";
+      version = parse "version";
+    in
+    { inherit src pname version; };
+
+  mkHackageDir = { pname, version, src }:
+    runCommand "${pname}-${version}-hackage"
+      { } ''
+      set -e
+      mkdir -p $out/${pname}/${version}
+      md5=11111111111111111111111111111111
+      sha256=1111111111111111111111111111111111111111111111111111111111111111
+      length=1
+      cat <<EOF > $out/"${pname}"/"${version}"/package.json
+      {
+        "signatures" : [],
+        "signed" : {
+            "_type" : "Targets",
+            "expires" : null,
+            "targets" : {
+              "<repo>/package/${pname}-${version}.tar.gz" : {
+                  "hashes" : {
+                    "md5" : "$md5",
+                    "sha256" : "$sha256"
+                  },
+                  "length" : $length
+              }
+            },
+            "version" : 0
+        }
+      }
+      EOF
+      cp ${src}/*.cabal $out/"${pname}"/"${version}"/
+    '';
+
+  mkHackageTarballFromDirs = name: hackageDirs:
+    runCommand "${name}-hackage-index.tar.gz" { } ''
+      mkdir hackage
+      ${builtins.concatStringsSep "" (map (dir: ''
+        echo ${dir}
+        ln -sf ${dir}/* hackage/
+      '') hackageDirs)}
+      cd hackage
+      tar --sort=name --owner=root:0 --group=root:0 --mtime='UTC 2009-01-01' -hczvf $out */*/*
+    '';
+
+  mkHackageTarball = name: pkg-specs:
+    mkHackageTarballFromDirs name (map mkHackageDir pkg-specs);
+
+  mkHackageNix = name: hackageTarball:
+    runCommand "${name}-hackage-nix"
+      {
+        nativeBuildInputs = [
+          gzip
+          nix-tools
+        ];
+      } ''
+      set -e
+      export LC_CTYPE=C.UTF-8
+      export LC_ALL=C.UTF-8
+      export LANG=C.UTF-8
+      cp ${hackageTarball} 01-index.tar.gz
+      gunzip 01-index.tar.gz
+      hackage-to-nix $out 01-index.tar "https://mkHackageNix/"
+    '';
+
+  mkModule = extraHackagePackages: {
+    packages = lib.listToAttrs (map
+      (spec: {
+        name = spec.pname;
+        value = {
+          inherit (spec) src;
+        };
+      })
+      extraHackagePackages);
+  };
+
+  mkHackageFromSpec = name: extraHackagePackages: rec {
+    extra-hackage-tarball = mkHackageTarball name extraHackagePackages;
+    extra-hackage = mkHackageNix name extra-hackage-tarball;
+    module = mkModule extraHackagePackages;
+  };
+
+in
+{ srcs # : [string]
+, name # : string
+}:
+
+if builtins.length srcs == 0
+then {
+  modules = [ ];
+  extra-hackage-tarballs = { };
+  extra-hackages = [ ];
+}
+else
+  let
+    hackage = mkHackageFromSpec name (map mkPackageSpec srcs);
+  in
+  {
+    modules = [ hackage.module ];
+    extra-hackage-tarballs = {
+      "${name}-hackage-tarball" = hackage.extra-hackage-tarball;
+    };
+    extra-hackages = [ (import hackage.extra-hackage) ];
+  }
diff --git a/nix/plutarch/default.nix b/nix/plutarch/default.nix
new file mode 100644
index 000000000..afb64fb43
--- /dev/null
+++ b/nix/plutarch/default.nix
@@ -0,0 +1,28 @@
+{ lib
+, flake-parts-lib
+, ...
+}:
+let
+  inherit (flake-parts-lib) mkPerSystemOption;
+in
+{
+  options = {
+    perSystem = mkPerSystemOption ({ config, pkgs, ... }: {
+      options = {
+        libPlutarch = lib.mkOption {
+          type = lib.types.anything;
+          default = { };
+        };
+      };
+
+      config = {
+        libPlutarch = {
+          mkPackage = pkgs.callPackage ./lib.nix {
+            mkHaskellPackage = config.libHaskell.mkPackage;
+            inherit (config.libUtils) applyPatches;
+          };
+        };
+      };
+    });
+  };
+}
diff --git a/nix/plutarch/lib.nix b/nix/plutarch/lib.nix
new file mode 100644
index 000000000..3ec84f23c
--- /dev/null
+++ b/nix/plutarch/lib.nix
@@ -0,0 +1,44 @@
+{ fetchFromGitHub
+, mkHaskellPackage
+, applyPatches
+, fetchpatch
+}:
+
+let
+  plutarchPackage = applyPatches {
+    name = "plutarch-patched";
+    src = fetchFromGitHub {
+      owner = "Plutonomicon";
+      repo = "plutarch-plutus";
+      rev = "288d9140468ae98abe1c9a4c0bb1c19a82eb7cd6"; # branch: master
+      hash = "sha256-aeaZMW5Y3r5GdSyrfrrKOuGahcL5MVkDUNggunbmtv0=";
+    };
+
+    patches = [
+      # https://github.com/Plutonomicon/plutarch-plutus/pull/650
+      (fetchpatch {
+        url = "https://github.com/Plutonomicon/plutarch-plutus/commit/7256acb8db3230d2453460f0358582283c69da5f.patch";
+        hash = "sha256-y/F1ZwLDC5E4vh8F+JTQStHJsQ1ZEe9LIZcwSGMSUek=";
+      })
+    ];
+  };
+
+  cardanoPackages = fetchFromGitHub {
+    owner = "input-output-hk";
+    repo = "cardano-haskell-packages";
+    rev = "3df392af2a61d61bdac1afd9c3674f27d6aa8efc"; # branch: repo
+    hash = "sha256-vvm56KzA6jEkG3mvwh1LEdK4H4FKxeoOJNz90H8l8dQ=";
+  };
+in
+
+args:
+mkHaskellPackage (args // {
+  externalRepositories = {
+    "https://input-output-hk.github.io/cardano-haskell-packages" = cardanoPackages;
+  } // (args.externalRepositories or { });
+
+  externalDependencies = [
+    "${plutarchPackage}"
+    "${plutarchPackage}/plutarch-extra"
+  ] ++ (args.externalDependencies or [ ]);
+})
diff --git a/nix/utils/default.nix b/nix/utils/default.nix
new file mode 100644
index 000000000..851ab543a
--- /dev/null
+++ b/nix/utils/default.nix
@@ -0,0 +1,22 @@
+{ lib
+, flake-parts-lib
+, ...
+}:
+let
+  inherit (flake-parts-lib) mkPerSystemOption;
+  inherit (lib) types mkOption;
+in
+{
+  options = {
+    perSystem = mkPerSystemOption ({ config, pkgs, ... }: {
+      options = {
+        libUtils = mkOption {
+          type = types.anything;
+          default = { };
+        };
+      };
+
+      config.libUtils = pkgs.callPackage ./lib.nix { };
+    });
+  };
+}
diff --git a/nix/utils/lib.nix b/nix/utils/lib.nix
new file mode 100644
index 000000000..c5b2f51b4
--- /dev/null
+++ b/nix/utils/lib.nix
@@ -0,0 +1,39 @@
+{ stdenv
+, lib
+}:
+
+let
+  applyPatches = args @ { patches, ... }: stdenv.mkDerivation ({
+    inherit patches;
+
+    dontConfigure = true;
+    dontBuild = true;
+
+    installPhase = ''
+      mkdir -p "$out"
+      cp -r * "$out"
+    '';
+
+    dontFixup = true;
+  } // args);
+
+  mkFlag = flag: value: "--${flag}=${value}";
+
+  mkFlags = flag: values: builtins.concatStringsSep " " (map (mkFlag flag) values);
+
+  mkCli = args:
+    builtins.concatStringsSep " "
+      (lib.attrsets.mapAttrsToList
+        (flag: value:
+          if builtins.isList value
+          then mkFlags flag value
+          else if builtins.isBool value then (if value then "--${flag}" else "")
+          else mkFlag flag "${value}"
+        )
+        args);
+
+  withNameAttr = f: name: args: f (args // { inherit name; });
+in
+{
+  inherit applyPatches mkCli withNameAttr;
+}
diff --git a/purescript.cabal b/purescript.cabal
index 6fed7b2a0..e51452b83 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -122,7 +122,7 @@ common defaults
     TypeFamilies
     ViewPatterns
   build-tool-depends:
-    happy:happy ==1.20.0
+    happy:happy ^>= 1.20.0
   build-depends:
     -- NOTE: Please do not edit these version constraints manually. They are
     -- deliberately made narrow because changing the dependency versions in
diff --git a/shell.nix b/shell.nix
deleted file mode 100644
index 7e50545de..000000000
--- a/shell.nix
+++ /dev/null
@@ -1,21 +0,0 @@
-with (import <nixpkgs> {});
-let haskell928 = haskell.packages.ghc928;
-    ghc928 = haskell.compiler.ghc928;
-in mkShell {
-  nativeBuildInputs = [
-    pkg-config
-    haskell928.haskell-language-server
-    ghc928
-    cabal-install
-  ];
-
-  buildInputs = [
-    zlib
-    libsodium
-    secp256k1
-  ];
-
-  shellHook = ''
-    export LC_ALL=C.utf8
-  '';
-}

From 991c7588101714c772b3abecf873202cfbc78f24 Mon Sep 17 00:00:00 2001
From: t4ccer <t4ccer@gmail.com>
Date: Sun, 18 Feb 2024 14:12:04 -0700
Subject: [PATCH 16/20] Trigger CI


From 4214ae69af340dba297684f868c31908440c849d Mon Sep 17 00:00:00 2001
From: t4ccer <t4ccer@gmail.com>
Date: Sun, 18 Feb 2024 14:35:20 -0700
Subject: [PATCH 17/20] Remove unused configs

---
 flake.nix | 19 -------------------
 1 file changed, 19 deletions(-)

diff --git a/flake.nix b/flake.nix
index dbd6c47f4..fb3d0f68c 100644
--- a/flake.nix
+++ b/flake.nix
@@ -72,21 +72,6 @@
                 mkHaskellPackage = config.libHaskell.mkPackage;
               });
             };
-
-            settings = {
-              latexindent.flags = config.libUtils.mkCli {
-                yaml = "\"defaultIndent:'  ', onlyOneBackUp: 1\"";
-                local = true;
-                silent = true;
-                overwriteIfDifferent = true;
-                logfile = "/dev/null";
-              };
-              deadnix.edit = true;
-            };
-
-            excludes = [
-              ".materialized"
-            ];
           };
 
           devShells = {
@@ -96,10 +81,6 @@
               inputsFrom = [
                 self'.devShells.purus
               ];
-
-              nativeBuildInputs = [
-                pkgs.fd
-              ];
             };
           };
         };

From 63494726daf887189f3703b5ec0d6f9bcf61565f Mon Sep 17 00:00:00 2001
From: t4ccer <t4ccer@gmail.com>
Date: Sun, 18 Feb 2024 14:49:26 -0700
Subject: [PATCH 18/20] Disable typos check

Too many of them to fix now
---
 .envrc    | 2 +-
 flake.nix | 1 -
 2 files changed, 1 insertion(+), 2 deletions(-)

diff --git a/.envrc b/.envrc
index 1d953f4bd..3550a30f2 100644
--- a/.envrc
+++ b/.envrc
@@ -1 +1 @@
-use nix
+use flake
diff --git a/flake.nix b/flake.nix
index fb3d0f68c..9552252a4 100644
--- a/flake.nix
+++ b/flake.nix
@@ -64,7 +64,6 @@
               # TODO: Enable in separate PR, causes mass changes.
               # fourmolu.enable = true;
               nixpkgs-fmt.enable = true;
-              typos.enable = true;
             };
 
             tools = {

From ed35645d28d5d83ac462c5c2a1158971b220bbcd Mon Sep 17 00:00:00 2001
From: t4ccer <t4ccer@gmail.com>
Date: Thu, 22 Feb 2024 18:08:06 -0700
Subject: [PATCH 19/20] Remove Nix Plutarch wrapper

---
 default.nix                | 15 +++++++++++--
 flake.nix                  |  1 -
 nix/haskell/mk-hackage.nix |  2 ++
 nix/plutarch/default.nix   | 28 ------------------------
 nix/plutarch/lib.nix       | 44 --------------------------------------
 5 files changed, 15 insertions(+), 75 deletions(-)
 delete mode 100644 nix/plutarch/default.nix
 delete mode 100644 nix/plutarch/lib.nix

diff --git a/default.nix b/default.nix
index 83f611fb1..4ff7fc519 100644
--- a/default.nix
+++ b/default.nix
@@ -1,9 +1,20 @@
 {
-  perSystem = { self', config, ... }:
+  perSystem = { self', pkgs, config, ... }:
     let
-      purus = config.libPlutarch.mkPackage {
+      cardanoPackages = pkgs.fetchFromGitHub {
+        owner = "input-output-hk";
+        repo = "cardano-haskell-packages";
+        rev = "3df392af2a61d61bdac1afd9c3674f27d6aa8efc"; # branch: repo
+        hash = "sha256-vvm56KzA6jEkG3mvwh1LEdK4H4FKxeoOJNz90H8l8dQ=";
+      };
+
+      purus = config.libHaskell.mkPackage {
         name = "purus";
         src = ./.;
+
+        externalRepositories = {
+          "https://input-output-hk.github.io/cardano-haskell-packages" = cardanoPackages;
+        };
       };
     in
     {
diff --git a/flake.nix b/flake.nix
index 9552252a4..555cfe2e7 100644
--- a/flake.nix
+++ b/flake.nix
@@ -24,7 +24,6 @@
     let
       flakeModules = {
         haskell = ./nix/haskell;
-        plutarch = ./nix/plutarch;
         utils = ./nix/utils;
       };
     in
diff --git a/nix/haskell/mk-hackage.nix b/nix/haskell/mk-hackage.nix
index 9bd43db89..fc89862f6 100644
--- a/nix/haskell/mk-hackage.nix
+++ b/nix/haskell/mk-hackage.nix
@@ -1,3 +1,5 @@
+# Adapted from https://github.com/mlabs-haskell/mlabs-tooling.nix/blob/cd0cf0d29f17980befe384248c16937589912c69/mk-hackage.nix
+
 { gzip
 , runCommand
 , lib
diff --git a/nix/plutarch/default.nix b/nix/plutarch/default.nix
deleted file mode 100644
index afb64fb43..000000000
--- a/nix/plutarch/default.nix
+++ /dev/null
@@ -1,28 +0,0 @@
-{ lib
-, flake-parts-lib
-, ...
-}:
-let
-  inherit (flake-parts-lib) mkPerSystemOption;
-in
-{
-  options = {
-    perSystem = mkPerSystemOption ({ config, pkgs, ... }: {
-      options = {
-        libPlutarch = lib.mkOption {
-          type = lib.types.anything;
-          default = { };
-        };
-      };
-
-      config = {
-        libPlutarch = {
-          mkPackage = pkgs.callPackage ./lib.nix {
-            mkHaskellPackage = config.libHaskell.mkPackage;
-            inherit (config.libUtils) applyPatches;
-          };
-        };
-      };
-    });
-  };
-}
diff --git a/nix/plutarch/lib.nix b/nix/plutarch/lib.nix
deleted file mode 100644
index 3ec84f23c..000000000
--- a/nix/plutarch/lib.nix
+++ /dev/null
@@ -1,44 +0,0 @@
-{ fetchFromGitHub
-, mkHaskellPackage
-, applyPatches
-, fetchpatch
-}:
-
-let
-  plutarchPackage = applyPatches {
-    name = "plutarch-patched";
-    src = fetchFromGitHub {
-      owner = "Plutonomicon";
-      repo = "plutarch-plutus";
-      rev = "288d9140468ae98abe1c9a4c0bb1c19a82eb7cd6"; # branch: master
-      hash = "sha256-aeaZMW5Y3r5GdSyrfrrKOuGahcL5MVkDUNggunbmtv0=";
-    };
-
-    patches = [
-      # https://github.com/Plutonomicon/plutarch-plutus/pull/650
-      (fetchpatch {
-        url = "https://github.com/Plutonomicon/plutarch-plutus/commit/7256acb8db3230d2453460f0358582283c69da5f.patch";
-        hash = "sha256-y/F1ZwLDC5E4vh8F+JTQStHJsQ1ZEe9LIZcwSGMSUek=";
-      })
-    ];
-  };
-
-  cardanoPackages = fetchFromGitHub {
-    owner = "input-output-hk";
-    repo = "cardano-haskell-packages";
-    rev = "3df392af2a61d61bdac1afd9c3674f27d6aa8efc"; # branch: repo
-    hash = "sha256-vvm56KzA6jEkG3mvwh1LEdK4H4FKxeoOJNz90H8l8dQ=";
-  };
-in
-
-args:
-mkHaskellPackage (args // {
-  externalRepositories = {
-    "https://input-output-hk.github.io/cardano-haskell-packages" = cardanoPackages;
-  } // (args.externalRepositories or { });
-
-  externalDependencies = [
-    "${plutarchPackage}"
-    "${plutarchPackage}/plutarch-extra"
-  ] ++ (args.externalDependencies or [ ]);
-})

From a9f7a144d890e1f892be6917b449e69dd08175c4 Mon Sep 17 00:00:00 2001
From: gnumonik <gnumonik@protonmail.com>
Date: Tue, 5 Mar 2024 19:34:15 -0500
Subject: [PATCH 20/20] Removed some dead comments, testing pre-commit hooks

---
 src/Language/PureScript/CoreFn/Desugar.hs     | 25 ++++++++-----------
 .../PureScript/CoreFn/Desugar/Utils.hs        |  3 ---
 2 files changed, 11 insertions(+), 17 deletions(-)

diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs
index 3e357c13c..244d97ac6 100644
--- a/src/Language/PureScript/CoreFn/Desugar.hs
+++ b/src/Language/PureScript/CoreFn/Desugar.hs
@@ -224,7 +224,7 @@ exprToCoreFn mn ss (Just arrT@(ArrayT ty)) astlit@(A.Literal _ (ArrayLiteral ts)
   arr <- ArrayLiteral <$> traverse (exprToCoreFn mn ss (Just ty)) ts
   pure $ Literal (ss,[],Nothing) arrT  arr
 -- An empty list could either have a TyVar or a quantified type (or a concrete type, which is handled by the previous case)
-exprToCoreFn mn ss (Just tyVar) astlit@(A.Literal _ (ArrayLiteral [])) = wrapTrace ("exprToCoreFn ARRAYLIT EMPTY " <> renderValue 100 astlit) $ do
+exprToCoreFn _ ss (Just tyVar) astlit@(A.Literal _ (ArrayLiteral [])) = wrapTrace ("exprToCoreFn ARRAYLIT EMPTY " <> renderValue 100 astlit) $ do
   pure $ Literal (ss,[],Nothing) tyVar (ArrayLiteral [])
 exprToCoreFn _ _ Nothing astlit@(A.Literal _ (ArrayLiteral _)) =
   internalError $ "Error while desugaring Array Literal. No type provided for literal:\n" <> renderValue 100 astlit
@@ -376,8 +376,7 @@ exprToCoreFn _ _ _ (A.Var ss ident) = wrapTrace ("exprToCoreFn VAR " <> show ide
     Nothing -> lookupDictType ident >>= \case
       Just ty -> pure $  Var (ss, [], getValueMeta env ident) (purusTy ty) ident
       Nothing -> do
-      -- pEnv <- printEnv
-        traceM $ "No known type for identifier " <> show ident -- <> "\n    in:\n" <> LT.unpack (pShow $ names env)
+        traceM $ "No known type for identifier " <> show ident
         error "boom"
 -- If-Then-Else Turns into a case expression
 exprToCoreFn mn ss (Just resT) (A.IfThenElse cond th el) = wrapTrace "exprToCoreFn IFTE" $ do
@@ -539,11 +538,11 @@ inferBinder'
   -> A.Binder
   -> m (M.Map Ident (SourceSpan, SourceType))
 inferBinder' _ A.NullBinder = return M.empty
-inferBinder' val (A.LiteralBinder _ (StringLiteral _)) = wrapTrace "inferBinder' STRLIT" $ return M.empty
-inferBinder' val (A.LiteralBinder _ (CharLiteral _)) = wrapTrace "inferBinder' CHARLIT" $  return M.empty
-inferBinder' val (A.LiteralBinder _ (NumericLiteral (Left _))) = wrapTrace "inferBinder' LITINT" $ return M.empty
-inferBinder' val (A.LiteralBinder _ (NumericLiteral (Right _))) = wrapTrace "inferBinder' NUMBERLIT" $ return M.empty
-inferBinder' val (A.LiteralBinder _ (BooleanLiteral _)) = wrapTrace "inferBinder' BOOLLIT" $ return M.empty
+inferBinder' _ (A.LiteralBinder _ (StringLiteral _)) = wrapTrace "inferBinder' STRLIT" $ return M.empty
+inferBinder' _ (A.LiteralBinder _ (CharLiteral _)) = wrapTrace "inferBinder' CHARLIT" $  return M.empty
+inferBinder' _ (A.LiteralBinder _ (NumericLiteral (Left _))) = wrapTrace "inferBinder' LITINT" $ return M.empty
+inferBinder' _ (A.LiteralBinder _ (NumericLiteral (Right _))) = wrapTrace "inferBinder' NUMBERLIT" $ return M.empty
+inferBinder' _ (A.LiteralBinder _ (BooleanLiteral _)) = wrapTrace "inferBinder' BOOLLIT" $ return M.empty
 inferBinder' val (A.VarBinder ss name) = wrapTrace ("inferBinder' VAR " <> T.unpack (runIdent name))  $ return $ M.singleton name (ss, val)
 inferBinder' val (A.ConstructorBinder ss ctor binders) = wrapTrace ("inferBinder' CTOR: " <> show ctor) $ do
   traceM $ "InferBinder VAL:\n" <>  ppType 100 val
@@ -559,7 +558,7 @@ inferBinder' val (A.ConstructorBinder ss ctor binders) = wrapTrace ("inferBinder
       M.unions <$> zipWithM inferBinder' (reverse args) binders
     _ -> throwError . errorMessage' ss . UnknownName . fmap DctorName $ ctor
   where
-  peelArgs :: Type a -> ([Type a], Type a) -- NOTE: Not sure if we want to "peel constraints" too. Need to think of an example to test.
+  peelArgs :: Type a -> ([Type a], Type a)
   peelArgs = go []
     where
     go args (TypeApp _ (TypeApp _ fn arg) ret) | eqType fn tyFunction = go (arg : args) ret
@@ -578,7 +577,7 @@ inferBinder' val (A.LiteralBinder _ (ObjectLiteral props)) = wrapTrace "inferBin
           -- The type-level labels are authoritative
           diff = S.difference typeKeys exprKeys
       if S.null diff
-        then deduceRowProperties (M.fromList rowItems) props' -- M.unions <$> zipWithM inferBinder' (snd <$> rowItems) (snd <$> props')
+        then deduceRowProperties (M.fromList rowItems) props'
         else error $ "Error. Object literal in a pattern match is missing fields: " <> show diff
   where
   deduceRowProperties :: M.Map PSString SourceType -> [(PSString,A.Binder)] -> m (M.Map Ident (SourceSpan,SourceType))
@@ -598,10 +597,8 @@ inferBinder' val (A.NamedBinder ss name binder) = wrapTrace ("inferBinder' NAMED
     return $ M.insert name (ss, val) m
 inferBinder' val (A.PositionedBinder pos _ binder) = wrapTrace "inferBinder' POSITIONEDBINDER" $
   warnAndRethrowWithPositionTC pos $ inferBinder' val binder
-inferBinder' val (A.TypedBinder ty binder) = wrapTrace "inferBinder' TYPEDBINDER" $ do
-  (elabTy, kind) <- kindOf ty
-  -- checkTypeKind ty kind -- NOTE: Check whether we really need to do anything except inferBinder' the inner
-  -- unifyTypes val elabTy
+inferBinder' _ (A.TypedBinder ty binder) = wrapTrace "inferBinder' TYPEDBINDER" $ do
+  (elabTy, _) <- kindOf ty
   inferBinder' elabTy binder
 inferBinder' _ A.OpBinder{} =
   internalError "OpBinder should have been desugared before inferBinder'"
diff --git a/src/Language/PureScript/CoreFn/Desugar/Utils.hs b/src/Language/PureScript/CoreFn/Desugar/Utils.hs
index bf0d62cec..0d630612b 100644
--- a/src/Language/PureScript/CoreFn/Desugar/Utils.hs
+++ b/src/Language/PureScript/CoreFn/Desugar/Utils.hs
@@ -260,7 +260,6 @@ unwrapRecord = \case
   go :: RowListItem a -> (PSString, Type a)
   go RowListItem{..} = (runLabel rowListLabel, rowListType)
 
-
 traceNameTypes :: M m => m ()
 traceNameTypes  = do
   nametypes <- getEnv >>= pure . debugNames
@@ -321,7 +320,6 @@ desugarConstraintsInDecl = \case
     in A.DataDeclaration ann declTy tName args (fixCtor <$> ctorDecs)
   other -> other
 
-
 -- Gives much more readable output (with colors for brackets/parens!) than plain old `show`
 pTrace :: (Monad m, Show a) => a -> m ()
 pTrace = traceM . LT.unpack . pShow
@@ -339,7 +337,6 @@ wrapTrace msg act = do
    startMsg = pad $ "BEGIN " <> msg
    endMsg = pad $ "END " <> msg
 
-
 {-
   This is used to solve a problem that arises with re-exported instances.