cabal-install/src/Distribution/Client/ScriptUtils.hs

   1 {-# LANGUAGE LambdaCase #-}
   2 {-# LANGUAGE NamedFieldPuns #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 {-# LANGUAGE RecordWildCards #-}
   5
   6 -- | Utilities to help commands with scripts
   7 module Distribution.Client.ScriptUtils
   8   ( getScriptHash
   9   , getScriptCacheDirectory
  10   , ensureScriptCacheDirectory
  11   , withContextAndSelectors
  12   , AcceptNoTargets (..)
  13   , TargetContext (..)
  14   , updateContextAndWriteProjectFile
  15   , updateContextAndWriteProjectFile'
  16   , fakeProjectSourcePackage
  17   , lSrcpkgDescription
  18   , movedExePath
  19   ) where
  20
  21 import Distribution.Client.Compat.Prelude hiding (toList)
  22 import Prelude ()
  23
  24 import Distribution.Compat.Lens
  25 import qualified Distribution.Types.Lens as L
  26
  27 import Distribution.CabalSpecVersion
  28   ( CabalSpecVersion (..)
  29   , cabalSpecLatest
  30   )
  31 import Distribution.Client.Config
  32   ( defaultScriptBuildsDir
  33   )
  34 import Distribution.Client.DistDirLayout
  35   ( DistDirLayout (..)
  36   , DistDirParams (..)
  37   )
  38 import Distribution.Client.HashValue
  39   ( hashValue
  40   , showHashValue
  41   , truncateHash
  42   )
  43 import Distribution.Client.HttpUtils
  44   ( HttpTransport
  45   , configureTransport
  46   )
  47 import Distribution.Client.NixStyleOptions
  48   ( NixStyleFlags (..)
  49   )
  50 import Distribution.Client.ProjectConfig
  51   ( PackageConfig (..)
  52   , ProjectConfig (..)
  53   , ProjectConfigShared (..)
  54   , projectConfigHttpTransport
  55   , reportParseResult
  56   , withGlobalConfig
  57   , withProjectOrGlobalConfig
  58   )
  59 import Distribution.Client.ProjectConfig.Legacy
  60   ( ProjectConfigSkeleton
  61   , instantiateProjectConfigSkeletonFetchingCompiler
  62   , parseProjectSkeleton
  63   )
  64 import Distribution.Client.ProjectFlags
  65   ( flagIgnoreProject
  66   )
  67 import Distribution.Client.ProjectOrchestration
  68 import Distribution.Client.ProjectPlanning
  69   ( ElaboratedConfiguredPackage (..)
  70   , ElaboratedSharedConfig (..)
  71   , configureCompiler
  72   )
  73 import Distribution.Client.RebuildMonad
  74   ( runRebuild
  75   )
  76 import Distribution.Client.Setup
  77   ( ConfigFlags (..)
  78   , GlobalFlags (..)
  79   )
  80 import Distribution.Client.TargetSelector
  81   ( TargetSelectorProblem (..)
  82   , TargetString (..)
  83   )
  84 import Distribution.Client.Types
  85   ( PackageLocation (..)
  86   , PackageSpecifier (..)
  87   , UnresolvedSourcePackage
  88   )
  89 import Distribution.Compiler
  90   ( CompilerId (..)
  91   , perCompilerFlavorToList
  92   )
  93 import Distribution.FieldGrammar
  94   ( parseFieldGrammar
  95   , takeFields
  96   )
  97 import Distribution.Fields
  98   ( ParseResult
  99   , parseFatalFailure
 100   , readFields
 101   )
 102 import Distribution.PackageDescription
 103   ( ignoreConditions
 104   )
 105 import Distribution.PackageDescription.FieldGrammar
 106   ( executableFieldGrammar
 107   )
 108 import Distribution.PackageDescription.PrettyPrint
 109   ( showGenericPackageDescription
 110   )
 111 import Distribution.Parsec
 112   ( Position (..)
 113   )
 114 import qualified Distribution.SPDX.License as SPDX
 115 import Distribution.Simple.Compiler
 116   ( Compiler (..)
 117   , OptimisationLevel (..)
 118   , compilerInfo
 119   )
 120 import Distribution.Simple.Flag
 121   ( flagToMaybe
 122   , fromFlagOrDefault
 123   )
 124 import Distribution.Simple.PackageDescription
 125   ( parseString
 126   )
 127 import Distribution.Simple.Setup
 128   ( Flag (..)
 129   )
 130 import Distribution.Simple.Utils
 131   ( createDirectoryIfMissingVerbose
 132   , createTempDirectory
 133   , dieWithException
 134   , handleDoesNotExist
 135   , readUTF8File
 136   , warn
 137   , writeUTF8File
 138   )
 139 import Distribution.Solver.Types.SourcePackage as SP
 140   ( SourcePackage (..)
 141   )
 142 import Distribution.System
 143   ( Platform (..)
 144   )
 145 import Distribution.Types.BuildInfo
 146   ( BuildInfo (..)
 147   )
 148 import Distribution.Types.ComponentId
 149   ( mkComponentId
 150   )
 151 import Distribution.Types.CondTree
 152   ( CondTree (..)
 153   )
 154 import Distribution.Types.Executable
 155   ( Executable (..)
 156   )
 157 import Distribution.Types.GenericPackageDescription as GPD
 158   ( GenericPackageDescription (..)
 159   , emptyGenericPackageDescription
 160   )
 161 import Distribution.Types.PackageDescription
 162   ( PackageDescription (..)
 163   , emptyPackageDescription
 164   )
 165 import Distribution.Types.PackageName.Magic
 166   ( fakePackageCabalFileName
 167   , fakePackageId
 168   )
 169 import Distribution.Types.UnitId
 170   ( newSimpleUnitId
 171   )
 172 import Distribution.Types.UnqualComponentName
 173   ( UnqualComponentName
 174   )
 175 import Distribution.Utils.NubList
 176   ( fromNubList
 177   )
 178 import Distribution.Verbosity
 179   ( normal
 180   )
 181 import Language.Haskell.Extension
 182   ( Language (..)
 183   )
 184
 185 import Control.Concurrent.MVar
 186   ( newEmptyMVar
 187   , putMVar
 188   , tryTakeMVar
 189   )
 190 import Control.Exception
 191   ( bracket
 192   )
 193 import qualified Data.ByteString.Char8 as BS
 194 import Data.ByteString.Lazy ()
 195 import qualified Data.Set as S
 196 import Distribution.Client.Errors
 197 import System.Directory
 198   ( canonicalizePath
 199   , doesFileExist
 200   , getTemporaryDirectory
 201   , removeDirectoryRecursive
 202   )
 203 import System.FilePath
 204   ( makeRelative
 205   , takeDirectory
 206   , takeFileName
 207   , (</>)
 208   )
 209 import qualified Text.Parsec as P
 210
 211 -- A note on multi-module script support #6787:
 212 -- Multi-module scripts are not supported and support is non-trivial.
 213 -- What you want to do is pass the absolute path to the script's directory in hs-source-dirs,
 214 -- but hs-source-dirs only accepts relative paths. This leaves you with several options none
 215 -- of which are particularly appealing.
 216 -- 1) Loosen the requirement that hs-source-dirs take relative paths
 217 -- 2) Add a field to BuildInfo that acts like an hs-source-dir, but accepts an absolute path
 218 -- 3) Use a path relative to the project root in hs-source-dirs, and pass extra flags to the
 219 --    repl to deal with the fact that the repl is relative to the working directory and not
 220 --    the project root.
 221
 222 -- | Get the hash of a script's absolute path.
 223 --
 224 -- Two hashes will be the same as long as the absolute paths
 225 -- are the same.
 226 getScriptHash :: FilePath -> IO String
 227 getScriptHash script =
 228   -- Truncation here tries to help with long path issues on Windows.
 229   showHashValue
 230     . truncateHash 26
 231     . hashValue
 232     . fromString
 233     <$> canonicalizePath script
 234
 235 -- | Get the directory for caching a script build.
 236 --
 237 -- The only identity of a script is it's absolute path, so append the
 238 -- hashed path to the @script-builds@ dir to get the cache directory.
 239 getScriptCacheDirectory :: FilePath -> IO FilePath
 240 getScriptCacheDirectory script = (</>) <$> defaultScriptBuildsDir <*> getScriptHash script
 241
 242 -- | Get the directory for caching a script build and ensure it exists.
 243 --
 244 -- The only identity of a script is it's absolute path, so append the
 245 -- hashed path to the @script-builds@ dir to get the cache directory.
 246 ensureScriptCacheDirectory :: Verbosity -> FilePath -> IO FilePath
 247 ensureScriptCacheDirectory verbosity script = do
 248   cacheDir <- getScriptCacheDirectory script
 249   createDirectoryIfMissingVerbose verbosity True cacheDir
 250   return cacheDir
 251
 252 -- | What your command should do when no targets are found.
 253 data AcceptNoTargets
 254   = -- | die on 'TargetSelectorNoTargetsInProject'
 255     RejectNoTargets
 256   | -- | return a default 'TargetSelector'
 257     AcceptNoTargets
 258   deriving (Eq, Show)
 259
 260 -- | Information about the context in which we found the 'TargetSelector's.
 261 data TargetContext
 262   = -- | The target selectors are part of a project.
 263     ProjectContext
 264   | -- | The target selectors are from the global context.
 265     GlobalContext
 266   | -- | The target selectors refer to a script. Contains the path to the script and
 267     -- the executable metadata parsed from the script
 268     ScriptContext FilePath Executable
 269   deriving (Eq, Show)
 270
 271 -- | Determine whether the targets represent regular targets or a script
 272 -- and return the proper context and target selectors.
 273 -- Die with an error message if selectors are valid as neither regular targets or as a script.
 274 --
 275 -- In the case that the context refers to a temporary directory,
 276 -- delete it after the action finishes.
 277 withContextAndSelectors
 278   :: AcceptNoTargets
 279   -- ^ What your command should do when no targets are found.
 280   -> Maybe ComponentKind
 281   -- ^ A target filter
 282   -> NixStyleFlags a
 283   -- ^ Command line flags
 284   -> [String]
 285   -- ^ Target strings or a script and args.
 286   -> GlobalFlags
 287   -- ^ Global flags.
 288   -> CurrentCommand
 289   -- ^ Current Command (usually for error reporting).
 290   -> (TargetContext -> ProjectBaseContext -> [TargetSelector] -> IO b)
 291   -- ^ The body of your command action.
 292   -> IO b
 293 withContextAndSelectors noTargets kind flags@NixStyleFlags{..} targetStrings globalFlags cmd act =
 294   withTemporaryTempDirectory $ \mkTmpDir -> do
 295     (tc, ctx) <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag withProject (withoutProject mkTmpDir)
 296
 297     (tc', ctx', sels) <- case targetStrings of
 298       -- Only script targets may contain spaces and or end with ':'.
 299       -- Trying to readTargetSelectors such a target leads to a parse error.
 300       [target] | any (\c -> isSpace c) target || ":" `isSuffixOf` target -> do
 301         scriptOrError target [TargetSelectorNoScript $ TargetString1 target]
 302       _ -> do
 303         -- In the case where a selector is both a valid target and script, assume it is a target,
 304         -- because you can disambiguate the script with "./script"
 305         readTargetSelectors (localPackages ctx) kind targetStrings >>= \case
 306           Left err@(TargetSelectorNoTargetsInProject : _)
 307             | [] <- targetStrings
 308             , AcceptNoTargets <- noTargets ->
 309                 return (tc, ctx, defaultTarget)
 310             | (script : _) <- targetStrings -> scriptOrError script err
 311           Left err@(TargetSelectorNoSuch t _ : _)
 312             | TargetString1 script <- t -> scriptOrError script err
 313           Left err@(TargetSelectorExpected t _ _ : _)
 314             | TargetString1 script <- t -> scriptOrError script err
 315           Left err@(MatchingInternalError _ _ _ : _) -- Handle ':' in middle of script name.
 316             | [script] <- targetStrings -> scriptOrError script err
 317           Left err -> reportTargetSelectorProblems verbosity err
 318           Right sels -> return (tc, ctx, sels)
 319
 320     act tc' ctx' sels
 321   where
 322     verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
 323     ignoreProject = flagIgnoreProject projectFlags
 324     cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty
 325     globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig)
 326     defaultTarget = [TargetPackage TargetExplicitNamed [fakePackageId] Nothing]
 327
 328     withProject = do
 329       ctx <- establishProjectBaseContext verbosity cliConfig cmd
 330       return (ProjectContext, ctx)
 331     withoutProject mkTmpDir globalConfig = do
 332       distDirLayout <- establishDummyDistDirLayout verbosity (globalConfig <> cliConfig) =<< mkTmpDir
 333       ctx <- establishDummyProjectBaseContext verbosity (globalConfig <> cliConfig) distDirLayout [] cmd
 334       return (GlobalContext, ctx)
 335
 336     scriptBaseCtx script globalConfig = do
 337       let noDistDir = mempty{projectConfigShared = mempty{projectConfigDistDir = Flag ""}}
 338       let cfg = noDistDir <> globalConfig <> cliConfig
 339       rootDir <- ensureScriptCacheDirectory verbosity script
 340       distDirLayout <- establishDummyDistDirLayout verbosity cfg rootDir
 341       establishDummyProjectBaseContext verbosity cfg distDirLayout [] cmd
 342
 343     scriptOrError script err = do
 344       exists <- doesFileExist script
 345       if exists
 346         then do
 347           ctx <- withGlobalConfig verbosity globalConfigFlag (scriptBaseCtx script)
 348
 349           let projectRoot = distProjectRootDirectory $ distDirLayout ctx
 350           writeFile (projectRoot </> "scriptlocation") =<< canonicalizePath script
 351
 352           scriptContents <- BS.readFile script
 353           executable <- readExecutableBlockFromScript verbosity scriptContents
 354
 355           httpTransport <-
 356             configureTransport
 357               verbosity
 358               (fromNubList . projectConfigProgPathExtra $ projectConfigShared cliConfig)
 359               (flagToMaybe . projectConfigHttpTransport $ projectConfigBuildOnly cliConfig)
 360
 361           projectCfgSkeleton <- readProjectBlockFromScript verbosity httpTransport (distDirLayout ctx) (takeFileName script) scriptContents
 362
 363           createDirectoryIfMissingVerbose verbosity True (distProjectCacheDirectory $ distDirLayout ctx)
 364           (compiler, platform@(Platform arch os), _) <- runRebuild projectRoot $ configureCompiler verbosity (distDirLayout ctx) (fst (ignoreConditions projectCfgSkeleton) <> projectConfig ctx)
 365
 366           projectCfg <- instantiateProjectConfigSkeletonFetchingCompiler (pure (os, arch, compilerInfo compiler)) mempty projectCfgSkeleton
 367
 368           let ctx' = ctx & lProjectConfig %~ (<> projectCfg)
 369
 370               build_dir = distBuildDirectory (distDirLayout ctx') $ (scriptDistDirParams script) ctx' compiler platform
 371               exePath = build_dir </> "bin" </> scriptExeFileName script
 372               exePathRel = makeRelative projectRoot exePath
 373
 374               executable' =
 375                 executable
 376                   & L.buildInfo . L.defaultLanguage %~ maybe (Just Haskell2010) Just
 377                   & L.buildInfo . L.options %~ fmap (setExePath exePathRel)
 378
 379           createDirectoryIfMissingVerbose verbosity True (takeDirectory exePath)
 380
 381           return (ScriptContext script executable', ctx', defaultTarget)
 382         else reportTargetSelectorProblems verbosity err
 383
 384 withTemporaryTempDirectory :: (IO FilePath -> IO a) -> IO a
 385 withTemporaryTempDirectory act = newEmptyMVar >>= \m -> bracket (getMkTmp m) (rmTmp m) act
 386   where
 387     -- We return an (IO Filepath) instead of a FilePath for two reasons:
 388     -- 1) To give the consumer the discretion to not create the tmpDir,
 389     --    but still grantee that it's deleted if they do create it
 390     -- 2) Because the path returned by createTempDirectory is not predicable
 391     getMkTmp m = return $ do
 392       tmpDir <- getTemporaryDirectory >>= flip createTempDirectory "cabal-repl."
 393       putMVar m tmpDir
 394       return tmpDir
 395     rmTmp m _ = tryTakeMVar m >>= maybe (return ()) (handleDoesNotExist () . removeDirectoryRecursive)
 396
 397 scriptComponenetName :: IsString s => FilePath -> s
 398 scriptComponenetName scriptPath = fromString cname
 399   where
 400     cname = "script-" ++ map censor (takeFileName scriptPath)
 401     censor c
 402       | c `S.member` ccNamecore = c
 403       | otherwise = '_'
 404
 405 scriptExeFileName :: FilePath -> FilePath
 406 scriptExeFileName scriptPath = "cabal-script-" ++ takeFileName scriptPath
 407
 408 scriptDistDirParams :: FilePath -> ProjectBaseContext -> Compiler -> Platform -> DistDirParams
 409 scriptDistDirParams scriptPath ctx compiler platform =
 410   DistDirParams
 411     { distParamUnitId = newSimpleUnitId cid
 412     , distParamPackageId = fakePackageId
 413     , distParamComponentId = cid
 414     , distParamComponentName = Just $ CExeName cn
 415     , distParamCompilerId = compilerId compiler
 416     , distParamPlatform = platform
 417     , distParamOptimization = fromFlagOrDefault NormalOptimisation optimization
 418     }
 419   where
 420     cn = scriptComponenetName scriptPath
 421     cid = mkComponentId $ prettyShow fakePackageId <> "-inplace-" <> prettyShow cn
 422     optimization = (packageConfigOptimization . projectConfigLocalPackages . projectConfig) ctx
 423
 424 setExePath :: FilePath -> [String] -> [String]
 425 setExePath exePath options
 426   | "-o" `notElem` options = "-o" : exePath : options
 427   | otherwise = options
 428
 429 -- | Add the 'SourcePackage' to the context and use it to write a .cabal file.
 430 updateContextAndWriteProjectFile' :: ProjectBaseContext -> SourcePackage (PackageLocation (Maybe FilePath)) -> IO ProjectBaseContext
 431 updateContextAndWriteProjectFile' ctx srcPkg = do
 432   let projectRoot = distProjectRootDirectory $ distDirLayout ctx
 433       packageFile = projectRoot </> fakePackageCabalFileName
 434       contents = showGenericPackageDescription (srcpkgDescription srcPkg)
 435       writePackageFile = writeUTF8File packageFile contents
 436   -- TODO This is here to prevent reconfiguration of cached repl packages.
 437   -- It's worth investigating why it's needed in the first place.
 438   packageFileExists <- doesFileExist packageFile
 439   if packageFileExists
 440     then do
 441       cached <- force <$> readUTF8File packageFile
 442       when
 443         (cached /= contents)
 444         writePackageFile
 445     else writePackageFile
 446   return (ctx & lLocalPackages %~ (++ [SpecificSourcePackage srcPkg]))
 447
 448 -- | Add add the executable metadata to the context and write a .cabal file.
 449 updateContextAndWriteProjectFile :: ProjectBaseContext -> FilePath -> Executable -> IO ProjectBaseContext
 450 updateContextAndWriteProjectFile ctx scriptPath scriptExecutable = do
 451   let projectRoot = distProjectRootDirectory $ distDirLayout ctx
 452
 453   absScript <- canonicalizePath scriptPath
 454   let
 455     sourcePackage =
 456       fakeProjectSourcePackage projectRoot
 457         & lSrcpkgDescription . L.condExecutables
 458           .~ [(scriptComponenetName scriptPath, CondNode executable (targetBuildDepends $ buildInfo executable) [])]
 459     executable =
 460       scriptExecutable
 461         & L.modulePath .~ absScript
 462
 463   updateContextAndWriteProjectFile' ctx sourcePackage
 464
 465 parseScriptBlock :: BS.ByteString -> ParseResult Executable
 466 parseScriptBlock str =
 467   case readFields str of
 468     Right fs -> do
 469       let (fields, _) = takeFields fs
 470       parseFieldGrammar cabalSpecLatest fields (executableFieldGrammar "script")
 471     Left perr -> parseFatalFailure pos (show perr)
 472       where
 473         ppos = P.errorPos perr
 474         pos = Position (P.sourceLine ppos) (P.sourceColumn ppos)
 475
 476 readScriptBlock :: Verbosity -> BS.ByteString -> IO Executable
 477 readScriptBlock verbosity = parseString parseScriptBlock verbosity "script block"
 478
 479 -- | Extract the first encountered executable metadata block started and
 480 -- terminated by the below tokens or die.
 481 --
 482 -- * @{- cabal:@
 483 --
 484 -- * @-}@
 485 --
 486 -- Return the metadata.
 487 readExecutableBlockFromScript :: Verbosity -> BS.ByteString -> IO Executable
 488 readExecutableBlockFromScript verbosity str = do
 489   str' <- case extractScriptBlock "cabal" str of
 490     Left e -> dieWithException verbosity $ FailedExtractingScriptBlock e
 491     Right x -> return x
 492   when (BS.all isSpace str') $ warn verbosity "Empty script block"
 493   readScriptBlock verbosity str'
 494
 495 -- | Extract the first encountered project metadata block started and
 496 -- terminated by the below tokens.
 497 --
 498 -- * @{- project:@
 499 --
 500 -- * @-}@
 501 --
 502 -- Return the metadata.
 503 readProjectBlockFromScript :: Verbosity -> HttpTransport -> DistDirLayout -> String -> BS.ByteString -> IO ProjectConfigSkeleton
 504 readProjectBlockFromScript verbosity httpTransport DistDirLayout{distDownloadSrcDirectory} scriptName str = do
 505   case extractScriptBlock "project" str of
 506     Left _ -> return mempty
 507     Right x ->
 508       reportParseResult verbosity "script" scriptName
 509         =<< parseProjectSkeleton distDownloadSrcDirectory httpTransport verbosity [] scriptName x
 510
 511 -- | Extract the first encountered script metadata block started end
 512 -- terminated by the tokens
 513 --
 514 -- * @{- <header>:@
 515 --
 516 -- * @-}@
 517 --
 518 -- appearing alone on lines (while tolerating trailing whitespace).
 519 -- These tokens are not part of the 'Right' result.
 520 --
 521 -- In case of missing or unterminated blocks a 'Left'-error is
 522 -- returned.
 523 extractScriptBlock :: BS.ByteString -> BS.ByteString -> Either String BS.ByteString
 524 extractScriptBlock header str = goPre (BS.lines str)
 525   where
 526     isStartMarker = (== startMarker) . stripTrailSpace
 527     isEndMarker = (== endMarker) . stripTrailSpace
 528
 529     stripTrailSpace = fst . BS.spanEnd isSpace
 530
 531     -- before start marker
 532     goPre ls = case dropWhile (not . isStartMarker) ls of
 533       [] -> Left $ "`" ++ BS.unpack startMarker ++ "` start marker not found"
 534       (_ : ls') -> goBody [] ls'
 535
 536     goBody _ [] = Left $ "`" ++ BS.unpack endMarker ++ "` end marker not found"
 537     goBody acc (l : ls)
 538       | isEndMarker l = Right $! BS.unlines $ reverse acc
 539       | otherwise = goBody (l : acc) ls
 540
 541     startMarker, endMarker :: BS.ByteString
 542     startMarker = "{- " <> header <> ":"
 543     endMarker = "-}"
 544
 545 -- | The base for making a 'SourcePackage' for a fake project.
 546 -- It needs a 'Distribution.Types.Library.Library' or 'Executable' depending on the command.
 547 fakeProjectSourcePackage :: FilePath -> SourcePackage (PackageLocation loc)
 548 fakeProjectSourcePackage projectRoot = sourcePackage
 549   where
 550     sourcePackage =
 551       SourcePackage
 552         { srcpkgPackageId = fakePackageId
 553         , srcpkgDescription = genericPackageDescription
 554         , srcpkgSource = LocalUnpackedPackage projectRoot
 555         , srcpkgDescrOverride = Nothing
 556         }
 557     genericPackageDescription =
 558       emptyGenericPackageDescription
 559         { GPD.packageDescription = packageDescription
 560         }
 561     packageDescription =
 562       emptyPackageDescription
 563         { package = fakePackageId
 564         , specVersion = CabalSpecV2_2
 565         , licenseRaw = Left SPDX.NONE
 566         }
 567
 568 -- | Find the path of an exe that has been relocated with a "-o" option
 569 movedExePath :: UnqualComponentName -> DistDirLayout -> ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> Maybe FilePath
 570 movedExePath selectedComponent distDirLayout elabShared elabConfigured = do
 571   exe <- find ((== selectedComponent) . exeName) . executables $ elabPkgDescription elabConfigured
 572   let CompilerId flavor _ = (compilerId . pkgConfigCompiler) elabShared
 573   opts <- lookup flavor (perCompilerFlavorToList . options $ buildInfo exe)
 574   let projectRoot = distProjectRootDirectory distDirLayout
 575   fmap (projectRoot </>) . lookup "-o" $ reverse (zip opts (drop 1 opts))
 576
 577 -- Lenses
 578
 579 -- | A lens for the 'srcpkgDescription' field of 'SourcePackage'
 580 lSrcpkgDescription :: Lens' (SourcePackage loc) GenericPackageDescription
 581 lSrcpkgDescription f s = fmap (\x -> s{srcpkgDescription = x}) (f (srcpkgDescription s))
 582 {-# INLINE lSrcpkgDescription #-}
 583
 584 lLocalPackages :: Lens' ProjectBaseContext [PackageSpecifier UnresolvedSourcePackage]
 585 lLocalPackages f s = fmap (\x -> s{localPackages = x}) (f (localPackages s))
 586 {-# INLINE lLocalPackages #-}
 587
 588 lProjectConfig :: Lens' ProjectBaseContext ProjectConfig
 589 lProjectConfig f s = fmap (\x -> s{projectConfig = x}) (f (projectConfig s))
 590 {-# INLINE lProjectConfig #-}
 591
 592 -- Character classes
 593 -- Transcribed from "templates/Lexer.x"
 594 ccSpace, ccCtrlchar, ccPrintable, ccSymbol', ccParen, ccNamecore :: Set Char
 595 ccSpace = S.fromList " "
 596 ccCtrlchar = S.fromList $ [chr 0x0 .. chr 0x1f] ++ [chr 0x7f]
 597 ccPrintable = S.fromList [chr 0x0 .. chr 0xff] S.\\ ccCtrlchar
 598 ccSymbol' = S.fromList ",=<>+*&|!$%^@#?/\\~"
 599 ccParen = S.fromList "()[]"
 600 ccNamecore = ccPrintable S.\\ S.unions [ccSpace, S.fromList ":\"{}", ccParen, ccSymbol']