{- |
Copyright: (c) 2020 Kowainik
SPDX-License-Identifier: MPL-2.0
Maintainer: Kowainik <xrom.xkov@gmail.com>

Custom Setup to automate package modules discovery
-}

module Autopack
    ( defaultMainAutoModules
    ) where

import Data.Functor ((<&>))
import Data.List (nub, stripPrefix)
import Data.Maybe (maybeToList)
import Distribution.ModuleName (ModuleName, fromComponents)
import Distribution.Simple (UserHooks (..), defaultMainWithHooks, simpleUserHooks)
import Distribution.Types.BuildInfo (BuildInfo (..))
import Distribution.Types.CondTree (CondTree (..))
import Distribution.Types.GenericPackageDescription (GenericPackageDescription (..))
import Distribution.Types.Library (Library (..))
import System.Directory.Recursive (getDirRecursive)
import System.FilePath (dropExtension, splitDirectories, takeExtension)

{- | The main function that should be used in the custom @Setup.hs@ files
in the following way:

@
__import__ "Autopack" ('defaultMainAutoModules')

main :: 'IO' ()
main = 'defaultMainAutoModules'
@

This function uses custom hooks with 'defaultMainWithHooks' that
discover all Haskell modules in the @hs-source-dirs@ directories and implies
this list into @exposed-modules@ of the library.
-}
defaultMainAutoModules :: IO ()
defaultMainAutoModules :: IO ()
defaultMainAutoModules = UserHooks -> IO ()
UserHooks -> IO ()
defaultMainWithHooks (UserHooks -> IO ()) -> UserHooks -> IO ()
forall a b. (a -> b) -> a -> b
$
    (GenericPackageDescription -> IO [ModuleName])
-> UserHooks -> UserHooks
modulesHooks GenericPackageDescription -> IO [ModuleName]
getModules UserHooks
simpleUserHooks
  where
    getModules :: GenericPackageDescription -> IO [ModuleName]
    getModules :: GenericPackageDescription -> IO [ModuleName]
getModules pkgDescr :: GenericPackageDescription
pkgDescr = do
        let dirs :: [FilePath]
dirs = (CondTree ConfVar [Dependency] Library -> [FilePath])
-> [CondTree ConfVar [Dependency] Library] -> [FilePath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (BuildInfo -> [FilePath]
hsSourceDirs (BuildInfo -> [FilePath])
-> (CondTree ConfVar [Dependency] Library -> BuildInfo)
-> CondTree ConfVar [Dependency] Library
-> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Library -> BuildInfo
libBuildInfo (Library -> BuildInfo)
-> (CondTree ConfVar [Dependency] Library -> Library)
-> CondTree ConfVar [Dependency] Library
-> BuildInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CondTree ConfVar [Dependency] Library -> Library
forall v c a. CondTree v c a -> a
condTreeData) ([CondTree ConfVar [Dependency] Library] -> [FilePath])
-> [CondTree ConfVar [Dependency] Library] -> [FilePath]
forall a b. (a -> b) -> a -> b
$
                Maybe (CondTree ConfVar [Dependency] Library)
-> [CondTree ConfVar [Dependency] Library]
forall a. Maybe a -> [a]
maybeToList (Maybe (CondTree ConfVar [Dependency] Library)
 -> [CondTree ConfVar [Dependency] Library])
-> Maybe (CondTree ConfVar [Dependency] Library)
-> [CondTree ConfVar [Dependency] Library]
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription
-> Maybe (CondTree ConfVar [Dependency] Library)
condLibrary GenericPackageDescription
pkgDescr
        [FilePath]
files <- [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[FilePath]] -> [FilePath]) -> IO [[FilePath]] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> IO [FilePath]) -> [FilePath] -> IO [[FilePath]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> IO [FilePath]
getDirRecursive [FilePath]
dirs
        let hsFiles :: [FilePath]
hsFiles = (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (\f :: FilePath
f -> FilePath -> FilePath
takeExtension FilePath
f FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== ".hs") [FilePath]
files
        [ModuleName] -> IO [ModuleName]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ModuleName] -> IO [ModuleName])
-> [ModuleName] -> IO [ModuleName]
forall a b. (a -> b) -> a -> b
$ (FilePath -> ModuleName) -> [FilePath] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map ([FilePath] -> FilePath -> ModuleName
toModuleName [FilePath]
dirs) [FilePath]
hsFiles

    toModuleName :: [FilePath] -> FilePath -> ModuleName
    toModuleName :: [FilePath] -> FilePath -> ModuleName
toModuleName dirs :: [FilePath]
dirs file :: FilePath
file = do
        -- strip dir
        let strippedFile :: FilePath
strippedFile = [FilePath] -> FilePath
removeDirPrefix [FilePath]
dirs
        -- remove extension
        let noExtFile :: FilePath
noExtFile = FilePath -> FilePath
dropExtension FilePath
strippedFile
        -- replace '/' with '.'
        [FilePath] -> ModuleName
fromComponents ([FilePath] -> ModuleName) -> [FilePath] -> ModuleName
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath]
splitDirectories FilePath
noExtFile
      where
        removeDirPrefix :: [FilePath] -> FilePath
        removeDirPrefix :: [FilePath] -> FilePath
removeDirPrefix [] = FilePath
file
        removeDirPrefix (d :: FilePath
d:ds :: [FilePath]
ds) = case FilePath -> FilePath -> Maybe FilePath
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix FilePath
d FilePath
file of
            Just newFile :: FilePath
newFile -> Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
drop 1 FilePath
newFile
            Nothing      -> [FilePath] -> FilePath
removeDirPrefix [FilePath]
ds

modulesHooks
    :: (GenericPackageDescription -> IO [ModuleName])
    -> UserHooks
    -> UserHooks
modulesHooks :: (GenericPackageDescription -> IO [ModuleName])
-> UserHooks -> UserHooks
modulesHooks getModules :: GenericPackageDescription -> IO [ModuleName]
getModules hooks :: UserHooks
hooks = UserHooks
hooks
    { confHook :: (GenericPackageDescription, HookedBuildInfo)
-> ConfigFlags -> IO LocalBuildInfo
confHook = \(gPackDescr :: GenericPackageDescription
gPackDescr, hBuildInfo :: HookedBuildInfo
hBuildInfo) flags :: ConfigFlags
flags -> do
        [ModuleName]
modules <- GenericPackageDescription -> IO [ModuleName]
getModules GenericPackageDescription
gPackDescr
        let newGPackDescr :: GenericPackageDescription
newGPackDescr = GenericPackageDescription
gPackDescr
                { condLibrary :: Maybe (CondTree ConfVar [Dependency] Library)
condLibrary = GenericPackageDescription
-> Maybe (CondTree ConfVar [Dependency] Library)
condLibrary GenericPackageDescription
gPackDescr Maybe (CondTree ConfVar [Dependency] Library)
-> (CondTree ConfVar [Dependency] Library
    -> CondTree ConfVar [Dependency] Library)
-> Maybe (CondTree ConfVar [Dependency] Library)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \condLib :: CondTree ConfVar [Dependency] Library
condLib -> CondTree ConfVar [Dependency] Library
condLib
                    { condTreeData :: Library
condTreeData = (CondTree ConfVar [Dependency] Library -> Library
forall v c a. CondTree v c a -> a
condTreeData CondTree ConfVar [Dependency] Library
condLib)
                        { exposedModules :: [ModuleName]
exposedModules = [ModuleName] -> [ModuleName]
forall a. Eq a => [a] -> [a]
nub ([ModuleName] -> [ModuleName]) -> [ModuleName] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$
                            Library -> [ModuleName]
exposedModules (CondTree ConfVar [Dependency] Library -> Library
forall v c a. CondTree v c a -> a
condTreeData CondTree ConfVar [Dependency] Library
condLib) [ModuleName] -> [ModuleName] -> [ModuleName]
forall a. [a] -> [a] -> [a]
++ [ModuleName]
modules
                        }
                    }
                }
        UserHooks
-> (GenericPackageDescription, HookedBuildInfo)
-> ConfigFlags
-> IO LocalBuildInfo
confHook UserHooks
hooks (GenericPackageDescription
newGPackDescr, HookedBuildInfo
hBuildInfo) ConfigFlags
flags
    }