-- | Everything in this module is slightly morally dubious in that it works by
-- considering *all* modules to be @exposed-modules@ in the preprocessor phase.
--
-- This works in practice, but the Cabal API provides no guarantees this will
-- continue to be the case in the future.
module Distribution.C2Hs ( defaultMainC2Hs
                         -- * User hooks
                         , c2hsUserHooks
                         -- * Specialized hooks
                         , c2hsBuildHooks
                         , c2hsHaddockHooks
                         , c2hsReplHooks
                         ) where

import           Control.Applicative                   (pure)
import           Data.Traversable                      (traverse)
import           Distribution.C2Hs.TopSort
import           Distribution.ModuleName               (ModuleName)
import           Distribution.Simple                   (UserHooks (buildHook, haddockHook, replHook),
                                                        defaultMainWithHooks,
                                                        simpleUserHooks)
import           Distribution.Simple.LocalBuildInfo    (LocalBuildInfo)
import           Distribution.Simple.Setup             (BuildFlags (BuildFlags, buildVerbosity),
                                                        HaddockFlags (HaddockFlags, haddockVerbosity),
                                                        ReplFlags (ReplFlags, replVerbosity),
                                                        fromFlagOrDefault)
import           Distribution.Types.Benchmark
import           Distribution.Types.BuildInfo
import           Distribution.Types.Executable
import           Distribution.Types.ForeignLib
import           Distribution.Types.Library
import           Distribution.Types.PackageDescription
import           Distribution.Types.TestSuite
import           Distribution.Utils.Path               (PackageDir, SourceDir,
                                                        SymbolicPath,
                                                        getSymbolicPath)
import           Distribution.Verbosity                (Verbosity, normal)

type CabalFP = SymbolicPath PackageDir SourceDir

defaultMainC2Hs :: IO ()
defaultMainC2Hs :: IO ()
defaultMainC2Hs = UserHooks -> IO ()
defaultMainWithHooks UserHooks
c2hsUserHooks

-- | @since 0.1.1.0
c2hsUserHooks :: UserHooks
c2hsUserHooks :: UserHooks
c2hsUserHooks = UserHooks
simpleUserHooks { buildHook :: PackageDescription
-> LocalBuildInfo -> UserHooks -> BuildFlags -> IO ()
buildHook = PackageDescription
-> LocalBuildInfo -> UserHooks -> BuildFlags -> IO ()
c2hsBuildHooks
                                , haddockHook :: PackageDescription
-> LocalBuildInfo -> UserHooks -> HaddockFlags -> IO ()
haddockHook = PackageDescription
-> LocalBuildInfo -> UserHooks -> HaddockFlags -> IO ()
c2hsHaddockHooks
                                , replHook :: PackageDescription
-> LocalBuildInfo -> UserHooks -> ReplFlags -> [String] -> IO ()
replHook = PackageDescription
-> LocalBuildInfo -> UserHooks -> ReplFlags -> [String] -> IO ()
c2hsReplHooks
                                }

reorderC2Hs' :: Verbosity -> [CabalFP] -> [ModuleName] -> IO [ModuleName]
reorderC2Hs' :: Verbosity -> [CabalFP] -> [ModuleName] -> IO [ModuleName]
reorderC2Hs' Verbosity
v [CabalFP]
fps = Verbosity -> [String] -> [ModuleName] -> IO [ModuleName]
reorderC2Hs Verbosity
v ((CabalFP -> String) -> [CabalFP] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CabalFP -> String
forall from to. SymbolicPath from to -> String
getSymbolicPath [CabalFP]
fps)

-- | Custom build hooks to be used with @.chs@ files which @{\#import\#}@ one
-- another.
c2hsBuildHooks :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO ()
c2hsBuildHooks :: PackageDescription
-> LocalBuildInfo -> UserHooks -> BuildFlags -> IO ()
c2hsBuildHooks = \PackageDescription
pd LocalBuildInfo
lbi UserHooks
hooks BuildFlags
bf -> do
    let v :: Verbosity
v = BuildFlags -> Verbosity
getVerbosity BuildFlags
bf
    PackageDescription
pd' <- ([CabalFP] -> [ModuleName] -> IO [ModuleName])
-> PackageDescription -> IO PackageDescription
mapPackageDescription (Verbosity -> [CabalFP] -> [ModuleName] -> IO [ModuleName]
reorderC2Hs' Verbosity
v) PackageDescription
pd
    UserHooks
-> PackageDescription
-> LocalBuildInfo
-> UserHooks
-> BuildFlags
-> IO ()
buildHook UserHooks
simpleUserHooks PackageDescription
pd' LocalBuildInfo
lbi UserHooks
hooks BuildFlags
bf

c2hsHaddockHooks :: PackageDescription -> LocalBuildInfo -> UserHooks -> HaddockFlags -> IO ()
c2hsHaddockHooks :: PackageDescription
-> LocalBuildInfo -> UserHooks -> HaddockFlags -> IO ()
c2hsHaddockHooks = \PackageDescription
pd LocalBuildInfo
lbi UserHooks
hooks HaddockFlags
hf -> do
    let v :: Verbosity
v = HaddockFlags -> Verbosity
getHaddockVerbosity HaddockFlags
hf
    PackageDescription
pd' <- ([CabalFP] -> [ModuleName] -> IO [ModuleName])
-> PackageDescription -> IO PackageDescription
mapPackageDescription (Verbosity -> [CabalFP] -> [ModuleName] -> IO [ModuleName]
reorderC2Hs' Verbosity
v) PackageDescription
pd
    UserHooks
-> PackageDescription
-> LocalBuildInfo
-> UserHooks
-> HaddockFlags
-> IO ()
haddockHook UserHooks
simpleUserHooks PackageDescription
pd' LocalBuildInfo
lbi UserHooks
hooks HaddockFlags
hf

c2hsReplHooks :: PackageDescription -> LocalBuildInfo -> UserHooks -> ReplFlags -> [String] -> IO ()
c2hsReplHooks :: PackageDescription
-> LocalBuildInfo -> UserHooks -> ReplFlags -> [String] -> IO ()
c2hsReplHooks = \PackageDescription
pd LocalBuildInfo
lbi UserHooks
hooks ReplFlags
rf [String]
ss -> do
    let v :: Verbosity
v = ReplFlags -> Verbosity
getReplVerbosity ReplFlags
rf
    PackageDescription
pd' <- ([CabalFP] -> [ModuleName] -> IO [ModuleName])
-> PackageDescription -> IO PackageDescription
mapPackageDescription (Verbosity -> [CabalFP] -> [ModuleName] -> IO [ModuleName]
reorderC2Hs' Verbosity
v) PackageDescription
pd
    UserHooks
-> PackageDescription
-> LocalBuildInfo
-> UserHooks
-> ReplFlags
-> [String]
-> IO ()
replHook UserHooks
simpleUserHooks PackageDescription
pd' LocalBuildInfo
lbi UserHooks
hooks ReplFlags
rf [String]
ss

getHaddockVerbosity :: HaddockFlags -> Verbosity
getHaddockVerbosity :: HaddockFlags -> Verbosity
getHaddockVerbosity HaddockFlags { haddockVerbosity :: HaddockFlags -> Flag Verbosity
haddockVerbosity = Flag Verbosity
v } = Verbosity -> Flag Verbosity -> Verbosity
forall a. a -> Flag a -> a
fromFlagOrDefault Verbosity
normal Flag Verbosity
v

getVerbosity :: BuildFlags -> Verbosity
getVerbosity :: BuildFlags -> Verbosity
getVerbosity BuildFlags { buildVerbosity :: BuildFlags -> Flag Verbosity
buildVerbosity = Flag Verbosity
v } = Verbosity -> Flag Verbosity -> Verbosity
forall a. a -> Flag a -> a
fromFlagOrDefault Verbosity
normal Flag Verbosity
v

getReplVerbosity :: ReplFlags -> Verbosity
getReplVerbosity :: ReplFlags -> Verbosity
getReplVerbosity ReplFlags { replVerbosity :: ReplFlags -> Flag Verbosity
replVerbosity = Flag Verbosity
v } = Verbosity -> Flag Verbosity -> Verbosity
forall a. a -> Flag a -> a
fromFlagOrDefault Verbosity
normal Flag Verbosity
v

mapPackageDescription :: ([CabalFP] -> [ModuleName] -> IO [ModuleName]) -> PackageDescription -> IO PackageDescription
mapPackageDescription :: ([CabalFP] -> [ModuleName] -> IO [ModuleName])
-> PackageDescription -> IO PackageDescription
mapPackageDescription [CabalFP] -> [ModuleName] -> IO [ModuleName]
f p :: PackageDescription
p@PackageDescription { library :: PackageDescription -> Maybe Library
library = Maybe Library
ml
                                             , subLibraries :: PackageDescription -> [Library]
subLibraries = [Library]
ls
                                             , executables :: PackageDescription -> [Executable]
executables = [Executable]
es
                                             , foreignLibs :: PackageDescription -> [ForeignLib]
foreignLibs = [ForeignLib]
fs
                                             , testSuites :: PackageDescription -> [TestSuite]
testSuites = [TestSuite]
ts
                                             , benchmarks :: PackageDescription -> [Benchmark]
benchmarks = [Benchmark]
bs
                                             } = do
    Maybe Library
ml' <- (Library -> IO Library) -> Maybe Library -> IO (Maybe Library)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (([CabalFP] -> [ModuleName] -> IO [ModuleName])
-> Library -> IO Library
mapLibrary [CabalFP] -> [ModuleName] -> IO [ModuleName]
f) Maybe Library
ml
    [Library]
ls' <- (Library -> IO Library) -> [Library] -> IO [Library]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (([CabalFP] -> [ModuleName] -> IO [ModuleName])
-> Library -> IO Library
mapLibrary [CabalFP] -> [ModuleName] -> IO [ModuleName]
f) [Library]
ls
    [Executable]
es' <- (Executable -> IO Executable) -> [Executable] -> IO [Executable]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (([CabalFP] -> [ModuleName] -> IO [ModuleName])
-> Executable -> IO Executable
mapExecutable [CabalFP] -> [ModuleName] -> IO [ModuleName]
f) [Executable]
es
    [ForeignLib]
fs' <- (ForeignLib -> IO ForeignLib) -> [ForeignLib] -> IO [ForeignLib]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (([CabalFP] -> [ModuleName] -> IO [ModuleName])
-> ForeignLib -> IO ForeignLib
mapForeignLibrary [CabalFP] -> [ModuleName] -> IO [ModuleName]
f) [ForeignLib]
fs
    [TestSuite]
ts' <- (TestSuite -> IO TestSuite) -> [TestSuite] -> IO [TestSuite]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (([CabalFP] -> [ModuleName] -> IO [ModuleName])
-> TestSuite -> IO TestSuite
mapTestSuite [CabalFP] -> [ModuleName] -> IO [ModuleName]
f) [TestSuite]
ts
    [Benchmark]
bs' <- (Benchmark -> IO Benchmark) -> [Benchmark] -> IO [Benchmark]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (([CabalFP] -> [ModuleName] -> IO [ModuleName])
-> Benchmark -> IO Benchmark
mapBenchmark [CabalFP] -> [ModuleName] -> IO [ModuleName]
f) [Benchmark]
bs
    PackageDescription -> IO PackageDescription
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageDescription -> IO PackageDescription)
-> PackageDescription -> IO PackageDescription
forall a b. (a -> b) -> a -> b
$ PackageDescription
p { library :: Maybe Library
library = Maybe Library
ml'
             , subLibraries :: [Library]
subLibraries = [Library]
ls'
             , executables :: [Executable]
executables = [Executable]
es'
             , foreignLibs :: [ForeignLib]
foreignLibs = [ForeignLib]
fs'
             , testSuites :: [TestSuite]
testSuites = [TestSuite]
ts'
             , benchmarks :: [Benchmark]
benchmarks = [Benchmark]
bs'
             }

mapLibrary :: ([CabalFP] -> [ModuleName] -> IO [ModuleName]) -> Library -> IO Library
mapLibrary :: ([CabalFP] -> [ModuleName] -> IO [ModuleName])
-> Library -> IO Library
mapLibrary [CabalFP] -> [ModuleName] -> IO [ModuleName]
f lib :: Library
lib@Library { exposedModules :: Library -> [ModuleName]
exposedModules = [ModuleName]
es, libBuildInfo :: Library -> BuildInfo
libBuildInfo = BuildInfo
bi } = do
    let dirs :: [CabalFP]
dirs = BuildInfo -> [CabalFP]
hsSourceDirs BuildInfo
bi
        om :: [ModuleName]
om = BuildInfo -> [ModuleName]
otherModules BuildInfo
bi
        isOther :: ModuleName -> Bool
isOther = (ModuleName -> [ModuleName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [ModuleName]
es)
    [ModuleName]
newMods <- [CabalFP] -> [ModuleName] -> IO [ModuleName]
f [CabalFP]
dirs ([ModuleName]
es [ModuleName] -> [ModuleName] -> [ModuleName]
forall a. [a] -> [a] -> [a]
++ [ModuleName]
om)
    let om' :: [ModuleName]
om' = (ModuleName -> Bool) -> [ModuleName] -> [ModuleName]
forall a. (a -> Bool) -> [a] -> [a]
filter ModuleName -> Bool
isOther [ModuleName]
newMods
        bi' :: BuildInfo
bi' = BuildInfo
bi { otherModules :: [ModuleName]
otherModules = [ModuleName]
om' }
        -- This is stupid, but I've tested it and it seems to not do anything
        -- egregious
    Library -> IO Library
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Library -> IO Library) -> Library -> IO Library
forall a b. (a -> b) -> a -> b
$ Library
lib { exposedModules :: [ModuleName]
exposedModules = [ModuleName]
newMods, libBuildInfo :: BuildInfo
libBuildInfo = BuildInfo
bi' }

mapBenchmark :: ([CabalFP] -> [ModuleName] -> IO [ModuleName]) -> Benchmark -> IO Benchmark
mapBenchmark :: ([CabalFP] -> [ModuleName] -> IO [ModuleName])
-> Benchmark -> IO Benchmark
mapBenchmark [CabalFP] -> [ModuleName] -> IO [ModuleName]
f b :: Benchmark
b@Benchmark { benchmarkBuildInfo :: Benchmark -> BuildInfo
benchmarkBuildInfo = BuildInfo
bi } = do
    BuildInfo
bi' <- ([CabalFP] -> [ModuleName] -> IO [ModuleName])
-> BuildInfo -> IO BuildInfo
mapBuildInfo [CabalFP] -> [ModuleName] -> IO [ModuleName]
f BuildInfo
bi
    Benchmark -> IO Benchmark
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Benchmark -> IO Benchmark) -> Benchmark -> IO Benchmark
forall a b. (a -> b) -> a -> b
$ Benchmark
b { benchmarkBuildInfo :: BuildInfo
benchmarkBuildInfo = BuildInfo
bi' }

mapExecutable :: ([CabalFP] -> [ModuleName] -> IO [ModuleName]) -> Executable -> IO Executable
mapExecutable :: ([CabalFP] -> [ModuleName] -> IO [ModuleName])
-> Executable -> IO Executable
mapExecutable [CabalFP] -> [ModuleName] -> IO [ModuleName]
f e :: Executable
e@Executable { buildInfo :: Executable -> BuildInfo
buildInfo = BuildInfo
bi } = do
    BuildInfo
bi' <- ([CabalFP] -> [ModuleName] -> IO [ModuleName])
-> BuildInfo -> IO BuildInfo
mapBuildInfo [CabalFP] -> [ModuleName] -> IO [ModuleName]
f BuildInfo
bi
    Executable -> IO Executable
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Executable -> IO Executable) -> Executable -> IO Executable
forall a b. (a -> b) -> a -> b
$ Executable
e { buildInfo :: BuildInfo
buildInfo = BuildInfo
bi' }

mapForeignLibrary :: ([CabalFP] -> [ModuleName] -> IO [ModuleName]) -> ForeignLib -> IO ForeignLib
mapForeignLibrary :: ([CabalFP] -> [ModuleName] -> IO [ModuleName])
-> ForeignLib -> IO ForeignLib
mapForeignLibrary [CabalFP] -> [ModuleName] -> IO [ModuleName]
f fl :: ForeignLib
fl@ForeignLib { foreignLibBuildInfo :: ForeignLib -> BuildInfo
foreignLibBuildInfo = BuildInfo
bi } = do
    BuildInfo
bi' <- ([CabalFP] -> [ModuleName] -> IO [ModuleName])
-> BuildInfo -> IO BuildInfo
mapBuildInfo [CabalFP] -> [ModuleName] -> IO [ModuleName]
f BuildInfo
bi
    ForeignLib -> IO ForeignLib
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ForeignLib -> IO ForeignLib) -> ForeignLib -> IO ForeignLib
forall a b. (a -> b) -> a -> b
$ ForeignLib
fl { foreignLibBuildInfo :: BuildInfo
foreignLibBuildInfo = BuildInfo
bi' }

mapTestSuite :: ([CabalFP] -> [ModuleName] -> IO [ModuleName]) -> TestSuite -> IO TestSuite
mapTestSuite :: ([CabalFP] -> [ModuleName] -> IO [ModuleName])
-> TestSuite -> IO TestSuite
mapTestSuite [CabalFP] -> [ModuleName] -> IO [ModuleName]
f t :: TestSuite
t@TestSuite { testBuildInfo :: TestSuite -> BuildInfo
testBuildInfo = BuildInfo
bi } = do
    BuildInfo
bi' <- ([CabalFP] -> [ModuleName] -> IO [ModuleName])
-> BuildInfo -> IO BuildInfo
mapBuildInfo [CabalFP] -> [ModuleName] -> IO [ModuleName]
f BuildInfo
bi
    TestSuite -> IO TestSuite
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestSuite -> IO TestSuite) -> TestSuite -> IO TestSuite
forall a b. (a -> b) -> a -> b
$ TestSuite
t { testBuildInfo :: BuildInfo
testBuildInfo = BuildInfo
bi' }

mapBuildInfo :: ([CabalFP] -> [ModuleName] -> IO [ModuleName]) -> BuildInfo -> IO BuildInfo
mapBuildInfo :: ([CabalFP] -> [ModuleName] -> IO [ModuleName])
-> BuildInfo -> IO BuildInfo
mapBuildInfo [CabalFP] -> [ModuleName] -> IO [ModuleName]
f bi :: BuildInfo
bi@BuildInfo { otherModules :: BuildInfo -> [ModuleName]
otherModules = [ModuleName]
om, hsSourceDirs :: BuildInfo -> [CabalFP]
hsSourceDirs = [CabalFP]
dirs } = do
    [ModuleName]
om' <- [CabalFP] -> [ModuleName] -> IO [ModuleName]
f [CabalFP]
dirs [ModuleName]
om
    BuildInfo -> IO BuildInfo
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BuildInfo -> IO BuildInfo) -> BuildInfo -> IO BuildInfo
forall a b. (a -> b) -> a -> b
$ BuildInfo
bi { otherModules :: [ModuleName]
otherModules = [ModuleName]
om' }