From 48563a435e3edac621fd0611ad0a8e328753e6ea Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sun, 8 Feb 2015 14:17:53 +0100 Subject: [PATCH] Use crazy TemplateHaskell magic for Setup.hs backwards compatibility --- NotCPP/COPYING | 30 ++++++ NotCPP/Declarations.hs | 146 +++++++++++++++++++++++++++ NotCPP/LookupValueName.hs | 38 +++++++ NotCPP/OrphanEvasion.hs | 114 +++++++++++++++++++++ NotCPP/ScopeLookup.hs | 65 ++++++++++++ NotCPP/Utils.hs | 29 ++++++ Setup.hs | 15 ++- SetupCompat.hs | 204 ++++++++++++++++++++++++++------------ 8 files changed, 567 insertions(+), 74 deletions(-) create mode 100644 NotCPP/COPYING create mode 100644 NotCPP/Declarations.hs create mode 100644 NotCPP/LookupValueName.hs create mode 100644 NotCPP/OrphanEvasion.hs create mode 100644 NotCPP/ScopeLookup.hs create mode 100644 NotCPP/Utils.hs diff --git a/NotCPP/COPYING b/NotCPP/COPYING new file mode 100644 index 0000000..9eb8e81 --- /dev/null +++ b/NotCPP/COPYING @@ -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. diff --git a/NotCPP/Declarations.hs b/NotCPP/Declarations.hs new file mode 100644 index 0000000..7ae4188 --- /dev/null +++ b/NotCPP/Declarations.hs @@ -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 diff --git a/NotCPP/LookupValueName.hs b/NotCPP/LookupValueName.hs new file mode 100644 index 0000000..72462c2 --- /dev/null +++ b/NotCPP/LookupValueName.hs @@ -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 []) diff --git a/NotCPP/OrphanEvasion.hs b/NotCPP/OrphanEvasion.hs new file mode 100644 index 0000000..d666d7b --- /dev/null +++ b/NotCPP/OrphanEvasion.hs @@ -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 diff --git a/NotCPP/ScopeLookup.hs b/NotCPP/ScopeLookup.hs new file mode 100644 index 0000000..5fb6415 --- /dev/null +++ b/NotCPP/ScopeLookup.hs @@ -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 diff --git a/NotCPP/Utils.hs b/NotCPP/Utils.hs new file mode 100644 index 0000000..9da7958 --- /dev/null +++ b/NotCPP/Utils.hs @@ -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 diff --git a/Setup.hs b/Setup.hs index a53920c..20e34b2 100755 --- a/Setup.hs +++ b/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) diff --git a/SetupCompat.hs b/SetupCompat.hs index b39475d..028dacd 100644 --- a/SetupCompat.hs +++ b/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 + + |])