Rework the way foreign imports are linked, add treefmt, reformat sources

Author: Unisay

Setup.hs

@@ -2,5 +2,5 @@ module Main (main) where
 
 import Distribution.Simple
 
-main :: IO ()
+main ∷ IO ()
 main = defaultMain

exe/Main.hs

@@ -16,30 +16,30 @@ import Path.IO qualified as Path
 import Prettyprinter (defaultLayoutOptions, layoutPretty)
 import Prettyprinter.Render.Text (renderIO)
 
-main :: IO ()
+main ∷ IO ()
 main = Utf8.withUtf8 do
   Cli.Args
     { foreignPath
     , luaOutputFile
     , psOutputPath
     , appOrModule
-    } <-
+    } ←
     Cli.parseArguments
 
-  foreignDir :: Tagged "foreign" (Path Abs Dir) <-
+  foreignDir ∷ Tagged "foreign" (Path Abs Dir) ←
     Tagged
       <$> case unTagged foreignPath of
-        Path.Abs a -> pure a
-        Path.Rel r -> Path.makeAbsolute r
+        Path.Abs a → pure a
+        Path.Rel r → Path.makeAbsolute r
 
-  luaOutput <-
+  luaOutput ←
     case unTagged luaOutputFile of
-      Path.Abs a -> pure a
-      Path.Rel r -> Path.makeAbsolute r
+      Path.Abs a → pure a
+      Path.Rel r → Path.makeAbsolute r
 
   putTextLn "Compiling modules:"
 
-  luaChunk <-
+  luaChunk ←
     Backend.compileModules psOutputPath foreignDir appOrModule
       & handleModuleNotFoundError
       & handleModuleDecodingError
@@ -48,7 +48,7 @@ main = Utf8.withUtf8 do
       & Oops.runOops
 
   let outputFile = toFilePath luaOutput
-  withFile outputFile WriteMode \h ->
+  withFile outputFile WriteMode \h →
     renderIO h . layoutPretty defaultLayoutOptions $
       Printer.printLuaChunk luaChunk
 
@@ -58,41 +58,41 @@ main = Utf8.withUtf8 do
 -- Error handlers --------------------------------------------------------------
 
 handleModuleNotFoundError
-  :: ExceptT (Oops.Variant (CoreFn.ModuleNotFound ': e)) IO a
-  -> ExceptT (Oops.Variant e) IO a
-handleModuleNotFoundError = Oops.catch \(CoreFn.ModuleNotFound p) ->
+  ∷ ExceptT (Oops.Variant (CoreFn.ModuleNotFound ': e)) IO a
+  → ExceptT (Oops.Variant e) IO a
+handleModuleNotFoundError = Oops.catch \(CoreFn.ModuleNotFound p) →
   die . toString . unlines $
     [ "Can't find CoreFn module file: " <> toText (toFilePath p)
     , "Please make sure you did run purs with the `-g corefn` arg."
     ]
 
 handleModuleDecodingError
-  :: ExceptT (Oops.Variant (CoreFn.ModuleDecodingErr ': e)) IO a
-  -> ExceptT (Oops.Variant e) IO a
-handleModuleDecodingError = Oops.catch \(CoreFn.ModuleDecodingErr p e) ->
+  ∷ ExceptT (Oops.Variant (CoreFn.ModuleDecodingErr ': e)) IO a
+  → ExceptT (Oops.Variant e) IO a
+handleModuleDecodingError = Oops.catch \(CoreFn.ModuleDecodingErr p e) →
   die . toString . unlines $
     [ "Can't parse CoreFn module file: " <> toText (toFilePath p)
     , toText e
     ]
 
 handleCoreFnError
-  :: ExceptT (Oops.Variant (IR.CoreFnError ': e)) IO a
-  -> ExceptT (Oops.Variant e) IO a
+  ∷ ExceptT (Oops.Variant (IR.CoreFnError ': e)) IO a
+  → ExceptT (Oops.Variant e) IO a
 handleCoreFnError =
-  Oops.catch \(e :: IR.CoreFnError) ->
+  Oops.catch \(e ∷ IR.CoreFnError) →
     die $ "CoreFn contains an unexpected value: " <> show e
 
 handleLuaError
-  :: ExceptT (Oops.Variant (Lua.Error ': e)) IO a
-  -> ExceptT (Oops.Variant e) IO a
+  ∷ ExceptT (Oops.Variant (Lua.Error ': e)) IO a
+  → ExceptT (Oops.Variant e) IO a
 handleLuaError =
   Oops.catch \case
-    Lua.UnexpectedRefBound modname expr ->
+    Lua.UnexpectedRefBound modname expr →
       die . toString . unwords $
         [ "Unexpected bound reference:"
         , show expr
         , "in module"
         , runModuleName modname
         ]
-    Lua.LinkerErrorForeign e ->
+    Lua.LinkerErrorForeign e →
       die $ "Linker error:\n" <> show e

flake.nix

@@ -25,18 +25,20 @@
               src = ./.;
               evalSystem = "x86_64-linux";
               # index-state = "2023-06-28T00:00:00Z";
-              modules = let prof = false;
-              in [{
-                doHaddock = false;
-                doHoogle = false;
-                enableProfiling = prof;
-                enableLibraryProfiling = prof;
-              }];
+              modules =
+                let prof = false;
+                in [{
+                  doHaddock = false;
+                  doHoogle = false;
+                  enableProfiling = prof;
+                  enableLibraryProfiling = prof;
+                }];
             };
           })
         ];
         flake = pkgs.hixProject.flake { };
-      in flake // {
+      in
+      flake // {
         legacyPackages = pkgs;
         packages.default = flake.packages."pslua:exe:pslua";
       });

fourmolu.yaml

@@ -1,11 +1,12 @@
-indentation: 2
 comma-style: leading
-function-arrows: leading
-record-brace-space: true
-indent-wheres: false
 diff-friendly-import-export: true
-respectful: true
+function-arrows: leading
 haddock-style: multi-line
-newlines-between-decls: 1
 import-export-style: leading
+indent-wheres: false
+indentation: 2
+newlines-between-decls: 1
+record-brace-space: true
+respectful: true
+single-constraint-parens: never
 unicode: always

lib/Language/PureScript/Backend/IR/DCE.hs

@@ -24,19 +24,21 @@ import Language.PureScript.Backend.IR.Types
   , rewriteExpTopDown
   )
 import Language.PureScript.Names (ModuleName)
+import Shower (shower)
 
 data EntryPoint = EntryPoint ModuleName [Name]
   deriving stock (Show)
 
+deriving stock instance Show AExp
+
 eliminateDeadCode ∷ UberModule → UberModule
 eliminateDeadCode uber@UberModule {..} =
   -- trace ("\n\nannotatedBindings:\n" <> shower annotatedBindings <> "\n") $
   --   trace ("\nannotatedExports:\n" <> shower annotatedExports <> "\n") $
   --     trace ("\nadjacencyList:\n" <> shower adjacencyList <> "\n") $
   --       trace ("\nreachableIds:\n" <> shower reachableIds <> "\n\n") $
   uber
-    { uberModuleForeigns
-    , uberModuleBindings = preserveBindings
+    { uberModuleBindings = preserveBindings
     , uberModuleExports = preservedExports
     }
  where
@@ -45,6 +47,8 @@ eliminateDeadCode uber@UberModule {..} =
     grouping ← annotatedBindings
     case grouping of
       Standalone (nodeId, qname, expr) → do
+        -- unless (nodeId `Set.member` reachableIds) $
+        --   traceM $ "nodeId " <> shower nodeId <> " not in reachable: " <> shower qname
         guard $ nodeId `Set.member` reachableIds
         [Standalone (qname, dceAnnotatedExp expr)]
       RecursiveGroup recBinds →
@@ -167,6 +171,7 @@ eliminateDeadCode uber@UberModule {..} =
         LiteralArray as → foldMap (adjacencyListForExpr scope) as
         LiteralObject ps → foldMap (adjacencyListForExpr scope . snd) ps
         Exception {} → mempty
+        ForeignImport {} → mempty
         Ctor {} → mempty
         ReflectCtor a → adjacencyListForExpr scope a
         Eq a b → adjacencyListForExpr scope a <> adjacencyListForExpr scope b
@@ -236,6 +241,7 @@ eliminateDeadCode uber@UberModule {..} =
       LiteralChar {} → []
       LiteralBool {} → []
       Exception {} → []
+      ForeignImport {} → []
       Ctor {} → []
       ReflectCtor a → [fst a]
       Eq a b → [fst a, fst b]
@@ -308,6 +314,7 @@ annotateExp = \case
   IfThenElse i t e → IfThenElse <$> ann i <*> ann t <*> ann e
   Ctor aty ty ctor fs → pure $ Ctor aty ty ctor fs
   Exception m → pure $ Exception m
+  ForeignImport m p → pure $ ForeignImport m p
  where
   ann ∷ Annotated Identity RawExp → AnnM (Id, AExp)
   ann = liftA2 (,) nextId . annotateExp . runIdentity
@@ -338,6 +345,7 @@ deannotateExp = \case
   IfThenElse i t e → IfThenElse (de i) (de t) (de e)
   Ctor aty ty ctor fs → Ctor aty ty ctor fs
   Exception m → Exception m
+  ForeignImport m p → ForeignImport m p
  where
   de ∷ (a, AExp) → Identity Exp
   de = pure . deannotateExp . snd

lib/Language/PureScript/Backend/IR/Linker.hs

@@ -31,7 +31,6 @@ data LinkMode
 
 data UberModule = UberModule
   { uberModuleBindings ∷ [Grouping (QName, Exp)]
-  , uberModuleForeigns ∷ [(ModuleName, FilePath)]
   , uberModuleExports ∷ [(Name, Exp)]
   }
   deriving stock (Show, Eq)
@@ -41,15 +40,14 @@ data UberModule = UberModule
 
 makeUberModule ∷ LinkMode → [Module] → UberModule
 makeUberModule linkMode modules =
-  UberModule
-    { uberModuleBindings
-    , uberModuleForeigns
-    , uberModuleExports
-    }
+  UberModule {uberModuleBindings, uberModuleExports}
  where
   sortedModules = topoSorted modules
-  uberModuleBindings = concatMap qualifiedModuleBindings sortedModules
-  uberModuleForeigns = concatMap qualifiedModuleForeigns sortedModules
+
+  uberModuleBindings =
+    concatMap foreignBindings sortedModules
+      <> concatMap qualifiedModuleBindings sortedModules
+
   uberModuleExports ∷ [(Name, Exp)] =
     case linkMode of
       LinkAsApplication moduleName name →
@@ -61,30 +59,41 @@ makeUberModule linkMode modules =
         , exportedName ← moduleExports
         ]
 
-qualifiedModuleBindings ∷ Module → [Grouping (QName, Exp)]
-qualifiedModuleBindings Module {moduleName, moduleBindings, moduleForeigns} =
-  foreignBindings <> flip fmap moduleBindings \case
-    Standalone binding → Standalone $ qualifyBinding binding
-    RecursiveGroup bindings → RecursiveGroup $ qualifyBinding <$> bindings
+foreignBindings ∷ Module → [Grouping (QName, Exp)]
+foreignBindings Module {moduleName, modulePath, moduleForeigns} =
+  foreignModuleBinding <> foreignNamesBindings
  where
-  foreignModule = refImported moduleName (Name "foreign") 0
-  foreignBindings ∷ [Grouping (QName, Exp)] =
+  foreignName = Name "foreign"
+  foreignModuleRef = refImported moduleName foreignName 0
+
+  foreignModuleBinding ∷ [Grouping (QName, Exp)]
+  foreignModuleBinding =
+    [ Standalone
+      ( QName moduleName foreignName
+      , ForeignImport moduleName modulePath
+      )
+    | not (null moduleForeigns)
+    ]
+
+  foreignNamesBindings ∷ [Grouping (QName, Exp)] =
     moduleForeigns <&> \name →
       Standalone
         ( QName moduleName name
-        , objectProp foreignModule (PropName (nameToText name))
+        , objectProp foreignModuleRef (PropName (nameToText name))
         )
 
+qualifiedModuleBindings ∷ Module → [Grouping (QName, Exp)]
+qualifiedModuleBindings Module {moduleName, moduleBindings, moduleForeigns} =
+  moduleBindings <&> \case
+    Standalone binding → Standalone $ qualifyBinding binding
+    RecursiveGroup bindings → RecursiveGroup $ qualifyBinding <$> bindings
+ where
   qualifyBinding ∷ (Name, Exp) → (QName, Exp)
   qualifyBinding = bimap (QName moduleName) (qualifyTopRefs moduleName topRefs)
    where
     topRefs ∷ Map Name Index = Map.fromList do
       (,0) <$> ((moduleBindings >>= bindingNames) <> moduleForeigns)
 
-qualifiedModuleForeigns ∷ Module → [(ModuleName, FilePath)]
-qualifiedModuleForeigns Module {moduleName, modulePath, moduleForeigns} =
-  [(moduleName, modulePath) | not (null moduleForeigns)]
-
 qualifyTopRefs ∷ ModuleName → Map Name Index → Exp → Exp
 qualifyTopRefs moduleName = go
  where

lib/Language/PureScript/Backend/IR/Query.hs

@@ -12,28 +12,28 @@ import Language.PureScript.Backend.IR.Types
   )
 import Language.PureScript.Names (runModuleName)
 
-usesRuntimeLazy :: UberModule -> Bool
+usesRuntimeLazy ∷ UberModule → Bool
 usesRuntimeLazy UberModule {uberModuleBindings, uberModuleExports} =
   getAny $
     foldMap
-      (foldMap (\(_qname, e) -> Any (findRuntimeLazyInExpr e)) . listGrouping)
+      (foldMap (\(_qname, e) → Any (findRuntimeLazyInExpr e)) . listGrouping)
       uberModuleBindings
       <> foldMap (Any . findRuntimeLazyInExpr . snd) uberModuleExports
 
-findRuntimeLazyInExpr :: Exp -> Bool
+findRuntimeLazyInExpr ∷ Exp → Bool
 findRuntimeLazyInExpr expr =
   countFreeRef (Local (Name "$__runtime_lazy")) expr > 0
 
-usesPrimModule :: UberModule -> Bool
+usesPrimModule ∷ UberModule → Bool
 usesPrimModule UberModule {uberModuleBindings, uberModuleExports} =
   getAny $
     foldMap
-      (foldMap (\(_qname, e) -> Any (findPrimModuleInExpr e)) . listGrouping)
+      (foldMap (\(_qname, e) → Any (findPrimModuleInExpr e)) . listGrouping)
       uberModuleBindings
       <> foldMap (Any . findPrimModuleInExpr . snd) uberModuleExports
 
-findPrimModuleInExpr :: Exp -> Bool
+findPrimModuleInExpr ∷ Exp → Bool
 findPrimModuleInExpr expr =
   Map.keys (countFreeRefs expr) & any \case
-    Local _name -> False
-    Imported moduleName _name -> runModuleName moduleName == "Prim"
+    Local _name → False
+    Imported moduleName _name → runModuleName moduleName == "Prim"

lib/Language/PureScript/Backend/IR/Types.hs

@@ -70,6 +70,7 @@ data RawExp (n ∷ Type → Type)
   | Let (NonEmpty (Grouping (n Name, Annotated n RawExp))) (Annotated n RawExp)
   | IfThenElse (Annotated n RawExp) (Annotated n RawExp) (Annotated n RawExp)
   | Exception Text
+  | ForeignImport ModuleName FilePath
 
 type Exp = RawExp Identity
 
@@ -478,6 +479,7 @@ countFreeRefs = fmap getSum . MMap.toMap . countFreeRefs' mempty
     LiteralChar {} → mempty
     Ctor {} → mempty
     Exception {} → mempty
+    ForeignImport {} → mempty
    where
     go = countFreeRefs' minIndexes
 
@@ -568,6 +570,7 @@ substitute name idx replacement = substitute' idx
     LiteralChar {} → subExpression
     Ctor {} → subExpression
     Exception {} → subExpression
+    ForeignImport {} → subExpression
    where
     go ∷ Exp → Exp = substitute' index