git.iko.soy/haskell-generate
on master help sign in
haskell-generate/Setup.hs
69 lines 3.1 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Main (main) where
4import Data.IORef
5import Data.List ( nub )
6import Data.Version ( showVersion )
7import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName )
8import Distribution.PackageDescription ( PackageDescription(), TestSuite(..), hsSourceDirs, libBuildInfo, buildInfo)
9import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )
10import Distribution.Simple.BuildPaths ( autogenModulesDir )
11import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, withExeLBI, ComponentLocalBuildInfo(), LocalBuildInfo(), componentPackageDeps )
12import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), fromFlag, buildDistPref, defaultDistPref, fromFlagOrDefault )
13import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose )
14import Distribution.Verbosity ( Verbosity )
15import System.Directory ( canonicalizePath )
16import System.FilePath ( (</>) )
18main :: IO ()
19main = defaultMainWithHooks simpleUserHooks
20 { buildHook = \pkg lbi hooks flags -> do
21 generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi flags
22 buildHook simpleUserHooks pkg lbi hooks flags
23 }
25-- Very ad-hoc implementation of difference lists
26singletonDL :: a -> [a] -> [a]
27singletonDL = (:)
29emptyDL :: [a] -> [a]
30emptyDL = id
32appendDL :: ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
33appendDL x y = x . y
35generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> BuildFlags -> IO ()
36generateBuildModule verbosity pkg lbi flags = do
37 let dir = autogenModulesDir lbi
38 createDirectoryIfMissingVerbose verbosity True dir
39 withTestLBI pkg lbi $ \suite suitelbi -> do
40 srcDirs <- mapM canonicalizePath $ hsSourceDirs $ testBuildInfo suite
41 distDir <- canonicalizePath $ fromFlagOrDefault defaultDistPref $ buildDistPref flags
43 depsVar <- newIORef emptyDL
44 withLibLBI pkg lbi $ \lib liblbi ->
45 modifyIORef depsVar $ appendDL . singletonDL $ depsEntry (libBuildInfo lib) liblbi suitelbi
46 withExeLBI pkg lbi $ \exe exelbi ->
47 modifyIORef depsVar $ appendDL . singletonDL $ depsEntry (buildInfo exe) exelbi suitelbi
48 deps <- fmap ($ []) $ readIORef depsVar
50 rewriteFile (map fixchar $ dir </> "Build_" ++ testName suite ++ ".hs") $ unlines
51 [ "module Build_" ++ map fixchar (testName suite) ++ " where"
52 , "getDistDir :: FilePath"
53 , "getDistDir = " ++ show distDir
54 , "getSrcDirs :: [FilePath]"
55 , "getSrcDirs = " ++ show srcDirs
56 , "deps :: [([FilePath], [String])]"
57 , "deps = " ++ show deps
58 ]
60 where
61 formatdeps = map (formatone . snd)
62 formatone p = case packageName p of
63 PackageName n -> n ++ "-" ++ showVersion (packageVersion p)
64 depsEntry targetbi targetlbi suitelbi = (hsSourceDirs targetbi, formatdeps $ testDeps targetlbi suitelbi)
65 fixchar '-' = '_'
66 fixchar c = c
68testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]
69testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys