{-# LANGUAGE GADTs, RankNTypes #-}
module Clash.Clashilator.Cabal
    ( BuildHook
    , ComponentHook
    , withComponentHook
    , packageDBs
    ) where

import Distribution.Simple
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.BuildTarget
import Distribution.Simple.Setup
import Distribution.Simple.Register
import Distribution.Types.ComponentRequestedSpec

import Distribution.Types.Lens
import Control.Lens hiding ((<.>))
import Control.Monad (unless, when)

type BuildHook = PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO ()
type ComponentHook = LocalBuildInfo -> BuildFlags -> Component -> IO BuildInfo

withComponentHook :: ComponentHook -> BuildHook -> BuildHook
withComponentHook :: ComponentHook -> BuildHook -> BuildHook
withComponentHook ComponentHook
componentHook BuildHook
nextBuildHook PackageDescription
pkg LocalBuildInfo
lbi UserHooks
userHooks BuildFlags
flags = do
    let reqSpec :: ComponentRequestedSpec
reqSpec = LocalBuildInfo -> ComponentRequestedSpec
componentEnabledSpec LocalBuildInfo
lbi
    PackageDescription
-> LocalBuildInfo
-> (Component -> ComponentLocalBuildInfo -> IO ())
-> IO ()
withAllComponentsInBuildOrder PackageDescription
pkg LocalBuildInfo
lbi ((Component -> ComponentLocalBuildInfo -> IO ()) -> IO ())
-> (Component -> ComponentLocalBuildInfo -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Component
c ComponentLocalBuildInfo
clbi -> do
        BuildFlags
flags <- BuildFlags -> IO BuildFlags
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (BuildFlags -> IO BuildFlags) -> BuildFlags -> IO BuildFlags
forall a b. (a -> b) -> a -> b
$ PackageDescription -> Component -> BuildFlags -> BuildFlags
restrictBuildFlags PackageDescription
pkg Component
c BuildFlags
flags
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ComponentRequestedSpec -> Component -> Bool
componentEnabled ComponentRequestedSpec
reqSpec Component
c Bool -> Bool -> Bool
&& Bool -> Bool
not ([String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([String] -> Bool) -> [String] -> Bool
forall a b. (a -> b) -> a -> b
$ BuildFlags -> [String]
buildArgs BuildFlags
flags)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            BuildInfo
bi <- ComponentHook
componentHook LocalBuildInfo
lbi BuildFlags
flags Component
c
            PackageDescription
pkg <- PackageDescription -> IO PackageDescription
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageDescription -> IO PackageDescription)
-> PackageDescription -> IO PackageDescription
forall a b. (a -> b) -> a -> b
$ Component -> BuildInfo -> PackageDescription -> PackageDescription
updateBuildInfo Component
c BuildInfo
bi PackageDescription
pkg
            BuildHook
nextBuildHook PackageDescription
pkg LocalBuildInfo
lbi UserHooks
userHooks BuildFlags
flags

packageDBs :: LocalBuildInfo -> BuildFlags -> IO [PackageDB]
packageDBs :: LocalBuildInfo -> BuildFlags -> IO [PackageDB]
packageDBs LocalBuildInfo
lbi BuildFlags
flags = do
    PackageDB
pkgdb0 <- do
        let dbPath :: String
dbPath = LocalBuildInfo -> String -> String
internalPackageDBPath LocalBuildInfo
lbi String
distPref
        Bool
existsAlready <- String -> IO Bool
doesPackageDBExist String
dbPath
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
existsAlready (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Verbosity -> Compiler -> ProgramDb -> Bool -> String -> IO ()
createPackageDB Verbosity
verbosity (LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi) (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi) Bool
False String
dbPath
        PackageDB -> IO PackageDB
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageDB -> IO PackageDB) -> PackageDB -> IO PackageDB
forall a b. (a -> b) -> a -> b
$ String -> PackageDB
SpecificPackageDB String
dbPath
    [PackageDB]
pkgdbs <- [PackageDB] -> IO [PackageDB]
absolutePackageDBPaths ([PackageDB] -> IO [PackageDB]) -> [PackageDB] -> IO [PackageDB]
forall a b. (a -> b) -> a -> b
$ LocalBuildInfo -> [PackageDB]
withPackageDB LocalBuildInfo
lbi

    [PackageDB] -> IO [PackageDB]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([PackageDB] -> IO [PackageDB]) -> [PackageDB] -> IO [PackageDB]
forall a b. (a -> b) -> a -> b
$ PackageDB
pkgdb0 PackageDB -> [PackageDB] -> [PackageDB]
forall a. a -> [a] -> [a]
: [PackageDB]
pkgdbs
  where
    verbosity :: Verbosity
verbosity = Flag Verbosity -> Verbosity
forall a. WithCallStack (Flag a -> a)
fromFlag (BuildFlags -> Flag Verbosity
buildVerbosity BuildFlags
flags)
    distPref :: String
distPref  = Flag String -> String
forall a. WithCallStack (Flag a -> a)
fromFlag (BuildFlags -> Flag String
buildDistPref BuildFlags
flags)

data NamedComponent where
    NamedComponent
        :: (HasBuildInfo a)
        => Traversal' PackageDescription a
        -> (a -> ComponentName)
        -> NamedComponent

namedComponents :: [NamedComponent]
namedComponents :: [NamedComponent]
namedComponents =
    [ Traversal' PackageDescription Library
-> (Library -> ComponentName) -> NamedComponent
forall a.
HasBuildInfo a =>
Traversal' PackageDescription a
-> (a -> ComponentName) -> NamedComponent
NamedComponent (LensLike
  f
  PackageDescription
  PackageDescription
  (Maybe Library)
  (Maybe Library)
Lens' PackageDescription (Maybe Library)
library LensLike
  f
  PackageDescription
  PackageDescription
  (Maybe Library)
  (Maybe Library)
-> ((Library -> f Library) -> Maybe Library -> f (Maybe Library))
-> (Library -> f Library)
-> PackageDescription
-> f PackageDescription
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Library -> f Library) -> Maybe Library -> f (Maybe Library)
forall s t a b. Each s t a b => Traversal s t a b
Traversal (Maybe Library) (Maybe Library) Library Library
each)      (LibraryName -> ComponentName
CLibName (LibraryName -> ComponentName)
-> (Library -> LibraryName) -> Library -> ComponentName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting LibraryName Library LibraryName -> Library -> LibraryName
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting LibraryName Library LibraryName
Lens' Library LibraryName
libName)
    , Traversal' PackageDescription Library
-> (Library -> ComponentName) -> NamedComponent
forall a.
HasBuildInfo a =>
Traversal' PackageDescription a
-> (a -> ComponentName) -> NamedComponent
NamedComponent (LensLike
  f PackageDescription PackageDescription [Library] [Library]
Lens' PackageDescription [Library]
subLibraries LensLike
  f PackageDescription PackageDescription [Library] [Library]
-> ((Library -> f Library) -> [Library] -> f [Library])
-> (Library -> f Library)
-> PackageDescription
-> f PackageDescription
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Library -> f Library) -> [Library] -> f [Library]
forall s t a b. Each s t a b => Traversal s t a b
Traversal [Library] [Library] Library Library
each) (LibraryName -> ComponentName
CLibName (LibraryName -> ComponentName)
-> (Library -> LibraryName) -> Library -> ComponentName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting LibraryName Library LibraryName -> Library -> LibraryName
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting LibraryName Library LibraryName
Lens' Library LibraryName
libName)
    , Traversal' PackageDescription Executable
-> (Executable -> ComponentName) -> NamedComponent
forall a.
HasBuildInfo a =>
Traversal' PackageDescription a
-> (a -> ComponentName) -> NamedComponent
NamedComponent (LensLike
  f PackageDescription PackageDescription [Executable] [Executable]
Lens' PackageDescription [Executable]
executables LensLike
  f PackageDescription PackageDescription [Executable] [Executable]
-> ((Executable -> f Executable) -> [Executable] -> f [Executable])
-> (Executable -> f Executable)
-> PackageDescription
-> f PackageDescription
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Executable -> f Executable) -> [Executable] -> f [Executable]
forall s t a b. Each s t a b => Traversal s t a b
Traversal [Executable] [Executable] Executable Executable
each)  (UnqualComponentName -> ComponentName
CExeName (UnqualComponentName -> ComponentName)
-> (Executable -> UnqualComponentName)
-> Executable
-> ComponentName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting UnqualComponentName Executable UnqualComponentName
-> Executable -> UnqualComponentName
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting UnqualComponentName Executable UnqualComponentName
Lens' Executable UnqualComponentName
exeName)
    , Traversal' PackageDescription TestSuite
-> (TestSuite -> ComponentName) -> NamedComponent
forall a.
HasBuildInfo a =>
Traversal' PackageDescription a
-> (a -> ComponentName) -> NamedComponent
NamedComponent (LensLike
  f PackageDescription PackageDescription [TestSuite] [TestSuite]
Lens' PackageDescription [TestSuite]
testSuites LensLike
  f PackageDescription PackageDescription [TestSuite] [TestSuite]
-> ((TestSuite -> f TestSuite) -> [TestSuite] -> f [TestSuite])
-> (TestSuite -> f TestSuite)
-> PackageDescription
-> f PackageDescription
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TestSuite -> f TestSuite) -> [TestSuite] -> f [TestSuite]
forall s t a b. Each s t a b => Traversal s t a b
Traversal [TestSuite] [TestSuite] TestSuite TestSuite
each)   (UnqualComponentName -> ComponentName
CTestName (UnqualComponentName -> ComponentName)
-> (TestSuite -> UnqualComponentName) -> TestSuite -> ComponentName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting UnqualComponentName TestSuite UnqualComponentName
-> TestSuite -> UnqualComponentName
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting UnqualComponentName TestSuite UnqualComponentName
Lens' TestSuite UnqualComponentName
testName)
    , Traversal' PackageDescription Benchmark
-> (Benchmark -> ComponentName) -> NamedComponent
forall a.
HasBuildInfo a =>
Traversal' PackageDescription a
-> (a -> ComponentName) -> NamedComponent
NamedComponent (LensLike
  f PackageDescription PackageDescription [Benchmark] [Benchmark]
Lens' PackageDescription [Benchmark]
benchmarks LensLike
  f PackageDescription PackageDescription [Benchmark] [Benchmark]
-> ((Benchmark -> f Benchmark) -> [Benchmark] -> f [Benchmark])
-> (Benchmark -> f Benchmark)
-> PackageDescription
-> f PackageDescription
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Benchmark -> f Benchmark) -> [Benchmark] -> f [Benchmark]
forall s t a b. Each s t a b => Traversal s t a b
Traversal [Benchmark] [Benchmark] Benchmark Benchmark
each)   (UnqualComponentName -> ComponentName
CBenchName (UnqualComponentName -> ComponentName)
-> (Benchmark -> UnqualComponentName) -> Benchmark -> ComponentName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting UnqualComponentName Benchmark UnqualComponentName
-> Benchmark -> UnqualComponentName
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting UnqualComponentName Benchmark UnqualComponentName
Lens' Benchmark UnqualComponentName
benchmarkName)
    ]

itagged :: Traversal' s a -> (a -> b) -> IndexedTraversal' b s a
itagged :: forall s a b. Traversal' s a -> (a -> b) -> IndexedTraversal' b s a
itagged Traversal' s a
l a -> b
f = (a -> b)
-> (Indexed a a (f a) -> s -> f s) -> p a (f a) -> s -> f s
forall j (p :: * -> * -> *) i a b r.
Indexable j p =>
(i -> j) -> (Indexed i a b -> r) -> p a b -> r
reindexed a -> b
f ((a -> f a) -> s -> f s
Traversal' s a
l ((a -> f a) -> s -> f s)
-> (Indexed a a (f a) -> a -> f a) -> Indexed a a (f a) -> s -> f s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Indexed a a (f a) -> a -> f a
forall a (p :: * -> * -> *) fb. Indexable a p => p a fb -> a -> fb
selfIndex)

updateBuildInfo :: Component -> BuildInfo -> PackageDescription -> PackageDescription
updateBuildInfo :: Component -> BuildInfo -> PackageDescription -> PackageDescription
updateBuildInfo Component
c BuildInfo
bi PackageDescription
pkg = ((PackageDescription -> PackageDescription)
 -> PackageDescription -> PackageDescription)
-> PackageDescription
-> [PackageDescription -> PackageDescription]
-> PackageDescription
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (PackageDescription -> PackageDescription)
-> PackageDescription -> PackageDescription
forall a b. (a -> b) -> a -> b
($) PackageDescription
pkg ([PackageDescription -> PackageDescription] -> PackageDescription)
-> [PackageDescription -> PackageDescription] -> PackageDescription
forall a b. (a -> b) -> a -> b
$
    [ AnIndexedSetter
  ComponentName
  PackageDescription
  PackageDescription
  BuildInfo
  BuildInfo
-> (ComponentName -> BuildInfo -> BuildInfo)
-> PackageDescription
-> PackageDescription
forall i s t a b.
AnIndexedSetter i s t a b -> (i -> a -> b) -> s -> t
iover AnIndexedSetter
  ComponentName
  PackageDescription
  PackageDescription
  BuildInfo
  BuildInfo
focus ((ComponentName -> BuildInfo -> BuildInfo)
 -> PackageDescription -> PackageDescription)
-> (ComponentName -> BuildInfo -> BuildInfo)
-> PackageDescription
-> PackageDescription
forall a b. (a -> b) -> a -> b
$ \ ComponentName
name -> if ComponentName
name ComponentName -> ComponentName -> Bool
forall a. Eq a => a -> a -> Bool
== Component -> ComponentName
componentName Component
c then BuildInfo -> BuildInfo -> BuildInfo
forall a b. a -> b -> a
const BuildInfo
bi else BuildInfo -> BuildInfo
forall a. a -> a
id
    | NamedComponent Traversal' PackageDescription a
component a -> ComponentName
getName <- [NamedComponent]
namedComponents
    , let focus :: AnIndexedSetter
  ComponentName
  PackageDescription
  PackageDescription
  BuildInfo
  BuildInfo
focus = Traversal' PackageDescription a
-> (a -> ComponentName)
-> IndexedTraversal' ComponentName PackageDescription a
forall s a b. Traversal' s a -> (a -> b) -> IndexedTraversal' b s a
itagged (a -> f a) -> PackageDescription -> f PackageDescription
Traversal' PackageDescription a
component a -> ComponentName
getName (Indexed ComponentName a (Identity a)
 -> PackageDescription -> Identity PackageDescription)
-> ((BuildInfo -> Identity BuildInfo) -> a -> Identity a)
-> AnIndexedSetter
     ComponentName
     PackageDescription
     PackageDescription
     BuildInfo
     BuildInfo
forall i (p :: * -> * -> *) s t r a b.
Indexable i p =>
(Indexed i s t -> r) -> ((a -> b) -> s -> t) -> p a b -> r
<. (BuildInfo -> Identity BuildInfo) -> a -> Identity a
forall a. HasBuildInfo a => Lens' a BuildInfo
Lens' a BuildInfo
buildInfo
    ]

restrictBuildFlags :: PackageDescription -> Component -> BuildFlags -> BuildFlags
restrictBuildFlags :: PackageDescription -> Component -> BuildFlags -> BuildFlags
restrictBuildFlags PackageDescription
pkg Component
c BuildFlags
buildFlags = BuildFlags
buildFlags
    { buildArgs = selectedArgs
    }
  where
    selectedArgs :: [String]
selectedArgs = [PackageId -> BuildTarget -> String
showBuildTarget (PackageDescription -> PackageId
forall pkg. Package pkg => pkg -> PackageId
packageId PackageDescription
pkg) (BuildTarget -> String) -> BuildTarget -> String
forall a b. (a -> b) -> a -> b
$ ComponentName -> BuildTarget
BuildTargetComponent (ComponentName -> BuildTarget) -> ComponentName -> BuildTarget
forall a b. (a -> b) -> a -> b
$ Component -> ComponentName
componentName Component
c]