Configuration.hs 17.9 KB
Newer Older
1 2 3
-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Configuration
4
-- Copyright   :  Thomas Schilling, 2007
5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41
-- 
-- Maintainer  :  Isaac Jones <ijones@syntaxpolice.org>
-- Stability   :  alpha
-- Portability :  portable
--
-- Configurations

{- 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 Isaac Jones 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. -}

42 43 44 45 46 47 48
module Distribution.PackageDescription.Configuration (
    finalizePackageDescription,
    flattenPackageDescription,

    -- Utils
    parseCondition,
    freeVars,
49
  ) where
50

51
import Distribution.Package (Package, Dependency(..))
52 53 54 55
import Distribution.PackageDescription
         ( GenericPackageDescription(..), PackageDescription(..)
         , Library(..), Executable(..), BuildInfo(..)
         , Flag(..), CondTree(..), ConfVar(..), ConfFlag(..), Condition(..) )
56
import Distribution.Simple.PackageIndex (PackageIndex)
57
import qualified Distribution.Simple.PackageIndex as PackageIndex
58
import Distribution.Version
59
    ( Version(..), VersionRange(..), withinRange, parseVersionRange )
60
import Distribution.Compiler (CompilerFlavor, readCompilerFlavor)
61
import Distribution.System
62
         ( OS, readOS, Arch, readArch )
63
import Distribution.Simple.Utils (currentDir)
64

65 66 67
import Distribution.Compat.ReadP as ReadP hiding ( char )
import qualified Distribution.Compat.ReadP as ReadP ( char )

68
import Data.Char ( isAlphaNum, toLower )
Duncan Coutts's avatar
Duncan Coutts committed
69 70
import Data.Maybe ( catMaybes, maybeToList )
import Data.List  ( nub )
71
import Data.Monoid
72

73 74
------------------------------------------------------------------------------

75 76
-- | Simplify the condition and return its free variables.
simplifyCondition :: Condition c
77 78
                  -> (c -> Either d Bool)   -- ^ (partial) variable assignment
                  -> (Condition d, [d])
79
simplifyCondition cond i = fv . walk $ cond
80
  where
81
    walk cnd = case cnd of
82
      Var v   -> either Var Lit (i v)
83 84 85 86 87 88 89
      Lit b   -> Lit b
      CNot c  -> case walk c of
                   Lit True -> Lit False
                   Lit False -> Lit True
                   c' -> CNot c'
      COr c d -> case (walk c, walk d) of
                   (Lit False, d') -> d'
90
                   (Lit True, _)   -> Lit True
91
                   (c', Lit False) -> c'
92
                   (_, Lit True)   -> Lit True
93 94 95 96 97 98 99
                   (c',d')         -> COr c' d'
      CAnd c d -> case (walk c, walk d) of
                    (Lit False, _) -> Lit False
                    (Lit True, d') -> d'
                    (_, Lit False) -> Lit False
                    (c', Lit True) -> c'
                    (c',d')        -> CAnd c' d'
100
    -- gather free vars
101 102
    fv c = (c, fv' c)
    fv' c = case c of
103
      Var v     -> [v]
104
      Lit _      -> []
105 106 107 108
      CNot c'    -> fv' c'
      COr c1 c2  -> fv' c1 ++ fv' c2
      CAnd c1 c2 -> fv' c1 ++ fv' c2

109 110
-- | Simplify a configuration condition using the os and arch names.  Returns
--   the names of all the flags occurring in the condition.
111
simplifyWithSysParams :: OS -> Arch -> (CompilerFlavor, Version) -> Condition ConfVar
112
                      -> (Condition ConfFlag, [String])
113
simplifyWithSysParams os arch (comp, compVer) cond = (cond', flags)
114 115
  where
    (cond', fvs) = simplifyCondition cond interp 
116
    interp (OS os')    = Right $ os' == os
117
    interp (Arch arch') = Right $ arch' == arch
118 119
    interp (Impl comp' vr) = Right $ comp' == comp
                                  && compVer `withinRange` vr
120 121
    interp (Flag  f)   = Left f
    flags = [ fname | ConfFlag fname <- fvs ]
122

123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138
-- XXX: Add instances and check
--
-- prop_sC_idempotent cond a o = cond' == cond''
--   where
--     cond'  = simplifyCondition cond a o
--     cond'' = simplifyCondition cond' a o
--
-- prop_sC_noLits cond a o = isLit res || not (hasLits res)
--   where
--     res = simplifyCondition cond a o
--     hasLits (Lit _) = True
--     hasLits (CNot c) = hasLits c
--     hasLits (COr l r) = hasLits l || hasLits r
--     hasLits (CAnd l r) = hasLits l || hasLits r
--     hasLits _ = False
--
139

140
-- | Parse a configuration condition from a string.
141
parseCondition :: ReadP r (Condition ConfVar)
142 143 144 145
parseCondition = condOr
  where
    condOr   = sepBy1 condAnd (oper "||") >>= return . foldl1 COr
    condAnd  = sepBy1 cond (oper "&&")>>= return . foldl1 CAnd
146
    cond     = sp >> (lit +++ inparens condOr +++ notCond +++ osCond 
147
                      +++ archCond +++ flagCond +++ implCond )
148
    inparens   = between (ReadP.char '(' >> sp) (sp >> ReadP.char ')' >> sp)
149
    notCond  = ReadP.char '!' >> sp >> cond >>= return . CNot
150
    osCond   = string "os" >> sp >> inparens osIdent >>= return . Var . OS . readOS
151
    archCond = string "arch" >> sp >> inparens archIdent >>= return . Var . Arch . readArch
152
    flagCond = string "flag" >> sp >> inparens flagIdent >>= return . Var . Flag . ConfFlag
153
    implCond = string "impl" >> sp >> inparens implIdent >>= return . Var
154 155 156
    ident    = munch1 isIdentChar >>= return . map toLower
    lit      = ((string "true" <++ string "True") >> return (Lit True)) <++ 
               ((string "false" <++ string "False") >> return (Lit False))
157 158
    archIdent     = ident >>= return 
    osIdent       = ident >>= return 
159 160 161 162
    flagIdent     = ident
    isIdentChar c = isAlphaNum c || (c `elem` "_-")
    oper s        = sp >> string s >> sp
    sp            = skipSpaces
163 164
    implIdent     = do i <- ident
                       vr <- sp >> option AnyVersion parseVersionRange
165
                       return $ Impl (readCompilerFlavor i) vr
166

167 168
------------------------------------------------------------------------------

169 170 171 172 173 174 175 176 177 178 179 180 181
mapCondTree :: (a -> b) -> (c -> d) -> (Condition v -> Condition w) 
            -> CondTree v c a -> CondTree w d b
mapCondTree fa fc fcnd (CondNode a c ifs) =
    CondNode (fa a) (fc c) (map g ifs)
  where
    g (cnd, t, me) = (fcnd cnd, mapCondTree fa fc fcnd t,
                           fmap (mapCondTree fa fc fcnd) me)

mapTreeConstrs :: (c -> d) -> CondTree v c a -> CondTree v d a
mapTreeConstrs f = mapCondTree id f id

mapTreeConds :: (Condition v -> Condition w) -> CondTree v c a -> CondTree w c a
mapTreeConds f = mapCondTree id id f
182

183 184
mapTreeData :: (a -> b) -> CondTree v c a -> CondTree v c b
mapTreeData f = mapCondTree f id id
185

186 187 188 189 190 191 192 193 194 195
-- | Result of dependency test. Isomorphic to @Maybe d@ but renamed for
--   clarity.
data DepTestRslt d = DepOk | MissingDeps d 

instance Monoid d => Monoid (DepTestRslt d) where
    mempty = DepOk
    mappend DepOk x = x
    mappend x DepOk = x
    mappend (MissingDeps d) (MissingDeps d') = MissingDeps (d `mappend` d')

196

197 198
data BT a = BTN a | BTB (BT a) (BT a)  -- very simple binary tree

199 200 201 202 203 204

-- | Try to find a flag assignment that satisfies the constaints of all trees.
--
-- Returns either the missing dependencies, or a tuple containing the
-- resulting data, the associated dependencies, and the chosen flag
-- assignments.
205 206
--
-- In case of failure, the _smallest_ number of of missing dependencies is
207
-- returned. [XXX: Could also be specified with a function argument.]
208
--
Ian Lynagh's avatar
Ian Lynagh committed
209
-- XXX: The current algorithm is rather naive.  A better approach would be to:
210 211 212 213 214 215 216 217
--
-- * Rule out possible paths, by taking a look at the associated dependencies.
--
-- * Infer the required values for the conditions of these paths, and
--   calculate the required domains for the variables used in these
--   conditions.  Then picking a flag assignment would be linear (I guess).
--
-- This would require some sort of SAT solving, though, thus it's not
Ian Lynagh's avatar
Ian Lynagh committed
218
-- implemented unless we really need it.
219
--   
220 221 222
resolveWithFlags :: Monoid a =>
     [(String,[Bool])] 
        -- ^ Domain for each flag name, will be tested in order.
223
  -> OS      -- ^ OS as returned by Distribution.System.buildOS
224
  -> Arch    -- ^ Arch as returned by Distribution.System.buildArch
225
  -> (CompilerFlavor, Version) -- ^ Compiler flavour + version
226 227 228 229
  -> [CondTree ConfVar [d] a]    
  -> ([d] -> DepTestRslt [d])  -- ^ Dependency test function.
  -> (Either [d] -- missing dependencies
       ([a], [d], [(String, Bool)]))
230
resolveWithFlags dom os arch impl trees checkDeps =
231 232 233
    case try dom [] of
      Right r -> Right r
      Left dbt -> Left $ findShortest dbt
234
  where 
235 236
    -- Check dependencies only once; might avoid some duplicate efforts.
    preCheckedTrees = map ( mapTreeConstrs (\d -> (checkDeps d,d))
237
                          . mapTreeConds (fst . simplifyWithSysParams os arch impl) )
238 239
                        trees

240 241 242 243
    -- @try@ recursively tries all possible flag assignments in the domain and
    -- either succeeds or returns a binary tree with the missing dependencies
    -- encountered in each run.  Since the tree is constructed lazily, we
    -- avoid some computation overhead in the successful case.
244 245 246 247 248 249 250 251 252
    try [] flags = 
        let (depss, as) = unzip 
                         . map (simplifyCondTree (env flags)) 
                         $ preCheckedTrees
        in case mconcat depss of
             (DepOk, ds) -> Right (as, ds, flags)
             (MissingDeps mds, _) -> Left (BTN mds)
    try ((n, vals):rest) flags = 
        tryAll $ map (\v -> try rest ((n, v):flags)) vals
253 254 255

    tryAll = foldr mp mz

256
    -- special version of `mplus' for our local purposes
257 258 259 260 261 262
    mp (Left xs)   (Left ys)   = (Left (BTB xs ys))
    mp (Left _)    m@(Right _) = m
    mp m@(Right _) _           = m

    -- `mzero'
    mz = Left (BTN [])
263

264
    env flags flag@(ConfFlag n) = maybe (Left flag) Right . lookup n $ flags 
265

266 267
    -- for the error case we inspect our lazy tree of missing dependencies and
    -- pick the shortest list of missing dependencies
268 269 270 271 272 273 274 275 276 277 278 279 280 281 282
    findShortest (BTN x) = x
    findShortest (BTB lt rt) = 
        let l = findShortest lt
            r = findShortest rt
        in case (l,r) of
             ([], xs) -> xs  -- [] is too short
             (xs, []) -> xs
             ([x], _) -> [x] -- single elem is optimum
             (_, [x]) -> [x]
             (xs, ys) -> if lazyLengthCmp xs ys
                         then xs else ys 
    -- lazy variant of @\xs ys -> length xs <= length ys@
    lazyLengthCmp [] _ = True
    lazyLengthCmp _ [] = False
    lazyLengthCmp (_:xs) (_:ys) = lazyLengthCmp xs ys
283

284

285 286

simplifyCondTree :: (Monoid a, Monoid d) =>
287
                    (v -> Either v Bool) 
288 289 290 291
                 -> CondTree v d a 
                 -> (d, a)
simplifyCondTree env (CondNode a d ifs) =
    foldr mappend (d, a) $ catMaybes $ map simplifyIf ifs
292
  where
293 294 295 296 297 298
    simplifyIf (cnd, t, me) = 
        case simplifyCondition cnd env of
          (Lit True, _) -> Just $ simplifyCondTree env t
          (Lit False, _) -> fmap (simplifyCondTree env) me
          _ -> error $ "Environment not defined for all free vars" 

299 300
-- | Flatten a CondTree.  This will resolve the CondTree by taking all
--  possible paths into account.  Note that since branches represent exclusive
Ian Lynagh's avatar
Ian Lynagh committed
301
--  choices this may not result in a \"sane\" result.
302 303 304 305
ignoreConditions :: (Monoid a, Monoid c) => CondTree v c a -> (a, c)
ignoreConditions (CondNode a c ifs) = (a, c) `mappend` mconcat (concatMap f ifs)
  where f (_, t, me) = ignoreConditions t 
                       : maybeToList (fmap ignoreConditions me)
306

307 308 309 310 311 312 313 314 315 316 317 318
freeVars :: CondTree ConfVar c a  -> [String]
freeVars t = [ s | Flag (ConfFlag s) <- freeVars' t ]
  where
    freeVars' (CondNode _ _ ifs) = concatMap compfv ifs
    compfv (c, ct, mct) = condfv c ++ freeVars' ct ++ maybe [] freeVars' mct
    condfv c = case c of
      Var v      -> [v]
      Lit _      -> []
      CNot c'    -> condfv c'
      COr c1 c2  -> condfv c1 ++ condfv c2
      CAnd c1 c2 -> condfv c1 ++ condfv c2

319 320 321 322 323 324 325 326 327 328 329 330 331 332 333
------------------------------------------------------------------------------
-- Convert GenericPackageDescription to PackageDescription
--

data PDTagged = Lib Library | Exe String Executable | PDNull

instance Monoid PDTagged where
    mempty = PDNull
    PDNull `mappend` x = x
    x `mappend` PDNull = x
    Lib l `mappend` Lib l' = Lib (l `mappend` l')
    Exe n e `mappend` Exe n' e' | n == n' = Exe n (e `mappend` e')
    _ `mappend` _ = bug "Cannot combine incompatible tags"

finalizePackageDescription
334 335 336 337
  :: Package pkg
  => [(String,Bool)]  -- ^ Explicitly specified flag assignments
  -> Maybe (PackageIndex pkg) -- ^ Available dependencies. Pass 'Nothing' if
                              -- this is unknown.
338
  -> OS     -- ^ OS-name
339
  -> Arch   -- ^ Arch-name
340
  -> (CompilerFlavor, Version) -- ^ Compiler + Version
341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387
  -> GenericPackageDescription
  -> Either [Dependency]
            (PackageDescription, [(String,Bool)])
	     -- ^ Either missing dependencies or the resolved package
	     -- description along with the flag assignments chosen.
finalizePackageDescription userflags mpkgs os arch impl
        (GenericPackageDescription pkg flags mlib0 exes0) =
    case resolveFlags of
      Right ((mlib, exes'), deps, flagVals) ->
        Right ( pkg { library = mlib
                    , executables = exes'
                    , buildDepends = nub deps
                    }
              , flagVals )
      Left missing -> Left $ nub missing
  where
    -- Combine lib and exes into one list of @CondTree@s with tagged data
    condTrees = maybeToList (fmap (mapTreeData Lib) mlib0 )
                ++ map (\(name,tree) -> mapTreeData (Exe name) tree) exes0

    untagRslts = foldr untag (Nothing, [])
      where
        untag (Lib _) (Just _, _) = bug "Only one library expected"
        untag (Lib l) (Nothing, exes) = (Just l, exes)
        untag (Exe n e) (mlib, exes)
         | any ((== n) . fst) exes = bug "Exe with same name found"
         | otherwise = (mlib, exes ++ [(n, e)])
        untag PDNull x = x  -- actually this should not happen, but let's be liberal

    resolveFlags =
        case resolveWithFlags flagChoices os arch impl condTrees check of
          Right (as, ds, fs) ->
              let (mlib, exes) = untagRslts as in
              Right ( (fmap libFillInDefaults mlib,
                       map (\(n,e) -> (exeFillInDefaults e) { exeName = n }) exes),
                     ds, fs)
          Left missing      -> Left missing

    flagChoices  = map (\(MkFlag n _ d) -> (n, d2c n d)) flags
    d2c n b      = maybe [b, not b] (\x -> [x]) $ lookup n userflags
    --flagDefaults = map (\(n,x:_) -> (n,x)) flagChoices
    check ds     = if all satisfyDep ds
                   then DepOk
                   else MissingDeps $ filter (not . satisfyDep) ds
    -- if we don't know which packages are present, we just accept any
    -- dependency
    satisfyDep   = maybe (const True)
388
                         (\pkgs -> not . null . PackageIndex.lookupDependency pkgs)
389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442
                         mpkgs


-- | Flatten a generic package description by ignoring all conditions and just
-- join the field descriptors into on package description.  Note, however,
-- that this may lead to inconsistent field values, since all values are
-- joined into one field, which may not be possible in the original package
-- description, due to the use of exclusive choices (if ... else ...).
--
-- XXX: One particularly tricky case is defaulting.  In the original package
-- description, e.g., the source dirctory might either be the default or a
-- certain, explicitly set path.  Since defaults are filled in only after the
-- package has been resolved and when no explicit value has been set, the
-- default path will be missing from the package description returned by this
-- function.
flattenPackageDescription :: GenericPackageDescription -> PackageDescription
flattenPackageDescription (GenericPackageDescription pkg _ mlib0 exes0) =
    pkg { library = mlib
        , executables = reverse exes
        , buildDepends = nub $ ldeps ++ reverse edeps
        }
  where
    (mlib, ldeps) = case mlib0 of
        Just lib -> let (l,ds) = ignoreConditions lib in
                    (Just (libFillInDefaults l), ds)
        Nothing -> (Nothing, [])
    (exes, edeps) = foldr flattenExe ([],[]) exes0
    flattenExe (n, t) (es, ds) =
        let (e, ds') = ignoreConditions t in
        ( (exeFillInDefaults $ e { exeName = n }) : es, ds' ++ ds )

-- This is in fact rather a hack.  The original version just overrode the
-- default values, however, when adding conditions we had to switch to a
-- modifier-based approach.  There, nothing is ever overwritten, but only
-- joined together.
--
-- This is the cleanest way i could think of, that doesn't require
-- changing all field parsing functions to return modifiers instead.
libFillInDefaults :: Library -> Library
libFillInDefaults lib@(Library { libBuildInfo = bi }) =
    lib { libBuildInfo = biFillInDefaults bi }

exeFillInDefaults :: Executable -> Executable
exeFillInDefaults exe@(Executable { buildInfo = bi }) =
    exe { buildInfo = biFillInDefaults bi }

biFillInDefaults :: BuildInfo -> BuildInfo
biFillInDefaults bi =
    if null (hsSourceDirs bi)
    then bi { hsSourceDirs = [currentDir] }
    else bi

bug :: String -> a
bug msg = error $ msg ++ ". Consider this a bug."