Commit cc8f62c0 authored by Alp Mestanogullari's avatar Alp Mestanogullari Committed by Andrey Mokhov

Move a bunch of types into dedicated modules (#502)

* move a bunch of types into dedicated modules

* address review feedback

* do away with Hadrian.Builder.Mode for now
parent 2e0e8aeb
......@@ -22,8 +22,10 @@ executable hadrian
, Builder
, CommandLine
, Context
, Context.Type
, Environment
, Expression
, Expression.Type
, Flavour
, GHC
, Hadrian.Builder
......@@ -33,11 +35,13 @@ executable hadrian
, Hadrian.Expression
, Hadrian.Haskell.Cabal
, Hadrian.Haskell.Cabal.Parse
, Hadrian.Haskell.Cabal.Type
, Hadrian.Oracles.ArgsHash
, Hadrian.Oracles.DirectoryContents
, Hadrian.Oracles.Path
, Hadrian.Oracles.TextFile
, Hadrian.Package
, Hadrian.Package.Type
, Hadrian.Target
, Hadrian.Utilities
, Oracles.Flag
......@@ -106,6 +110,7 @@ executable hadrian
, UserSettings
, Utilities
, Way
, Way.Type
default-language: Haskell2010
default-extensions: DeriveFunctor
, DeriveGeneric
......
......@@ -12,25 +12,13 @@ module Context (
pkgConfFile, objectPath
) where
import GHC.Generics
import Context.Type
import Hadrian.Expression
import Hadrian.Haskell.Cabal
import Base
import Oracles.Setting
-- | Build context for a currently built 'Target'. We generate potentially
-- different build rules for each 'Context'.
data Context = Context
{ stage :: Stage -- ^ Currently build Stage
, package :: Package -- ^ Currently build Package
, way :: Way -- ^ Currently build Way (usually 'vanilla')
} deriving (Eq, Generic, Show)
instance Binary Context
instance Hashable Context
instance NFData Context
-- | Most targets are built only one way, hence the notion of 'vanillaContext'.
vanillaContext :: Stage -> Package -> Context
vanillaContext s p = Context s p vanilla
......
module Context.Type where
import Hadrian.Package.Type
import Stage
import Way.Type
import GHC.Generics
import Development.Shake.Classes
-- | Build context for a currently built 'Target'. We generate potentially
-- different build rules for each 'Context'.
data Context = Context
{ stage :: Stage -- ^ Currently build Stage
, package :: Package -- ^ Currently build Package
, way :: Way -- ^ Currently build Way (usually 'vanilla')
} deriving (Eq, Generic, Show)
instance Binary Context
instance Hashable Context
instance NFData Context
......@@ -23,26 +23,14 @@ module Expression (
module GHC
) where
import qualified Hadrian.Expression as H
import Hadrian.Expression hiding (Expr, Predicate, Args)
import Base
import Builder
import GHC
import Context hiding (stage, package, way)
import Expression.Type
import GHC
import Hadrian.Expression hiding (Expr, Predicate, Args)
import Oracles.PackageData
-- | @Expr a@ is a computation that produces a value of type @Action a@ and can
-- read parameters of the current build 'Target'.
type Expr a = H.Expr Context Builder a
-- | The following expressions are used throughout the build system for
-- specifying conditions ('Predicate'), lists of arguments ('Args'), 'Ways'
-- and 'Packages'.
type Predicate = H.Predicate Context Builder
type Args = H.Args Context Builder
type Ways = Expr [Way]
-- | Get a value from the @package-data.mk@ file of the current context.
getPkgData :: (FilePath -> PackageData) -> Expr String
getPkgData key = expr . pkgData . key =<< getBuildPath
......
module Expression.Type where
import Builder
import Context.Type
import qualified Hadrian.Expression as H
import Way.Type
-- | @Expr a@ is a computation that produces a value of type @Action a@ and can
-- read parameters of the current build 'Target'.
type Expr a = H.Expr Context Builder a
-- | The following expressions are used throughout the build system for
-- specifying conditions ('Predicate'), lists of arguments ('Args'), 'Ways'
-- and 'Packages'.
type Predicate = H.Predicate Context Builder
type Args = H.Args Context Builder
type Ways = Expr [Way]
......@@ -22,6 +22,7 @@ instance Binary TarMode
instance Hashable TarMode
instance NFData TarMode
-- | Default command line arguments for invoking the archiving utility @tar@.
args :: (ShakeValue c, ShakeValue b) => TarMode -> Args c b
args Create = mconcat
......
......@@ -12,7 +12,6 @@ module Hadrian.Haskell.Cabal.Parse (Cabal (..), parseCabal) where
import Data.List.Extra
import Development.Shake
import Development.Shake.Classes
import qualified Distribution.Package as C
import qualified Distribution.PackageDescription as C
import qualified Distribution.PackageDescription.Parsec as C
......@@ -20,26 +19,7 @@ import qualified Distribution.Text as C
import qualified Distribution.Types.CondTree as C
import qualified Distribution.Verbosity as C
import Hadrian.Package
-- TODO: Use fine-grain tracking instead of tracking the whole Cabal file.
-- | Haskell package metadata extracted from a Cabal file.
data Cabal = Cabal
{ dependencies :: [PackageName]
, name :: PackageName
, synopsis :: String
, version :: String
} deriving (Eq, Read, Show, Typeable)
instance Binary Cabal where
put = put . show
get = fmap read get
instance Hashable Cabal where
hashWithSalt salt = hashWithSalt salt . show
instance NFData Cabal where
rnf (Cabal a b c d) = a `seq` b `seq` c `seq` d `seq` ()
import Hadrian.Haskell.Cabal.Type
-- | Parse a Cabal file.
parseCabal :: FilePath -> IO Cabal
......
module Hadrian.Haskell.Cabal.Type where
import Development.Shake.Classes
import Hadrian.Package.Type
-- TODO: Use fine-grain tracking instead of tracking the whole Cabal file.
-- | Haskell package metadata extracted from a Cabal file.
data Cabal = Cabal
{ dependencies :: [PackageName]
, name :: PackageName
, synopsis :: String
, version :: String
} deriving (Eq, Read, Show, Typeable)
instance Binary Cabal where
put = put . show
get = fmap read get
instance Hashable Cabal where
hashWithSalt salt = hashWithSalt salt . show
instance NFData Cabal where
rnf (Cabal a b c d) = a `seq` b `seq` c `seq` d `seq` ()
......@@ -24,53 +24,11 @@ module Hadrian.Package (
) where
import Data.Maybe
import Development.Shake.Classes
import Development.Shake.FilePath
import GHC.Generics
import GHC.Stack
import Hadrian.Package.Type
import Hadrian.Utilities
data PackageLanguage = C | Haskell deriving (Generic, Show)
-- TODO: Make PackageType more precise.
-- See https://github.com/snowleopard/hadrian/issues/12.
data PackageType = Library | Program deriving (Generic, Show)
type PackageName = String
-- TODO: Consider turning Package into a GADT indexed with language and type.
data Package = Package {
-- | The package language. 'C' and 'Haskell' packages are supported.
pkgLanguage :: PackageLanguage,
-- | The package type. 'Library' and 'Program' packages are supported.
pkgType :: PackageType,
-- | The package name. We assume that all packages have different names,
-- hence two packages with the same name are considered equal.
pkgName :: PackageName,
-- | The path to the package source code relative to the root of the build
-- system. For example, @libraries/Cabal/Cabal@ and @ghc@ are paths to the
-- @Cabal@ and @ghc-bin@ packages in GHC.
pkgPath :: FilePath
} deriving (Generic, Show)
instance Eq Package where
p == q = pkgName p == pkgName q
instance Ord Package where
compare p q = compare (pkgName p) (pkgName q)
instance Binary PackageLanguage
instance Hashable PackageLanguage
instance NFData PackageLanguage
instance Binary PackageType
instance Hashable PackageType
instance NFData PackageType
instance Binary Package
instance Hashable Package
instance NFData Package
-- | Construct a C library package.
cLibrary :: PackageName -> FilePath -> Package
cLibrary = Package C Library
......
module Hadrian.Package.Type where
import GHC.Generics
import Development.Shake.Classes
data PackageLanguage = C | Haskell deriving (Generic, Show)
-- TODO: Make PackageType more precise.
-- See https://github.com/snowleopard/hadrian/issues/12.
data PackageType = Library | Program deriving (Generic, Show)
type PackageName = String
-- TODO: Consider turning Package into a GADT indexed with language and type.
data Package = Package {
-- | The package language. 'C' and 'Haskell' packages are supported.
pkgLanguage :: PackageLanguage,
-- | The package type. 'Library' and 'Program' packages are supported.
pkgType :: PackageType,
-- | The package name. We assume that all packages have different names,
-- hence two packages with the same name are considered equal.
pkgName :: PackageName,
-- | The path to the package source code relative to the root of the build
-- system. For example, @libraries/Cabal/Cabal@ and @ghc@ are paths to the
-- @Cabal@ and @ghc-bin@ packages in GHC.
pkgPath :: FilePath
} deriving (Generic, Show)
instance Eq Package where
p == q = pkgName p == pkgName q
instance Ord Package where
compare p q = compare (pkgName p) (pkgName q)
instance Binary PackageLanguage
instance Hashable PackageLanguage
instance NFData PackageLanguage
instance Binary PackageType
instance Hashable PackageType
instance NFData PackageType
instance Binary Package
instance Hashable Package
instance NFData Package
......@@ -9,88 +9,7 @@ module Way (
wayPrefix, waySuffix, hisuf, osuf, hcsuf, obootsuf, hibootsuf, ssuf
) where
import Data.IntSet (IntSet)
import qualified Data.IntSet as Set
import Data.List
import Data.Maybe
import Development.Shake.Classes
import Hadrian.Utilities
-- Note: order of constructors is important for compatibility with the old build
-- system, e.g. we want "thr_p", not "p_thr" (see instance Show Way).
-- | A 'WayUnit' is a single way of building source code, for example with
-- profiling enabled, or dynamically linked.
data WayUnit = Threaded
| Debug
| Profiling
| Logging
| Dynamic
deriving (Bounded, Enum, Eq, Ord)
-- TODO: get rid of non-derived Show instances
instance Show WayUnit where
show unit = case unit of
Threaded -> "thr"
Debug -> "debug"
Profiling -> "p"
Logging -> "l"
Dynamic -> "dyn"
instance Read WayUnit where
readsPrec _ s = [(unit, "") | unit <- [minBound ..], show unit == s]
-- | Collection of 'WayUnit's that stands for the different ways source code
-- is to be built.
newtype Way = Way IntSet
instance Binary Way where
put = put . show
get = fmap read get
instance Hashable Way where
hashWithSalt salt = hashWithSalt salt . show
instance NFData Way where
rnf (Way s) = s `seq` ()
-- | Construct a 'Way' from multiple 'WayUnit's. Inverse of 'wayToUnits'.
wayFromUnits :: [WayUnit] -> Way
wayFromUnits = Way . Set.fromList . map fromEnum
-- | Split a 'Way' into its 'WayUnit' building blocks.
-- Inverse of 'wayFromUnits'.
wayToUnits :: Way -> [WayUnit]
wayToUnits (Way set) = map toEnum . Set.elems $ set
-- | Check whether a 'Way' contains a certain 'WayUnit'.
wayUnit :: WayUnit -> Way -> Bool
wayUnit unit (Way set) = fromEnum unit `Set.member` set
-- | Remove a 'WayUnit' from 'Way'.
removeWayUnit :: WayUnit -> Way -> Way
removeWayUnit unit (Way set) = Way . Set.delete (fromEnum unit) $ 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 result
where
uniqueReads token = case reads token of
[(unit, "")] -> Just unit
_ -> Nothing
units = map uniqueReads . words . replaceEq '_' ' ' $ s
result = if Nothing `elem` units
then []
else [(wayFromUnits . map fromJust $ units, "")]
instance Eq Way where
Way a == Way b = a == b
instance Ord Way where
compare (Way a) (Way b) = compare a b
import Way.Type
-- | Build default _vanilla_ way.
vanilla :: Way
......
module Way.Type where
import Data.IntSet (IntSet)
import qualified Data.IntSet as Set
import Data.List
import Data.Maybe
import Development.Shake.Classes
import Hadrian.Utilities
-- Note: order of constructors is important for compatibility with the old build
-- system, e.g. we want "thr_p", not "p_thr" (see instance Show Way).
-- | A 'WayUnit' is a single way of building source code, for example with
-- profiling enabled, or dynamically linked.
data WayUnit = Threaded
| Debug
| Profiling
| Logging
| Dynamic
deriving (Bounded, Enum, Eq, Ord)
-- TODO: get rid of non-derived Show instances
instance Show WayUnit where
show unit = case unit of
Threaded -> "thr"
Debug -> "debug"
Profiling -> "p"
Logging -> "l"
Dynamic -> "dyn"
instance Read WayUnit where
readsPrec _ s = [(unit, "") | unit <- [minBound ..], show unit == s]
-- | Collection of 'WayUnit's that stands for the different ways source code
-- is to be built.
newtype Way = Way IntSet
instance Binary Way where
put = put . show
get = fmap read get
instance Hashable Way where
hashWithSalt salt = hashWithSalt salt . show
instance NFData Way where
rnf (Way s) = s `seq` ()
-- | Construct a 'Way' from multiple 'WayUnit's. Inverse of 'wayToUnits'.
wayFromUnits :: [WayUnit] -> Way
wayFromUnits = Way . Set.fromList . map fromEnum
-- | Split a 'Way' into its 'WayUnit' building blocks.
-- Inverse of 'wayFromUnits'.
wayToUnits :: Way -> [WayUnit]
wayToUnits (Way set) = map toEnum . Set.elems $ set
-- | Check whether a 'Way' contains a certain 'WayUnit'.
wayUnit :: WayUnit -> Way -> Bool
wayUnit unit (Way set) = fromEnum unit `Set.member` set
-- | Remove a 'WayUnit' from 'Way'.
removeWayUnit :: WayUnit -> Way -> Way
removeWayUnit unit (Way set) = Way . Set.delete (fromEnum unit) $ 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 [(wayFromUnits [], "")] else result
where
uniqueReads token = case reads token of
[(unit, "")] -> Just unit
_ -> Nothing
units = map uniqueReads . words . replaceEq '_' ' ' $ s
result = if Nothing `elem` units
then []
else [(wayFromUnits . map fromJust $ units, "")]
instance Eq Way where
Way a == Way b = a == b
instance Ord Way where
compare (Way a) (Way b) = compare a b
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment