Split Oracles.hs module into logical parts.
authorAndrey Mokhov <andrey.mokhov@gmail.com>
Thu, 1 Jan 2015 22:26:03 +0000 (22:26 +0000)
committerAndrey Mokhov <andrey.mokhov@gmail.com>
Thu, 1 Jan 2015 22:26:03 +0000 (22:26 +0000)
src/Oracles/Base.hs [new file with mode: 0644]
src/Oracles/Builder.hs [new file with mode: 0644]
src/Oracles/Flag.hs [new file with mode: 0644]
src/Oracles/Option.hs [new file with mode: 0644]
src/Oracles/PackageData.hs [new file with mode: 0644]

diff --git a/src/Oracles/Base.hs b/src/Oracles/Base.hs
new file mode 100644 (file)
index 0000000..1e3dec2
--- /dev/null
@@ -0,0 +1,26 @@
+{-# LANGUAGE TypeFamilies, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses #-}
+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, ConstraintKinds #-}
+
+module Oracles.Base (
+    ConfigKey (..),
+    askConfigWithDefault, askConfig,
+    Condition (..)
+    ) where
+
+import Base
+import Development.Shake.Classes
+
+type Condition = Action Bool
+
+newtype ConfigKey = ConfigKey String deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
+
+askConfigWithDefault :: String -> Action String -> Action String
+askConfigWithDefault key defaultAction = do
+    maybeValue <- askOracle $ ConfigKey key 
+    case maybeValue of
+        Just value -> return value
+        Nothing    -> defaultAction
+
+askConfig :: String -> Action String
+askConfig key = askConfigWithDefault key $
+    error $ "\nCannot find key '" ++ key ++ "' in configuration files."
diff --git a/src/Oracles/Builder.hs b/src/Oracles/Builder.hs
new file mode 100644 (file)
index 0000000..3d3a0e9
--- /dev/null
@@ -0,0 +1,93 @@
+{-# LANGUAGE TypeFamilies, FlexibleInstances, FlexibleContexts, NoImplicitPrelude #-}
+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, ConstraintKinds #-}
+
+module Oracles.Builder (
+    Builder (..),
+    path, with, run, argPath,
+    hsColourSrcs
+    ) where
+
+import Data.Char
+import Base
+import Oracles.Base
+import Oracles.Flag
+import Oracles.Option
+
+data Builder = Ar | Ld | Gcc | Alex | Happy | HsColour | GhcCabal | GhcPkg Stage | Ghc Stage
+
+path :: Builder -> Action FilePath
+path builder = do
+    let key = case builder of
+            Ar            -> "ar"
+            Ld            -> "ld"
+            Gcc           -> "gcc"
+            Alex          -> "alex"
+            Happy         -> "happy"
+            HsColour      -> "hscolour"
+            GhcCabal      -> "ghc-cabal"
+            Ghc Stage0    -> "system-ghc"     -- Ghc Stage0 is the bootstrapping compiler 
+            Ghc Stage1    -> "ghc-stage1"     -- Ghc StageN, N > 0, is the one built on stage (N - 1)
+            Ghc Stage2    -> "ghc-stage2"
+            Ghc Stage3    -> "ghc-stage3"
+            GhcPkg Stage0 -> "system-ghc-pkg" -- GhcPkg Stage0 is the bootstrapping GhcPkg 
+            GhcPkg _      -> "ghc-pkg"        -- GhcPkg StageN, N > 0, is the one built on stage 0 (TODO: need only Stage1?)
+    cfgPath <- askConfigWithDefault key $
+        error $ "\nCannot find path to '"
+        ++ key
+        ++ "' in configuration files."
+    let cfgPathExe = if cfgPath /= "" then cfgPath -<.> exe else ""
+    windows <- windowsHost
+    if (windows && "/" `isPrefixOf` cfgPathExe)
+    then do
+        Stdout out <- quietly $ cmd ["cygpath", "-m", "/"]
+        return $ dropWhileEnd isSpace out ++ drop 1 cfgPathExe
+    else
+        return cfgPathExe
+
+argPath :: Builder -> Args
+argPath builder = do
+    path <- path builder
+    arg [path]
+
+-- When LaxDeps flag is set (by adding 'lax-dependencies = YES' to user.config),
+-- dependencies on the GHC executable are turned into order-only dependencies to
+-- avoid needless recompilation when making changes to GHC's sources. In certain
+-- situations this can lead to build failures, in which case you should reset
+-- the flag (at least temporarily).
+needBuilder :: Builder -> Action ()
+needBuilder ghc @ (Ghc stage) = do
+    target  <- path ghc
+    laxDeps <- test LaxDeps
+    if laxDeps then orderOnly [target] else need [target]
+
+needBuilder builder = do 
+    target <- path builder
+    need [target]
+
+-- Action 'with Gcc' returns an argument '--with-gcc=/path/to/gcc' and needs the builder 
+with :: Builder -> Args
+with builder = do 
+    let prefix = case builder of 
+            Ar       -> "--with-ar="
+            Ld       -> "--with-ld="
+            Gcc      -> "--with-gcc="
+            Ghc _    -> "--with-ghc="
+            Alex     -> "--with-alex="
+            Happy    -> "--with-happy="
+            GhcPkg _ -> "--with-ghc-pkg="
+            HsColour -> "--with-hscolour="
+    suffix <- path builder
+    needBuilder builder
+    return [prefix ++ suffix]
+
+run :: Builder -> Args -> Action ()
+run builder args = do
+    needBuilder builder
+    exe   <- path builder
+    args' <- args
+    cmd [exe :: FilePath] args'
+
+hsColourSrcs :: Condition
+hsColourSrcs = do
+    hscolour <- path HsColour
+    return $ hscolour /= ""
diff --git a/src/Oracles/Flag.hs b/src/Oracles/Flag.hs
new file mode 100644 (file)
index 0000000..9245fb2
--- /dev/null
@@ -0,0 +1,103 @@
+{-# LANGUAGE TypeFamilies, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses #-}
+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, ConstraintKinds #-}
+
+module Oracles.Flag (
+    module Control.Monad,
+    module Prelude,
+    Flag (..), 
+    Condition, test, when, unless, not, (&&), (||)
+    ) where
+
+import Control.Monad hiding (when, unless)
+import qualified Prelude
+import Prelude hiding (not, (&&), (||))
+import Base
+import Oracles.Base
+
+data Flag = LaxDeps | DynamicGhcPrograms
+          | GccIsClang | GccLt46 | CrossCompiling | Validating
+          | SupportsPackageKey
+
+test :: Flag -> Action Bool
+test flag = do
+    (key, defaultValue) <- return $ case flag of
+        LaxDeps            -> ("lax-dependencies"     , False) -- TODO: move flags to a separate file
+        DynamicGhcPrograms -> ("dynamic-ghc-programs" , False)
+        GccIsClang         -> ("gcc-is-clang"         , False)
+        GccLt46            -> ("gcc-lt-46"            , False)
+        CrossCompiling     -> ("cross-compiling"      , False)
+        Validating         -> ("validating"           , False)
+        SupportsPackageKey -> ("supports-package-key" , False)
+    let defaultString = if defaultValue then "YES" else "NO"
+    value <- askConfigWithDefault key $
+        do putLoud $ "\nFlag '" -- TODO: Give the warning *only once* per key
+                ++ key
+                ++ "' not set in configuration files. "
+                ++ "Proceeding with default value '"
+                ++ defaultString
+                ++ "'.\n"
+           return defaultString
+    return $ value == "YES"
+
+class ToCondition a where
+    toCondition :: a -> Condition
+
+instance ToCondition Condition where
+    toCondition = id
+
+instance ToCondition Bool where
+    toCondition = return
+
+instance ToCondition Flag where
+    toCondition = test
+
+when :: (ToCondition a, Monoid m) => a -> Action m -> Action m
+when x args = do
+    bool <- toCondition x
+    if bool then args else mempty
+
+unless :: (ToCondition a, Monoid m) => a -> Action m -> Action m
+unless x args = do
+    bool <- toCondition x
+    if bool then mempty else args
+
+class Not a where
+    type NotResult a
+    not :: a -> NotResult a
+
+instance Not Bool where
+    type NotResult Bool = Bool
+    not = Prelude.not
+
+instance Not Condition where
+    type NotResult Condition = Condition
+    not x = not <$> (toCondition x)
+
+instance Not Flag where
+    type NotResult Flag = Condition
+    not x = not (toCondition x)
+
+class AndOr a b where
+    type AndOrResult a b
+    (&&) :: a -> b -> AndOrResult a b
+    (||) :: a -> b -> AndOrResult a b
+
+infixr 3 &&
+infixr 2 ||
+
+instance AndOr Bool Bool where
+    type AndOrResult Bool Bool = Bool
+    (&&) = (Prelude.&&)
+    (||) = (Prelude.||)
+
+instance ToCondition a => AndOr Condition a where
+    type AndOrResult Condition a = Condition
+    x && y = (Prelude.&&) <$> toCondition x <*> toCondition y
+    x || y = (Prelude.||) <$> toCondition x <*> toCondition y
+
+instance ToCondition a => AndOr Flag a where
+    type AndOrResult Flag a = Condition
+    x && y = toCondition x && y
+    x || y = toCondition x || y
+
+
diff --git a/src/Oracles/Option.hs b/src/Oracles/Option.hs
new file mode 100644 (file)
index 0000000..72d166b
--- /dev/null
@@ -0,0 +1,57 @@
+{-# LANGUAGE TypeFamilies, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses #-}
+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, ConstraintKinds #-}
+
+module Oracles.Option (
+    Option (..),
+    option, argOption,
+    ghcWithInterpreter, platformSupportsSharedLibs, windowsHost
+    ) where
+
+import Base
+import Oracles.Base
+
+data Option = TargetOS | TargetArch | TargetPlatformFull
+            | ConfCcArgs Stage | ConfGccLinkerArgs Stage | ConfLdLinkerArgs Stage | ConfCppArgs Stage
+            | IconvIncludeDirs | IconvLibDirs | GmpIncludeDirs | GmpLibDirs
+            | SrcHcOpts
+            | HostOsCpp
+
+option :: Option -> Action String
+option opt = askConfig $ case opt of 
+    TargetOS                -> "target-os"
+    TargetArch              -> "target-arch"
+    TargetPlatformFull      -> "target-platform-full"
+    ConfCcArgs        stage -> "conf-cc-args-stage-"         ++ (show . fromEnum) stage
+    ConfCppArgs       stage -> "conf-cpp-args-stage-"        ++ (show . fromEnum) stage
+    ConfGccLinkerArgs stage -> "conf-gcc-linker-args-stage-" ++ (show . fromEnum) stage
+    ConfLdLinkerArgs  stage -> "conf-ld-linker-args-stage-"  ++ (show . fromEnum) stage
+    IconvIncludeDirs        -> "iconv-include-dirs"
+    IconvLibDirs            -> "iconv-lib-dirs"
+    GmpIncludeDirs          -> "gmp-include-dirs"
+    GmpLibDirs              -> "gmp-lib-dirs"
+    SrcHcOpts               -> "src-hc-opts"
+    HostOsCpp               -> "host-os-cpp"
+
+argOption :: Option -> Args
+argOption opt = do
+    opt' <- option opt
+    arg [opt']
+
+ghcWithInterpreter :: Condition
+ghcWithInterpreter = do
+    os   <- option TargetOS
+    arch <- option TargetArch
+    return $
+        os `elem` ["mingw32", "cygwin32", "linux", "solaris2", "freebsd", "dragonfly", "netbsd", "openbsd", "darwin", "kfreebsdgnu"]
+        &&
+        arch `elem` ["i386", "x86_64", "powerpc", "sparc", "sparc64", "arm"]
+
+platformSupportsSharedLibs :: Condition
+platformSupportsSharedLibs = do
+    platform <- option TargetPlatformFull
+    return $ platform `notElem` [ "powerpc-unknown-linux", "x86_64-unknown-mingw32", "i386-unknown-mingw32" ] -- TODO: i386-unknown-solaris2?
+
+windowsHost :: Condition
+windowsHost = do
+    hostOsCpp <- option HostOsCpp
+    return $ hostOsCpp `elem` ["mingw32", "cygwin32"]
diff --git a/src/Oracles/PackageData.hs b/src/Oracles/PackageData.hs
new file mode 100644 (file)
index 0000000..3abd7a2
--- /dev/null
@@ -0,0 +1,38 @@
+{-# LANGUAGE TypeFamilies, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses #-}
+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, ConstraintKinds #-}
+
+module Oracles.PackageData (
+    PackageDataPair (..),
+    packagaDataOption, PackageDataKey (..)
+    ) where
+
+import Development.Shake.Classes
+import Base
+import Util
+
+newtype PackageDataPair = PackageDataPair (FilePath, String)
+                        deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
+
+packagaDataOptionWithDefault :: FilePath -> String -> Action String -> Action String
+packagaDataOptionWithDefault file key defaultAction = do
+    maybeValue <- askOracle $ PackageDataPair (file, key) 
+    case maybeValue of
+        Just value -> return value
+        Nothing    -> defaultAction
+
+data PackageDataKey = Modules | SrcDirs | PackageKey | IncludeDirs | Deps | DepKeys
+                    deriving Show
+
+packagaDataOption :: FilePath -> PackageDataKey -> Action String
+packagaDataOption file key = do
+    let (keyName, ifEmpty) = case key of
+           Modules     -> ("MODULES"     , "" )
+           SrcDirs     -> ("HS_SRC_DIRS" , ".")
+           PackageKey  -> ("PACKAGE_KEY" , "" )
+           IncludeDirs -> ("INCLUDE_DIRS", ".")
+           Deps        -> ("DEPS"        , "" )
+           DepKeys     -> ("DEP_KEYS"    , "" )
+        keyFullName = replaceSeparators '_' $ takeDirectory file ++ "_" ++ keyName
+    res <- packagaDataOptionWithDefault file keyFullName $
+        error $ "\nCannot find key '" ++ keyName ++ "' in " ++ file ++ "."
+    return $ if res == "" then ifEmpty else res