Use crazy TemplateHaskell magic for Setup.hs backwards compatibility
This commit is contained in:
Daniel Gröber
parent
ef96b926c7
commit
48563a435e
|
|
@ -0,0 +1,30 @@
|
|||
Copyright Ben Millwood 2012
|
||||
|
||||
All rights reserved.
|
||||
|
||||
Redistribution and use in source and binary forms, with or without
|
||||
modification, are permitted provided that the following conditions are met:
|
||||
|
||||
* Redistributions of source code must retain the above copyright
|
||||
notice, this list of conditions and the following disclaimer.
|
||||
|
||||
* Redistributions in binary form must reproduce the above
|
||||
copyright notice, this list of conditions and the following
|
||||
disclaimer in the documentation and/or other materials provided
|
||||
with the distribution.
|
||||
|
||||
* Neither the name of Ben Millwood nor the names of other
|
||||
contributors may be used to endorse or promote products derived
|
||||
from this software without specific prior written permission.
|
||||
|
||||
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
||||
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
|
||||
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
|
||||
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
||||
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
|
||||
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
||||
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
||||
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
||||
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
|
|
@ -0,0 +1,146 @@
|
|||
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
-- Using CPP so you don't have to :)
|
||||
module NotCPP.Declarations where
|
||||
|
||||
import Control.Arrow
|
||||
import Control.Applicative
|
||||
import Data.Maybe
|
||||
import Language.Haskell.TH.Syntax hiding (lookupName)
|
||||
|
||||
import NotCPP.LookupValueName
|
||||
|
||||
nT :: Monad m => String -> m Type
|
||||
cT :: Monad m => String -> m Type
|
||||
nE :: Monad m => String -> m Exp
|
||||
nP :: Monad m => String -> m Pat
|
||||
|
||||
nT str = return $ VarT (mkName str)
|
||||
cT str = return $ ConT (mkName str)
|
||||
nE str = return $ VarE (mkName str)
|
||||
nP str = return $ VarP (mkName str)
|
||||
recUpdE' :: Q Exp -> Name -> Exp -> Q Exp
|
||||
recUpdE' ex name assign = do
|
||||
RecUpdE <$> ex <*> pure [(name, assign)]
|
||||
|
||||
lookupName :: (NameSpace, String) -> Q (Maybe Name)
|
||||
lookupName (VarName, n) = lookupValueName n
|
||||
lookupName (DataName, n) = lookupValueName n
|
||||
lookupName (TcClsName, n) = lookupTypeName n
|
||||
|
||||
-- Does this even make sense?
|
||||
ifelseD :: Q [Dec] -> Q [Dec] -> Q [Dec]
|
||||
ifelseD if_decls' else_decls = do
|
||||
if_decls <- if_decls'
|
||||
alreadyDefined <- definedNames (boundNames `concatMap` if_decls)
|
||||
case alreadyDefined of
|
||||
[] -> if_decls'
|
||||
_ -> else_decls
|
||||
|
||||
ifdefelseD, ifelsedefD :: String -> Q [Dec] -> Q [Dec] -> Q [Dec]
|
||||
ifelsedefD = ifdefelseD
|
||||
ifdefelseD ident if_decls else_decls = do
|
||||
exists <- isJust <$> lookupValueName ident
|
||||
if exists
|
||||
then if_decls
|
||||
else else_decls
|
||||
|
||||
ifdefD :: String -> Q [Dec] -> Q [Dec]
|
||||
ifdefD ident decls = ifdefelseD ident decls (return [])
|
||||
|
||||
ifndefD :: String -> Q [Dec] -> Q [Dec]
|
||||
ifndefD ident decls = ifdefelseD ident (return []) decls
|
||||
|
||||
-- | Each of the given declarations is only spliced if the identifier it defines
|
||||
-- is not defined yet.
|
||||
--
|
||||
-- For example:
|
||||
--
|
||||
-- @$(ifD [[d| someFunctionThatShouldExist x = x+1 |]]@
|
||||
--
|
||||
-- If @someFunctionThatShouldExist@ doesn't actually exist the definition given
|
||||
-- in the splice will be the result of the splice otherwise nothing will be
|
||||
-- spliced.
|
||||
--
|
||||
-- Currently this only works for function declarations but it can be easily
|
||||
-- extended to other kinds of declarations.
|
||||
ifD :: Q [Dec] -> Q [Dec]
|
||||
ifD decls' = do
|
||||
decls <- decls'
|
||||
concat <$> flip mapM decls (\decl -> do
|
||||
alreadyDefined <- definedNames (boundNames decl)
|
||||
case alreadyDefined of
|
||||
[] -> return [decl]
|
||||
_ -> return [])
|
||||
|
||||
definedNames :: [(NameSpace, Name)] -> Q [Name]
|
||||
definedNames ns = catMaybes <$> (lookupName . second nameBase) `mapM` ns
|
||||
|
||||
boundNames :: Dec -> [(NameSpace, Name)]
|
||||
boundNames decl =
|
||||
case decl of
|
||||
SigD n _ -> [(VarName, n)]
|
||||
FunD n _cls -> [(VarName, n)]
|
||||
InfixD _ n -> [(VarName, n)]
|
||||
ValD p _ _ -> map ((,) VarName) $ patNames p
|
||||
|
||||
TySynD n _ _ -> [(TcClsName, n)]
|
||||
ClassD _ n _ _ _ -> [(TcClsName, n)]
|
||||
FamilyD _ n _ _ -> [(TcClsName, n)]
|
||||
|
||||
DataD _ n _ ctors _ ->
|
||||
[(TcClsName, n)] ++ map ((,) TcClsName) (conNames `concatMap` ctors)
|
||||
|
||||
NewtypeD _ n _ ctor _ ->
|
||||
[(TcClsName, n)] ++ map ((,) TcClsName) (conNames ctor)
|
||||
|
||||
DataInstD _ _n _ ctors _ ->
|
||||
map ((,) TcClsName) (conNames `concatMap` ctors)
|
||||
|
||||
NewtypeInstD _ _n _ ctor _ ->
|
||||
map ((,) TcClsName) (conNames ctor)
|
||||
|
||||
InstanceD _ _ty _ ->
|
||||
error "notcpp: Instance declarations are not supported yet"
|
||||
ForeignD _ ->
|
||||
error "notcpp: Foreign declarations are not supported yet"
|
||||
PragmaD _pragma -> error "notcpp: pragmas are not supported yet"
|
||||
|
||||
#if __GLASGOW_HASKELL__ >= 708
|
||||
TySynInstD _n _ -> error "notcpp: TySynInstD not supported yet"
|
||||
#else
|
||||
TySynInstD _n _ _ -> error "notcpp: TySynInstD not supported yet"
|
||||
#endif
|
||||
|
||||
#if __GLASGOW_HASKELL__ >= 708
|
||||
ClosedTypeFamilyD n _ _ _ -> [(TcClsName, n)]
|
||||
RoleAnnotD _n _ -> error "notcpp: RoleAnnotD not supported yet"
|
||||
#endif
|
||||
|
||||
conNames :: Con -> [Name]
|
||||
conNames con =
|
||||
case con of
|
||||
NormalC n _ -> [n]
|
||||
RecC n _ -> [n]
|
||||
InfixC _ n _ -> [n]
|
||||
ForallC _ _ c -> conNames c
|
||||
|
||||
patNames :: Pat -> [Name]
|
||||
patNames p'' =
|
||||
case p'' of
|
||||
LitP _ -> []
|
||||
VarP n -> [n]
|
||||
TupP ps -> patNames `concatMap` ps
|
||||
UnboxedTupP ps -> patNames `concatMap` ps
|
||||
ConP _ ps -> patNames `concatMap` ps
|
||||
InfixP p _ p' -> patNames `concatMap` [p,p']
|
||||
UInfixP p _ p' -> patNames `concatMap` [p,p']
|
||||
ParensP p -> patNames p
|
||||
TildeP p -> patNames p
|
||||
BangP p -> patNames p
|
||||
AsP n p -> n:(patNames p)
|
||||
WildP -> []
|
||||
RecP _ fps -> patNames `concatMap` map snd fps
|
||||
ListP ps -> patNames `concatMap` ps
|
||||
SigP p _ -> patNames p
|
||||
ViewP _ p -> patNames p
|
||||
|
|
@ -0,0 +1,38 @@
|
|||
{-# LANGUAGE TemplateHaskell #-}
|
||||
-- | This module uses scope lookup techniques to either export
|
||||
-- 'lookupValueName' from @Language.Haskell.TH@, or define
|
||||
-- its own 'lookupValueName', which attempts to do the
|
||||
-- same job with just 'reify'. This will sometimes fail, but if it
|
||||
-- succeeds it will give the answer that the real function would have
|
||||
-- given.
|
||||
--
|
||||
-- The idea is that if you use lookupValueName from this module,
|
||||
-- your client code will automatically use the best available name
|
||||
-- lookup mechanism. This means that e.g. 'scopeLookup' can work
|
||||
-- very well on recent GHCs and less well but still somewhat
|
||||
-- usefully on older GHCs.
|
||||
module NotCPP.LookupValueName (
|
||||
lookupValueName
|
||||
) where
|
||||
|
||||
import Language.Haskell.TH
|
||||
|
||||
import NotCPP.Utils
|
||||
|
||||
bestValueGuess :: String -> Q (Maybe Name)
|
||||
bestValueGuess s = do
|
||||
mi <- maybeReify (mkName s)
|
||||
case mi of
|
||||
Nothing -> no
|
||||
Just i -> case i of
|
||||
VarI n _ _ _ -> yes n
|
||||
DataConI n _ _ _ -> yes n
|
||||
_ -> err ["unexpected info:", show i]
|
||||
where
|
||||
no = return Nothing
|
||||
yes = return . Just
|
||||
err = fail . showString "NotCPP.bestValueGuess: " . unwords
|
||||
|
||||
$(recover [d| lookupValueName = bestValueGuess |] $ do
|
||||
VarI _ _ _ _ <- reify (mkName "lookupValueName")
|
||||
return [])
|
||||
|
|
@ -0,0 +1,114 @@
|
|||
{-# LANGUAGE EmptyDataDecls, TemplateHaskell #-}
|
||||
-- |
|
||||
-- The orphan instance problem is well-known in Haskell. This module
|
||||
-- by no means purports to solve the problem, but provides a workaround
|
||||
-- that may be significantly less awful than the status quo in some
|
||||
-- cases.
|
||||
--
|
||||
-- Say I think that the 'Name' type should have an 'IsString' instance.
|
||||
-- But I don't control either the class or the type, so if I define the
|
||||
-- instance, and then the template-haskell package defines one, my code
|
||||
-- is going to break.
|
||||
--
|
||||
-- 'safeInstance' can help me to solve this problem:
|
||||
--
|
||||
-- > safeInstance ''IsString [t| Name |] [d|
|
||||
-- > fromString = mkName |]
|
||||
--
|
||||
-- This will declare an instance only if one doesn't already exist.
|
||||
-- Now anyone importing your module is guaranteed to get an instance
|
||||
-- one way or the other.
|
||||
--
|
||||
-- This module is still highly experimental. The example given above
|
||||
-- does work, but anything involving type variables or complex method
|
||||
-- bodies may be less fortunate. The names of the methods are mangled
|
||||
-- a bit, so using recursion to define them may not work. Define the
|
||||
-- method outside the code and then use a simple binding as above.
|
||||
--
|
||||
-- If you use this code (successfully or unsuccessfully!), go fetch
|
||||
-- the maintainer address from the cabal file and let me know!
|
||||
module NotCPP.OrphanEvasion (
|
||||
MultiParams,
|
||||
safeInstance,
|
||||
safeInstance',
|
||||
) where
|
||||
|
||||
import Control.Applicative
|
||||
|
||||
import Language.Haskell.TH
|
||||
import Language.Haskell.TH.Syntax
|
||||
|
||||
import NotCPP.ScopeLookup
|
||||
|
||||
-- | An empty type used only to signify a multiparameter typeclass in
|
||||
-- 'safeInstance'.
|
||||
data MultiParams a
|
||||
|
||||
-- | Given @(forall ts. Cxt => t)@, return @(Cxt, [t])@.
|
||||
-- Given @(forall ts. Cxt => 'MultiParams' (t1, t2, t3))@, return
|
||||
-- @(Cxt, [t1, t2, t3])@.
|
||||
--
|
||||
-- This is used in 'safeInstance' to allow types to be specified more
|
||||
-- easily with TH typequotes.
|
||||
fromTuple :: Type -> (Cxt, [Type])
|
||||
fromTuple ty = unTuple <$> case ty of
|
||||
ForallT _ cxt ty' -> (cxt, ty')
|
||||
_ -> ([], ty)
|
||||
where
|
||||
unTuple :: Type -> [Type]
|
||||
unTuple (AppT (ConT n) ta)
|
||||
| n == ''MultiParams = case unrollAppT ta of
|
||||
(TupleT{}, ts) -> ts
|
||||
_ -> [ty]
|
||||
unTuple t = [t]
|
||||
|
||||
-- | A helper function to unwind type application.
|
||||
-- Given @TyCon t1 t2 t3@, returns @(TyCon, [t1,t2,t3])@
|
||||
unrollAppT :: Type -> (Type, [Type])
|
||||
unrollAppT = go []
|
||||
where
|
||||
go acc (AppT tc ta) = go (ta : acc) tc
|
||||
go acc ty = (ty, reverse acc)
|
||||
|
||||
-- | Left inverse to unrollAppT, equal to @'foldl' 'AppT'@
|
||||
rollAppT :: Type -> [Type] -> Type
|
||||
rollAppT = foldl AppT
|
||||
|
||||
-- | @'safeInstance'' className cxt types methods@ produces an instance
|
||||
-- of the given class if and only if one doesn't already exist.
|
||||
--
|
||||
-- See 'safeInstance' for a simple way to construct the 'Cxt' and
|
||||
-- @['Type']@ parameters.
|
||||
safeInstance' :: Name -> Cxt -> [Type] -> Q [Dec] -> Q [Dec]
|
||||
safeInstance' cl cxt tys inst = do
|
||||
b <- $(scopeLookups ["isInstance", "isClassInstance"]) cl tys
|
||||
if b
|
||||
then return []
|
||||
else do
|
||||
ds <- map fixInst <$> inst
|
||||
return [InstanceD cxt (rollAppT (ConT cl) tys) ds]
|
||||
where
|
||||
fixInst (FunD n cls) = FunD (fixName n) cls
|
||||
fixInst (ValD (VarP n) rhs wh) = ValD (VarP (fixName n)) rhs wh
|
||||
fixInst d = d
|
||||
fixName (Name n _) = Name n NameS
|
||||
|
||||
-- | 'safeInstance' is a more convenient version of 'safeInstance''
|
||||
-- that takes the context and type from a @'Q' 'Type'@ with the intention
|
||||
-- that it be supplied using a type-quote.
|
||||
--
|
||||
-- To define an instance @Show a => Show (Wrapper a)@, you'd use:
|
||||
--
|
||||
-- > safeInstance ''Show [t| Show a => Wrapper a |]
|
||||
-- > [d| show _ = "stuff" |]
|
||||
--
|
||||
-- To define an instance of a multi-param type class, use the
|
||||
-- 'MultiParams' type constructor with a tuple:
|
||||
--
|
||||
-- > safeInstance ''MonadState
|
||||
-- > [t| MonadState s m => MultiParams (s, MaybeT m) |]
|
||||
-- > [d| put = ... |]
|
||||
safeInstance :: Name -> Q Type -> Q [Dec] -> Q [Dec]
|
||||
safeInstance n qty inst = do
|
||||
(cxt, tys) <- fromTuple <$> qty
|
||||
safeInstance' n cxt tys inst
|
||||
|
|
@ -0,0 +1,65 @@
|
|||
{-# LANGUAGE TemplateHaskell #-}
|
||||
-- |
|
||||
-- This module exports 'scopeLookup', which will find a variable or
|
||||
-- value constructor for you and present it for your use. E.g. at some
|
||||
-- point in the history of the acid-state package, 'openAcidState' was
|
||||
-- renamed 'openLocalState'; for compatibility with both, you could
|
||||
-- use:
|
||||
--
|
||||
-- > openState :: IO (AcidState st)
|
||||
-- > openState = case $(scopeLookup "openLocalState") of
|
||||
-- > Just open -> open defaultState
|
||||
-- > Nothing -> case $(scopeLookup "openAcidState") of
|
||||
-- > Just open -> open defaultState
|
||||
-- > Nothing -> error
|
||||
-- > "openState: runtime name resolution has its drawbacks :/"
|
||||
--
|
||||
-- Or, for this specific case, you can use 'scopeLookups':
|
||||
--
|
||||
-- > openState :: IO (AcidState st)
|
||||
-- > openState = open defaultState
|
||||
-- > where
|
||||
-- > open = $(scopeLookups ["openLocalState","openAcidState"])
|
||||
--
|
||||
-- Now if neither of the names are found then TH will throw a
|
||||
-- compile-time error.
|
||||
module NotCPP.ScopeLookup (
|
||||
scopeLookup,
|
||||
scopeLookups,
|
||||
scopeLookup',
|
||||
liftMaybe,
|
||||
recoverMaybe,
|
||||
maybeReify,
|
||||
infoToExp,
|
||||
) where
|
||||
|
||||
import Control.Applicative ((<$>))
|
||||
|
||||
import Language.Haskell.TH (Q, Exp, recover, reify)
|
||||
|
||||
import NotCPP.LookupValueName
|
||||
import NotCPP.Utils
|
||||
|
||||
-- | Produces a spliceable expression which expands to @'Just' val@ if
|
||||
-- the given string refers to a value @val@ in scope, or 'Nothing'
|
||||
-- otherwise.
|
||||
--
|
||||
-- @scopeLookup = 'fmap' 'liftMaybe' . 'scopeLookup''@
|
||||
scopeLookup :: String -> Q Exp
|
||||
scopeLookup = fmap liftMaybe . scopeLookup'
|
||||
|
||||
-- | Finds the first string in the list that names a value, and produces
|
||||
-- a spliceable expression of that value, or reports a compile error if
|
||||
-- it fails.
|
||||
scopeLookups :: [String] -> Q Exp
|
||||
scopeLookups xs = foldr
|
||||
(\s r -> maybe r return =<< scopeLookup' s)
|
||||
(fail ("scopeLookups: none found: " ++ show xs))
|
||||
xs
|
||||
|
||||
-- | Produces @'Just' x@ if the given string names the value @x@,
|
||||
-- or 'Nothing' otherwise.
|
||||
scopeLookup' :: String -> Q (Maybe Exp)
|
||||
scopeLookup' s = recover (return Nothing) $ do
|
||||
Just n <- lookupValueName s
|
||||
infoToExp <$> reify n
|
||||
|
|
@ -0,0 +1,29 @@
|
|||
{-# LANGUAGE TemplateHaskell #-}
|
||||
module NotCPP.Utils where
|
||||
|
||||
import Control.Applicative ((<$>))
|
||||
import Language.Haskell.TH
|
||||
|
||||
-- | Turns 'Nothing' into an expression representing 'Nothing', and
|
||||
-- @'Just' x@ into an expression representing 'Just' applied to the
|
||||
-- expression in @x@.
|
||||
liftMaybe :: Maybe Exp -> Exp
|
||||
liftMaybe = maybe (ConE 'Nothing) (AppE (ConE 'Just))
|
||||
|
||||
-- | A useful variant of 'reify' that returns 'Nothing' instead of
|
||||
-- halting compilation when an error occurs (e.g. because the given
|
||||
-- name was not in scope).
|
||||
maybeReify :: Name -> Q (Maybe Info)
|
||||
maybeReify = recoverMaybe . reify
|
||||
|
||||
-- | Turns a possibly-failing 'Q' action into one returning a 'Maybe'
|
||||
-- value.
|
||||
recoverMaybe :: Q a -> Q (Maybe a)
|
||||
recoverMaybe q = recover (return Nothing) (Just <$> q)
|
||||
|
||||
-- | Returns @'Just' ('VarE' n)@ if the info relates to a value called
|
||||
-- @n@, or 'Nothing' if it relates to a different sort of thing.
|
||||
infoToExp :: Info -> Maybe Exp
|
||||
infoToExp (VarI n _ _ _) = Just (VarE n)
|
||||
infoToExp (DataConI n _ _ _) = Just (ConE n)
|
||||
infoToExp _ = Nothing
|
||||
15
Setup.hs
15
Setup.hs
|
|
@ -24,7 +24,7 @@ import SetupCompat
|
|||
main :: IO ()
|
||||
main = defaultMainWithHooks $ simpleUserHooks {
|
||||
confHook = \(gpd, hbi) cf ->
|
||||
xBuildDependsLike <$> (confHook simpleUserHooks) (gpd, hbi) cf
|
||||
xBuildDependsLike <$> (confHook simpleUserHooks) (gpd, hbi) cf
|
||||
|
||||
, copyHook = xInstallTargetHook
|
||||
|
||||
|
|
@ -47,18 +47,15 @@ xBuildDependsLike lbi =
|
|||
]
|
||||
|
||||
where
|
||||
updateClbi deps comp clbi = let
|
||||
cpdeps = componentPackageDeps clbi
|
||||
in clbi {
|
||||
componentPackageDeps = cpdeps `union` otherDeps deps comp
|
||||
}
|
||||
updateClbi deps comp clbi = setUnionDeps (otherDeps deps comp) clbi
|
||||
|
||||
dependsMap ::
|
||||
LocalBuildInfo -> [(ComponentName, [(InstalledPackageId, PackageId)])]
|
||||
LocalBuildInfo -> [(ComponentName, Deps)]
|
||||
dependsMap lbi =
|
||||
second componentPackageDeps <$> allComponentsInBuildOrder lbi
|
||||
second getDeps <$> allComponentsInBuildOrder lbi
|
||||
|
||||
otherDeps deps comp = fromMaybe [] $
|
||||
otherDeps :: [(ComponentName, Deps)] -> Component -> Deps
|
||||
otherDeps deps comp = fromMaybe noDeps $
|
||||
flip lookup deps =<< read <$> lookup "x-build-depends-like" fields
|
||||
where
|
||||
fields = customFieldsBI (componentBuildInfo comp)
|
||||
|
|
|
|||
204
SetupCompat.hs
204
SetupCompat.hs
|
|
@ -1,6 +1,7 @@
|
|||
{-# LANGUAGE CPP, RecordWildCards, StandaloneDeriving #-}
|
||||
{-# LANGUAGE TemplateHaskell, RecordWildCards, StandaloneDeriving #-}
|
||||
module SetupCompat where
|
||||
|
||||
import Control.Arrow
|
||||
import Control.Monad.State.Strict
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
|
|
@ -9,61 +10,34 @@ import Data.Function
|
|||
import Distribution.Simple.LocalBuildInfo
|
||||
import Distribution.PackageDescription
|
||||
|
||||
#if __GLASGOW_HASKELL__ <= 706
|
||||
componentsConfigs ::
|
||||
LocalBuildInfo -> [(ComponentName, ComponentLocalBuildInfo, [ComponentName])]
|
||||
componentsConfigs LocalBuildInfo {..} =
|
||||
(maybe [] (\c -> [(CLibName, c, [])]) libraryConfig)
|
||||
++ ((\(n, clbi) -> (CExeName n, clbi, [])) <$> executableConfigs)
|
||||
++ ((\(n, clbi) -> (CTestName n, clbi, [])) <$> testSuiteConfigs)
|
||||
++ ((\(n, clbi) -> (CBenchName n, clbi, [])) <$> benchmarkConfigs)
|
||||
import Distribution.Simple
|
||||
import Distribution.Simple.Setup
|
||||
import Distribution.Simple.Install
|
||||
|
||||
getComponent :: PackageDescription -> ComponentName -> Component
|
||||
getComponent pkg cname =
|
||||
case lookupComponent pkg cname of
|
||||
Just cpnt -> cpnt
|
||||
Nothing -> missingComponent
|
||||
where
|
||||
missingComponent =
|
||||
error $ "internal error: the package description contains no "
|
||||
++ "component corresponding to " ++ show cname
|
||||
import qualified Data.Map as M
|
||||
|
||||
lookupComponent :: PackageDescription -> ComponentName -> Maybe Component
|
||||
lookupComponent pkg CLibName =
|
||||
fmap CLib $ library pkg
|
||||
lookupComponent pkg (CExeName name) =
|
||||
fmap CExe $ find ((name ==) . exeName) (executables pkg)
|
||||
lookupComponent pkg (CTestName name) =
|
||||
fmap CTest $ find ((name ==) . testName) (testSuites pkg)
|
||||
lookupComponent pkg (CBenchName name) =
|
||||
fmap CBench $ find ((name ==) . benchmarkName) (benchmarks pkg)
|
||||
|
||||
-- We're lying here can't be bothered to order these
|
||||
allComponentsInBuildOrder :: LocalBuildInfo
|
||||
-> [(ComponentName, ComponentLocalBuildInfo)]
|
||||
allComponentsInBuildOrder lbi =
|
||||
[ (cname, clbi) | (cname, clbi, _) <- componentsConfigs lbi ]
|
||||
import NotCPP.Declarations
|
||||
import Language.Haskell.TH
|
||||
|
||||
getComponentLocalBuildInfo :: LocalBuildInfo -> ComponentName -> ComponentLocalBuildInfo
|
||||
getComponentLocalBuildInfo lbi cname =
|
||||
case [ clbi
|
||||
| (cname', clbi, _) <- componentsConfigs lbi
|
||||
, cname == cname' ] of
|
||||
[clbi] -> clbi
|
||||
_ -> missingComponent
|
||||
where
|
||||
missingComponent =
|
||||
error $ "internal error: there is no configuration data "
|
||||
++ "for component " ++ show cname
|
||||
$(ifndefD "componentsConfigs" [d| deriving instance (Ord ComponentName) |] )
|
||||
|
||||
deriving instance (Ord ComponentName)
|
||||
$(ifelsedefD "componentsConfigs" [d|
|
||||
|
||||
setComponentsConfigs
|
||||
setComponentsConfigs
|
||||
:: LocalBuildInfo
|
||||
-> [(ComponentName, ComponentLocalBuildInfo, [ComponentName])]
|
||||
-> LocalBuildInfo
|
||||
setComponentsConfigs lbi cs = $(recUpdE' (nE "lbi") (mkName "componentsConfigs") (VarE $ mkName "cs"))
|
||||
|
||||
|] [d|
|
||||
|
||||
setComponentsConfigs
|
||||
:: LocalBuildInfo
|
||||
-> [(ComponentName, ComponentLocalBuildInfo, a)]
|
||||
-> LocalBuildInfo
|
||||
setComponentsConfigs lbi cs = flip execState lbi $ mapM setClbis gcs
|
||||
where
|
||||
setComponentsConfigs lbi cs = flip execState lbi $ mapM setClbis gcs
|
||||
where
|
||||
-- gcs :: [ [(ComponentLocalBuildInfo, ComponentName, a)] ]
|
||||
gcs = groupBy (sameKind `on` fst3) $ sortBy (compare `on` fst3) cs
|
||||
|
||||
|
|
@ -79,35 +53,135 @@ setComponentsConfigs lbi cs = flip execState lbi $ mapM setClbis gcs
|
|||
sameKind (CBenchName _) _ = False
|
||||
|
||||
setClbis [(CLibName, clbi, _)] =
|
||||
get >>= \lbi -> put $ lbi {libraryConfig = Just clbi}
|
||||
get >>= \lbi ->
|
||||
put $ $(recUpdE' (nE "lbi") (mkName "libraryConfig") (AppE (ConE (mkName "Just")) (VarE (mkName "clbi"))))
|
||||
|
||||
setClbis cs@((CExeName _, _, _):_) =
|
||||
let cfg = (\((CExeName n), clbi, _) -> (n, clbi)) <$> cs in
|
||||
get >>= \lbi -> put $ lbi {executableConfigs = cfg }
|
||||
get >>= \lbi ->
|
||||
put $ $(recUpdE' (nE "lbi") (mkName "executableConfigs") (VarE $ mkName "cfg"))
|
||||
|
||||
setClbis cs@((CTestName _, _, _):_) =
|
||||
let cfg = (\((CTestName n), clbi, _) -> (n, clbi)) <$> cs in
|
||||
get >>= \lbi -> put $ lbi {testSuiteConfigs = cfg }
|
||||
get >>= \lbi ->
|
||||
put $ $(recUpdE' (nE "lbi") (mkName "testSuiteConfigs") (VarE $ mkName "cfg"))
|
||||
|
||||
setClbis cs@((CBenchName _, _, _):_) =
|
||||
let cfg = (\((CBenchName n), clbi, _) -> (n, clbi)) <$> cs in
|
||||
get >>= \lbi -> put $ lbi {benchmarkConfigs = cfg }
|
||||
get >>= \lbi ->
|
||||
put $ $(recUpdE' (nE "lbi") (mkName "benchmarkConfigs") (VarE $ mkName "cfg"))
|
||||
|
||||
#else
|
||||
|
||||
setComponentsConfigs
|
||||
:: LocalBuildInfo
|
||||
-> [(ComponentName, ComponentLocalBuildInfo, [ComponentName])]
|
||||
-> LocalBuildInfo
|
||||
setComponentsConfigs lbi cs = lbi { componentsConfigs = cs }
|
||||
|
||||
#endif
|
||||
|])
|
||||
|
||||
|
||||
#if __GLASGOW_HASKELL__ <= 704
|
||||
$(ifD [d|
|
||||
|
||||
componentBuildInfo :: Component -> BuildInfo
|
||||
componentBuildInfo =
|
||||
foldComponent libBuildInfo buildInfo testBuildInfo benchmarkBuildInfo
|
||||
componentsConfigs ::
|
||||
LocalBuildInfo -> [(ComponentName, ComponentLocalBuildInfo, [ComponentName])]
|
||||
componentsConfigs LocalBuildInfo {..} =
|
||||
(maybe [] (\c -> [(CLibName, c, [])]) $(nE "libraryConfig"))
|
||||
++ ((\(n, clbi) -> (CExeName n, clbi, [])) <$> $(nE "executableConfigs"))
|
||||
++ ((\(n, clbi) -> (CTestName n, clbi, [])) <$> $(nE "testSuiteConfigs"))
|
||||
++ ((\(n, clbi) -> (CBenchName n, clbi, [])) <$> $(nE "benchmarkConfigs"))
|
||||
|
||||
#endif
|
||||
getComponent :: PackageDescription -> ComponentName -> Component
|
||||
getComponent pkg cname =
|
||||
case lookupComponent pkg cname of
|
||||
Just cpnt -> cpnt
|
||||
Nothing -> missingComponent
|
||||
where
|
||||
missingComponent =
|
||||
error $ "internal error: the package description contains no "
|
||||
++ "component corresponding to " ++ show cname
|
||||
|
||||
lookupComponent :: PackageDescription -> ComponentName -> Maybe Component
|
||||
lookupComponent pkg CLibName =
|
||||
fmap CLib $ library pkg
|
||||
lookupComponent pkg (CExeName name) =
|
||||
fmap CExe $ find ((name ==) . exeName) (executables pkg)
|
||||
lookupComponent pkg (CTestName name) =
|
||||
fmap CTest $ find ((name ==) . testName) (testSuites pkg)
|
||||
lookupComponent pkg (CBenchName name) =
|
||||
fmap CBench $ find ((name ==) . benchmarkName) (benchmarks pkg)
|
||||
|
||||
-- We're lying here can't be bothered to order these
|
||||
allComponentsInBuildOrder :: LocalBuildInfo
|
||||
-> [(ComponentName, ComponentLocalBuildInfo)]
|
||||
allComponentsInBuildOrder lbi =
|
||||
[ (cname, clbi) | (cname, clbi, _) <- componentsConfigs lbi ]
|
||||
|
||||
getComponentLocalBuildInfo :: LocalBuildInfo -> ComponentName -> ComponentLocalBuildInfo
|
||||
getComponentLocalBuildInfo lbi cname =
|
||||
case [ clbi
|
||||
| (cname', clbi, _) <- componentsConfigs lbi
|
||||
, cname == cname' ] of
|
||||
[clbi] -> clbi
|
||||
_ -> missingComponent
|
||||
where
|
||||
missingComponent =
|
||||
error $ "internal error: there is no configuration data "
|
||||
++ "for component " ++ show cname
|
||||
|
||||
componentBuildInfo :: Component -> BuildInfo
|
||||
componentBuildInfo =
|
||||
foldComponent libBuildInfo buildInfo testBuildInfo benchmarkBuildInfo
|
||||
|
||||
|])
|
||||
|
||||
|
||||
$(ifelsedefD "componentPackageRenaming" [d|
|
||||
|
||||
type Deps = ([(InstalledPackageId, PackageId)], M.Map PackageName $(cT "ModuleRenaming"))
|
||||
|
||||
noDeps = ([], M.empty)
|
||||
|
||||
getDeps :: ComponentLocalBuildInfo -> Deps
|
||||
getDeps = componentPackageDeps &&& $(nE "componentPackageRenaming")
|
||||
|
||||
setUnionDeps :: Deps -> ComponentLocalBuildInfo -> ComponentLocalBuildInfo
|
||||
setUnionDeps (deps, rns) clbi = let
|
||||
clbi' = setComponentPackageRenaming clbi rns
|
||||
cpdeps = componentPackageDeps clbi
|
||||
in
|
||||
clbi' {
|
||||
componentPackageDeps = cpdeps `union` deps
|
||||
}
|
||||
|
||||
setComponentPackageRenaming clbi cprn =
|
||||
-- [| clbi { componentPackageRenaming = componentPackageRenaming clbi `M.union` cprn } |]
|
||||
$(recUpdE'
|
||||
(nE "clbi")
|
||||
(mkName "componentPackageRenaming")
|
||||
(InfixE
|
||||
(Just
|
||||
(AppE
|
||||
(VarE
|
||||
(mkName "componentPackageRenaming"))
|
||||
(VarE (mkName "clbi"))
|
||||
))
|
||||
(VarE (mkName "M.union"))
|
||||
(Just (VarE (mkName "cprn")))
|
||||
)
|
||||
)
|
||||
|
||||
|] [d|
|
||||
|
||||
type Deps = [(InstalledPackageId, PackageId)]
|
||||
|
||||
noDeps = []
|
||||
|
||||
getDeps :: ComponentLocalBuildInfo -> Deps
|
||||
getDeps lbi = componentPackageDeps lbi
|
||||
|
||||
setUnionDeps :: Deps -> ComponentLocalBuildInfo -> ComponentLocalBuildInfo
|
||||
setUnionDeps deps clbi = let
|
||||
cpdeps = componentPackageDeps clbi
|
||||
in
|
||||
clbi {
|
||||
componentPackageDeps = cpdeps `union` deps
|
||||
}
|
||||
|
||||
|
||||
-- setComponentPackageRenaming clbi _cprn = clbi
|
||||
|
||||
|])
|
||||
|
|
|
|||
Loading…
Reference in New Issue