C2Hs.hs

-- | 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 = defaultMainWithHooks c2hsUserHooks

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

reorderC2Hs' :: Verbosity -> [CabalFP] -> [ModuleName] -> IO [ModuleName]
reorderC2Hs' v fps = reorderC2Hs v (fmap getSymbolicPath fps)

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

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

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

getHaddockVerbosity :: HaddockFlags -> Verbosity
getHaddockVerbosity HaddockFlags { haddockVerbosity = v } = fromFlagOrDefault normal v

getVerbosity :: BuildFlags -> Verbosity
getVerbosity BuildFlags { buildVerbosity = v } = fromFlagOrDefault normal v

getReplVerbosity :: ReplFlags -> Verbosity
getReplVerbosity ReplFlags { replVerbosity = v } = fromFlagOrDefault normal v

mapPackageDescription :: ([CabalFP] -> [ModuleName] -> IO [ModuleName]) -> PackageDescription -> IO PackageDescription
mapPackageDescription f p@PackageDescription { library = ml
                                             , subLibraries = ls
                                             , executables = es
                                             , foreignLibs = fs
                                             , testSuites = ts
                                             , benchmarks = bs
                                             } = do
    ml' <- traverse (mapLibrary f) 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 f lib@Library { exposedModules = es, libBuildInfo = bi } = do
    let dirs = hsSourceDirs bi
        om = otherModules bi
        isOther = (`notElem` es)
    newMods <- f dirs (es ++ om)
    let om' = filter isOther newMods
        bi' = 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 f b@Benchmark { benchmarkBuildInfo = bi } = do
    bi' <- mapBuildInfo f bi
    pure $ b { benchmarkBuildInfo = bi' }

mapExecutable :: ([CabalFP] -> [ModuleName] -> IO [ModuleName]) -> Executable -> IO Executable
mapExecutable f e@Executable { buildInfo = bi } = do
    bi' <- mapBuildInfo f bi
    pure $ e { buildInfo = bi' }

mapForeignLibrary :: ([CabalFP] -> [ModuleName] -> IO [ModuleName]) -> ForeignLib -> IO ForeignLib
mapForeignLibrary f fl@ForeignLib { foreignLibBuildInfo = bi } = do
    bi' <- mapBuildInfo f bi
    pure $ fl { foreignLibBuildInfo = bi' }

mapTestSuite :: ([CabalFP] -> [ModuleName] -> IO [ModuleName]) -> TestSuite -> IO TestSuite
mapTestSuite f t@TestSuite { testBuildInfo = bi } = do
    bi' <- mapBuildInfo f bi
    pure $ t { testBuildInfo = bi' }

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