Rename Ways.hs => Way.hs and refactor it.

src/Base.hs

@@ -27,10 +27,6 @@ data Stage = Stage0 | Stage1 | Stage2 | Stage3 deriving (Eq, Enum, Generic)
 instance Show Stage where
     show = show . fromEnum
 
--- Instances for storing Target in the Shake database
-instance Binary Stage
-instance Hashable Stage
-
 -- The returned string or list of strings is a part of an argument list
 -- to be passed to a Builder
 type Arg     = Action String
@@ -73,3 +69,7 @@ concatArgs as bs = do
     as' <- showArgs as
     bs' <- showArgs bs
     return $ map concat $ sequence [as', bs']
+
+-- Instances for storing in the Shake database
+instance Binary Stage
+instance Hashable Stage

src/Builder.hs

@@ -87,6 +87,6 @@ needBuilder builder = do
     path <- builderPath builder
     need [path]
 
--- Instances for storing Target in the Shake database
+-- Instances for storing in the Shake database
 instance Binary Builder
 instance Hashable Builder

src/Expression.hs

@@ -11,8 +11,8 @@ module Expression (
     configKeyValue, configKeyValues
     ) where
 
+import Way
 import Base
-import Ways
 import Builder
 import Package
 import Target

src/Package.hs

@@ -25,11 +25,6 @@ instance Eq Package where
 instance Ord Package where
     compare = compare `on` pkgName
 
-instance Binary Package
-
-instance Hashable Package where
-    hashWithSalt salt = hashWithSalt salt . show
-
 -- TODO: check if unifyPath is actually needed
 library :: String -> Package
 library name =
@@ -40,3 +35,8 @@ topLevel name = Package name name (name <.> "cabal")
 
 setCabal :: Package -> FilePath -> Package
 setCabal pkg cabalName = pkg { pkgCabal = cabalName }
+
+-- Instances for storing in the Shake database
+instance Binary Package
+instance Hashable Package where
+    hashWithSalt salt = hashWithSalt salt . show

src/Rules/Data.hs

@@ -4,6 +4,7 @@ module Rules.Data (
     cabalArgs, ghcPkgArgs, buildPackageData
     ) where
 
+import Way
 import Base
 import Package
 import Builder
@@ -14,7 +15,6 @@ import Settings.GhcCabal
 import Settings.TargetDirectory
 import Rules.Actions
 import Util
-import Ways
 
 -- Build package-data.mk by using GhcCabal to process pkgCabal file
 buildPackageData :: StagePackageTarget -> Rules ()

src/Settings/GhcCabal.hs

@@ -2,10 +2,10 @@ module Settings.GhcCabal (
     cabalArgs, bootPackageDbArgs, customPackageArgs
     ) where
 
+import Way
 import Base
 import Builder
 import Package
-import Ways
 import Util
 import Oracles.Base
 import Switches

src/Settings/Util.hs

@@ -102,3 +102,18 @@ appendCcArgs xs = do
 -- -- An ordered list of prefixed arguments: prefix </> arg1, prefix </> arg2, ...
 -- argPrefixPath :: String -> Args -> Args
 -- argPrefixPath prefix = fmap (Fold ConcatPath . (arg prefix |>) . return)
+
+-- TODO: do '-ticky' in all debug ways?
+-- wayHcArgs :: Way -> Args
+-- wayHcArgs (Way _ units) = args
+--     [ if (Dynamic    `elem` units)
+--       then args ["-fPIC", "-dynamic"]
+--       else arg "-static"
+--     , when (Threaded   `elem` units) $ arg "-optc-DTHREADED_RTS"
+--     , when (Debug      `elem` units) $ arg "-optc-DDEBUG"
+--     , when (Profiling  `elem` units) $ arg "-prof"
+--     , when (Logging    `elem` units) $ arg "-eventlog"
+--     , when (Parallel   `elem` units) $ arg "-parallel"
+--     , when (GranSim    `elem` units) $ arg "-gransim"
+--     , when (units == [Debug] || units == [Debug, Dynamic]) $
+--       args ["-ticky", "-DTICKY_TICKY"] ]

src/Settings/Ways.hs

@@ -2,8 +2,8 @@ module Settings.Ways (
     ways
     ) where
 
+import Way
 import Base
-import Ways
 import Switches
 import Expression
 import Settings.User

src/Target.hs

@@ -4,8 +4,8 @@ module Target (
     stageTarget, stagePackageTarget, fullTarget
     ) where
 
+import Way
 import Base
-import Ways
 import Package
 import Builder
 import GHC.Generics
@@ -70,7 +70,7 @@ instance Show FullTarget where
                   ++ " (" ++ show (getBuilder target)
                   ++ ", " ++ show (getWay target) ++ ")"
 
--- Instances for storing FullTarget in the Shake database
+-- Instances for storing in the Shake database
 instance Binary FullTarget
 instance NFData FullTarget
 instance Hashable FullTarget

src/Way.hs

+module Way ( -- TODO: rename to "Way"?
+    WayUnit (..),
+    Way, wayFromUnits, wayUnit,
+
+    vanilla, profiling, logging, parallel, granSim,
+    threaded, threadedProfiling, threadedLogging,
+    debug, debugProfiling, threadedDebug, threadedDebugProfiling,
+    dynamic, profilingDynamic, threadedProfilingDynamic,
+    threadedDynamic, threadedDebugDynamic, debugDynamic,
+    loggingDynamic, threadedLoggingDynamic,
+
+    wayPrefix, hisuf, osuf, hcsuf, obootsuf, ssuf, libsuf,
+    detectWay
+    ) where
+
+import Base
+import Util
+import Data.IntSet (IntSet)
+import qualified Data.IntSet as IntSet
+import Oracles.Option
+import Development.Shake.Classes
+
+data WayUnit = Threaded
+             | Debug
+             | Profiling
+             | Logging
+             | Dynamic
+             | Parallel
+             | GranSim
+             deriving Enum
+
+instance Show WayUnit where
+    show unit = case unit of
+        Threaded  -> "thr"
+        Debug     -> "debug"
+        Profiling -> "p"
+        Logging   -> "l"
+        Dynamic   -> "dyn"
+        Parallel  -> "mp"
+        GranSim   -> "gm"
+
+instance Read WayUnit where
+    readsPrec _ s = [(unit, "") | unit <- [Threaded ..], show unit == s]
+
+newtype Way = Way IntSet
+
+wayFromUnits :: [WayUnit] -> Way
+wayFromUnits = Way . IntSet.fromList . map fromEnum
+
+wayToUnits :: Way -> [WayUnit]
+wayToUnits (Way set) = map toEnum . IntSet.elems $ set
+
+wayUnit :: WayUnit -> Way -> Bool
+wayUnit unit (Way set) = fromEnum unit `IntSet.member` set
+
+instance Show Way where
+    show way = if null tag then "v" else tag
+      where
+        tag = intercalate "_" . map show . wayToUnits $ way
+
+instance Read Way where
+    readsPrec _ s =
+        if s == "v"
+        then [(vanilla, "")]
+        else [(wayFromUnits . map read . words . replaceEq '_' ' ' $ s, "")]
+
+instance Eq Way where
+    Way a == Way b = a == b
+
+vanilla   = wayFromUnits []
+profiling = wayFromUnits [Profiling]
+logging   = wayFromUnits [Logging]
+parallel  = wayFromUnits [Parallel]
+granSim   = wayFromUnits [GranSim]
+
+-- RTS only ways
+-- TODO: do we need to define *only* these? Shall we generalise/simplify?
+threaded                 = wayFromUnits [Threaded]
+threadedProfiling        = wayFromUnits [Threaded, Profiling]
+threadedLogging          = wayFromUnits [Threaded, Logging]
+debug                    = wayFromUnits [Debug]
+debugProfiling           = wayFromUnits [Debug, Profiling]
+threadedDebug            = wayFromUnits [Threaded, Debug]
+threadedDebugProfiling   = wayFromUnits [Threaded, Debug, Profiling]
+dynamic                  = wayFromUnits [Dynamic]
+profilingDynamic         = wayFromUnits [Profiling, Dynamic]
+threadedProfilingDynamic = wayFromUnits [Threaded, Profiling, Dynamic]
+threadedDynamic          = wayFromUnits [Threaded, Dynamic]
+threadedDebugDynamic     = wayFromUnits [Threaded, Debug, Dynamic]
+debugDynamic             = wayFromUnits [Debug, Dynamic]
+loggingDynamic           = wayFromUnits [Logging, Dynamic]
+threadedLoggingDynamic   = wayFromUnits [Threaded, Logging, Dynamic]
+
+wayPrefix :: Way -> String
+wayPrefix way | way == vanilla = ""
+              | otherwise      = show way ++ "_"
+
+hisuf, osuf, hcsuf, obootsuf, ssuf :: Way -> String
+osuf     = (++ "o"     ) . wayPrefix
+ssuf     = (++ "s"     ) . wayPrefix
+hisuf    = (++ "hi"    ) . wayPrefix
+hcsuf    = (++ "hc"    ) . wayPrefix
+obootsuf = (++ "o-boot") . wayPrefix
+
+-- Note: in the previous build system libsuf was mysteriously different
+-- from other suffixes. For example, in the profiling way it used to be
+-- "_p.a" instead of ".p_a" which is how other suffixes work. I decided
+-- to make all suffixes consistent: ".way_extension".
+-- TODO: find out why we need version number in the dynamic suffix
+-- The current theory: dynamic libraries are eventually placed in a single
+-- giant directory in the load path of the dynamic linker, and hence we must
+-- distinguish different versions of GHC. In contrast static libraries live
+-- in their own per-package directory and hence do not need a unique filename.
+-- We also need to respect the system's dynamic extension, e.g. .dll or .so.
+libsuf :: Way -> Action String
+libsuf way @ (Way set) =
+    if (not . wayUnit Dynamic $ way)
+    then return $ wayPrefix way ++ "a" -- e.g., p_a
+    else do
+        extension <- showArg DynamicExtension  -- e.g., .dll or .so
+        version   <- showArg ProjectVersion    -- e.g., 7.11.20141222
+        let prefix = wayPrefix . Way . IntSet.delete (fromEnum Dynamic) $ set
+        -- e.g., p_ghc7.11.20141222.dll (the result)
+        return $ prefix ++ "ghc" ++ version ++ extension
+
+-- Detect way from a given file extension. Fails if there is no match.
+detectWay :: FilePath -> Way
+detectWay extension = read prefix
+  where
+    prefix = dropWhileEnd (== '_') . dropWhileEnd (/= '_') $ extension
+
+-- Instances for storing in the Shake database
+instance Binary Way where
+    put = put . show
+    get = read <$> get
+
+instance Hashable Way where
+    hashWithSalt salt = hashWithSalt salt . show

src/Ways.hs

-{-# LANGUAGE DeriveGeneric #-}
-module Ways ( -- TODO: rename to "Way"?
-    WayUnit (..),
-    Way, tag,
-
-    allWays,
-
-    vanilla, profiling, logging, parallel, granSim,
-    threaded, threadedProfiling, threadedLogging,
-    debug, debugProfiling, threadedDebug, threadedDebugProfiling,
-    dynamic, profilingDynamic, threadedProfilingDynamic,
-    threadedDynamic, threadedDebugDynamic, debugDynamic,
-    loggingDynamic, threadedLoggingDynamic,
-
-    wayPrefix,
-    hisuf, osuf, hcsuf, obootsuf, ssuf, libsuf,
-    detectWay
-    ) where
-
-import Base
-import Oracles.Option
-import GHC.Generics
-import Development.Shake.Classes
-
-data WayUnit = Profiling
-             | Logging
-             | Parallel
-             | GranSim
-             | Threaded
-             | Debug
-             | Dynamic
-             deriving (Eq, Generic)
-
--- TODO: think about Booleans instead of a list of ways.
-data Way = Way
-     {
-         tag         :: String,    -- e.g., "thr_p"
-         units       :: [WayUnit]  -- e.g., [Threaded, Profiling]
-     } deriving Generic
-
-instance Show Way where
-    show = tag
-
-instance Binary WayUnit
-instance Binary Way
-
-instance Hashable Way where
-    hashWithSalt salt = hashWithSalt salt . show
-
-instance Eq Way where
-    -- The tag is fully determined by the units
-    a == b = units a == units b
-
-vanilla   = Way "v"  []
-profiling = Way "p"  [Profiling]
-logging   = Way "l"  [Logging]
-parallel  = Way "mp" [Parallel]
-granSim   = Way "gm" [GranSim]
-
-isVanilla :: Way -> Bool
-isVanilla = null . units
-
--- RTS only ways
--- TODO: do we need to define *only* these? Shall we generalise/simplify?
-threaded                 = Way "thr"           [Threaded]
-threadedProfiling        = Way "thr_p"         [Threaded, Profiling]
-threadedLogging          = Way "thr_l"         [Threaded, Logging]
-debug                    = Way "debug"         [Debug]
-debugProfiling           = Way "debug_p"       [Debug, Profiling]
-threadedDebug            = Way "thr_debug"     [Threaded, Debug]
-threadedDebugProfiling   = Way "thr_debug_p"   [Threaded, Debug, Profiling]
-dynamic                  = Way "dyn"           [Dynamic]
-profilingDynamic         = Way "p_dyn"         [Profiling, Dynamic]
-threadedProfilingDynamic = Way "thr_p_dyn"     [Threaded, Profiling, Dynamic]
-threadedDynamic          = Way "thr_dyn"       [Threaded, Dynamic]
-threadedDebugDynamic     = Way "thr_debug_dyn" [Threaded, Debug, Dynamic]
-debugDynamic             = Way "debug_dyn"     [Debug, Dynamic]
-loggingDynamic           = Way "l_dyn"         [Logging, Dynamic]
-threadedLoggingDynamic   = Way "thr_l_dyn"     [Threaded, Logging, Dynamic]
-
-allWays = [vanilla, profiling, logging, parallel, granSim,
-    threaded, threadedProfiling, threadedLogging,
-    debug, debugProfiling, threadedDebug, threadedDebugProfiling,
-    dynamic, profilingDynamic, threadedProfilingDynamic,
-    threadedDynamic, threadedDebugDynamic, debugDynamic,
-    loggingDynamic, threadedLoggingDynamic]
-
--- defaultWays :: Stage -> Action [Way]
--- defaultWays stage = do
---     sharedLibs <- platformSupportsSharedLibs
---     return $ [vanilla]
---           ++ [profiling | stage /= Stage0]
---           ++ [dynamic   | sharedLibs     ]
-
--- TODO: do '-ticky' in all debug ways?
--- wayHcArgs :: Way -> Args
--- wayHcArgs (Way _ units) = args
---     [ if (Dynamic    `elem` units)
---       then args ["-fPIC", "-dynamic"]
---       else arg "-static"
---     , when (Threaded   `elem` units) $ arg "-optc-DTHREADED_RTS"
---     , when (Debug      `elem` units) $ arg "-optc-DDEBUG"
---     , when (Profiling  `elem` units) $ arg "-prof"
---     , when (Logging    `elem` units) $ arg "-eventlog"
---     , when (Parallel   `elem` units) $ arg "-parallel"
---     , when (GranSim    `elem` units) $ arg "-gransim"
---     , when (units == [Debug] || units == [Debug, Dynamic]) $
---       args ["-ticky", "-DTICKY_TICKY"] ]
-
-wayPrefix :: Way -> String
-wayPrefix way | isVanilla way = ""
-              | otherwise     = tag way ++ "_"
-
-hisuf, osuf, hcsuf, obootsuf, ssuf :: Way -> String
-osuf     = (++ "o"     ) . wayPrefix
-ssuf     = (++ "s"     ) . wayPrefix
-hisuf    = (++ "hi"    ) . wayPrefix
-hcsuf    = (++ "hc"    ) . wayPrefix
-obootsuf = (++ "o-boot") . wayPrefix
-
--- Note: in the previous build system libsuf was mysteriously different
--- from other suffixes. For example, in the profiling way it used to be
--- "_p.a" instead of ".p_a" which is how other suffixes work. I decided
--- to make all suffixes consistent: ".way_extension".
--- TODO: find out why we need version number in the dynamic suffix
--- The current theory: dynamic libraries are eventually placed in a single
--- giant directory in the load path of the dynamic linker, and hence we must
--- distinguish different versions of GHC. In contrast static libraries live
--- in their own per-package directory and hence do not need a unique filename.
--- We also need to respect the system's dynamic extension, e.g. .dll or .so.
--- TODO: fix the extension
-libsuf :: Way -> Action String
-libsuf way | Dynamic `notElem` units way
-           = return $ wayPrefix way ++ "a"             -- e.g., p_a
-           | otherwise
-           = do extension <- showArg DynamicExtension  -- e.g., .dll or .so
-                version   <- showArg ProjectVersion    -- e.g., 7.11.20141222
-                let suffix = wayPrefix $ dropDynamic way
-                -- e.g., p_ghc7.11.20141222.dll (the result)
-                return $ suffix ++ "ghc" ++ version ++ extension
-
--- TODO: This may be slow -- optimise if overhead is significant.
-dropDynamic :: Way -> Way
-dropDynamic way
-    | way == dynamic                  = vanilla
-    | way == profilingDynamic         = profiling
-    | way == threadedProfilingDynamic = threadedProfiling
-    | way == threadedDynamic          = threaded
-    | way == threadedDebugDynamic     = threadedDebug
-    | way == debugDynamic             = debug
-    | way == loggingDynamic           = logging
-    | way == threadedLoggingDynamic   = threadedLogging
-    | otherwise                       = way
-
--- Detect way from a given extension. Fail if the result is not unique.
--- TODO: This may be slow -- optimise if overhead is significant.
-detectWay :: FilePath -> Way
-detectWay extension =
-    let prefix = reverse $ dropWhile (/= '_') $ reverse extension
-        result = filter ((== prefix) . wayPrefix) allWays
-    in
-    case result of
-        [way] -> way
-        _     -> error $ "Cannot detect way from extension '"
-                       ++ extension ++ "'."