Use crazy TemplateHaskell magic for Setup.hs backwards compatibility

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.

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

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 [])

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

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

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

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
+   updateClbi deps comp clbi = setUnionDeps (otherDeps deps comp) clbi
-         cpdeps = componentPackageDeps clbi
-       in clbi {
-                componentPackageDeps = cpdeps `union` otherDeps deps comp
-              }
 
    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)

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
+import Distribution.Simple
-componentsConfigs ::
+import Distribution.Simple.Setup
-    LocalBuildInfo -> [(ComponentName, ComponentLocalBuildInfo, [ComponentName])]
+import Distribution.Simple.Install
-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)
 
-getComponent :: PackageDescription -> ComponentName -> Component
+import qualified Data.Map as M
-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
+import NotCPP.Declarations
-allComponentsInBuildOrder :: LocalBuildInfo
+import Language.Haskell.TH
-                          -> [(ComponentName, ComponentLocalBuildInfo)]
-allComponentsInBuildOrder lbi =
-      [ (cname, clbi) | (cname, clbi, _) <- componentsConfigs lbi ]
 
-getComponentLocalBuildInfo :: LocalBuildInfo -> ComponentName -> ComponentLocalBuildInfo
+$(ifndefD "componentsConfigs" [d| deriving instance (Ord ComponentName) |] )
-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
 
-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
+ setComponentsConfigs lbi cs = flip execState lbi $ mapM setClbis gcs
- where
+  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
+ componentsConfigs ::
-componentBuildInfo =
+    LocalBuildInfo -> [(ComponentName, ComponentLocalBuildInfo, [ComponentName])]
-  foldComponent libBuildInfo buildInfo testBuildInfo benchmarkBuildInfo
+ 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
+
+ |])