[commit: ghc] wip/nfs-locking: Distringuish partial Targets using type synonyms. (c319fbb)

git at git.haskell.org git at git.haskell.org
Thu Oct 26 23:12:50 UTC 2017


Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/nfs-locking
Link       : http://ghc.haskell.org/trac/ghc/changeset/c319fbbf892b9a8a231676b3ecf9550d4b56a01b/ghc

>---------------------------------------------------------------

commit c319fbbf892b9a8a231676b3ecf9550d4b56a01b
Author: Andrey Mokhov <andrey.mokhov at gmail.com>
Date:   Tue Jul 14 16:07:42 2015 +0100

    Distringuish partial Targets using type synonyms.


>---------------------------------------------------------------

c319fbbf892b9a8a231676b3ecf9550d4b56a01b
 src/Oracles/ArgsHash.hs  |  4 ++--
 src/Rules/Data.hs        | 10 ++++-----
 src/Rules/Package.hs     |  2 +-
 src/Rules/Util.hs        |  2 +-
 src/Settings/Packages.hs |  5 ++++-
 src/Target.hs            | 55 ++++++++++++++++++++++++++++++++----------------
 6 files changed, 49 insertions(+), 29 deletions(-)

diff --git a/src/Oracles/ArgsHash.hs b/src/Oracles/ArgsHash.hs
index 1586b97..acb3e98 100644
--- a/src/Oracles/ArgsHash.hs
+++ b/src/Oracles/ArgsHash.hs
@@ -9,10 +9,10 @@ import Base
 import Settings
 import Expression
 
-newtype ArgsHashKey = ArgsHashKey Target
+newtype ArgsHashKey = ArgsHashKey FullTarget
                       deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
 
-askArgsHash :: Target -> Action Int
+askArgsHash :: FullTarget -> Action Int
 askArgsHash = askOracle . ArgsHashKey
 
 -- Oracle for storing per-target argument list hashes
diff --git a/src/Rules/Data.hs b/src/Rules/Data.hs
index 684cde6..2a40519 100644
--- a/src/Rules/Data.hs
+++ b/src/Rules/Data.hs
@@ -17,7 +17,7 @@ import Util
 import Ways
 
 -- Build package-data.mk by using GhcCabal to process pkgCabal file
-buildPackageData :: Target -> Rules ()
+buildPackageData :: StagePackageTarget -> Rules ()
 buildPackageData target =
     let stage = getStage target
         pkg   = getPackage target
@@ -33,16 +33,14 @@ buildPackageData target =
     -- , "build" </> "autogen" </> ("Paths_" ++ name) <.> "hs"
     ] &%> \_ -> do
         let configure = pkgPath pkg </> "configure"
-            -- TODO: 1) how to automate this? 2) handle multiple files?
-            newTarget = target { getFile = path </> "package-data.mk"
-                               , getWay = vanilla } -- TODO: think
         -- GhcCabal will run the configure script, so we depend on it
         need [pkgPath pkg </> pkgCabal pkg]
         -- We still don't know who built the configure script from configure.ac
         whenM (doesFileExist $ configure <.> "ac") $ need [configure]
-        build $ newTarget { getBuilder = GhcCabal }
+        -- TODO: 1) automate? 2) mutliple files 3) vanilla?
+        build $ fullTarget target (path </> "package-data.mk") GhcCabal vanilla
         -- TODO: when (registerPackage settings) $
-        build $ newTarget { getBuilder = GhcPkg stage }
+        build $ fullTarget target (path </> "package-data.mk") (GhcPkg stage) vanilla
         postProcessPackageData $ path </> "package-data.mk"
 
 -- Prepare a given 'packaga-data.mk' file for parsing by readConfigFile:
diff --git a/src/Rules/Package.hs b/src/Rules/Package.hs
index a5a09dd..e316805 100644
--- a/src/Rules/Package.hs
+++ b/src/Rules/Package.hs
@@ -6,5 +6,5 @@ import Base
 import Rules.Data
 import Expression
 
-buildPackage :: Target -> Rules ()
+buildPackage :: StagePackageTarget -> Rules ()
 buildPackage = buildPackageData
diff --git a/src/Rules/Util.hs b/src/Rules/Util.hs
index a18e25e..6e1296e 100644
--- a/src/Rules/Util.hs
+++ b/src/Rules/Util.hs
@@ -9,7 +9,7 @@ import Expression
 import Oracles.Builder
 import Oracles.ArgsHash
 
-build :: Target -> Action ()
+build :: FullTarget -> Action ()
 build target = do
     argList <- interpret target args
     putColoured Green (show target)
diff --git a/src/Settings/Packages.hs b/src/Settings/Packages.hs
index 7eaa5d5..b1d98de 100644
--- a/src/Settings/Packages.hs
+++ b/src/Settings/Packages.hs
@@ -1,4 +1,5 @@
 module Settings.Packages (
+    module Settings.Default,
     packages, knownPackages
     ) where
 
@@ -6,6 +7,7 @@ import Base
 import Package
 import Switches
 import Expression
+import Settings.Default
 import Settings.User
 
 -- Combining default list of packages with user modifications
@@ -25,7 +27,8 @@ packagesStage0 = mconcat
 
 packagesStage1 :: Packages
 packagesStage1 = mconcat
-    [ append [ array, base, bytestring, containers, deepseq, directory
+    [ packagesStage0
+    , append [ array, base, bytestring, containers, deepseq, directory
              , filepath, ghcPrim, haskeline, integerLibrary, parallel
              , pretty, primitive, process, stm, templateHaskell, time ]
     , windowsHost    ? append [win32]
diff --git a/src/Target.hs b/src/Target.hs
index 6161db7..0a0ed00 100644
--- a/src/Target.hs
+++ b/src/Target.hs
@@ -1,6 +1,7 @@
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveGeneric, TypeSynonymInstances #-}
 module Target (
-    Target (..), stageTarget, stagePackageTarget
+    Target (..), StageTarget (..), StagePackageTarget (..), FullTarget (..),
+    stageTarget, stagePackageTarget, fullTarget
     ) where
 
 import Base
@@ -17,41 +18,59 @@ data Target = Target
      {
         getStage   :: Stage,
         getPackage :: Package,
-        getBuilder :: Builder,
         getFile    :: FilePath, -- TODO: handle multple files?
+        getBuilder :: Builder,
         getWay     :: Way
      }
      deriving (Eq, Generic)
 
--- Shows a target as "package:file at stage (builder, way)"
-instance Show Target where
-    show target = show (getPackage target)
-                  ++ ":" ++ show (getFile target)
-                  ++ "@" ++ show (getStage target)
-                  ++ " (" ++ show (getBuilder target)
-                  ++ ", " ++ show (getWay target) ++ ")"
+-- StageTarget is a Target whose field getStage is already assigned
+type StageTarget = Target
 
-stageTarget :: Stage -> Target
+stageTarget :: Stage -> StageTarget
 stageTarget stage = Target
     {
         getStage   = stage,
         getPackage = error "stageTarget: Package not set",
-        getBuilder = error "stageTarget: Builder not set",
         getFile    = error "stageTarget: File not set",
+        getBuilder = error "stageTarget: Builder not set",
         getWay     = error "stageTarget: Way not set"
     }
 
-stagePackageTarget :: Stage -> Package -> Target
+-- StagePackageTarget is a Target whose fields getStage and getPackage are
+-- already assigned
+type StagePackageTarget = Target
+
+stagePackageTarget :: Stage -> Package -> StagePackageTarget
 stagePackageTarget stage package = Target
     {
         getStage   = stage,
         getPackage = package,
-        getBuilder = error "stagePackageTarget: Builder not set",
         getFile    = error "stagePackageTarget: File not set",
+        getBuilder = error "stagePackageTarget: Builder not set",
         getWay     = error "stagePackageTarget: Way not set"
     }
 
--- Instances for storing Target in the Shake database
-instance Binary Target
-instance NFData Target
-instance Hashable Target
+-- FullTarget is a Target whose fields are all assigned
+type FullTarget = Target
+
+fullTarget :: StagePackageTarget -> FilePath -> Builder -> Way -> FullTarget
+fullTarget target file builder way = target
+    {
+        getFile    = file,
+        getBuilder = builder,
+        getWay     = way
+    }
+
+-- Shows a (full) target as "package:file at stage (builder, way)"
+instance Show FullTarget where
+    show target = show (getPackage target)
+                  ++ ":" ++ getFile target
+                  ++ "@" ++ show (getStage target)
+                  ++ " (" ++ show (getBuilder target)
+                  ++ ", " ++ show (getWay target) ++ ")"
+
+-- Instances for storing FullTarget in the Shake database
+instance Binary FullTarget
+instance NFData FullTarget
+instance Hashable FullTarget



More information about the ghc-commits mailing list