{-# LANGUAGE DataKinds #-}

-- | 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, buildCommonFlags,
                                                        HaddockFlags, haddockCommonFlags,
                                                        ReplFlags, replCommonFlags,
                                                        CommonSetupFlags (CommonSetupFlags, setupVerbosity),
                                                        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               (Pkg, Source, FileOrDir (Dir),
                                                        SymbolicPath)
import           Distribution.Verbosity                (Verbosity, normal)

type CabalFP = SymbolicPath Pkg (Dir Source)

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

-- | @since 0.1.1.0
c2hsUserHooks :: UserHooks
c2hsUserHooks :: UserHooks
c2hsUserHooks = UserHooks
simpleUserHooks { buildHook = c2hsBuildHooks
                                , haddockHook = c2hsHaddockHooks
                                , replHook = c2hsReplHooks
                                }

-- | 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 = CommonSetupFlags -> Verbosity
getSetupVerbosity (BuildFlags -> CommonSetupFlags
buildCommonFlags 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 = CommonSetupFlags -> Verbosity
getSetupVerbosity (HaddockFlags -> CommonSetupFlags
haddockCommonFlags 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 = CommonSetupFlags -> Verbosity
getSetupVerbosity (ReplFlags -> CommonSetupFlags
replCommonFlags 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

getSetupVerbosity :: CommonSetupFlags -> Verbosity
getSetupVerbosity :: CommonSetupFlags -> Verbosity
getSetupVerbosity CommonSetupFlags { setupVerbosity :: CommonSetupFlags -> Flag Verbosity
setupVerbosity = 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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe 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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (([CabalFP] -> [ModuleName] -> IO [ModuleName])
-> Benchmark -> IO Benchmark
mapBenchmark [CabalFP] -> [ModuleName] -> IO [ModuleName]
f) [Benchmark]
bs
    PackageDescription -> IO PackageDescription
forall a. a -> IO a
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 = ml'
             , subLibraries = ls'
             , executables = es'
             , foreignLibs = fs'
             , testSuites = ts'
             , benchmarks = 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 = om' }
        -- This is stupid, but I've tested it and it seems to not do anything
        -- egregious
    Library -> IO Library
forall a. a -> IO a
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 = newMods, libBuildInfo = 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 a. a -> IO a
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 = 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 a. a -> IO a
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 = 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 a. a -> IO a
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 = 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 a. a -> IO a
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 = 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 a. a -> IO a
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 = om' }