C2Hs.hs

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

-- | @since 0.1.1.0
c2hsUserHooks :: UserHooks
c2hsUserHooks = 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 = \pd lbi hooks bf -> do
    let v = getSetupVerbosity (buildCommonFlags 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 = getSetupVerbosity (haddockCommonFlags 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 = getSetupVerbosity (replCommonFlags rf)
    pd' <- mapPackageDescription (reorderC2Hs v) pd
    replHook simpleUserHooks pd' lbi hooks rf ss

getSetupVerbosity :: CommonSetupFlags -> Verbosity
getSetupVerbosity CommonSetupFlags { setupVerbosity = 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' }