Skip to content

Commit

Permalink
Refactoring
Browse files Browse the repository at this point in the history 
Use a `Reader` instead of explicitly passing `CabalVersion` around when
rendering.
  • Loading branch information
@sol
sol committed Jan 24, 2025
1 parent 3887865 commit 8051c12
Show file tree
Hide file tree
Showing 2 changed files with 112 additions and 90 deletions.
193 changes: 107 additions & 86 deletions src/Hpack/Render.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -36,6 +36,7 @@ module Hpack.Render (

import Imports

import Control.Monad.Reader
import Data.Char
import Data.Maybe
import Data.Map.Lazy (Map)
Expand All @@ -47,6 +48,8 @@ import Hpack.Render.Hints
import Hpack.Render.Dsl hiding (sortFieldsBy)
import qualified Hpack.Render.Dsl as Dsl

type RenderM = Reader CabalVersion

renderPackage :: [String] -> Package -> String
renderPackage oldCabalFile = renderPackageWith settings headerFieldsAlignment formattingHintsFieldOrder formattingHintsSectionsFieldOrder
where
Expand Down Expand Up @@ -78,20 +81,26 @@ renderPackageWith settings headerFieldsAlignment existingFieldOrder sectionsFiel
customSetup :: [Element]
customSetup = maybe [] (return . renderCustomSetup) packageCustomSetup

library :: [Element]
library = maybe [] (return . renderLibrary packageCabalVersion) packageLibrary

stanzas :: [Element]
stanzas = concat [
sourceRepository
, customSetup
, map renderFlag packageFlags
, library
, renderInternalLibraries packageCabalVersion packageInternalLibraries
, renderExecutables packageCabalVersion packageExecutables
, renderTests packageCabalVersion packageTests
, renderBenchmarks packageCabalVersion packageBenchmarks
]
stanzas = runReader stanzasM packageCabalVersion

stanzasM :: RenderM [Element]
stanzasM = do
lib <- maybe (return []) (fmap (:[]) . renderLibrary) packageLibrary
internalLibs <- renderInternalLibraries packageInternalLibraries
executables <- renderExecutables packageExecutables
tests <- renderTests packageTests
benchmarks <- renderBenchmarks packageBenchmarks
return $ concat [
sourceRepository
, customSetup
, map renderFlag packageFlags
, lib
, internalLibs
, executables
, tests
, benchmarks
]

headerFields :: [Element]
headerFields = mapMaybe (\(name, value) -> Field name . Literal <$> value) $ [
Expand Down Expand Up @@ -155,38 +164,40 @@ renderFlag Flag {..} = Stanza ("flag " ++ flagName) $ description ++ [
where
description = maybe [] (return . Field "description" . Literal) flagDescription

renderInternalLibraries :: CabalVersion -> Map String (Section Library) -> [Element]
renderInternalLibraries cabalVersion = map (renderInternalLibrary cabalVersion) . Map.toList
renderInternalLibraries :: Map String (Section Library) -> RenderM [Element]
renderInternalLibraries = traverse renderInternalLibrary . Map.toList

renderInternalLibrary :: CabalVersion -> (String, Section Library) -> Element
renderInternalLibrary cabalVersion (name, sect) =
Stanza ("library " ++ name) (renderLibrarySection cabalVersion sect)
renderInternalLibrary :: (String, Section Library) -> RenderM Element
renderInternalLibrary (name, sect) = do
elements <- renderLibrarySection sect
return $ Stanza ("library " ++ name) elements

renderExecutables :: CabalVersion -> Map String (Section Executable) -> [Element]
renderExecutables cabalVersion = map (renderExecutable cabalVersion) . Map.toList
renderExecutables :: Map String (Section Executable) -> RenderM [Element]
renderExecutables = traverse renderExecutable . Map.toList

renderExecutable :: CabalVersion -> (String, Section Executable) -> Element
renderExecutable cabalVersion (name, sect) =
Stanza ("executable " ++ name) (renderExecutableSection cabalVersion [] sect)
renderExecutable :: (String, Section Executable) -> RenderM Element
renderExecutable (name, sect) = do
elements <- renderExecutableSection [] sect
return $ Stanza ("executable " ++ name) elements

renderTests :: CabalVersion -> Map String (Section Executable) -> [Element]
renderTests cabalVersion = map (renderTest cabalVersion) . Map.toList
renderTests :: Map String (Section Executable) -> RenderM [Element]
renderTests = traverse renderTest . Map.toList

renderTest :: CabalVersion -> (String, Section Executable) -> Element
renderTest cabalVersion (name, sect) =
Stanza ("test-suite " ++ name)
(renderExecutableSection cabalVersion [Field "type" "exitcode-stdio-1.0"] sect)
renderTest :: (String, Section Executable) -> RenderM Element
renderTest (name, sect) = do
elements <- renderExecutableSection [Field "type" "exitcode-stdio-1.0"] sect
return $ Stanza ("test-suite " ++ name) elements

renderBenchmarks :: CabalVersion -> Map String (Section Executable) -> [Element]
renderBenchmarks cabalVersion = map (renderBenchmark cabalVersion) . Map.toList
renderBenchmarks :: Map String (Section Executable) -> RenderM [Element]
renderBenchmarks = traverse renderBenchmark . Map.toList

renderBenchmark :: CabalVersion -> (String, Section Executable) -> Element
renderBenchmark cabalVersion (name, sect) =
Stanza ("benchmark " ++ name)
(renderExecutableSection cabalVersion [Field "type" "exitcode-stdio-1.0"] sect)
renderBenchmark :: (String, Section Executable) -> RenderM Element
renderBenchmark (name, sect) = do
elements <- renderExecutableSection [Field "type" "exitcode-stdio-1.0"] sect
return $ Stanza ("benchmark " ++ name) elements

renderExecutableSection :: CabalVersion -> [Element] -> Section Executable -> [Element]
renderExecutableSection cabalVersion extraFields = renderSection cabalVersion renderExecutableFields extraFields
renderExecutableSection :: [Element] -> Section Executable -> RenderM [Element]
renderExecutableSection extraFields = renderSection renderExecutableFields extraFields

renderExecutableFields :: Executable -> [Element]
renderExecutableFields Executable{..} = mainIs ++ [otherModules, generatedModules]
Expand All @@ -199,11 +210,11 @@ renderCustomSetup :: CustomSetup -> Element
renderCustomSetup CustomSetup{..} =
Stanza "custom-setup" $ renderDependencies "setup-depends" customSetupDependencies

renderLibrary :: CabalVersion -> Section Library -> Element
renderLibrary cabalVersion sect = Stanza "library" $ renderLibrarySection cabalVersion sect
renderLibrary :: Section Library -> RenderM Element
renderLibrary sect = Stanza "library" <$> renderLibrarySection sect

renderLibrarySection :: CabalVersion -> Section Library -> [Element]
renderLibrarySection cabalVersion = renderSection cabalVersion renderLibraryFields []
renderLibrarySection :: Section Library -> RenderM [Element]
renderLibrarySection = renderSection renderLibraryFields []

renderLibraryFields :: Library -> [Element]
renderLibraryFields Library{..} =
Expand All @@ -222,39 +233,44 @@ renderExposed = Field "exposed" . Literal . show
renderVisibility :: String -> Element
renderVisibility = Field "visibility" . Literal

renderSection :: CabalVersion -> (a -> [Element]) -> [Element] -> Section a -> [Element]
renderSection cabalVersion renderSectionData extraFieldsStart Section{..} = addVerbatim sectionVerbatim $
extraFieldsStart
++ renderSectionData sectionData ++ [
renderDirectories "hs-source-dirs" sectionSourceDirs
, renderDefaultExtensions sectionDefaultExtensions
, renderOtherExtensions sectionOtherExtensions
, renderGhcOptions sectionGhcOptions
, renderGhcProfOptions sectionGhcProfOptions
, renderGhcSharedOptions sectionGhcSharedOptions
, renderGhcjsOptions sectionGhcjsOptions
, renderCppOptions sectionCppOptions
, renderAsmOptions sectionAsmOptions
, renderCcOptions sectionCcOptions
, renderCxxOptions sectionCxxOptions
, renderDirectories "include-dirs" sectionIncludeDirs
, Field "install-includes" (LineSeparatedList sectionInstallIncludes)
, Field "asm-sources" (renderPaths sectionAsmSources)
, Field "c-sources" (renderPaths sectionCSources)
, Field "cxx-sources" (renderPaths sectionCxxSources)
, Field "js-sources" (renderPaths sectionJsSources)
, renderDirectories "extra-lib-dirs" sectionExtraLibDirs
, Field "extra-libraries" (LineSeparatedList sectionExtraLibraries)
, renderDirectories "extra-frameworks-dirs" sectionExtraFrameworksDirs
, Field "frameworks" (LineSeparatedList sectionFrameworks)
, renderLdOptions sectionLdOptions
, Field "pkgconfig-depends" (CommaSeparatedList sectionPkgConfigDependencies)
]
++ renderBuildTools cabalVersion sectionBuildTools sectionSystemBuildTools
++ renderDependencies "build-depends" sectionDependencies
++ maybe [] (return . renderBuildable) sectionBuildable
++ maybe [] (return . renderLanguage) sectionLanguage
++ map (renderConditional cabalVersion renderSectionData) sectionConditionals
renderSection :: (a -> [Element]) -> [Element] -> Section a -> RenderM [Element]
renderSection renderSectionData extraFieldsStart Section{..} = do
buildToolsElements <- renderBuildTools sectionBuildTools sectionSystemBuildTools
conditionalElements <- mapM (renderConditional renderSectionData) sectionConditionals
return $ addVerbatim sectionVerbatim (
extraFieldsStart
++ renderSectionData sectionData
++ [
renderDirectories "hs-source-dirs" sectionSourceDirs
, renderDefaultExtensions sectionDefaultExtensions
, renderOtherExtensions sectionOtherExtensions
, renderGhcOptions sectionGhcOptions
, renderGhcProfOptions sectionGhcProfOptions
, renderGhcSharedOptions sectionGhcSharedOptions
, renderGhcjsOptions sectionGhcjsOptions
, renderCppOptions sectionCppOptions
, renderAsmOptions sectionAsmOptions
, renderCcOptions sectionCcOptions
, renderCxxOptions sectionCxxOptions
, renderDirectories "include-dirs" sectionIncludeDirs
, Field "install-includes" (LineSeparatedList sectionInstallIncludes)
, Field "asm-sources" (renderPaths sectionAsmSources)
, Field "c-sources" (renderPaths sectionCSources)
, Field "cxx-sources" (renderPaths sectionCxxSources)
, Field "js-sources" (renderPaths sectionJsSources)
, renderDirectories "extra-lib-dirs" sectionExtraLibDirs
, Field "extra-libraries" (LineSeparatedList sectionExtraLibraries)
, renderDirectories "extra-frameworks-dirs" sectionExtraFrameworksDirs
, Field "frameworks" (LineSeparatedList sectionFrameworks)
, renderLdOptions sectionLdOptions
, Field "pkgconfig-depends" (CommaSeparatedList sectionPkgConfigDependencies)
]
++ buildToolsElements
++ renderDependencies "build-depends" sectionDependencies
++ maybe [] (return . renderBuildable) sectionBuildable
++ maybe [] (return . renderLanguage) sectionLanguage
++ conditionalElements
)

addVerbatim :: [Verbatim] -> [Element] -> [Element]
addVerbatim verbatim fields = filterVerbatim verbatim fields ++ renderVerbatim verbatim
Expand Down Expand Up @@ -285,12 +301,14 @@ renderVerbatimObject = map renderPair . Map.toList
[x] -> Field key (Literal x)
xs -> Field key (LineSeparatedList xs)

renderConditional :: CabalVersion -> (a -> [Element]) -> Conditional (Section a) -> Element
renderConditional cabalVersion renderSectionData (Conditional condition sect mElse) = case mElse of
Nothing -> if_
Just else_ -> Group if_ (Stanza "else" $ renderSection cabalVersion renderSectionData [] else_)
where
if_ = Stanza ("if " ++ renderCond condition) (renderSection cabalVersion renderSectionData [] sect)
renderConditional :: (a -> [Element]) -> Conditional (Section a) -> RenderM Element
renderConditional renderSectionData (Conditional condition sect mElse) = do
ifElements <- renderSection renderSectionData [] sect
case mElse of
Nothing -> return $ Stanza ("if " ++ renderCond condition) ifElements
Just elseSect -> do
elseElements <- renderSection renderSectionData [] elseSect
return $ Group (Stanza ("if " ++ renderCond condition) ifElements) (Stanza "else" elseElements)

renderCond :: Cond -> String
renderCond = \ case
Expand Down Expand Up @@ -343,15 +361,18 @@ renderVersionConstraint version = case version of
AnyVersion -> ""
VersionRange x -> " " ++ x

renderBuildTools :: CabalVersion -> Map BuildTool DependencyVersion -> SystemBuildTools -> [Element]
renderBuildTools cabalVersion (map (renderBuildTool cabalVersion) . Map.toList -> xs) systemBuildTools = [
Field "build-tools" (CommaSeparatedList $ [x | BuildTools x <- xs] ++ renderSystemBuildTools systemBuildTools)
, Field "build-tool-depends" (CommaSeparatedList [x | BuildToolDepends x <- xs])
]
renderBuildTools :: Map BuildTool DependencyVersion -> SystemBuildTools -> RenderM [Element]
renderBuildTools buildTools systemBuildTools = do
cabalVersion <- ask
let xs = map (renderBuildTool cabalVersion) $ Map.toList buildTools
return [
Field "build-tools" (CommaSeparatedList $ [x | BuildTools x <- xs] ++ renderSystemBuildTools systemBuildTools)
, Field "build-tool-depends" (CommaSeparatedList [x | BuildToolDepends x <- xs])
]

data RenderBuildTool = BuildTools String | BuildToolDepends String

renderBuildTool :: CabalVersion -> (BuildTool, DependencyVersion) -> RenderBuildTool
renderBuildTool :: CabalVersion -> (BuildTool, DependencyVersion) -> RenderBuildTool
renderBuildTool cabalVersion (buildTool, renderVersion -> version) = case buildTool of
LocalBuildTool executable -> BuildTools (executable ++ version)
BuildTool pkg executable
Expand Down
9 changes: 5 additions & 4 deletions test/Hpack/RenderSpec.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -4,6 +4,7 @@ module Hpack.RenderSpec (spec) where

import Helper

import Control.Monad.Reader (runReader)
import Hpack.Syntax.DependencyVersion
import Hpack.ConfigSpec hiding (spec)
import Hpack.Config hiding (package)
Expand Down Expand Up @@ -225,15 +226,15 @@ spec = do
describe "renderConditional" $ do
it "renders conditionals" $ do
let conditional = Conditional "os(windows)" (section Empty) {sectionDependencies = deps ["Win32"]} Nothing
render defaultRenderSettings 0 (renderConditional cabalVersion renderEmptySection conditional) `shouldBe` [
render defaultRenderSettings 0 (runReader (renderConditional renderEmptySection conditional) cabalVersion) `shouldBe` [
"if os(windows)"
, " build-depends:"
, " Win32"
]

it "renders conditionals with else-branch" $ do
let conditional = Conditional "os(windows)" (section Empty) {sectionDependencies = deps ["Win32"]} (Just $ (section Empty) {sectionDependencies = deps ["unix"]})
render defaultRenderSettings 0 (renderConditional cabalVersion renderEmptySection conditional) `shouldBe` [
render defaultRenderSettings 0 (runReader (renderConditional renderEmptySection conditional) cabalVersion) `shouldBe` [
"if os(windows)"
, " build-depends:"
, " Win32"
Expand All @@ -245,7 +246,7 @@ spec = do
it "renders nested conditionals" $ do
let conditional = Conditional "arch(i386)" (section Empty) {sectionGhcOptions = ["-threaded"], sectionConditionals = [innerConditional]} Nothing
innerConditional = Conditional "os(windows)" (section Empty) {sectionDependencies = deps ["Win32"]} Nothing
render defaultRenderSettings 0 (renderConditional cabalVersion renderEmptySection conditional) `shouldBe` [
render defaultRenderSettings 0 (runReader (renderConditional renderEmptySection conditional) cabalVersion) `shouldBe` [
"if arch(i386)"
, " ghc-options: -threaded"
, " if os(windows)"
Expand All @@ -256,7 +257,7 @@ spec = do
it "conditionalises both build-depends and mixins" $ do
let conditional = Conditional "os(windows)" (section Empty) {sectionDependencies = [("Win32", depInfo)]} Nothing
depInfo = defaultInfo { dependencyInfoMixins = ["hiding (Blah)"] }
render defaultRenderSettings 0 (renderConditional cabalVersion renderEmptySection conditional) `shouldBe` [
render defaultRenderSettings 0 (runReader (renderConditional renderEmptySection conditional) cabalVersion) `shouldBe` [
"if os(windows)"
, " build-depends:"
, " Win32"
Expand Down

0 comments on commit 8051c12

Please sign in to comment.