From a80fd54276c19b1da1f1b1f64c3ee0265ddef088 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 30 Aug 2018 16:26:40 +0300 Subject: [PATCH] Move store-related TH into its own module #4272 --- package.yaml | 1 + src/Stack/Build/Cache.hs | 30 ++++---- src/Stack/Constants.hs | 13 ++-- src/Stack/Options/Completion.hs | 11 +-- src/Stack/PackageDump.hs | 7 +- src/Stack/Snapshot.hs | 5 +- src/Stack/StoreTH.hs | 117 ++++++++++++++++++++++++++++++++ src/Stack/Types/TemplateName.hs | 28 ++------ 8 files changed, 155 insertions(+), 57 deletions(-) create mode 100644 src/Stack/StoreTH.hs diff --git a/package.yaml b/package.yaml index 5738d350ab..9e95f17e2e 100644 --- a/package.yaml +++ b/package.yaml @@ -231,6 +231,7 @@ library: - Stack.Sig.Sign - Stack.Snapshot - Stack.Solver + - Stack.StoreTH - Stack.Types.Build - Stack.Types.BuildPlan - Stack.Types.CompilerBuild diff --git a/src/Stack/Build/Cache.hs b/src/Stack/Build/Cache.hs index 7e82bfb6e4..66aaa2b5ee 100644 --- a/src/Stack/Build/Cache.hs +++ b/src/Stack/Build/Cache.hs @@ -1,7 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE OverloadedStrings #-} @@ -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 @@ -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 @@ -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 } @@ -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 @@ -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) @@ -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 @@ -202,7 +200,7 @@ 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 @@ -210,7 +208,7 @@ setTestSuccess :: HasEnvConfig env -> 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 @@ -218,7 +216,7 @@ unsetTestSuccess :: HasEnvConfig env -> 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 @@ -227,7 +225,7 @@ checkTestSuccess :: HasEnvConfig env checkTestSuccess dir = liftM (fromMaybe False) - ($(versionedDecodeFile testSuccessVC) =<< testSuccessFile dir) + (decodeTestSuccess =<< testSuccessFile dir) -------------------------------------- -- Precompiled Cache @@ -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' @@ -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, diff --git a/src/Stack/Constants.hs b/src/Stack/Constants.hs index 067f98b041..75e8c1deea 100644 --- a/src/Stack/Constants.hs +++ b/src/Stack/Constants.hs @@ -118,7 +118,7 @@ module Stack.Constants ,relFileStackDotExe ,relFileStackDotTmpDotExe ,relFileStackDotTmp - ,defaultTemplateName + ,ghcShowOptionsOutput ) where @@ -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] @@ -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) diff --git a/src/Stack/Options/Completion.hs b/src/Stack/Options/Completion.hs index 426cf297f7..bca7678f10 100644 --- a/src/Stack/Options/Completion.hs +++ b/src/Stack/Options/Completion.hs @@ -1,6 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} module Stack.Options.Completion @@ -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 $ @@ -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. diff --git a/src/Stack/PackageDump.hs b/src/Stack/PackageDump.hs index 59529557e4..802c202586 100644 --- a/src/Stack/PackageDump.hs +++ b/src/Stack/PackageDump.hs @@ -6,7 +6,6 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} module Stack.PackageDump ( Line , eachSection @@ -34,7 +33,6 @@ 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) @@ -42,6 +40,7 @@ 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 @@ -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. -- diff --git a/src/Stack/Snapshot.hs b/src/Stack/Snapshot.hs index 19b6c5a400..f915102eb3 100644 --- a/src/Stack/Snapshot.hs +++ b/src/Stack/Snapshot.hs @@ -9,7 +9,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} @@ -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 @@ -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 @@ -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 diff --git a/src/Stack/StoreTH.hs b/src/Stack/StoreTH.hs new file mode 100644 index 0000000000..0c8719c8a6 --- /dev/null +++ b/src/Stack/StoreTH.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module Stack.StoreTH + ( decodeBuildCache + , encodeBuildCache + + , decodeConfigCache + , encodeConfigCache + + , decodeModTime + , encodeModTime + + , decodeTestSuccess + , encodeTestSuccess + + , decodePrecompiledCache + , encodePrecompiledCache + + , decodeOrLoadInstalledCache + , encodeInstalledCache + + , decodeOrLoadLoadedSnapshot + ) where + +import Data.Store.VersionTagged +import Stack.Prelude +import Stack.Types.Build +import Stack.Types.BuildPlan +import Stack.Types.Package +import Stack.Types.PackageDump + +decodeBuildCache + :: HasLogFunc env + => Path Abs File + -> RIO env (Maybe BuildCache) +encodeBuildCache = $(versionedEncodeFile buildCacheVC) + +encodeBuildCache + :: HasLogFunc env + => Path Abs File + -> BuildCache + -> RIO env () +decodeBuildCache = $(versionedDecodeFile buildCacheVC) + +decodeConfigCache + :: HasLogFunc env + => Path Abs File + -> RIO env (Maybe ConfigCache) +decodeConfigCache = $(versionedDecodeFile configCacheVC) + +encodeConfigCache + :: HasLogFunc env + => Path Abs File + -> ConfigCache + -> RIO env () +encodeConfigCache = $(versionedEncodeFile configCacheVC) + +decodeModTime + :: HasLogFunc env + => Path Abs File + -> RIO env (Maybe ModTime) +decodeModTime = $(versionedDecodeFile modTimeVC) + +encodeModTime + :: HasLogFunc env + => Path Abs File + -> ModTime + -> RIO env () +encodeModTime = $(versionedEncodeFile modTimeVC) + +decodeTestSuccess + :: HasLogFunc env + => Path Abs File + -> RIO env (Maybe Bool) +decodeTestSuccess = $(versionedDecodeFile testSuccessVC) + +encodeTestSuccess + :: HasLogFunc env + => Path Abs File + -> Bool + -> RIO env () +encodeTestSuccess = $(versionedEncodeFile testSuccessVC) + +decodePrecompiledCache + :: HasLogFunc env + => Path Abs File + -> RIO env (Maybe PrecompiledCache) +decodePrecompiledCache = $(versionedDecodeFile precompiledCacheVC) + +encodePrecompiledCache + :: HasLogFunc env + => Path Abs File + -> PrecompiledCache + -> RIO env () +encodePrecompiledCache = $(versionedEncodeFile precompiledCacheVC) + +decodeOrLoadInstalledCache + :: HasLogFunc env + => Path Abs File + -> RIO env InstalledCacheInner + -> RIO env InstalledCacheInner +decodeOrLoadInstalledCache = $(versionedDecodeOrLoad installedCacheVC) + +encodeInstalledCache + :: HasLogFunc env + => Path Abs File + -> InstalledCacheInner + -> RIO env () +encodeInstalledCache = $(versionedEncodeFile installedCacheVC) + +decodeOrLoadLoadedSnapshot + :: HasLogFunc env + => Path Abs File + -> RIO env LoadedSnapshot + -> RIO env LoadedSnapshot +decodeOrLoadLoadedSnapshot = $(versionedDecodeOrLoad loadedSnapshotVC) diff --git a/src/Stack/Types/TemplateName.hs b/src/Stack/Types/TemplateName.hs index 90860b98dd..2a66343783 100644 --- a/src/Stack/Types/TemplateName.hs +++ b/src/Stack/Types/TemplateName.hs @@ -1,6 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -11,22 +10,20 @@ module Stack.Types.TemplateName , RepoTemplatePath (..) , RepoService (..) , TemplatePath (..) - , mkTemplateName , templateName , templatePath , parseTemplateNameFromString , parseRepoPathWithService , templateNameArgument , templateParamArgument + , defaultTemplateName ) where import Data.Aeson (FromJSON (..), withText) import qualified Data.Text as T -import Language.Haskell.TH import Network.HTTP.StackClient (parseRequest) import qualified Options.Applicative as O import Path -import Path.Internal import Stack.Prelude -- | A template name. @@ -101,23 +98,12 @@ parseTemplateNameFromString fname = expected = "Expected a template like: foo or foo.hsfiles or\ \ https://example.com/foo.hsfiles or github:user/foo" --- | Make a template name. -mkTemplateName :: String -> Q Exp -mkTemplateName s = - case parseTemplateNameFromString s of - Left{} -> runIO $ throwString ("Invalid template name: " ++ show s) - Right (TemplateName (T.unpack -> prefix) p) -> - [|TemplateName (T.pack prefix) $(pn)|] - where pn = - case p of - AbsPath (Path fp) -> [|AbsPath (Path fp)|] - RelPath (Path fp) -> [|RelPath (Path fp)|] - UrlPath fp -> [|UrlPath fp|] - RepoPath (RepoTemplatePath sv u t) -> - case sv of - Github -> [|RepoPath $ RepoTemplatePath Github u t|] - Gitlab -> [|RepoPath $ RepoTemplatePath Gitlab u t|] - Bitbucket -> [|RepoPath $ RepoTemplatePath Bitbucket u t|] +-- | The default template name you can use if you don't have one. +defaultTemplateName :: TemplateName +defaultTemplateName = + case parseTemplateNameFromString "new-template" of + Left s -> error $ "Bug in Stack codebase, cannot parse default template name: " ++ s + Right x -> x -- | Get a text representation of the template name. templateName :: TemplateName -> Text