-- | 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 = c2hsBuildHooks
                                , haddockHook = c2hsHaddockHooks
                                , replHook = 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 a b. (a -> b) -> [a] -> [b]
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
    pd' <- ([CabalFP] -> [ModuleName] -> IO [ModuleName])
-> PackageDescription -> IO PackageDescription
mapPackageDescription (Verbosity -> [CabalFP] -> [ModuleName] -> IO [ModuleName]
reorderC2Hs' Verbosity
v) PackageDescription
pd
    buildHook simpleUserHooks pd' lbi hooks 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
    pd' <- ([CabalFP] -> [ModuleName] -> IO [ModuleName])
-> PackageDescription -> IO PackageDescription
mapPackageDescription (Verbosity -> [CabalFP] -> [ModuleName] -> IO [ModuleName]
reorderC2Hs' Verbosity
v) PackageDescription
pd
    haddockHook simpleUserHooks pd' lbi hooks 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
    pd' <- ([CabalFP] -> [ModuleName] -> IO [ModuleName])
-> PackageDescription -> IO PackageDescription
mapPackageDescription (Verbosity -> [CabalFP] -> [ModuleName] -> IO [ModuleName]
reorderC2Hs' Verbosity
v) PackageDescription
pd
    replHook simpleUserHooks pd' lbi hooks rf 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
    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
    ls' <- traverse (mapLibrary f) ls
    es' <- traverse (mapExecutable f) es
    fs' <- traverse (mapForeignLibrary f) fs
    ts' <- traverse (mapTestSuite f) ts
    bs' <- traverse (mapBenchmark f) bs
    pure $ 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)
    newMods <- [CabalFP] -> [ModuleName] -> IO [ModuleName]
f [CabalFP]
dirs ([ModuleName]
es [ModuleName] -> [ModuleName] -> [ModuleName]
forall a. [a] -> [a] -> [a]
++ [ModuleName]
om)
    let om' = (ModuleName -> Bool) -> [ModuleName] -> [ModuleName]
forall a. (a -> Bool) -> [a] -> [a]
filter ModuleName -> Bool
isOther [ModuleName]
newMods
        bi' = BuildInfo
bi { otherModules = om' }
        -- This is stupid, but I've tested it and it seems to not do anything
        -- egregious
    pure $ 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
    bi' <- ([CabalFP] -> [ModuleName] -> IO [ModuleName])
-> BuildInfo -> IO BuildInfo
mapBuildInfo [CabalFP] -> [ModuleName] -> IO [ModuleName]
f BuildInfo
bi
    pure $ 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
    bi' <- ([CabalFP] -> [ModuleName] -> IO [ModuleName])
-> BuildInfo -> IO BuildInfo
mapBuildInfo [CabalFP] -> [ModuleName] -> IO [ModuleName]
f BuildInfo
bi
    pure $ 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
    bi' <- ([CabalFP] -> [ModuleName] -> IO [ModuleName])
-> BuildInfo -> IO BuildInfo
mapBuildInfo [CabalFP] -> [ModuleName] -> IO [ModuleName]
f BuildInfo
bi
    pure $ 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
    bi' <- ([CabalFP] -> [ModuleName] -> IO [ModuleName])
-> BuildInfo -> IO BuildInfo
mapBuildInfo [CabalFP] -> [ModuleName] -> IO [ModuleName]
f BuildInfo
bi
    pure $ 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
    om' <- [CabalFP] -> [ModuleName] -> IO [ModuleName]
f [CabalFP]
dirs [ModuleName]
om
    pure $ bi { otherModules = om' }