Skip to content

Commit

Permalink
Move store-related TH into its own module #4272
Browse files Browse the repository at this point in the history
  • Loading branch information
snoyberg committed Aug 31, 2018
1 parent 73e713b commit a80fd54
Show file tree
Hide file tree
Showing 8 changed files with 155 additions and 57 deletions.
1 change: 1 addition & 0 deletions package.yaml
Original file line number Diff line number Diff line change
Expand Up @@ -231,6 +231,7 @@ library:
- Stack.Sig.Sign
- Stack.Snapshot
- Stack.Solver
- Stack.StoreTH
- Stack.Types.Build
- Stack.Types.BuildPlan
- Stack.Types.CompilerBuild
Expand Down
30 changes: 14 additions & 16 deletions src/Stack/Build/Cache.hs
Original file line number Diff line number Diff line change
@@ -1,7 +1,6 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE OverloadedStrings #-}
Expand Down Expand Up @@ -42,18 +41,17 @@ import Data.Char (ord)
import qualified Data.Map as M
import qualified Data.Set as Set
import qualified Data.Store as Store
import Data.Store.VersionTagged
import qualified Data.Text as T
import Path
import Path.IO
import Stack.Constants
import Stack.Constants.Config
import Stack.StoreTH
import Stack.Types.Build
import Stack.Types.Compiler
import Stack.Types.Config
import Stack.Types.GhcPkgId
import Stack.Types.NamedComponent
import Stack.Types.Package
import qualified System.FilePath as FP

-- | Directory containing files to mark an executable as installed
Expand Down Expand Up @@ -124,17 +122,17 @@ tryGetBuildCache :: HasEnvConfig env
=> Path Abs Dir
-> NamedComponent
-> RIO env (Maybe (Map FilePath FileCacheInfo))
tryGetBuildCache dir component = liftM (fmap buildCacheTimes) . $(versionedDecodeFile buildCacheVC) =<< buildCacheFile dir component
tryGetBuildCache dir component = liftM (fmap buildCacheTimes) . decodeBuildCache =<< buildCacheFile dir component

-- | Try to read the dirtiness cache for the given package directory.
tryGetConfigCache :: HasEnvConfig env
=> Path Abs Dir -> RIO env (Maybe ConfigCache)
tryGetConfigCache dir = $(versionedDecodeFile configCacheVC) =<< configCacheFile dir
tryGetConfigCache dir = decodeConfigCache =<< configCacheFile dir

-- | Try to read the mod time of the cabal file from the last build
tryGetCabalMod :: HasEnvConfig env
=> Path Abs Dir -> RIO env (Maybe ModTime)
tryGetCabalMod dir = $(versionedDecodeFile modTimeVC) =<< configCabalMod dir
tryGetCabalMod dir = decodeModTime =<< configCabalMod dir

-- | Write the dirtiness cache for this package's files.
writeBuildCache :: HasEnvConfig env
Expand All @@ -143,7 +141,7 @@ writeBuildCache :: HasEnvConfig env
-> Map FilePath FileCacheInfo -> RIO env ()
writeBuildCache dir component times = do
fp <- buildCacheFile dir component
$(versionedEncodeFile buildCacheVC) fp BuildCache
encodeBuildCache fp BuildCache
{ buildCacheTimes = times
}

Expand All @@ -154,7 +152,7 @@ writeConfigCache :: HasEnvConfig env
-> RIO env ()
writeConfigCache dir x = do
fp <- configCacheFile dir
$(versionedEncodeFile configCacheVC) fp x
encodeConfigCache fp x

-- | See 'tryGetCabalMod'
writeCabalMod :: HasEnvConfig env
Expand All @@ -163,7 +161,7 @@ writeCabalMod :: HasEnvConfig env
-> RIO env ()
writeCabalMod dir x = do
fp <- configCabalMod dir
$(versionedEncodeFile modTimeVC) fp x
encodeModTime fp x

-- | Delete the caches for the project.
deleteCaches :: (MonadIO m, MonadReader env m, HasEnvConfig env, MonadThrow m)
Expand Down Expand Up @@ -193,7 +191,7 @@ tryGetFlagCache :: HasEnvConfig env
-> RIO env (Maybe ConfigCache)
tryGetFlagCache gid = do
fp <- flagCacheFile gid
$(versionedDecodeFile configCacheVC) fp
decodeConfigCache fp

writeFlagCache :: HasEnvConfig env
=> Installed
Expand All @@ -202,23 +200,23 @@ writeFlagCache :: HasEnvConfig env
writeFlagCache gid cache = do
file <- flagCacheFile gid
ensureDir (parent file)
$(versionedEncodeFile configCacheVC) file cache
encodeConfigCache file cache

-- | Mark a test suite as having succeeded
setTestSuccess :: HasEnvConfig env
=> Path Abs Dir
-> RIO env ()
setTestSuccess dir = do
fp <- testSuccessFile dir
$(versionedEncodeFile testSuccessVC) fp True
encodeTestSuccess fp True

-- | Mark a test suite as not having succeeded
unsetTestSuccess :: HasEnvConfig env
=> Path Abs Dir
-> RIO env ()
unsetTestSuccess dir = do
fp <- testSuccessFile dir
$(versionedEncodeFile testSuccessVC) fp False
encodeTestSuccess fp False

-- | Check if the test suite already passed
checkTestSuccess :: HasEnvConfig env
Expand All @@ -227,7 +225,7 @@ checkTestSuccess :: HasEnvConfig env
checkTestSuccess dir =
liftM
(fromMaybe False)
($(versionedDecodeFile testSuccessVC) =<< testSuccessFile dir)
(decodeTestSuccess =<< testSuccessFile dir)

--------------------------------------
-- Precompiled Cache
Expand Down Expand Up @@ -315,7 +313,7 @@ writePrecompiledCache baseConfigOpts loc copts depIDs mghcPkgId sublibs exes = d
name <- parseRelFile $ T.unpack exe
relPath <- stackRootRelative $ bcoSnapInstallRoot baseConfigOpts </> bindirSuffix </> name
return $ toFilePath relPath
$(versionedEncodeFile precompiledCacheVC) file PrecompiledCache
encodePrecompiledCache file PrecompiledCache
{ pcLibrary = mlibpath
, pcSubLibs = sublibpaths
, pcExes = exes'
Expand All @@ -335,7 +333,7 @@ readPrecompiledCache :: forall env. HasEnvConfig env
-> RIO env (Maybe PrecompiledCache)
readPrecompiledCache loc copts depIDs = do
file <- precompiledCacheFile loc copts depIDs
mcache <- $(versionedDecodeFile precompiledCacheVC) file
mcache <- decodePrecompiledCache file
maybe (pure Nothing) (fmap Just . mkAbs) mcache
where
-- Since commit ed9ccc08f327bad68dd2d09a1851ce0d055c0422,
Expand Down
13 changes: 8 additions & 5 deletions src/Stack/Constants.hs
Original file line number Diff line number Diff line change
Expand Up @@ -118,7 +118,7 @@ module Stack.Constants
,relFileStackDotExe
,relFileStackDotTmpDotExe
,relFileStackDotTmp
,defaultTemplateName
,ghcShowOptionsOutput
)
where

Expand All @@ -127,11 +127,12 @@ import Data.FileEmbed (embedFile, makeRelativeToProject)
import qualified Data.Set as Set
import Distribution.Package (mkPackageName)
import qualified Hpack.Config as Hpack
import qualified Language.Haskell.TH.Syntax as TH (runIO, lift)
import Path as FL
import Stack.Prelude
import Stack.Types.Compiler
import Stack.Types.TemplateName
import System.Permissions (osIsWindows)
import System.Process (readProcess)

-- | Extensions used for Haskell modules. Excludes preprocessor ones.
haskellFileExts :: [Text]
Expand Down Expand Up @@ -584,6 +585,8 @@ relFileStackDotTmp = $(mkRelFile "stack.tmp")
relFileStack :: Path Rel File
relFileStack = $(mkRelFile "stack")

-- | The default template name you can use if you don't have one.
defaultTemplateName :: TemplateName
defaultTemplateName = $(mkTemplateName "new-template")
-- Technically, we should be consulting the user's current ghc,
-- but that would require loading up a BuildConfig.
ghcShowOptionsOutput :: [String]
ghcShowOptionsOutput =
$(TH.runIO (readProcess "ghc" ["--show-options"] "") >>= TH.lift . lines)
11 changes: 3 additions & 8 deletions src/Stack/Options/Completion.hs
Original file line number Diff line number Diff line change
@@ -1,6 +1,5 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}

module Stack.Options.Completion
Expand All @@ -21,14 +20,13 @@ import qualified Distribution.Types.UnqualComponentName as C
import Options.Applicative
import Options.Applicative.Builder.Extra
import Stack.Config (getLocalPackages)
import Stack.Constants (ghcShowOptionsOutput)
import Stack.Options.GlobalParser (globalOptsFromMonoid)
import Stack.Runners (loadConfigWithOpts)
import Stack.Prelude hiding (lift)
import Stack.Prelude
import Stack.Setup
import Stack.Types.Config
import Stack.Types.NamedComponent
import System.Process (readProcess)
import Language.Haskell.TH.Syntax (runIO, lift)

ghcOptsCompleter :: Completer
ghcOptsCompleter = mkCompleter $ \inputRaw -> return $
Expand All @@ -38,10 +36,7 @@ ghcOptsCompleter = mkCompleter $ \inputRaw -> return $
otherArgs = reverse otherArgsReversed
in if null curArg then [] else
map (otherArgs ++) $
filter (curArg `isPrefixOf`)
-- Technically, we should be consulting the user's current ghc,
-- but that would require loading up a BuildConfig.
$(runIO (readProcess "ghc" ["--show-options"] "") >>= lift . lines)
filter (curArg `isPrefixOf`) ghcShowOptionsOutput

-- TODO: Ideally this would pay attention to --stack-yaml, may require
-- changes to optparse-applicative.
Expand Down
7 changes: 3 additions & 4 deletions src/Stack/PackageDump.hs
Original file line number Diff line number Diff line change
Expand Up @@ -6,7 +6,6 @@
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TemplateHaskell #-}
module Stack.PackageDump
( Line
, eachSection
Expand Down Expand Up @@ -34,14 +33,14 @@ import qualified Data.Conduit.Text as CT
import Data.List (isPrefixOf)
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Store.VersionTagged
import qualified RIO.Text as T
import qualified Distribution.License as C
import Distribution.ModuleName (ModuleName)
import qualified Distribution.System as OS
import qualified Distribution.Text as C
import Path.Extra (toFilePathNoTrailingSep)
import Stack.GhcPkg
import Stack.StoreTH
import Stack.Types.Compiler
import Stack.Types.GhcPkgId
import Stack.Types.PackageDump
Expand Down Expand Up @@ -100,13 +99,13 @@ newInstalledCache = liftIO $ InstalledCache <$> newIORef (InstalledCacheInner Ma
-- empty cache.
loadInstalledCache :: HasLogFunc env => Path Abs File -> RIO env InstalledCache
loadInstalledCache path = do
m <- $(versionedDecodeOrLoad installedCacheVC) path (return $ InstalledCacheInner Map.empty)
m <- decodeOrLoadInstalledCache path (return $ InstalledCacheInner Map.empty)
liftIO $ InstalledCache <$> newIORef m

-- | Save a @InstalledCache@ to disk
saveInstalledCache :: HasLogFunc env => Path Abs File -> InstalledCache -> RIO env ()
saveInstalledCache path (InstalledCache ref) =
liftIO (readIORef ref) >>= $(versionedEncodeFile installedCacheVC) path
readIORef ref >>= encodeInstalledCache path

-- | Prune a list of possible packages down to those whose dependencies are met.
--
Expand Down
5 changes: 2 additions & 3 deletions src/Stack/Snapshot.hs
Original file line number Diff line number Diff line change
Expand Up @@ -9,7 +9,6 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}

Expand All @@ -24,7 +23,6 @@ module Stack.Snapshot

import Stack.Prelude hiding (Display (..))
import Control.Monad.State.Strict (get, put, StateT, execStateT)
import Data.Store.VersionTagged
import qualified Data.Conduit.List as CL
import qualified Data.Map as Map
import qualified Data.Set as Set
Expand All @@ -44,6 +42,7 @@ import qualified Pantry
import qualified Pantry.SHA256 as SHA256
import Stack.Package
import Stack.PackageDump
import Stack.StoreTH
import Stack.Types.BuildPlan
import Stack.Types.GhcPkgId
import Stack.Types.VersionIntervals
Expand Down Expand Up @@ -174,7 +173,7 @@ loadSnapshot mcompiler =
path <- configLoadedSnapshotCache
sd
(maybe GISSnapshotHints GISCompiler mcompiler)
$(versionedDecodeOrLoad loadedSnapshotVC) path (inner sd)
decodeOrLoadLoadedSnapshot path (inner sd)

inner :: SnapshotDef -> RIO env LoadedSnapshot
inner sd = do
Expand Down
Loading

0 comments on commit a80fd54

Please sign in to comment.