Add support for rts-options

sol · Jun 6, 2023 · da27c25 · da27c25
1 parent 21480fd
commit da27c25
Show file tree

Hide file tree

Showing 2 changed files with 56 additions and 3 deletions.
diff --git a/src/Hpack/Config.hs b/src/Hpack/Config.hs
@@ -230,17 +230,19 @@ data ExecutableSection = ExecutableSection {
   executableSectionMain :: Alias 'True "main-is" (Last FilePath)
 , executableSectionOtherModules :: Maybe (List Module)
 , executableSectionGeneratedOtherModules :: Maybe (List Module)
+, executableSectionRtsOptions :: Maybe (List String)
 } deriving (Eq, Show, Generic, FromValue)
 
 instance Monoid ExecutableSection where
-  mempty = ExecutableSection mempty Nothing Nothing
+  mempty = ExecutableSection mempty Nothing Nothing Nothing
   mappend = (<>)
 
 instance Semigroup ExecutableSection where
   a <> b = ExecutableSection {
       executableSectionMain = executableSectionMain a <> executableSectionMain b
     , executableSectionOtherModules = executableSectionOtherModules a <> executableSectionOtherModules b
     , executableSectionGeneratedOtherModules = executableSectionGeneratedOtherModules a <> executableSectionGeneratedOtherModules b
+    , executableSectionRtsOptions = executableSectionRtsOptions a <> executableSectionRtsOptions b
     }
 
 data VerbatimValue =
@@ -1428,13 +1430,13 @@ fromLibrarySectionPlain LibrarySection{..} = Library {
   }
 
 getMentionedExecutableModules :: ExecutableSection -> [Module]
-getMentionedExecutableModules (ExecutableSection (Alias (Last main)) otherModules generatedModules)=
+getMentionedExecutableModules (ExecutableSection (Alias (Last main)) otherModules generatedModules _rtsOptions)=
   maybe id (:) (toModule . Path.fromFilePath <$> main) $ fromMaybeList (otherModules <> generatedModules)
 
 toExecutable :: FilePath -> String -> Section ExecutableSection -> IO (Section Executable)
 toExecutable dir packageName_ =
     inferModules dir packageName_ getMentionedExecutableModules getExecutableModules fromExecutableSection (fromExecutableSection [])
-  . expandMain
+  . expandRtsOptions . expandMain
   where
     fromExecutableSection :: [Module] -> [Module] -> ExecutableSection -> Executable
     fromExecutableSection pathsModule inferableModules ExecutableSection{..} =
@@ -1443,12 +1445,33 @@ toExecutable dir packageName_ =
         otherModules = maybe (inferableModules ++ pathsModule) fromList executableSectionOtherModules
         generatedModules = maybe [] fromList executableSectionGeneratedOtherModules
 
+expandRtsOptions :: Section ExecutableSection -> Section ExecutableSection
+expandRtsOptions = flatten [] . expand
+  where
+    expand :: Section ExecutableSection -> Section ([String], ExecutableSection)
+    expand = fmap go
+      where
+        go :: ExecutableSection -> ([String], ExecutableSection)
+        go exec@ExecutableSection{..} = (fromMaybeList executableSectionRtsOptions, exec)
+
+    flatten :: [String] -> Section ([String], ExecutableSection) -> Section ExecutableSection
+    flatten outerRtsopts sect@Section{sectionData = (innerRtsopts, exec), ..} = sect{
+        sectionData = exec
+      , sectionGhcOptions = sectionGhcOptions ++ case innerRtsopts of
+        [] -> []
+        _ -> [show $ unwords ("-with-rtsopts" : rtsopts)]
+      , sectionConditionals = map (fmap $ flatten rtsopts) sectionConditionals
+      }
+      where
+        rtsopts = outerRtsopts ++ innerRtsopts
+
 expandMain :: Section ExecutableSection -> Section ExecutableSection
 expandMain = flatten . expand
   where
     expand :: Section ExecutableSection -> Section ([GhcOption], ExecutableSection)
     expand = fmap go
       where
+        go :: ExecutableSection -> ([GhcOption], ExecutableSection)
         go exec@ExecutableSection{..} =
           let
             (mainSrcFile, ghcOptions) = maybe (Nothing, []) (first Just . parseMain) (getLast $ unAlias executableSectionMain)

diff --git a/test/EndToEndSpec.hs b/test/EndToEndSpec.hs
@@ -1676,6 +1676,36 @@ spec = around_ (inTempDirectoryNamed "foo") $ do
             ghc-options: -main-is Foo
           |]
 
+      describe "rts-options" $ do
+        it "maps rts-options to ghc-options" $ do
+          [i|
+          executable:
+            main: Main.hs
+            rts-options: -s -N
+          |] `shouldRenderTo` executable_ "foo" [i|
+            main-is: Main.hs
+            ghc-options: "-with-rtsopts -s -N"
+          |]
+
+        context "inside a conditional" $ do
+          it "includes rts-options from outer scope" $ do
+            [i|
+            executable:
+              main: Main.hs
+              rts-options: -s
+              when:
+                condition: flag(use-threading)
+                rts-options: -N
+            |] `shouldRenderTo` executable "foo" [i|
+              main-is: Main.hs
+              ghc-options: "-with-rtsopts -s"
+              other-modules:
+                  Paths_foo
+              default-language: Haskell2010
+              if flag(use-threading)
+                ghc-options: "-with-rtsopts -s -N"
+            |]
+
     describe "when" $ do
       it "accepts conditionals" $ do
         [i|