module Settings.Builders.GhcPkg (ghcPkgBuilderArgs) where

import Settings.Builders.Common

ghcPkgBuilderArgs :: Args
ghcPkgBuilderArgs = mconcat
    [ builder (GhcPkg Copy) ? do
        verbosity <- expr getVerbosity
        stage     <- getStage
        pkgDb     <- expr $ packageDbPath stage
        mconcat [ arg "--global-package-db"
                , arg pkgDb
                , arg "register"
                , verbosity < Chatty ? arg "-v0"
                ]
    , builder (GhcPkg Unregister) ? do
        verbosity <- expr getVerbosity
        stage     <- getStage
        pkgDb     <- expr $ packageDbPath stage
        mconcat [ arg "--global-package-db"
                , arg pkgDb
                , arg "unregister"
                , arg "--force"
                , verbosity < Chatty ? arg "-v0"
                ]
    , builder (GhcPkg Update) ? do
        verbosity <- expr getVerbosity
        context   <- getContext
        config    <- expr $ pkgInplaceConfig context
        stage     <- getStage
        pkgDb     <- expr $ packageDbPath stage
        mconcat [ notStage0 ? arg "--global-package-db"
                , notStage0 ? arg pkgDb
                , arg "update"
                , arg "--force"
                , verbosity < Chatty ? arg "-v0"
                , bootPackageDatabaseArgs
                , arg config ] ]


module Settings.Builders.Haddock (haddockBuilderArgs) where

import Hadrian.Haskell.Cabal
import Hadrian.Haskell.Cabal.Type
import Hadrian.Utilities

import Packages
import Rules.Documentation
import Settings.Builders.Common
import Settings.Builders.Ghc

-- | Given a version string such as "2.16.2" produce an integer equivalent.
versionToInt :: String -> Int
versionToInt = read . dropWhile (=='0') . filter (/='.')

haddockBuilderArgs :: Args
haddockBuilderArgs = mconcat
    [ builder (Haddock BuildIndex) ? do
        output <- getOutput
        inputs <- getInputs
        root   <- getBuildRoot
        mconcat
            [ arg $ "-B" ++ root -/- stageString Stage1 -/- "lib"
            , arg $ "--lib=" ++ root -/- stageString Stage1 -/- "lib"
            , arg "--gen-index"
            , arg "--gen-contents"
            , arg "-o", arg $ takeDirectory output
            , arg "-t", arg "Haskell Hierarchical Libraries"
            , arg "-p", arg "libraries/prologue.txt"
            , pure [ "--read-interface="
                     ++ (takeFileName . takeDirectory) haddock
                     ++ "," ++ haddock | haddock <- inputs ] ]

    , builder (Haddock BuildPackage) ? do
        output   <- getOutput
        pkg      <- getPackage
        root     <- getBuildRoot
        path     <- getBuildPath
        context  <- getContext
        version  <- expr $ pkgVersion  pkg
        synopsis <- expr $ pkgSynopsis pkg
        deps     <- getContextData depNames
        haddocks <- expr $ haddockDependencies context
        hVersion <- expr $ pkgVersion haddock
        ghcOpts  <- haddockGhcArgs
        mconcat
            [ arg "--verbosity=0"
            , arg $ "-B" ++ root -/- stageString Stage1 -/- "lib"
            , arg $ "--lib=" ++ root -/- stageString Stage1 -/- "lib"
            , arg $ "--odir=" ++ takeDirectory output
            , arg "--no-tmp-comp-dir"
            , arg $ "--dump-interface=" ++ output
            , arg "--html"
            , arg "--hyperlinked-source"
            , arg "--hoogle"
            , arg "--quickjump"
            , arg $ "--title=" ++ pkgName pkg ++ "-" ++ version
                    ++ ": " ++ synopsis
            , arg $ "--prologue=" ++ takeDirectory output -/- "haddock-prologue.txt"
            , arg $ "--optghc=-D__HADDOCK_VERSION__="
                    ++ show (versionToInt hVersion)
            , map ("--hide=" ++) <$> getContextData otherModules
            , pure [ "--read-interface=../" ++ dep
                     ++ ",../" ++ dep ++ "/src/%{MODULE}.html#%{NAME},"
                     ++ haddock | (dep, haddock) <- zip deps haddocks ]
            , pure [ "--optghc=" ++ opt | opt <- ghcOpts, not ("--package-db" `isInfixOf` opt) ]
            , getInputs
            , arg "+RTS"
            , arg $ "-t" ++ path -/- "haddock.t"
            , arg "--machine-readable"
            , arg "-RTS" ] ]


module Settings.Builders.Happy (happyBuilderArgs) where

import Settings.Builders.Common

happyBuilderArgs :: Args
happyBuilderArgs = builder Happy ? mconcat [ arg "-ag" -- TODO (int-index): restore the -c option when happy/pull/134 is merged.
                                           , arg "--strict"
                                           , arg =<< getInput
                                           , arg "-o", arg =<< getOutput ]


module Settings.Builders.Hsc2Hs (hsc2hsBuilderArgs) where

import Hadrian.Haskell.Cabal.Type

import Builder
import Packages
import Settings.Builders.Common

hsc2hsBuilderArgs :: Args
hsc2hsBuilderArgs = builder Hsc2Hs ? do
    stage   <- getStage
    ccPath  <- getBuilderPath $ Cc CompileC stage
    gmpDir  <- getSetting GmpIncludeDir
    top     <- expr topDirectory
    hArch   <- getSetting HostArch
    hOs     <- getSetting HostOs
    tArch   <- getSetting TargetArch
    tOs     <- getSetting TargetOs
    version <- if stage == Stage0
               then expr ghcCanonVersion
               else getSetting ProjectVersionInt
    tmpl <- (top -/-) <$> expr (templateHscPath Stage0)
    mconcat [ arg $ "--cc=" ++ ccPath
            , arg $ "--ld=" ++ ccPath
            , notM windowsHost ? notM (flag CrossCompiling) ? arg "--cross-safe"
            , pure $ map ("-I" ++) (words gmpDir)
            , map ("--cflag=" ++) <$> getCFlags
            , map ("--lflag=" ++) <$> getLFlags
            , notStage0 ? flag CrossCompiling ? arg "--cross-compile"
            , stage0    ? arg ("--cflag=-D" ++ hArch ++ "_HOST_ARCH=1")
            , stage0    ? arg ("--cflag=-D" ++ hOs   ++ "_HOST_OS=1"  )
            , notStage0 ? arg ("--cflag=-D" ++ tArch ++ "_HOST_ARCH=1")
            , notStage0 ? arg ("--cflag=-D" ++ tOs   ++ "_HOST_OS=1"  )
            , arg $ "--cflag=-D__GLASGOW_HASKELL__=" ++ version
            , arg $ "--template=" ++ tmpl
            , arg =<< getInput
            , arg "-o", arg =<< getOutput ]

getCFlags :: Expr [String]
getCFlags = do
    context <- getContext
    autogen <- expr $ autogenPath context
    let cabalMacros = autogen -/- "cabal_macros.h"
    expr $ need [cabalMacros]
    mconcat [ remove ["-O"] (cArgs <> getStagedSettingList ConfCcArgs)
            , getStagedSettingList ConfCppArgs
            , cIncludeArgs
            , getContextData ccOpts
            -- we might be able to leave out cppOpts, to be investigated.
            , getContextData cppOpts
            , getContextData depCcOpts
            , cWarnings
            , arg "-include", arg cabalMacros ]

getLFlags :: Expr [String]
getLFlags =
    mconcat [ getStagedSettingList ConfGccLinkerArgs
            , ldArgs
            , getContextData ldOpts
            , getContextData depLdOpts ]


module Settings.Builders.HsCpp (hsCppBuilderArgs) where

import Packages
import Settings.Builders.Common

hsCppBuilderArgs :: Args
hsCppBuilderArgs = builder HsCpp ? do
    stage   <- getStage
    root    <- getBuildRoot
    ghcPath <- expr $ buildPath (vanillaContext stage compiler)
    mconcat [ getSettingList HsCppArgs
            , arg "-P"
            , arg "-Iincludes"
            , arg $ "-I" ++ root -/- generatedDir
            , arg $ "-I" ++ ghcPath
            , arg "-x", arg "c"
            , arg =<< getInput ]


module Settings.Builders.Ld (ldBuilderArgs) where

import Settings.Builders.Common

ldBuilderArgs :: Args
ldBuilderArgs = builder Ld ? mconcat [ getStagedSettingList ConfLdLinkerArgs
                                     , arg "-r"
                                     , arg "-o", arg =<< getOutput
                                     , getInputs ]


module Settings.Builders.Make (makeBuilderArgs, validateBuilderArgs) where

import Oracles.Setting
import Packages
import Rules.Gmp
import Settings.Builders.Common
import CommandLine

makeBuilderArgs :: Args
makeBuilderArgs = do
    threads    <- shakeThreads <$> expr getShakeOptions
    gmpPath    <- expr gmpBuildPath
    libffiPaths <- forM [Stage1 ..] $ \s -> expr (libffiBuildPath s)
    let t = show $ max 4 (threads - 2) -- Don't use all Shake's threads
    mconcat $
        (builder (Make gmpPath   ) ? pure ["MAKEFLAGS=-j" ++ t]) :
        [ builder (Make libffiPath) ? pure ["MAKEFLAGS=-j" ++ t, "install"]
        | libffiPath <- libffiPaths ]

validateBuilderArgs :: Args
validateBuilderArgs = builder (Make "testsuite/tests") ? do
    threads             <- shakeThreads <$> expr getShakeOptions
    top                 <- expr topDirectory
    compiler            <- expr $ fullpath ghc
    checkPpr            <- expr $ fullpath checkPpr
    checkApiAnnotations <- expr $ fullpath checkApiAnnotations
    args                <- expr $ userSetting defaultTestArgs
    return [ setTestSpeed $ testSpeed args
           , "THREADS=" ++ show threads
           , "TEST_HC=" ++ (top -/- compiler)
           , "CHECK_PPR=" ++ (top -/- checkPpr)
           , "CHECK_API_ANNOTATIONS=" ++ (top -/- checkApiAnnotations)
           ]
  where
    fullpath :: Package -> Action FilePath
    fullpath pkg = programPath =<< programContext Stage1 pkg

-- | Support for speed of validation
setTestSpeed :: TestSpeed -> String
setTestSpeed Fast    = "fasttest"
setTestSpeed Average = "test"
setTestSpeed Slow    = "slowtest"


module Settings.Builders.RunTest (runTestBuilderArgs, runTestGhcFlags) where

import Hadrian.Utilities
import System.Environment

import CommandLine
import Flavour
import Oracles.Setting (setting)
import Oracles.TestSettings
import Packages
import Settings.Builders.Common

getTestSetting :: TestSetting -> Expr String
getTestSetting key = expr $ testSetting key

-- | Parse the value of a Boolean test setting or report an error.
getBooleanSetting :: TestSetting -> Expr Bool
getBooleanSetting key = fromMaybe (error msg) <$> parseYesNo <$> getTestSetting key
  where
    msg = "Cannot parse test setting " ++ quote (show key)

-- | Extra flags to send to the Haskell compiler to run tests.
runTestGhcFlags :: Action String
runTestGhcFlags = do
    unregisterised <- flag GhcUnregisterised

    let ifMinGhcVer ver opt = do v <- ghcCanonVersion
                                 if ver <= v then pure opt
                                             else pure ""

    -- Read extra argument for test from command line, like `-fvectorize`.
    ghcOpts <- fromMaybe "" <$> (liftIO $ lookupEnv "EXTRA_HC_OPTS")

    -- See: https://github.com/ghc/ghc/blob/master/testsuite/mk/test.mk#L28
    let ghcExtraFlags = if unregisterised
                           then "-optc-fno-builtin"
                           else ""

    -- Take flags to send to the Haskell compiler from test.mk.
    -- See: https://github.com/ghc/ghc/blob/master/testsuite/mk/test.mk#L37
    unwords <$> sequence
        [ pure " -dcore-lint -dcmm-lint -no-user-package-db -rtsopts"
        , pure ghcOpts
        , pure ghcExtraFlags
        , ifMinGhcVer "711" "-fno-warn-missed-specialisations"
        , ifMinGhcVer "711" "-fshow-warning-groups"
        , ifMinGhcVer "801" "-fdiagnostics-color=never"
        , ifMinGhcVer "801" "-fno-diagnostics-show-caret"
        , pure "-Werror=compat" -- See Trac #15278
        , pure "-dno-debug-output"
        ]

-- Command line arguments for invoking the @runtest.py@ script. A lot of this
-- mirrors @testsuite/mk/test.mk@.
runTestBuilderArgs :: Args
runTestBuilderArgs = builder RunTest ? do
    pkgs     <- expr $ stagePackages Stage1
    libTests <- expr $ filterM doesDirectoryExist $ concat
            [ [ pkgPath pkg -/- "tests", pkgPath pkg -/- "tests-ghc" ]
            | pkg <- pkgs, isLibrary pkg, pkg /= rts, pkg /= libffi ]

    flav    <- expr flavour
    rtsWays <- expr testRTSSettings
    libWays <- libraryWays flav
    let hasRtsWay w = elem w rtsWays
        hasLibWay w = elem w libWays
        debugged    = ghcDebugged flav
    hasDynamic          <- getBooleanSetting TestGhcDynamic
    hasDynamicByDefault <- getBooleanSetting TestGhcDynamicByDefault
    withNativeCodeGen   <- getBooleanSetting TestGhcWithNativeCodeGen
    withInterpreter     <- getBooleanSetting TestGhcWithInterpreter
    unregisterised      <- getBooleanSetting TestGhcUnregisterised
    withSMP             <- getBooleanSetting TestGhcWithSMP

    windows     <- expr windowsHost
    darwin      <- expr osxHost
    threads     <- shakeThreads <$> expr getShakeOptions
    os          <- getTestSetting TestHostOS
    arch        <- getTestSetting TestTargetARCH_CPP
    platform    <- getTestSetting TestTARGETPLATFORM
    wordsize    <- getTestSetting TestWORDSIZE
    top         <- expr $ topDirectory
    ghcFlags    <- expr runTestGhcFlags
    timeoutProg <- expr buildRoot <&> (-/- timeoutPath)

    -- See #16087
    let ghcBuiltByLlvm = False -- TODO: Implement this check

    let asZeroOne s b = s ++ zeroOne b

    -- TODO: set CABAL_MINIMAL_BUILD/CABAL_PLUGIN_BUILD
    mconcat [ arg $ "testsuite/driver/runtests.py"
            , arg $ "--rootdir=" ++ ("testsuite" -/- "tests")
            , pure ["--rootdir=" ++ test | test <- libTests]
            , arg "-e", arg $ "windows=" ++ show windows
            , arg "-e", arg $ "darwin=" ++ show darwin
            , arg "-e", arg $ "config.local=True"
            , arg "-e", arg $ "config.cleanup=False" -- Don't clean up.
            , arg "-e", arg $ "config.compiler_debugged=" ++ quote (yesNo debugged)
            , arg "-e", arg $ "ghc_debugged=" ++ quote (yesNo debugged)
            , arg "-e", arg $ asZeroOne "ghc_with_native_codegen=" withNativeCodeGen

            , arg "-e", arg $ "config.have_interp=" ++ show withInterpreter
            , arg "-e", arg $ "config.unregisterised=" ++ show unregisterised

            , arg "-e", arg $ "ghc_compiler_always_flags=" ++ quote ghcFlags
            , arg "-e", arg $ asZeroOne "ghc_with_dynamic_rts="  (hasRtsWay "dyn")
            , arg "-e", arg $ asZeroOne "ghc_with_threaded_rts=" (hasRtsWay "thr")
            , arg "-e", arg $ asZeroOne "config.have_vanilla="   (hasLibWay vanilla)
            , arg "-e", arg $ asZeroOne "config.have_dynamic="   (hasLibWay dynamic)
            , arg "-e", arg $ asZeroOne "config.have_profiling=" (hasLibWay profiling)
            , arg "-e", arg $ asZeroOne "ghc_with_smp=" withSMP
            , arg "-e", arg $ "ghc_with_llvm=0" -- TODO: support LLVM

            , arg "-e", arg $ "config.ghc_dynamic_by_default=" ++ show hasDynamicByDefault
            , arg "-e", arg $ "config.ghc_dynamic=" ++ show hasDynamic
            , arg "-e", arg $ "config.ghc_built_by_llvm=" ++ show ghcBuiltByLlvm

            -- Use default value, see:
            -- https://github.com/ghc/ghc/blob/master/testsuite/mk/boilerplate.mk
            , arg "-e", arg $ "config.in_tree_compiler=True"
            , arg "-e", arg $ "config.top=" ++ show (top -/- "testsuite")
            , arg "-e", arg $ "config.wordsize=" ++ show wordsize
            , arg "-e", arg $ "config.os="       ++ show os
            , arg "-e", arg $ "config.arch="     ++ show arch
            , arg "-e", arg $ "config.platform=" ++ show platform

            , arg "--config", arg $ "gs=gs"                           -- Use the default value as in test.mk
            , arg "--config", arg $ "timeout_prog=" ++ show (top -/- timeoutProg)
            , arg $ "--threads=" ++ show threads
            , getTestArgs -- User-provided arguments from command line.
            ]

-- | Command line arguments for running GHC's test script.
getTestArgs :: Args
getTestArgs = do
    -- targets specified in the TEST env var
    testEnvTargets <- maybe [] words <$> expr (liftIO $ lookupEnv "TEST")
    args            <- expr $ userSetting defaultTestArgs
    bindir          <- expr $ setBinaryDirectory (testCompiler args)
    compiler        <- expr $ setCompiler (testCompiler args)
    globalVerbosity <- shakeVerbosity <$> expr getShakeOptions
    let configFileArg= ["--config-file=" ++ (testConfigFile args)]
        testOnlyArg  =  map ("--only=" ++) (testOnly args ++ testEnvTargets)
        onlyPerfArg  = if testOnlyPerf args
                           then Just "--only-perf-tests"
                           else Nothing
        skipPerfArg  = if testSkipPerf args
                           then Just "--skip-perf-tests"
                           else Nothing
        speedArg     = ["-e", "config.speed=" ++ setTestSpeed (testSpeed args)]
        summaryArg   = case testSummary args of
                           Just filepath -> Just $ "--summary-file" ++ quote filepath
                           Nothing -> Just $ "--summary-file=testsuite_summary.txt"
        junitArg     = case testJUnit args of
                           Just filepath -> Just $ "--junit " ++ quote filepath
                           Nothing -> Nothing
        configArgs   = concat [["-e", configArg] | configArg <- testConfigs args]
        verbosityArg = case testVerbosity args of
                           Nothing -> Just $ "--verbose=" ++ show (fromEnum globalVerbosity)
                           Just verbosity -> Just $ "--verbose=" ++ verbosity
        wayArgs      = map ("--way=" ++) (testWays args)
        compilerArg  = ["--config", "compiler=" ++ show (compiler)]
        ghcPkgArg    = ["--config", "ghc_pkg=" ++ show (bindir -/- "ghc-pkg")]
        haddockArg   = ["--config", "haddock=" ++ show (bindir -/- "haddock")]
        hp2psArg     = ["--config", "hp2ps=" ++ show (bindir -/- "hp2ps")]
        hpcArg       = ["--config", "hpc=" ++ show (bindir -/- "hpc")]
    pure $  configFileArg ++ testOnlyArg ++ speedArg
         ++ catMaybes [ onlyPerfArg, skipPerfArg, summaryArg
                      , junitArg, verbosityArg  ]
         ++ configArgs ++ wayArgs ++  compilerArg ++ ghcPkgArg
         ++ haddockArg ++ hp2psArg ++ hpcArg

-- TODO: Switch to 'Stage' as the first argument instead of 'String'.
-- | Directory to look for Binaries
-- | We assume that required programs are present in the same binary directory
-- | in which ghc is stored and that they have their conventional name.
-- | QUESTION : packages can be named different from their conventional names.
-- | For example, ghc-pkg can be named as ghc-pkg-version. In such cases, it will
-- | be impossible to search the binary. Only possible way will be to take user
-- | inputs for these directory also. boilerplate soes not account for this
-- | problem, but simply returns an error. How should we handle such cases?
setBinaryDirectory :: String -> Action FilePath
setBinaryDirectory "stage0" = takeDirectory <$> setting SystemGhc
setBinaryDirectory "stage1" = liftM2 (-/-) topDirectory (stageBinPath Stage0)
setBinaryDirectory "stage2" = liftM2 (-/-) topDirectory (stageBinPath Stage1)
setBinaryDirectory compiler = pure $ parentPath compiler

-- TODO: Switch to 'Stage' as the first argument instead of 'String'.
-- | Set Test Compiler.
setCompiler :: String -> Action FilePath
setCompiler "stage0" = setting SystemGhc
setCompiler "stage1" = liftM2 (-/-) topDirectory (fullPath Stage0 ghc)
setCompiler "stage2" = liftM2 (-/-) topDirectory (fullPath Stage1 ghc)
setCompiler compiler = pure compiler

-- | Set speed for test
setTestSpeed :: TestSpeed -> String
setTestSpeed Slow    = "0"
setTestSpeed Average = "1"
setTestSpeed Fast    = "2"

-- | Returns parent path of test compiler
-- | TODO: Is there a simpler way to find parent directory?
parentPath :: String -> String
parentPath path = intercalate "/" $ init $ splitOn "/" path

-- | TODO: Move to Hadrian utilities.
fullPath :: Stage -> Package -> Action FilePath
fullPath stage pkg = programPath =<< programContext stage pkg


module Settings.Builders.Xelatex (xelatexBuilderArgs) where

import Settings.Builders.Common

xelatexBuilderArgs :: Args
xelatexBuilderArgs = builder Xelatex ? mconcat [ arg "-halt-on-error"
                                               , arg =<< getInput ]


module Settings.Flavours.Common where

import Expression

-- See https://ghc.haskell.org/trac/ghc/ticket/15286 and
-- https://phabricator.haskell.org/D4880
naturalInBaseFixArgs :: Args
naturalInBaseFixArgs = mconcat
  [ input "//Natural.hs" ? pure ["-fno-omit-interface-pragmas"]
  , input "//Num.hs" ? pure ["-fno-ignore-interface-pragmas"]
  ]


module Settings.Flavours.Development (developmentFlavour) where

import Expression
import Flavour
import {-# SOURCE #-} Settings.Default

-- Please update doc/flavours.md when changing this file.
developmentFlavour :: Stage -> Flavour
developmentFlavour ghcStage = defaultFlavour
    { name = "devel" ++ show (fromEnum ghcStage)
    , args = defaultBuilderArgs <> developmentArgs ghcStage <> defaultPackageArgs
    , libraryWays = pure [vanilla]
    , rtsWays = pure [vanilla, threaded]
    , dynamicGhcPrograms = return False }

developmentArgs :: Stage -> Args
developmentArgs ghcStage = do
    stage <- getStage
    sourceArgs SourceArgs
        { hsDefault  = pure ["-O", "-H64m"]
        , hsLibrary  = notStage0 ? arg "-dcore-lint"
        , hsCompiler = mconcat [stage0 ? arg "-O2",
                                succ stage == ghcStage ? pure ["-O0", "-DDEBUG"]]
        , hsGhc      = succ stage == ghcStage ? pure ["-O0", "-DDEBUG"] }


module Settings.Flavours.Llvm (
  performanceLlvmFlavour,
  profiledLlvmFlavour,
  quickLlvmFlavour,
) where

import Expression
import Flavour

import Settings.Flavours.Performance
import Settings.Flavours.Profiled
import Settings.Flavours.Quick

-- Please update doc/flavours.md when changing this file.
performanceLlvmFlavour, profiledLlvmFlavour, quickLlvmFlavour :: Flavour
performanceLlvmFlavour = mkLlvmFlavour performanceFlavour
profiledLlvmFlavour    = mkLlvmFlavour profiledFlavour
quickLlvmFlavour       = mkLlvmFlavour quickFlavour

-- | Turn a flavour into an LLVM flavour
mkLlvmFlavour :: Flavour -> Flavour
mkLlvmFlavour flav = flav
    { name = name flav ++ "-llvm"
    , args = mconcat [ args flav
                     , builder Ghc ? arg "-fllvm" ]
    }


module Settings.Flavours.Performance (performanceFlavour) where

import Expression
import Flavour
import {-# SOURCE #-} Settings.Default

-- Please update doc/flavours.md when changing this file.
performanceFlavour :: Flavour
performanceFlavour = defaultFlavour
    { name = "perf"
    , args = defaultBuilderArgs <> performanceArgs <> defaultPackageArgs }

performanceArgs :: Args
performanceArgs = sourceArgs SourceArgs
    { hsDefault  = pure ["-O", "-H64m"]
    , hsLibrary  = notStage0 ? arg "-O2"
    , hsCompiler = pure ["-O2"]
    , hsGhc      = mconcat [stage0 ? arg "-O", notStage0 ? arg "-O2"] }


module Settings.Flavours.Profiled (profiledFlavour) where

import Expression
import Flavour
import {-# SOURCE #-} Settings.Default
import Settings.Flavours.Common (naturalInBaseFixArgs)

-- Please update doc/flavours.md when changing this file.
profiledFlavour :: Flavour
profiledFlavour = defaultFlavour
    { name        = "prof"
    , args        = defaultBuilderArgs <> profiledArgs <> defaultPackageArgs
    , ghcProfiled = True }

profiledArgs :: Args
profiledArgs = sourceArgs SourceArgs
    { hsDefault  = mconcat
        [ pure ["-O0", "-H64m"]
        , naturalInBaseFixArgs
        ]
    , hsLibrary  = notStage0 ? arg "-O"
    , hsCompiler = mconcat [stage0 ? arg "-O2", notStage0 ? arg "-O"]
    , hsGhc      = arg "-O" }


module Settings.Flavours.Quick (quickFlavour) where

import Expression
import Flavour
import Oracles.Flag
import {-# SOURCE #-} Settings.Default
import Settings.Flavours.Common

-- Please update doc/flavours.md when changing this file.
quickFlavour :: Flavour
quickFlavour = defaultFlavour
    { name        = "quick"
    , args        = defaultBuilderArgs <> quickArgs <> defaultPackageArgs
    , libraryWays = mconcat
                    [ pure [vanilla]
                    , notStage0 ? platformSupportsSharedLibs ? pure [dynamic] ]
    , rtsWays     = mconcat
                    [ pure
                      [ vanilla, threaded, logging, debug
                      , threadedDebug, threadedLogging, threaded ]
                    , notStage0 ? platformSupportsSharedLibs ? pure
                      [ dynamic, debugDynamic, threadedDynamic, loggingDynamic
                      , threadedDebugDynamic, threadedLoggingDynamic ]
                    ] }

quickArgs :: Args
quickArgs = sourceArgs SourceArgs
    { hsDefault  = mconcat $
        [ pure ["-O0", "-H64m"]
        , naturalInBaseFixArgs
        ]
    , hsLibrary  = notStage0 ? arg "-O"
    , hsCompiler =    stage0 ? arg "-O2"
    , hsGhc      =    stage0 ? arg "-O" }


module Settings.Flavours.QuickCross (quickCrossFlavour) where

import Expression
import Flavour
import Oracles.Flag
import {-# SOURCE #-} Settings.Default
import Settings.Flavours.Common

-- Please update doc/flavours.md when changing this file.
quickCrossFlavour :: Flavour
quickCrossFlavour = defaultFlavour
    { name        = "quick-cross"
    , args        = defaultBuilderArgs <> quickCrossArgs <> defaultPackageArgs
    , dynamicGhcPrograms = pure False
    , libraryWays = mconcat
                    [ pure [vanilla]
                    , notStage0 ? platformSupportsSharedLibs ? pure [dynamic] ]
    , rtsWays     = mconcat
                    [ pure
                      [ vanilla, threaded, logging, debug
                      , threadedDebug, threadedLogging, threaded ]
                    , notStage0 ? platformSupportsSharedLibs ? pure
                      [ dynamic, debugDynamic, threadedDynamic, loggingDynamic
                      , threadedDebugDynamic, threadedLoggingDynamic ]
                    ] }

quickCrossArgs :: Args
quickCrossArgs = sourceArgs SourceArgs
    { hsDefault  = mconcat $
        [ pure ["-O0", "-H64m"]
        , naturalInBaseFixArgs
        ]
    , hsLibrary  = notStage0 ? mconcat [ arg "-O", arg "-fllvm" ]
    , hsCompiler = stage0 ? arg "-O2"
    , hsGhc      = mconcat
                   [ stage0 ? arg "-O"
                   , stage1 ? mconcat [ arg "-O0", arg "-fllvm" ] ] }


module Settings.Flavours.Quickest (quickestFlavour) where

import Expression
import Flavour
import {-# SOURCE #-} Settings.Default
import Settings.Flavours.Common

-- Please update doc/flavours.md when changing this file.
quickestFlavour :: Flavour
quickestFlavour = defaultFlavour
    { name        = "quickest"
    , args        = defaultBuilderArgs <> quickestArgs <> defaultPackageArgs
    , libraryWays = pure [vanilla]
    , rtsWays     = pure [vanilla, threaded]
    , dynamicGhcPrograms = return False }

quickestArgs :: Args
quickestArgs = sourceArgs SourceArgs
    { hsDefault  = mconcat $
        [ pure ["-O0", "-H64m"]
        , naturalInBaseFixArgs
        ]
    , hsLibrary  = mempty
    , hsCompiler = stage0 ? arg "-O"
    , hsGhc      = stage0 ? arg "-O" }


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

-- | Add a 'WayUnit' to a 'Way'
addWayUnit :: WayUnit -> Way -> Way
addWayUnit unit (Way set) = Way . Set.insert (fromEnum unit) $ 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


import CmmExpr
#if !(defined(MACHREGS_i386) || defined(MACHREGS_x86_64) \
    || defined(MACHREGS_sparc) || defined(MACHREGS_powerpc))
import Panic
#endif
import Reg

#include "ghcautoconf.h"
#include "stg/MachRegs.h"

#if defined(MACHREGS_i386) || defined(MACHREGS_x86_64)

# if defined(MACHREGS_i386)
#  define eax 0
#  define ebx 1
#  define ecx 2
#  define edx 3
#  define esi 4
#  define edi 5
#  define ebp 6
#  define esp 7
# endif

# if defined(MACHREGS_x86_64)
#  define rax   0
#  define rbx   1
#  define rcx   2
#  define rdx   3
#  define rsi   4
#  define rdi   5
#  define rbp   6
#  define rsp   7
#  define r8    8
#  define r9    9
#  define r10   10
#  define r11   11
#  define r12   12
#  define r13   13
#  define r14   14
#  define r15   15
# endif

# define fake0 16
# define fake1 17
# define fake2 18
# define fake3 19
# define fake4 20
# define fake5 21

-- N.B. XMM, YMM, and ZMM are all aliased to the same hardware registers hence
-- being assigned the same RegNos.
# define xmm0  24
# define xmm1  25
# define xmm2  26
# define xmm3  27
# define xmm4  28
# define xmm5  29
# define xmm6  30
# define xmm7  31
# define xmm8  32
# define xmm9  33
# define xmm10 34
# define xmm11 35
# define xmm12 36
# define xmm13 37
# define xmm14 38
# define xmm15 39

# define ymm0  24
# define ymm1  25
# define ymm2  26
# define ymm3  27
# define ymm4  28
# define ymm5  29
# define ymm6  30
# define ymm7  31
# define ymm8  32
# define ymm9  33
# define ymm10 34
# define ymm11 35
# define ymm12 36
# define ymm13 37
# define ymm14 38
# define ymm15 39

# define zmm0  24
# define zmm1  25
# define zmm2  26
# define zmm3  27
# define zmm4  28
# define zmm5  29
# define zmm6  30
# define zmm7  31
# define zmm8  32
# define zmm9  33
# define zmm10 34
# define zmm11 35
# define zmm12 36
# define zmm13 37
# define zmm14 38
# define zmm15 39

-- Note: these are only needed for ARM/ARM64 because globalRegMaybe is now used in CmmSink.hs.
-- Since it's only used to check 'isJust', the actual values don't matter, thus
-- I'm not sure if these are the correct numberings.
-- Normally, the register names are just stringified as part of the REG() macro

#elif defined(MACHREGS_powerpc) || defined(MACHREGS_arm) \
    || defined(MACHREGS_aarch64)

# define r0 0
# define r1 1
# define r2 2
# define r3 3
# define r4 4
# define r5 5
# define r6 6
# define r7 7
# define r8 8
# define r9 9
# define r10 10
# define r11 11
# define r12 12
# define r13 13
# define r14 14
# define r15 15
# define r16 16
# define r17 17
# define r18 18
# define r19 19
# define r20 20
# define r21 21
# define r22 22
# define r23 23
# define r24 24
# define r25 25
# define r26 26
# define r27 27
# define r28 28
# define r29 29
# define r30 30
# define r31 31

-- See note above. These aren't actually used for anything except satisfying the compiler for globalRegMaybe
-- so I'm unsure if they're the correct numberings, should they ever be attempted to be used in the NCG.
#if defined(MACHREGS_aarch64) || defined(MACHREGS_arm)
# define s0 32
# define s1 33
# define s2 34
# define s3 35
# define s4 36
# define s5 37
# define s6 38
# define s7 39
# define s8 40
# define s9 41
# define s10 42
# define s11 43
# define s12 44
# define s13 45
# define s14 46
# define s15 47
# define s16 48
# define s17 49
# define s18 50
# define s19 51
# define s20 52
# define s21 53
# define s22 54
# define s23 55
# define s24 56
# define s25 57
# define s26 58
# define s27 59
# define s28 60
# define s29 61
# define s30 62
# define s31 63

# define d0 32
# define d1 33
# define d2 34
# define d3 35
# define d4 36
# define d5 37
# define d6 38
# define d7 39
# define d8 40
# define d9 41
# define d10 42
# define d11 43
# define d12 44
# define d13 45
# define d14 46
# define d15 47
# define d16 48
# define d17 49
# define d18 50
# define d19 51
# define d20 52
# define d21 53
# define d22 54
# define d23 55
# define d24 56
# define d25 57
# define d26 58
# define d27 59
# define d28 60
# define d29 61
# define d30 62
# define d31 63
#endif

# if defined(MACHREGS_darwin)
#  define f0  32
#  define f1  33
#  define f2  34
#  define f3  35
#  define f4  36
#  define f5  37
#  define f6  38
#  define f7  39
#  define f8  40
#  define f9  41
#  define f10 42
#  define f11 43
#  define f12 44
#  define f13 45
#  define f14 46
#  define f15 47
#  define f16 48
#  define f17 49
#  define f18 50
#  define f19 51
#  define f20 52
#  define f21 53
#  define f22 54
#  define f23 55
#  define f24 56
#  define f25 57
#  define f26 58
#  define f27 59
#  define f28 60
#  define f29 61
#  define f30 62
#  define f31 63
# else
#  define fr0  32
#  define fr1  33
#  define fr2  34
#  define fr3  35
#  define fr4  36
#  define fr5  37
#  define fr6  38
#  define fr7  39
#  define fr8  40
#  define fr9  41
#  define fr10 42
#  define fr11 43
#  define fr12 44
#  define fr13 45
#  define fr14 46
#  define fr15 47
#  define fr16 48
#  define fr17 49
#  define fr18 50
#  define fr19 51
#  define fr20 52
#  define fr21 53
#  define fr22 54
#  define fr23 55
#  define fr24 56
#  define fr25 57
#  define fr26 58
#  define fr27 59
#  define fr28 60
#  define fr29 61
#  define fr30 62
#  define fr31 63
# endif

#elif defined(MACHREGS_sparc)

# define g0  0
# define g1  1
# define g2  2
# define g3  3
# define g4  4
# define g5  5
# define g6  6
# define g7  7

# define o0  8
# define o1  9
# define o2  10
# define o3  11
# define o4  12
# define o5  13
# define o6  14
# define o7  15

# define l0  16
# define l1  17
# define l2  18
# define l3  19
# define l4  20
# define l5  21
# define l6  22
# define l7  23

# define i0  24
# define i1  25
# define i2  26
# define i3  27
# define i4  28
# define i5  29
# define i6  30
# define i7  31

# define f0  32
# define f1  33
# define f2  34
# define f3  35
# define f4  36
# define f5  37
# define f6  38
# define f7  39
# define f8  40
# define f9  41
# define f10 42
# define f11 43
# define f12 44
# define f13 45
# define f14 46
# define f15 47
# define f16 48
# define f17 49
# define f18 50
# define f19 51
# define f20 52
# define f21 53
# define f22 54
# define f23 55
# define f24 56
# define f25 57
# define f26 58
# define f27 59
# define f28 60
# define f29 61
# define f30 62
# define f31 63

#endif

callerSaves :: GlobalReg -> Bool
#if defined(CALLER_SAVES_Base)
callerSaves BaseReg           = True
#endif
#if defined(CALLER_SAVES_R1)
callerSaves (VanillaReg 1 _)  = True
#endif
#if defined(CALLER_SAVES_R2)
callerSaves (VanillaReg 2 _)  = True
#endif
#if defined(CALLER_SAVES_R3)
callerSaves (VanillaReg 3 _)  = True
#endif
#if defined(CALLER_SAVES_R4)
callerSaves (VanillaReg 4 _)  = True
#endif
#if defined(CALLER_SAVES_R5)
callerSaves (VanillaReg 5 _)  = True
#endif
#if defined(CALLER_SAVES_R6)
callerSaves (VanillaReg 6 _)  = True
#endif
#if defined(CALLER_SAVES_R7)
callerSaves (VanillaReg 7 _)  = True
#endif
#if defined(CALLER_SAVES_R8)
callerSaves (VanillaReg 8 _)  = True
#endif
#if defined(CALLER_SAVES_R9)
callerSaves (VanillaReg 9 _)  = True
#endif
#if defined(CALLER_SAVES_R10)
callerSaves (VanillaReg 10 _) = True
#endif
#if defined(CALLER_SAVES_F1)
callerSaves (FloatReg 1)      = True
#endif
#if defined(CALLER_SAVES_F2)
callerSaves (FloatReg 2)      = True
#endif
#if defined(CALLER_SAVES_F3)
callerSaves (FloatReg 3)      = True
#endif
#if defined(CALLER_SAVES_F4)
callerSaves (FloatReg 4)      = True
#endif
#if defined(CALLER_SAVES_F5)
callerSaves (FloatReg 5)      = True
#endif
#if defined(CALLER_SAVES_F6)
callerSaves (FloatReg 6)      = True
#endif
#if defined(CALLER_SAVES_D1)
callerSaves (DoubleReg 1)     = True
#endif
#if defined(CALLER_SAVES_D2)
callerSaves (DoubleReg 2)     = True
#endif
#if defined(CALLER_SAVES_D3)
callerSaves (DoubleReg 3)     = True
#endif
#if defined(CALLER_SAVES_D4)
callerSaves (DoubleReg 4)     = True
#endif
#if defined(CALLER_SAVES_D5)
callerSaves (DoubleReg 5)     = True
#endif
#if defined(CALLER_SAVES_D6)
callerSaves (DoubleReg 6)     = True
#endif
#if defined(CALLER_SAVES_L1)
callerSaves (LongReg 1)       = True
#endif
#if defined(CALLER_SAVES_Sp)
callerSaves Sp                = True
#endif
#if defined(CALLER_SAVES_SpLim)
callerSaves SpLim             = True
#endif
#if defined(CALLER_SAVES_Hp)
callerSaves Hp                = True
#endif
#if defined(CALLER_SAVES_HpLim)
callerSaves HpLim             = True
#endif
#if defined(CALLER_SAVES_CCCS)
callerSaves CCCS              = True
#endif
#if defined(CALLER_SAVES_CurrentTSO)
callerSaves CurrentTSO        = True
#endif
#if defined(CALLER_SAVES_CurrentNursery)
callerSaves CurrentNursery    = True
#endif
callerSaves _                 = False

activeStgRegs :: [GlobalReg]
activeStgRegs = [
#if defined(REG_Base)
    BaseReg
#endif
#if defined(REG_Sp)
    ,Sp
#endif
#if defined(REG_Hp)
    ,Hp
#endif
#if defined(REG_R1)
    ,VanillaReg 1 VGcPtr
#endif
#if defined(REG_R2)
    ,VanillaReg 2 VGcPtr
#endif
#if defined(REG_R3)
    ,VanillaReg 3 VGcPtr
#endif
#if defined(REG_R4)
    ,VanillaReg 4 VGcPtr
#endif
#if defined(REG_R5)
    ,VanillaReg 5 VGcPtr
#endif
#if defined(REG_R6)
    ,VanillaReg 6 VGcPtr
#endif
#if defined(REG_R7)
    ,VanillaReg 7 VGcPtr
#endif
#if defined(REG_R8)
    ,VanillaReg 8 VGcPtr
#endif
#if defined(REG_R9)
    ,VanillaReg 9 VGcPtr
#endif
#if defined(REG_R10)
    ,VanillaReg 10 VGcPtr
#endif
#if defined(REG_SpLim)
    ,SpLim
#endif
#if MAX_REAL_XMM_REG != 0
#if defined(REG_F1)
    ,FloatReg 1
#endif
#if defined(REG_D1)
    ,DoubleReg 1
#endif
#if defined(REG_XMM1)
    ,XmmReg 1
#endif
#if defined(REG_YMM1)
    ,YmmReg 1
#endif
#if defined(REG_ZMM1)
    ,ZmmReg 1
#endif
#if defined(REG_F2)
    ,FloatReg 2
#endif
#if defined(REG_D2)
    ,DoubleReg 2
#endif
#if defined(REG_XMM2)
    ,XmmReg 2
#endif
#if defined(REG_YMM2)
    ,YmmReg 2
#endif
#if defined(REG_ZMM2)
    ,ZmmReg 2
#endif
#if defined(REG_F3)
    ,FloatReg 3
#endif
#if defined(REG_D3)
    ,DoubleReg 3
#endif
#if defined(REG_XMM3)
    ,XmmReg 3
#endif
#if defined(REG_YMM3)
    ,YmmReg 3
#endif
#if defined(REG_ZMM3)
    ,ZmmReg 3
#endif
#if defined(REG_F4)
    ,FloatReg 4
#endif
#if defined(REG_D4)
    ,DoubleReg 4
#endif
#if defined(REG_XMM4)
    ,XmmReg 4
#endif
#if defined(REG_YMM4)
    ,YmmReg 4
#endif
#if defined(REG_ZMM4)
    ,ZmmReg 4
#endif
#if defined(REG_F5)
    ,FloatReg 5
#endif
#if defined(REG_D5)
    ,DoubleReg 5
#endif
#if defined(REG_XMM5)
    ,XmmReg 5
#endif
#if defined(REG_YMM5)
    ,YmmReg 5
#endif
#if defined(REG_ZMM5)
    ,ZmmReg 5
#endif
#if defined(REG_F6)
    ,FloatReg 6
#endif
#if defined(REG_D6)
    ,DoubleReg 6
#endif
#if defined(REG_XMM6)
    ,XmmReg 6
#endif
#if defined(REG_YMM6)
    ,YmmReg 6
#endif
#if defined(REG_ZMM6)
    ,ZmmReg 6
#endif
#else /* MAX_REAL_XMM_REG == 0 */
#if defined(REG_F1)
    ,FloatReg 1
#endif
#if defined(REG_F2)
    ,FloatReg 2
#endif
#if defined(REG_F3)
    ,FloatReg 3
#endif
#if defined(REG_F4)
    ,FloatReg 4
#endif
#if defined(REG_F5)
    ,FloatReg 5
#endif
#if defined(REG_F6)
    ,FloatReg 6
#endif
#if defined(REG_D1)
    ,DoubleReg 1
#endif
#if defined(REG_D2)
    ,DoubleReg 2
#endif
#if defined(REG_D3)
    ,DoubleReg 3
#endif
#if defined(REG_D4)
    ,DoubleReg 4
#endif
#if defined(REG_D5)
    ,DoubleReg 5
#endif
#if defined(REG_D6)
    ,DoubleReg 6
#endif
#endif /* MAX_REAL_XMM_REG == 0 */
    ]

haveRegBase :: Bool
#if defined(REG_Base)
haveRegBase = True
#else
haveRegBase = False
#endif

--  | Returns 'Nothing' if this global register is not stored
-- in a real machine register, otherwise returns @'Just' reg@, where
-- reg is the machine register it is stored in.
globalRegMaybe :: GlobalReg -> Maybe RealReg
#if defined(MACHREGS_i386) || defined(MACHREGS_x86_64) \
    || defined(MACHREGS_sparc) || defined(MACHREGS_powerpc) \
    || defined(MACHREGS_arm) || defined(MACHREGS_aarch64)
# if defined(REG_Base)
globalRegMaybe BaseReg                  = Just (RealRegSingle REG_Base)
# endif
# if defined(REG_R1)
globalRegMaybe (VanillaReg 1 _)         = Just (RealRegSingle REG_R1)
# endif
# if defined(REG_R2)
globalRegMaybe (VanillaReg 2 _)         = Just (RealRegSingle REG_R2)
# endif
# if defined(REG_R3)
globalRegMaybe (VanillaReg 3 _)         = Just (RealRegSingle REG_R3)
# endif
# if defined(REG_R4)
globalRegMaybe (VanillaReg 4 _)         = Just (RealRegSingle REG_R4)
# endif
# if defined(REG_R5)
globalRegMaybe (VanillaReg 5 _)         = Just (RealRegSingle REG_R5)
# endif
# if defined(REG_R6)
globalRegMaybe (VanillaReg 6 _)         = Just (RealRegSingle REG_R6)
# endif
# if defined(REG_R7)
globalRegMaybe (VanillaReg 7 _)         = Just (RealRegSingle REG_R7)
# endif
# if defined(REG_R8)
globalRegMaybe (VanillaReg 8 _)         = Just (RealRegSingle REG_R8)
# endif
# if defined(REG_R9)
globalRegMaybe (VanillaReg 9 _)         = Just (RealRegSingle REG_R9)
# endif
# if defined(REG_R10)
globalRegMaybe (VanillaReg 10 _)        = Just (RealRegSingle REG_R10)
# endif
# if defined(REG_F1)
globalRegMaybe (FloatReg 1)             = Just (RealRegSingle REG_F1)
# endif
# if defined(REG_F2)
globalRegMaybe (FloatReg 2)             = Just (RealRegSingle REG_F2)
# endif
# if defined(REG_F3)
globalRegMaybe (FloatReg 3)             = Just (RealRegSingle REG_F3)
# endif
# if defined(REG_F4)
globalRegMaybe (FloatReg 4)             = Just (RealRegSingle REG_F4)
# endif
# if defined(REG_F5)
globalRegMaybe (FloatReg 5)             = Just (RealRegSingle REG_F5)
# endif
# if defined(REG_F6)
globalRegMaybe (FloatReg 6)             = Just (RealRegSingle REG_F6)
# endif
# if defined(REG_D1)
globalRegMaybe (DoubleReg 1)            =
#  if defined(MACHREGS_sparc)
                                          Just (RealRegPair REG_D1 (REG_D1 + 1))
#  else
                                          Just (RealRegSingle REG_D1)
#  endif
# endif
# if defined(REG_D2)
globalRegMaybe (DoubleReg 2)            =
#  if defined(MACHREGS_sparc)
                                          Just (RealRegPair REG_D2 (REG_D2 + 1))
#  else
                                          Just (RealRegSingle REG_D2)
#  endif
# endif
# if defined(REG_D3)
globalRegMaybe (DoubleReg 3)            =
#  if defined(MACHREGS_sparc)
                                          Just (RealRegPair REG_D3 (REG_D3 + 1))
#  else
                                          Just (RealRegSingle REG_D3)
#  endif
# endif
# if defined(REG_D4)
globalRegMaybe (DoubleReg 4)            =
#  if defined(MACHREGS_sparc)
                                          Just (RealRegPair REG_D4 (REG_D4 + 1))
#  else
                                          Just (RealRegSingle REG_D4)
#  endif
# endif
# if defined(REG_D5)
globalRegMaybe (DoubleReg 5)            =
#  if defined(MACHREGS_sparc)
                                          Just (RealRegPair REG_D5 (REG_D5 + 1))
#  else
                                          Just (RealRegSingle REG_D5)
#  endif
# endif
# if defined(REG_D6)
globalRegMaybe (DoubleReg 6)            =
#  if defined(MACHREGS_sparc)
                                          Just (RealRegPair REG_D6 (REG_D6 + 1))
#  else
                                          Just (RealRegSingle REG_D6)
#  endif
# endif
# if MAX_REAL_XMM_REG != 0
#  if defined(REG_XMM1)
globalRegMaybe (XmmReg 1)               = Just (RealRegSingle REG_XMM1)
#  endif
#  if defined(REG_XMM2)
globalRegMaybe (XmmReg 2)               = Just (RealRegSingle REG_XMM2)
#  endif
#  if defined(REG_XMM3)
globalRegMaybe (XmmReg 3)               = Just (RealRegSingle REG_XMM3)
#  endif
#  if defined(REG_XMM4)
globalRegMaybe (XmmReg 4)               = Just (RealRegSingle REG_XMM4)
#  endif
#  if defined(REG_XMM5)
globalRegMaybe (XmmReg 5)               = Just (RealRegSingle REG_XMM5)
#  endif
#  if defined(REG_XMM6)
globalRegMaybe (XmmReg 6)               = Just (RealRegSingle REG_XMM6)
#  endif
# endif
# if defined(MAX_REAL_YMM_REG) && MAX_REAL_YMM_REG != 0
#  if defined(REG_YMM1)
globalRegMaybe (YmmReg 1)               = Just (RealRegSingle REG_YMM1)
#  endif
#  if defined(REG_YMM2)
globalRegMaybe (YmmReg 2)               = Just (RealRegSingle REG_YMM2)
#  endif
#  if defined(REG_YMM3)
globalRegMaybe (YmmReg 3)               = Just (RealRegSingle REG_YMM3)
#  endif
#  if defined(REG_YMM4)
globalRegMaybe (YmmReg 4)               = Just (RealRegSingle REG_YMM4)
#  endif
#  if defined(REG_YMM5)
globalRegMaybe (YmmReg 5)               = Just (RealRegSingle REG_YMM5)
#  endif
#  if defined(REG_YMM6)
globalRegMaybe (YmmReg 6)               = Just (RealRegSingle REG_YMM6)
#  endif
# endif
# if defined(MAX_REAL_ZMM_REG) && MAX_REAL_ZMM_REG != 0
#  if defined(REG_ZMM1)
globalRegMaybe (ZmmReg 1)               = Just (RealRegSingle REG_ZMM1)
#  endif
#  if defined(REG_ZMM2)
globalRegMaybe (ZmmReg 2)               = Just (RealRegSingle REG_ZMM2)
#  endif
#  if defined(REG_ZMM3)
globalRegMaybe (ZmmReg 3)               = Just (RealRegSingle REG_ZMM3)
#  endif
#  if defined(REG_ZMM4)
globalRegMaybe (ZmmReg 4)               = Just (RealRegSingle REG_ZMM4)
#  endif
#  if defined(REG_ZMM5)
globalRegMaybe (ZmmReg 5)               = Just (RealRegSingle REG_ZMM5)
#  endif
#  if defined(REG_ZMM6)
globalRegMaybe (ZmmReg 6)               = Just (RealRegSingle REG_ZMM6)
#  endif
# endif
# if defined(REG_Sp)
globalRegMaybe Sp                       = Just (RealRegSingle REG_Sp)
# endif
# if defined(REG_Lng1)
globalRegMaybe (LongReg 1)              = Just (RealRegSingle REG_Lng1)
# endif
# if defined(REG_Lng2)
globalRegMaybe (LongReg 2)              = Just (RealRegSingle REG_Lng2)
# endif
# if defined(REG_SpLim)
globalRegMaybe SpLim                    = Just (RealRegSingle REG_SpLim)
# endif
# if defined(REG_Hp)
globalRegMaybe Hp                       = Just (RealRegSingle REG_Hp)
# endif
# if defined(REG_HpLim)
globalRegMaybe HpLim                    = Just (RealRegSingle REG_HpLim)
# endif
# if defined(REG_CurrentTSO)
globalRegMaybe CurrentTSO               = Just (RealRegSingle REG_CurrentTSO)
# endif
# if defined(REG_CurrentNursery)
globalRegMaybe CurrentNursery           = Just (RealRegSingle REG_CurrentNursery)
# endif
# if defined(REG_MachSp)
globalRegMaybe MachSp                   = Just (RealRegSingle REG_MachSp)
# endif
globalRegMaybe _                        = Nothing
#elif defined(MACHREGS_NO_REGS)
globalRegMaybe _ = Nothing
#else
globalRegMaybe = panic "globalRegMaybe not defined for this platform"
#endif

freeReg :: RegNo -> Bool

#if defined(MACHREGS_i386) || defined(MACHREGS_x86_64)

# if defined(MACHREGS_i386)
freeReg esp = False -- %esp is the C stack pointer
freeReg esi = False -- Note [esi/edi/ebp not allocatable]
freeReg edi = False
freeReg ebp = False
# endif
# if defined(MACHREGS_x86_64)
freeReg rsp = False  --        %rsp is the C stack pointer
# endif

{-
Note [esi/edi/ebp not allocatable]

%esi is mapped to R1, so %esi would normally be allocatable while it
is not being used for R1.  However, %esi has no 8-bit version on x86,
and the linear register allocator is not sophisticated enough to
handle this irregularity (we need more RegClasses).  The
graph-colouring allocator also cannot handle this - it was designed
with more flexibility in mind, but the current implementation is
restricted to the same set of classes as the linear allocator.

Hence, on x86 esi, edi and ebp are treated as not allocatable.
-}

-- split patterns in two functions to prevent overlaps
freeReg r         = freeRegBase r

freeRegBase :: RegNo -> Bool
# if defined(REG_Base)
freeRegBase REG_Base  = False
# endif
# if defined(REG_Sp)
freeRegBase REG_Sp    = False
# endif
# if defined(REG_SpLim)
freeRegBase REG_SpLim = False
# endif
# if defined(REG_Hp)
freeRegBase REG_Hp    = False
# endif
# if defined(REG_HpLim)
freeRegBase REG_HpLim = False
# endif
-- All other regs are considered to be "free", because we can track
-- their liveness accurately.
freeRegBase _ = True

#elif defined(MACHREGS_powerpc)

freeReg 0 = False -- Used by code setting the back chain pointer
                  -- in stack reallocations on Linux.
                  -- Moreover r0 is not usable in all insns.
freeReg 1 = False -- The Stack Pointer
-- most ELF PowerPC OSes use r2 as a TOC pointer
freeReg 2 = False
freeReg 13 = False -- reserved for system thread ID on 64 bit
-- at least linux in -fPIC relies on r30 in PLT stubs
freeReg 30 = False
{- TODO: reserve r13 on 64 bit systems only and r30 on 32 bit respectively.
   For now we use r30 on 64 bit and r13 on 32 bit as a temporary register
   in stack handling code. See compiler/nativeGen/PPC/Instr.hs.

   Later we might want to reserve r13 and r30 only where it is required.
   Then use r12 as temporary register, which is also what the C ABI does.
-}

# if defined(REG_Base)
freeReg REG_Base  = False
# endif
# if defined(REG_R1)
freeReg REG_R1    = False
# endif
# if defined(REG_R2)
freeReg REG_R2    = False
# endif
# if defined(REG_R3)
freeReg REG_R3    = False
# endif
# if defined(REG_R4)
freeReg REG_R4    = False
# endif
# if defined(REG_R5)
freeReg REG_R5    = False
# endif
# if defined(REG_R6)
freeReg REG_R6    = False
# endif
# if defined(REG_R7)
freeReg REG_R7    = False
# endif
# if defined(REG_R8)
freeReg REG_R8    = False
# endif
# if defined(REG_R9)
freeReg REG_R9    = False
# endif
# if defined(REG_R10)
freeReg REG_R10   = False
# endif
# if defined(REG_F1)
freeReg REG_F1    = False
# endif
# if defined(REG_F2)
freeReg REG_F2    = False
# endif
# if defined(REG_F3)
freeReg REG_F3    = False
# endif
# if defined(REG_F4)
freeReg REG_F4    = False
# endif
# if defined(REG_F5)
freeReg REG_F5    = False
# endif
# if defined(REG_F6)
freeReg REG_F6    = False
# endif
# if defined(REG_D1)
freeReg REG_D1    = False
# endif
# if defined(REG_D2)
freeReg REG_D2    = False
# endif
# if defined(REG_D3)
freeReg REG_D3    = False
# endif
# if defined(REG_D4)
freeReg REG_D4    = False
# endif
# if defined(REG_D5)
freeReg REG_D5    = False
# endif
# if defined(REG_D6)
freeReg REG_D6    = False
# endif
# if defined(REG_Sp)
freeReg REG_Sp    = False
# endif
# if defined(REG_Su)
freeReg REG_Su    = False
# endif
# if defined(REG_SpLim)
freeReg REG_SpLim = False
# endif
# if defined(REG_Hp)
freeReg REG_Hp    = False
# endif
# if defined(REG_HpLim)
freeReg REG_HpLim = False
# endif
freeReg _ = True

#elif defined(MACHREGS_sparc)

-- SPARC regs used by the OS / ABI
-- %g0(r0) is always zero
freeReg g0  = False

-- %g5(r5) - %g7(r7)
--  are reserved for the OS
freeReg g5  = False
freeReg g6  = False
freeReg g7  = False

-- %o6(r14)
--  is the C stack pointer
freeReg o6  = False

-- %o7(r15)
--  holds the C return address
freeReg o7  = False

-- %i6(r30)
--  is the C frame pointer
freeReg i6  = False

-- %i7(r31)
--  is used for C return addresses
freeReg i7  = False

-- %f0(r32) - %f1(r32)
--  are C floating point return regs
freeReg f0  = False
freeReg f1  = False

{-
freeReg regNo
    -- don't release high half of double regs
    | regNo >= f0
    , regNo <  NCG_FirstFloatReg
    , regNo `mod` 2 /= 0
    = False
-}

# if defined(REG_Base)
freeReg REG_Base  = False
# endif
# if defined(REG_R1)
freeReg REG_R1    = False
# endif
# if defined(REG_R2)
freeReg REG_R2    = False
# endif
# if defined(REG_R3)
freeReg REG_R3    = False
# endif
# if defined(REG_R4)
freeReg REG_R4    = False
# endif
# if defined(REG_R5)
freeReg REG_R5    = False
# endif
# if defined(REG_R6)
freeReg REG_R6    = False
# endif
# if defined(REG_R7)
freeReg REG_R7    = False
# endif
# if defined(REG_R8)
freeReg REG_R8    = False
# endif
# if defined(REG_R9)
freeReg REG_R9    = False
# endif
# if defined(REG_R10)
freeReg REG_R10   = False
# endif
# if defined(REG_F1)
freeReg REG_F1    = False
# endif
# if defined(REG_F2)
freeReg REG_F2    = False
# endif
# if defined(REG_F3)
freeReg REG_F3    = False
# endif
# if defined(REG_F4)
freeReg REG_F4    = False
# endif
# if defined(REG_F5)
freeReg REG_F5    = False
# endif
# if defined(REG_F6)
freeReg REG_F6    = False
# endif
# if defined(REG_D1)
freeReg REG_D1    = False
# endif
# if defined(REG_D1_2)
freeReg REG_D1_2  = False
# endif
# if defined(REG_D2)
freeReg REG_D2    = False
# endif
# if defined(REG_D2_2)
freeReg REG_D2_2  = False
# endif
# if defined(REG_D3)
freeReg REG_D3    = False
# endif
# if defined(REG_D3_2)
freeReg REG_D3_2  = False
# endif
# if defined(REG_D4)
freeReg REG_D4    = False
# endif
# if defined(REG_D4_2)
freeReg REG_D4_2  = False
# endif
# if defined(REG_D5)
freeReg REG_D5    = False
# endif
# if defined(REG_D5_2)
freeReg REG_D5_2  = False
# endif
# if defined(REG_D6)
freeReg REG_D6    = False
# endif
# if defined(REG_D6_2)
freeReg REG_D6_2  = False
# endif
# if defined(REG_Sp)
freeReg REG_Sp    = False
# endif
# if defined(REG_Su)
freeReg REG_Su    = False
# endif
# if defined(REG_SpLim)
freeReg REG_SpLim = False
# endif
# if defined(REG_Hp)
freeReg REG_Hp    = False
# endif
# if defined(REG_HpLim)
freeReg REG_HpLim = False
# endif
freeReg _ = True

#else

freeReg = panic "freeReg not defined for this platform"

#endif


{-# LANGUAGE Safe #-}
{-# LANGUAGE NoImplicitPrelude #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Foreign
-- Copyright   :  (c) The FFI task force 2001
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  ffi@haskell.org
-- Stability   :  provisional
-- Portability :  portable
--
-- A collection of data types, classes, and functions for interfacing
-- with another programming language.
--
-----------------------------------------------------------------------------

module Foreign
        ( module Data.Bits
        , module Data.Int
        , module Data.Word
        , module Foreign.Ptr
        , module Foreign.ForeignPtr
        , module Foreign.StablePtr
        , module Foreign.Storable
        , module Foreign.Marshal
        ) where

import Data.Bits
import Data.Int
import Data.Word
import Foreign.Ptr
import Foreign.ForeignPtr
import Foreign.StablePtr
import Foreign.Storable
import Foreign.Marshal


{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude, MagicHash #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Numeric
-- Copyright   :  (c) The University of Glasgow 2002
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  provisional
-- Portability :  portable
--
-- Odds and ends, mostly functions for reading and showing
-- 'RealFloat'-like kind of values.
--
-----------------------------------------------------------------------------

module Numeric (

        -- * Showing

        showSigned,

        showIntAtBase,
        showInt,
        showHex,
        showOct,

        showEFloat,
        showFFloat,
        showGFloat,
        showFFloatAlt,
        showGFloatAlt,
        showFloat,
        showHFloat,

        floatToDigits,

        -- * Reading

        -- | /NB:/ 'readInt' is the \'dual\' of 'showIntAtBase',
        -- and 'readDec' is the \`dual\' of 'showInt'.
        -- The inconsistent naming is a historical accident.

        readSigned,

        readInt,
        readDec,
        readOct,
        readHex,

        readFloat,

        lexDigits,

        -- * Miscellaneous

        fromRat,
        Floating(..)

        ) where

import GHC.Base
import GHC.Read
import GHC.Real
import GHC.Float
import GHC.Num
import GHC.Show
import Text.ParserCombinators.ReadP( ReadP, readP_to_S, pfail )
import qualified Text.Read.Lex as L

-- -----------------------------------------------------------------------------
-- Reading

-- | Reads an /unsigned/ 'Integral' value in an arbitrary base.
readInt :: Num a
  => a                  -- ^ the base
  -> (Char -> Bool)     -- ^ a predicate distinguishing valid digits in this base
  -> (Char -> Int)      -- ^ a function converting a valid digit character to an 'Int'
  -> ReadS a
readInt base isDigit valDigit = readP_to_S (L.readIntP base isDigit valDigit)

-- | Read an unsigned number in octal notation.
--
-- >>> readOct "0644"
-- [(420,"")]
readOct :: (Eq a, Num a) => ReadS a
readOct = readP_to_S L.readOctP

-- | Read an unsigned number in decimal notation.
--
-- >>> readDec "0644"
-- [(644,"")]
readDec :: (Eq a, Num a) => ReadS a
readDec = readP_to_S L.readDecP

-- | Read an unsigned number in hexadecimal notation.
-- Both upper or lower case letters are allowed.
--
-- >>> readHex "deadbeef"
-- [(3735928559,"")]
readHex :: (Eq a, Num a) => ReadS a
readHex = readP_to_S L.readHexP

-- | Reads an /unsigned/ 'RealFrac' value,
-- expressed in decimal scientific notation.
readFloat :: RealFrac a => ReadS a
readFloat = readP_to_S readFloatP

readFloatP :: RealFrac a => ReadP a
readFloatP =
  do tok <- L.lex
     case tok of
       L.Number n -> return $ fromRational $ L.numberToRational n
       _          -> pfail

-- It's turgid to have readSigned work using list comprehensions,
-- but it's specified as a ReadS to ReadS transformer
-- With a bit of luck no one will use it.

-- | Reads a /signed/ 'Real' value, given a reader for an unsigned value.
readSigned :: (Real a) => ReadS a -> ReadS a
readSigned readPos = readParen False read'
                     where read' r  = read'' r ++
                                      (do
                                        ("-",s) <- lex r
                                        (x,t)   <- read'' s
                                        return (-x,t))
                           read'' r = do
                               (str,s) <- lex r
                               (n,"")  <- readPos str
                               return (n,s)

-- -----------------------------------------------------------------------------
-- Showing

-- | Show /non-negative/ 'Integral' numbers in base 10.
showInt :: Integral a => a -> ShowS
showInt n0 cs0
    | n0 < 0    = errorWithoutStackTrace "Numeric.showInt: can't show negative numbers"
    | otherwise = go n0 cs0
    where
    go n cs
        | n < 10    = case unsafeChr (ord '0' + fromIntegral n) of
            c@(C# _) -> c:cs
        | otherwise = case unsafeChr (ord '0' + fromIntegral r) of
            c@(C# _) -> go q (c:cs)
        where
        (q,r) = n `quotRem` 10

-- Controlling the format and precision of floats. The code that
-- implements the formatting itself is in @PrelNum@ to avoid
-- mutual module deps.

{-# SPECIALIZE showEFloat ::
        Maybe Int -> Float  -> ShowS,
        Maybe Int -> Double -> ShowS #-}
{-# SPECIALIZE showFFloat ::
        Maybe Int -> Float  -> ShowS,
        Maybe Int -> Double -> ShowS #-}
{-# SPECIALIZE showGFloat ::
        Maybe Int -> Float  -> ShowS,
        Maybe Int -> Double -> ShowS #-}

-- | Show a signed 'RealFloat' value
-- using scientific (exponential) notation (e.g. @2.45e2@, @1.5e-3@).
--
-- In the call @'showEFloat' digs val@, if @digs@ is 'Nothing',
-- the value is shown to full precision; if @digs@ is @'Just' d@,
-- then at most @d@ digits after the decimal point are shown.
showEFloat    :: (RealFloat a) => Maybe Int -> a -> ShowS

-- | Show a signed 'RealFloat' value
-- using standard decimal notation (e.g. @245000@, @0.0015@).
--
-- In the call @'showFFloat' digs val@, if @digs@ is 'Nothing',
-- the value is shown to full precision; if @digs@ is @'Just' d@,
-- then at most @d@ digits after the decimal point are shown.
showFFloat    :: (RealFloat a) => Maybe Int -> a -> ShowS

-- | Show a signed 'RealFloat' value
-- using standard decimal notation for arguments whose absolute value lies
-- between @0.1@ and @9,999,999@, and scientific notation otherwise.
--
-- In the call @'showGFloat' digs val@, if @digs@ is 'Nothing',
-- the value is shown to full precision; if @digs@ is @'Just' d@,
-- then at most @d@ digits after the decimal point are shown.
showGFloat    :: (RealFloat a) => Maybe Int -> a -> ShowS

showEFloat d x =  showString (formatRealFloat FFExponent d x)
showFFloat d x =  showString (formatRealFloat FFFixed d x)
showGFloat d x =  showString (formatRealFloat FFGeneric d x)

-- | Show a signed 'RealFloat' value
-- using standard decimal notation (e.g. @245000@, @0.0015@).
--
-- This behaves as 'showFFloat', except that a decimal point
-- is always guaranteed, even if not needed.
--
-- @since 4.7.0.0
showFFloatAlt    :: (RealFloat a) => Maybe Int -> a -> ShowS

-- | Show a signed 'RealFloat' value
-- using standard decimal notation for arguments whose absolute value lies
-- between @0.1@ and @9,999,999@, and scientific notation otherwise.
--
-- This behaves as 'showFFloat', except that a decimal point
-- is always guaranteed, even if not needed.
--
-- @since 4.7.0.0
showGFloatAlt    :: (RealFloat a) => Maybe Int -> a -> ShowS

showFFloatAlt d x =  showString (formatRealFloatAlt FFFixed d True x)
showGFloatAlt d x =  showString (formatRealFloatAlt FFGeneric d True x)

{- | Show a floating-point value in the hexadecimal format,
similar to the @%a@ specifier in C's printf.

  >>> showHFloat (212.21 :: Double) ""
  "0x1.a86b851eb851fp7"
  >>> showHFloat (-12.76 :: Float) ""
  "-0x1.9851ecp3"
  >>> showHFloat (-0 :: Double) ""
  "-0x0p+0"
-}
showHFloat :: RealFloat a => a -> ShowS
showHFloat = showString . fmt
  where
  fmt x
    | isNaN x                   = "NaN"
    | isInfinite x              = (if x < 0 then "-" else "") ++ "Infinity"
    | x < 0 || isNegativeZero x = '-' : cvt (-x)
    | otherwise                 = cvt x

  cvt x
    | x == 0 = "0x0p+0"
    | otherwise =
      case floatToDigits 2 x of
        r@([], _) -> error $ "Impossible happened: showHFloat: " ++ show r
        (d:ds, e) -> "0x" ++ show d ++ frac ds ++ "p" ++ show (e-1)

  -- Given binary digits, convert them to hex in blocks of 4
  -- Special case: If all 0's, just drop it.
  frac digits
    | allZ digits = ""
    | otherwise   = "." ++ hex digits
    where
    hex ds =
      case ds of
        []                -> ""
        [a]               -> hexDigit a 0 0 0 ""
        [a,b]             -> hexDigit a b 0 0 ""
        [a,b,c]           -> hexDigit a b c 0 ""
        a : b : c : d : r -> hexDigit a b c d (hex r)

  hexDigit a b c d = showHex (8*a + 4*b + 2*c + d)

  allZ xs = case xs of
              x : more -> x == 0 && allZ more
              []       -> True

-- ---------------------------------------------------------------------------
-- Integer printing functions

-- | Shows a /non-negative/ 'Integral' number using the base specified by the
-- first argument, and the character representation specified by the second.
showIntAtBase :: (Integral a, Show a) => a -> (Int -> Char) -> a -> ShowS
showIntAtBase base toChr n0 r0
  | base <= 1 = errorWithoutStackTrace ("Numeric.showIntAtBase: applied to unsupported base " ++ show base)
  | n0 <  0   = errorWithoutStackTrace ("Numeric.showIntAtBase: applied to negative number " ++ show n0)
  | otherwise = showIt (quotRem n0 base) r0
   where
    showIt (n,d) r = seq c $ -- stricter than necessary
      case n of
        0 -> r'
        _ -> showIt (quotRem n base) r'
     where
      c  = toChr (fromIntegral d)
      r' = c : r

-- | Show /non-negative/ 'Integral' numbers in base 16.
showHex :: (Integral a,Show a) => a -> ShowS
showHex = showIntAtBase 16 intToDigit

-- | Show /non-negative/ 'Integral' numbers in base 8.
showOct :: (Integral a, Show a) => a -> ShowS
showOct = showIntAtBase 8  intToDigit


{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Prelude
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  stable
-- Portability :  portable
--
-- The Prelude: a standard module. The Prelude is imported by default
-- into all Haskell modules unless either there is an explicit import
-- statement for it, or the NoImplicitPrelude extension is enabled.
--
-----------------------------------------------------------------------------

module Prelude (

    -- * Standard types, classes and related functions

    -- ** Basic data types
    Bool(False, True),
    (&&), (||), not, otherwise,

    Maybe(Nothing, Just),
    maybe,

    Either(Left, Right),
    either,

    Ordering(LT, EQ, GT),
    Char, String,

    -- *** Tuples
    fst, snd, curry, uncurry,

    -- ** Basic type classes
    Eq((==), (/=)),
    Ord(compare, (<), (<=), (>=), (>), max, min),
    Enum(succ, pred, toEnum, fromEnum, enumFrom, enumFromThen,
         enumFromTo, enumFromThenTo),
    Bounded(minBound, maxBound),

    -- ** Numbers

    -- *** Numeric types
    Int, Integer, Float, Double,
    Rational, Word,

    -- *** Numeric type classes
    Num((+), (-), (*), negate, abs, signum, fromInteger),
    Real(toRational),
    Integral(quot, rem, div, mod, quotRem, divMod, toInteger),
    Fractional((/), recip, fromRational),
    Floating(pi, exp, log, sqrt, (**), logBase, sin, cos, tan,
             asin, acos, atan, sinh, cosh, tanh, asinh, acosh, atanh),
    RealFrac(properFraction, truncate, round, ceiling, floor),
    RealFloat(floatRadix, floatDigits, floatRange, decodeFloat,
              encodeFloat, exponent, significand, scaleFloat, isNaN,
              isInfinite, isDenormalized, isIEEE, isNegativeZero, atan2),

    -- *** Numeric functions
    subtract, even, odd, gcd, lcm, (^), (^^),
    fromIntegral, realToFrac,

    -- ** Semigroups and Monoids
    Semigroup((<>)),
    Monoid(mempty, mappend, mconcat),

    -- ** Monads and functors
    Functor(fmap, (<$)), (<$>),
    Applicative(pure, (<*>), (*>), (<*)),
    Monad((>>=), (>>), return, fail),
    mapM_, sequence_, (=<<),

    -- ** Folds and traversals
    Foldable(elem,      -- :: (Foldable t, Eq a) => a -> t a -> Bool
             -- fold,   -- :: Monoid m => t m -> m
             foldMap,   -- :: Monoid m => (a -> m) -> t a -> m
             foldr,     -- :: (a -> b -> b) -> b -> t a -> b
             -- foldr', -- :: (a -> b -> b) -> b -> t a -> b
             foldl,     -- :: (b -> a -> b) -> b -> t a -> b
             -- foldl', -- :: (b -> a -> b) -> b -> t a -> b
             foldr1,    -- :: (a -> a -> a) -> t a -> a
             foldl1,    -- :: (a -> a -> a) -> t a -> a
             maximum,   -- :: (Foldable t, Ord a) => t a -> a
             minimum,   -- :: (Foldable t, Ord a) => t a -> a
             product,   -- :: (Foldable t, Num a) => t a -> a
             sum),      -- :: Num a => t a -> a
             -- toList) -- :: Foldable t => t a -> [a]

    Traversable(traverse, sequenceA, mapM, sequence),

    -- ** Miscellaneous functions
    id, const, (.), flip, ($), until,
    asTypeOf, error, errorWithoutStackTrace, undefined,
    seq, ($!),

    -- * List operations
    map, (++), filter,
    head, last, tail, init, null, length, (!!),
    reverse,
    -- *** Special folds
    and, or, any, all,
    concat, concatMap,
    -- ** Building lists
    -- *** Scans
    scanl, scanl1, scanr, scanr1,
    -- *** Infinite lists
    iterate, repeat, replicate, cycle,
    -- ** Sublists
    take, drop, splitAt, takeWhile, dropWhile, span, break,
    -- ** Searching lists
    notElem, lookup,
    -- ** Zipping and unzipping lists
    zip, zip3, zipWith, zipWith3, unzip, unzip3,
    -- ** Functions on strings
    lines, words, unlines, unwords,

    -- * Converting to and from @String@
    -- ** Converting to @String@
    ShowS,
    Show(showsPrec, showList, show),
    shows,
    showChar, showString, showParen,
    -- ** Converting from @String@
    ReadS,
    Read(readsPrec, readList),
    reads, readParen, read, lex,

    -- * Basic Input and output
    IO,
    -- ** Simple I\/O operations
    -- All I/O functions defined here are character oriented.  The
    -- treatment of the newline character will vary on different systems.
    -- For example, two characters of input, return and linefeed, may
    -- read as a single newline character.  These functions cannot be
    -- used portably for binary I/O.
    -- *** Output functions
    putChar,
    putStr, putStrLn, print,
    -- *** Input functions
    getChar,
    getLine, getContents, interact,
    -- *** Files
    FilePath,
    readFile, writeFile, appendFile, readIO, readLn,
    -- ** Exception handling in the I\/O monad
    IOError, ioError, userError,

  ) where

import Control.Monad
import System.IO
import System.IO.Error
import Data.List
import Data.Either
import Data.Foldable    ( Foldable(..) )
import Data.Functor     ( (<$>) )
import Data.Maybe
import Data.Traversable ( Traversable(..) )
import Data.Tuple

import GHC.Base hiding ( foldr, mapM, sequence )
import Text.Read
import GHC.Enum
import GHC.Num
import GHC.Real
import GHC.Float
import GHC.Show


module Main (main) where

import Distribution.Simple

main :: IO ()
main = defaultMainWithHooks autoconfUserHooks


{--
This is a script to generate the necessary tables to support Windows code page
encoding/decoding.

License: see libraries/base/LICENSE

The code page tables are available from :
http://www.unicode.org/Public/MAPPINGS/

To run this script, use e.g.
runghc MakeTable.hs <module-name> <output-file> <codepage-dir>/*.TXT

Currently, this script only supports single-byte encodings, since the lookup
tables required for the CJK double-byte codepages are too large to be
statically linked into every executable.  We plan to add support for them once
GHC is able to produce Windows DLLs.
--}

module Main where

import System.FilePath
import qualified Data.Map as Map
import System.IO
import Data.Maybe (mapMaybe)
import Data.List (intersperse)
import Data.Word
import Numeric
import Control.Monad.State
import System.Environment
import Control.Exception(evaluate)

main :: IO ()
main = do
    moduleName:outFile:files <- getArgs
    let badFiles = -- These fail with an error like
                   --     MakeTable: Enum.toEnum{Word8}: tag (33088) is outside of bounds (0,255)
                   -- I have no idea what's going on, so for now we just
                   -- skip them.
                   ["CPs/CP932.TXT",
                    "CPs/CP936.TXT",
                    "CPs/CP949.TXT",
                    "CPs/CP950.TXT"]
    let files' = filter (`notElem` badFiles) files
    sbes <- mapM readMapAndIx files'
    putStrLn "Writing output"
    withBinaryFile outFile WriteMode $ flip hPutStr
        $ unlines $ makeTableFile moduleName files' sbes
  where
    readMapAndIx f = do
        putStrLn ("Reading " ++ f)
        m <- readMap f
        return (codePageNum f, m)

-- filenames are assumed to be of the form "CP1250.TXT"
codePageNum :: FilePath -> Int
codePageNum = read . drop 2 . takeBaseName

readMap :: (Ord a, Enum a) => FilePath -> IO (Map.Map a Char)
readMap f  = withBinaryFile f ReadMode $ \h -> do
    contents <- hGetContents h
    let ms = Map.fromList $ mapMaybe parseLine $ lines contents
    evaluate $ Map.size ms
    return ms

parseLine :: Enum a => String -> Maybe (a,Char)
parseLine s = case words s of
    ('#':_):_           -> Nothing
    bs:"#DBCS":_        -> Just (readHex' bs, toEnum 0xDC00)
    bs:"#UNDEFINED":_   -> Just (readHex' bs, toEnum 0)
    bs:cs:('#':_):_     -> Just (readHex' bs, readCharHex cs)
    _                   -> Nothing

readHex' :: Enum a => String -> a
readHex' ('0':'x':s) = case readHex s of
    [(n,"")] -> toEnum n -- explicitly call toEnum to catch overflow errors.
    _ -> errorWithoutStackTrace $ "Can't read hex: " ++ show s
readHex' s = errorWithoutStackTrace $ "Can't read hex: " ++ show s

readCharHex :: String -> Char
readCharHex s = if c > fromEnum (maxBound :: Word16)
                    then errorWithoutStackTrace "Can't handle non-BMP character."
                    else toEnum c
    where c = readHex' s

-------------------------------------------
-- Writing out the main data values.

makeTableFile :: String -> [FilePath] -> [(Int,Map.Map Word8 Char)] -> [String]
makeTableFile moduleName files maps = concat
    [ languageDirectives, firstComment files, header,
        theImports, theTypes, blockSizeText, tablePart]
  where
    header = [ "module " ++ moduleName ++ " where"
             , ""
             ]
    tablePart = [ "codePageMap :: [(Word32, CodePageArrays)]"
                , "codePageMap = ["
                ] ++ (intersperse "\n    ," $ map mkTableEntry maps)
                ++ ["    ]"]
    mkTableEntry (i,m) = "    (" ++ show i ++ ", " ++ makeSBE m ++ "    )"
    blockSizeText = ["blockBitSize :: Int", "blockBitSize = " ++ show blockBitSize]

makeSBE :: Map.Map Word8 Char -> String
makeSBE m = unlines
                [ "SingleByteCP {"
                , "     decoderArray = " ++ mkConvArray es
                , "     , encoderArray = " ++ mkCompactArray (swapMap m)
                , "   }"
                ]
  where
    es = [Map.findWithDefault '\0' x m | x <- [minBound..maxBound]]

swapMap :: (Ord a, Ord b, Enum a, Enum b) => Map.Map a b -> Map.Map b a
swapMap = Map.insert (toEnum 0) (toEnum 0) . Map.fromList . map swap . Map.toList
  where
    swap (x,y) = (y,x)

mkConvArray :: Embed a => [a] -> String
mkConvArray xs = "ConvArray \"" ++ concatMap mkHex xs ++ "\"#"

-------------------------------------------
-- Compact arrays
--
-- The decoding map (from Word8 to Char) can be implemented with a simple array
-- of 256 Word16's.  Bytes which do not belong to the code page are mapped to
-- '\0'.
--
-- However, a naive table mapping Char to Word8 would require 2^16 Word8's.  We
-- can use much less space with the right data structure, since at most 256 of
-- those entries are nonzero.
--
-- We use "compact arrays", as described in "Unicode Demystified" by Richard
-- Gillam.
--
-- Fix a block size S which is a power of two.  We compress an array of N
-- entries (where N>>S) as follows.  First, split the array into blocks of size
-- S, then remove all repeate blocks to form the "value" array.  Then construct
-- a separate "index" array which maps the position of blocks in the old array
-- to a position in the value array.
--
-- For example, assume that S=32 we have six blocks ABABCA, each with 32
-- elements.
--
-- Then the compressed table consists of two arrays:
-- 1) An array "values", concatenating the unique blocks ABC
-- 2) An array "indices" which equals [0,1,0,1,2,0].
--
-- To look up '\100', first calculate divMod 100 32 = (3,4).  Since
-- indices[3]=1, we look at the second unique block B; thus the encoded byte is
-- B[4].
--
-- The upshot of this representation is that the lookup is very quick as it only
-- requires two array accesses plus some bit masking/shifting.

-- From testing, this is an optimal size.
blockBitSize :: Int
blockBitSize = 6

mkCompactArray :: (Embed a, Embed b) => Map.Map a b -> String
mkCompactArray m = unlines [
            ""
            , " CompactArray {"
            , "        encoderIndices = " ++ mkConvArray is'
            , "        , encoderValues = "
                    ++ mkConvArray (concat $ Map.elems vs)
            , "        , encoderMax = " ++ show (fst $ Map.findMax m)
            , "        }"
            ]
  where
    blockSize = 2 ^ blockBitSize
    (is,(vs,_)) = compress blockSize $ m
    is' = map (* blockSize) is

type CompressState b = (Map.Map Int [b], Map.Map [b] Int)
-- each entry in the list corresponds to a block of size n.
compress :: (Bounded a, Enum a, Ord a, Bounded b, Ord b) => Int -> Map.Map a b
        -> ([Int], CompressState b)
compress n ms = runState (mapM lookupOrAdd chunks) (Map.empty, Map.empty)
    where
        chunks = mkChunks $ map (\i -> Map.findWithDefault minBound i ms)
                    $ [minBound..fst (Map.findMax ms)]
        mkChunks [] = []
        mkChunks xs = take n xs : mkChunks (drop n xs)
        lookupOrAdd xs = do
            (m,rm) <- get
            case Map.lookup xs rm of
                Just i -> return i
                Nothing -> do
                    let i = if Map.null m
                                then 0
                                else 1 + fst (Map.findMax m)
                    put (Map.insert i xs m, Map.insert xs i rm)
                    return i

-------------------------------------------
-- Static parts of the generated module.

languageDirectives :: [String]
languageDirectives = ["{-# LANGUAGE MagicHash, NoImplicitPrelude #-}"]

firstComment :: [FilePath] -> [String]
firstComment files = map ("-- " ++) $
    [ "Do not edit this file directly!"
    , "It was generated by the MakeTable.hs script using the files below."
    , "To regenerate it, run \"make\" in ../../../../codepages/"
    , ""
    , "Files:"
    ] ++ map takeFileName files

theImports :: [String]
theImports = map ("import " ++ )
    ["GHC.Prim", "GHC.Base", "GHC.Word"]

theTypes :: [String]
theTypes = [ "data ConvArray a = ConvArray Addr#"
           , "data CompactArray a b = CompactArray {"
           , "    encoderMax :: !a,"
           , "    encoderIndices :: !(ConvArray Int),"
           , "    encoderValues :: !(ConvArray b)"
           , "  }"
           , ""
           , "data CodePageArrays = SingleByteCP {"
           , "    decoderArray :: !(ConvArray Char),"
           , "    encoderArray :: !(CompactArray Char Word8)"
           , "  }"
           , ""
           ]

-------------------------------------------
-- Embed class and associated functions

class (Ord a, Enum a, Bounded a, Show a) => Embed a where
    mkHex :: a -> String

-- | @since 4.2.0.0
instance Embed Word8 where
    mkHex = showHex'

-- | @since 4.2.0.0
instance Embed Word16 where
    mkHex = repDualByte

-- | @since 4.2.0.0
instance Embed Char where
    mkHex = repDualByte

-- this is used for the indices of the compressed array.
-- | @since 4.2.0.0
instance Embed Int where
    mkHex = repDualByte

showHex' :: Integral a => a -> String
showHex' s = "\\x" ++ showHex s ""

repDualByte :: Enum c => c -> String
repDualByte c
    | n >= 2^(16::Int) = errorWithoutStackTrace "value is too high!"
    -- NOTE : this assumes little-endian architecture.  But we're only using this on Windows,
    -- so it's probably OK.
    | otherwise = showHex' (n `mod` 256) ++ showHex' (n `div` 256)
  where
    n = fromEnum c


{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NoImplicitPrelude #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Applicative
-- Copyright   :  Conor McBride and Ross Paterson 2005
-- License     :  BSD-style (see the LICENSE file in the distribution)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  experimental
-- Portability :  portable
--
-- This module describes a structure intermediate between a functor and
-- a monad (technically, a strong lax monoidal functor).  Compared with
-- monads, this interface lacks the full power of the binding operation
-- '>>=', but
--
-- * it has more instances.
--
-- * it is sufficient for many uses, e.g. context-free parsing, or the
--   'Data.Traversable.Traversable' class.
--
-- * instances can perform analysis of computations before they are
--   executed, and thus produce shared optimizations.
--
-- This interface was introduced for parsers by Niklas Röjemo, because
-- it admits more sharing than the monadic interface.  The names here are
-- mostly based on parsing work by Doaitse Swierstra.
--
-- For more details, see
-- <http://www.soi.city.ac.uk/~ross/papers/Applicative.html Applicative Programming with Effects>,
-- by Conor McBride and Ross Paterson.

module Control.Applicative (
    -- * Applicative functors
    Applicative(..),
    -- * Alternatives
    Alternative(..),
    -- * Instances
    Const(..), WrappedMonad(..), WrappedArrow(..), ZipList(..),
    -- * Utility functions
    (<$>), (<$), (<**>),
    liftA, liftA3,
    optional,
    ) where

import Control.Category hiding ((.), id)
import Control.Arrow
import Data.Maybe
import Data.Tuple
import Data.Eq
import Data.Ord
import Data.Foldable (Foldable(..))
import Data.Functor ((<$>))
import Data.Functor.Const (Const(..))

import GHC.Base
import GHC.Generics
import GHC.List (repeat, zipWith, drop)
import GHC.Read (Read)
import GHC.Show (Show)

newtype WrappedMonad m a = WrapMonad { unwrapMonad :: m a }
                         deriving ( Generic  -- ^ @since 4.7.0.0
                                  , Generic1 -- ^ @since 4.7.0.0
                                  , Monad    -- ^ @since 4.7.0.0
                                  )

-- | @since 2.01
instance Monad m => Functor (WrappedMonad m) where
    fmap f (WrapMonad v) = WrapMonad (liftM f v)

-- | @since 2.01
instance Monad m => Applicative (WrappedMonad m) where
    pure = WrapMonad . pure
    WrapMonad f <*> WrapMonad v = WrapMonad (f `ap` v)
    liftA2 f (WrapMonad x) (WrapMonad y) = WrapMonad (liftM2 f x y)

-- | @since 2.01
instance MonadPlus m => Alternative (WrappedMonad m) where
    empty = WrapMonad mzero
    WrapMonad u <|> WrapMonad v = WrapMonad (u `mplus` v)

newtype WrappedArrow a b c = WrapArrow { unwrapArrow :: a b c }
                           deriving ( Generic  -- ^ @since 4.7.0.0
                                    , Generic1 -- ^ @since 4.7.0.0
                                    )

-- | @since 2.01
instance Arrow a => Functor (WrappedArrow a b) where
    fmap f (WrapArrow a) = WrapArrow (a >>> arr f)

-- | @since 2.01
instance Arrow a => Applicative (WrappedArrow a b) where
    pure x = WrapArrow (arr (const x))
    liftA2 f (WrapArrow u) (WrapArrow v) =
      WrapArrow (u &&& v >>> arr (uncurry f))

-- | @since 2.01
instance (ArrowZero a, ArrowPlus a) => Alternative (WrappedArrow a b) where
    empty = WrapArrow zeroArrow
    WrapArrow u <|> WrapArrow v = WrapArrow (u <+> v)

-- | Lists, but with an 'Applicative' functor based on zipping.
newtype ZipList a = ZipList { getZipList :: [a] }
                  deriving ( Show     -- ^ @since 4.7.0.0
                           , Eq       -- ^ @since 4.7.0.0
                           , Ord      -- ^ @since 4.7.0.0
                           , Read     -- ^ @since 4.7.0.0
                           , Functor  -- ^ @since 2.01
                           , Foldable -- ^ @since 4.9.0.0
                           , Generic  -- ^ @since 4.7.0.0
                           , Generic1 -- ^ @since 4.7.0.0
                           )
-- See Data.Traversable for Traversable instance due to import loops

-- |
-- > f <$> ZipList xs1 <*> ... <*> ZipList xsN
-- >     = ZipList (zipWithN f xs1 ... xsN)
--
-- where @zipWithN@ refers to the @zipWith@ function of the appropriate arity
-- (@zipWith@, @zipWith3@, @zipWith4@, ...). For example:
--
-- > (\a b c -> stimes c [a, b]) <$> ZipList "abcd" <*> ZipList "567" <*> ZipList [1..]
-- >     = ZipList (zipWith3 (\a b c -> stimes c [a, b]) "abcd" "567" [1..])
-- >     = ZipList {getZipList = ["a5","b6b6","c7c7c7"]}
--
-- @since 2.01
instance Applicative ZipList where
    pure x = ZipList (repeat x)
    liftA2 f (ZipList xs) (ZipList ys) = ZipList (zipWith f xs ys)

-- | @since 4.11.0.0
instance Alternative ZipList where
   empty = ZipList []
   ZipList xs <|> ZipList ys = ZipList (xs ++ drop (length xs) ys)

-- extra functions

-- | One or none.
optional :: Alternative f => f a -> f (Maybe a)
optional v = Just <$> v <|> pure Nothing


{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -Wno-inline-rule-shadowing #-}
    -- The RULES for the methods of class Arrow may never fire
    -- e.g. compose/arr;  see Trac #10528

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Arrow
-- Copyright   :  (c) Ross Paterson 2002
-- License     :  BSD-style (see the LICENSE file in the distribution)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  provisional
-- Portability :  portable
--
-- Basic arrow definitions, based on
--
--  * /Generalising Monads to Arrows/, by John Hughes,
--    /Science of Computer Programming/ 37, pp67-111, May 2000.
--
-- plus a couple of definitions ('returnA' and 'loop') from
--
--  * /A New Notation for Arrows/, by Ross Paterson, in /ICFP 2001/,
--    Firenze, Italy, pp229-240.
--
-- These papers and more information on arrows can be found at
-- <http://www.haskell.org/arrows/>.

module Control.Arrow (
    -- * Arrows
    Arrow(..), Kleisli(..),
    -- ** Derived combinators
    returnA,
    (^>>), (>>^),
    (>>>), (<<<), -- reexported
    -- ** Right-to-left variants
    (<<^), (^<<),
    -- * Monoid operations
    ArrowZero(..), ArrowPlus(..),
    -- * Conditionals
    ArrowChoice(..),
    -- * Arrow application
    ArrowApply(..), ArrowMonad(..), leftApp,
    -- * Feedback
    ArrowLoop(..)
    ) where

import Data.Tuple ( fst, snd, uncurry )
import Data.Either
import Control.Monad.Fix
import Control.Category
import GHC.Base hiding ( (.), id )

infixr 5 <+>
infixr 3 ***
infixr 3 &&&
infixr 2 +++
infixr 2 |||
infixr 1 ^>>, >>^
infixr 1 ^<<, <<^

-- | The basic arrow class.
--
-- Instances should satisfy the following laws:
--
--  * @'arr' id = 'id'@
--
--  * @'arr' (f >>> g) = 'arr' f >>> 'arr' g@
--
--  * @'first' ('arr' f) = 'arr' ('first' f)@
--
--  * @'first' (f >>> g) = 'first' f >>> 'first' g@
--
--  * @'first' f >>> 'arr' 'fst' = 'arr' 'fst' >>> f@
--
--  * @'first' f >>> 'arr' ('id' *** g) = 'arr' ('id' *** g) >>> 'first' f@
--
--  * @'first' ('first' f) >>> 'arr' assoc = 'arr' assoc >>> 'first' f@
--
-- where
--
-- > assoc ((a,b),c) = (a,(b,c))
--
-- The other combinators have sensible default definitions,
-- which may be overridden for efficiency.

class Category a => Arrow a where
    {-# MINIMAL arr, (first | (***)) #-}

    -- | Lift a function to an arrow.
    arr :: (b -> c) -> a b c

    -- | Send the first component of the input through the argument
    --   arrow, and copy the rest unchanged to the output.
    first :: a b c -> a (b,d) (c,d)
    first = (*** id)

    -- | A mirror image of 'first'.
    --
    --   The default definition may be overridden with a more efficient
    --   version if desired.
    second :: a b c -> a (d,b) (d,c)
    second = (id ***)

    -- | Split the input between the two argument arrows and combine
    --   their output.  Note that this is in general not a functor.
    --
    --   The default definition may be overridden with a more efficient
    --   version if desired.
    (***) :: a b c -> a b' c' -> a (b,b') (c,c')
    f *** g = first f >>> arr swap >>> first g >>> arr swap
      where swap ~(x,y) = (y,x)

    -- | Fanout: send the input to both argument arrows and combine
    --   their output.
    --
    --   The default definition may be overridden with a more efficient
    --   version if desired.
    (&&&) :: a b c -> a b c' -> a b (c,c')
    f &&& g = arr (\b -> (b,b)) >>> f *** g

{-# RULES
"compose/arr"   forall f g .
                (arr f) . (arr g) = arr (f . g)
"first/arr"     forall f .
                first (arr f) = arr (first f)
"second/arr"    forall f .
                second (arr f) = arr (second f)
"product/arr"   forall f g .
                arr f *** arr g = arr (f *** g)
"fanout/arr"    forall f g .
                arr f &&& arr g = arr (f &&& g)
"compose/first" forall f g .
                (first f) . (first g) = first (f . g)
"compose/second" forall f g .
                (second f) . (second g) = second (f . g)
 #-}

-- Ordinary functions are arrows.

-- | @since 2.01
instance Arrow (->) where
    arr f = f
--  (f *** g) ~(x,y) = (f x, g y)
--  sorry, although the above defn is fully H'98, nhc98 can't parse it.
    (***) f g ~(x,y) = (f x, g y)

-- | Kleisli arrows of a monad.
newtype Kleisli m a b = Kleisli { runKleisli :: a -> m b }

-- | @since 3.0
instance Monad m => Category (Kleisli m) where
    id = Kleisli return
    (Kleisli f) . (Kleisli g) = Kleisli (\b -> g b >>= f)

-- | @since 2.01
instance Monad m => Arrow (Kleisli m) where
    arr f = Kleisli (return . f)
    first (Kleisli f) = Kleisli (\ ~(b,d) -> f b >>= \c -> return (c,d))
    second (Kleisli f) = Kleisli (\ ~(d,b) -> f b >>= \c -> return (d,c))

-- | The identity arrow, which plays the role of 'return' in arrow notation.
returnA :: Arrow a => a b b
returnA = arr id

-- | Precomposition with a pure function.
(^>>) :: Arrow a => (b -> c) -> a c d -> a b d
f ^>> a = arr f >>> a

-- | Postcomposition with a pure function.
(>>^) :: Arrow a => a b c -> (c -> d) -> a b d
a >>^ f = a >>> arr f

-- | Precomposition with a pure function (right-to-left variant).
(<<^) :: Arrow a => a c d -> (b -> c) -> a b d
a <<^ f = a <<< arr f

-- | Postcomposition with a pure function (right-to-left variant).
(^<<) :: Arrow a => (c -> d) -> a b c -> a b d
f ^<< a = arr f <<< a

class Arrow a => ArrowZero a where
    zeroArrow :: a b c

-- | @since 2.01
instance MonadPlus m => ArrowZero (Kleisli m) where
    zeroArrow = Kleisli (\_ -> mzero)

-- | A monoid on arrows.
class ArrowZero a => ArrowPlus a where
    -- | An associative operation with identity 'zeroArrow'.
    (<+>) :: a b c -> a b c -> a b c

-- | @since 2.01
instance MonadPlus m => ArrowPlus (Kleisli m) where
    Kleisli f <+> Kleisli g = Kleisli (\x -> f x `mplus` g x)

-- | Choice, for arrows that support it.  This class underlies the
-- @if@ and @case@ constructs in arrow notation.
--
-- Instances should satisfy the following laws:
--
--  * @'left' ('arr' f) = 'arr' ('left' f)@
--
--  * @'left' (f >>> g) = 'left' f >>> 'left' g@
--
--  * @f >>> 'arr' 'Left' = 'arr' 'Left' >>> 'left' f@
--
--  * @'left' f >>> 'arr' ('id' +++ g) = 'arr' ('id' +++ g) >>> 'left' f@
--
--  * @'left' ('left' f) >>> 'arr' assocsum = 'arr' assocsum >>> 'left' f@
--
-- where
--
-- > assocsum (Left (Left x)) = Left x
-- > assocsum (Left (Right y)) = Right (Left y)
-- > assocsum (Right z) = Right (Right z)
--
-- The other combinators have sensible default definitions, which may
-- be overridden for efficiency.

class Arrow a => ArrowChoice a where
    {-# MINIMAL (left | (+++)) #-}

    -- | Feed marked inputs through the argument arrow, passing the
    --   rest through unchanged to the output.
    left :: a b c -> a (Either b d) (Either c d)
    left = (+++ id)

    -- | A mirror image of 'left'.
    --
    --   The default definition may be overridden with a more efficient
    --   version if desired.
    right :: a b c -> a (Either d b) (Either d c)
    right = (id +++)

    -- | Split the input between the two argument arrows, retagging
    --   and merging their outputs.
    --   Note that this is in general not a functor.
    --
    --   The default definition may be overridden with a more efficient
    --   version if desired.
    (+++) :: a b c -> a b' c' -> a (Either b b') (Either c c')
    f +++ g = left f >>> arr mirror >>> left g >>> arr mirror
      where
        mirror :: Either x y -> Either y x
        mirror (Left x) = Right x
        mirror (Right y) = Left y

    -- | Fanin: Split the input between the two argument arrows and
    --   merge their outputs.
    --
    --   The default definition may be overridden with a more efficient
    --   version if desired.
    (|||) :: a b d -> a c d -> a (Either b c) d
    f ||| g = f +++ g >>> arr untag
      where
        untag (Left x) = x
        untag (Right y) = y

{-# RULES
"left/arr"      forall f .
                left (arr f) = arr (left f)
"right/arr"     forall f .
                right (arr f) = arr (right f)
"sum/arr"       forall f g .
                arr f +++ arr g = arr (f +++ g)
"fanin/arr"     forall f g .
                arr f ||| arr g = arr (f ||| g)
"compose/left"  forall f g .
                left f . left g = left (f . g)
"compose/right" forall f g .
                right f . right g = right (f . g)
 #-}

-- | @since 2.01
instance ArrowChoice (->) where
    left f = f +++ id
    right f = id +++ f
    f +++ g = (Left . f) ||| (Right . g)
    (|||) = either

-- | @since 2.01
instance Monad m => ArrowChoice (Kleisli m) where
    left f = f +++ arr id
    right f = arr id +++ f
    f +++ g = (f >>> arr Left) ||| (g >>> arr Right)
    Kleisli f ||| Kleisli g = Kleisli (either f g)

-- | Some arrows allow application of arrow inputs to other inputs.
-- Instances should satisfy the following laws:
--
--  * @'first' ('arr' (\\x -> 'arr' (\\y -> (x,y)))) >>> 'app' = 'id'@
--
--  * @'first' ('arr' (g >>>)) >>> 'app' = 'second' g >>> 'app'@
--
--  * @'first' ('arr' (>>> h)) >>> 'app' = 'app' >>> h@
--
-- Such arrows are equivalent to monads (see 'ArrowMonad').

class Arrow a => ArrowApply a where
    app :: a (a b c, b) c

-- | @since 2.01
instance ArrowApply (->) where
    app (f,x) = f x

-- | @since 2.01
instance Monad m => ArrowApply (Kleisli m) where
    app = Kleisli (\(Kleisli f, x) -> f x)

-- | The 'ArrowApply' class is equivalent to 'Monad': any monad gives rise
--   to a 'Kleisli' arrow, and any instance of 'ArrowApply' defines a monad.

newtype ArrowMonad a b = ArrowMonad (a () b)

-- | @since 4.6.0.0
instance Arrow a => Functor (ArrowMonad a) where
    fmap f (ArrowMonad m) = ArrowMonad $ m >>> arr f

-- | @since 4.6.0.0
instance Arrow a => Applicative (ArrowMonad a) where
   pure x = ArrowMonad (arr (const x))
   ArrowMonad f <*> ArrowMonad x = ArrowMonad (f &&& x >>> arr (uncurry id))

-- | @since 2.01
instance ArrowApply a => Monad (ArrowMonad a) where
    ArrowMonad m >>= f = ArrowMonad $
        m >>> arr (\x -> let ArrowMonad h = f x in (h, ())) >>> app

-- | @since 4.6.0.0
instance ArrowPlus a => Alternative (ArrowMonad a) where
   empty = ArrowMonad zeroArrow
   ArrowMonad x <|> ArrowMonad y = ArrowMonad (x <+> y)

-- | @since 4.6.0.0
instance (ArrowApply a, ArrowPlus a) => MonadPlus (ArrowMonad a)

-- | Any instance of 'ArrowApply' can be made into an instance of
--   'ArrowChoice' by defining 'left' = 'leftApp'.

leftApp :: ArrowApply a => a b c -> a (Either b d) (Either c d)
leftApp f = arr ((\b -> (arr (\() -> b) >>> f >>> arr Left, ())) |||
             (\d -> (arr (\() -> d) >>> arr Right, ()))) >>> app

-- | The 'loop' operator expresses computations in which an output value
-- is fed back as input, although the computation occurs only once.
-- It underlies the @rec@ value recursion construct in arrow notation.
-- 'loop' should satisfy the following laws:
--
-- [/extension/]
--      @'loop' ('arr' f) = 'arr' (\\ b -> 'fst' ('fix' (\\ (c,d) -> f (b,d))))@
--
-- [/left tightening/]
--      @'loop' ('first' h >>> f) = h >>> 'loop' f@
--
-- [/right tightening/]
--      @'loop' (f >>> 'first' h) = 'loop' f >>> h@
--
-- [/sliding/]
--      @'loop' (f >>> 'arr' ('id' *** k)) = 'loop' ('arr' ('id' *** k) >>> f)@
--
-- [/vanishing/]
--      @'loop' ('loop' f) = 'loop' ('arr' unassoc >>> f >>> 'arr' assoc)@
--
-- [/superposing/]
--      @'second' ('loop' f) = 'loop' ('arr' assoc >>> 'second' f >>> 'arr' unassoc)@
--
-- where
--
-- > assoc ((a,b),c) = (a,(b,c))
-- > unassoc (a,(b,c)) = ((a,b),c)
--
class Arrow a => ArrowLoop a where
    loop :: a (b,d) (c,d) -> a b c

-- | @since 2.01
instance ArrowLoop (->) where
    loop f b = let (c,d) = f (b,d) in c

-- | Beware that for many monads (those for which the '>>=' operation
-- is strict) this instance will /not/ satisfy the right-tightening law
-- required by the 'ArrowLoop' class.
--
-- @since 2.01
instance MonadFix m => ArrowLoop (Kleisli m) where
    loop (Kleisli f) = Kleisli (liftM fst . mfix . f')
      where f' x y = f (x, snd y)


{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE PolyKinds #-}
{-# OPTIONS_GHC -Wno-inline-rule-shadowing #-}
    -- The RULES for the methods of class Category may never fire
    -- e.g. identity/left, identity/right, association;  see Trac #10528

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Category
-- Copyright   :  (c) Ashley Yakeley 2007
-- License     :  BSD-style (see the LICENSE file in the distribution)
--
-- Maintainer  :  ashley@semantic.org
-- Stability   :  experimental
-- Portability :  portable

-- http://ghc.haskell.org/trac/ghc/ticket/1773

module Control.Category where

import qualified GHC.Base (id,(.))
import Data.Type.Coercion
import Data.Type.Equality
import GHC.Prim (coerce)

infixr 9 .
infixr 1 >>>, <<<

-- | A class for categories. Instances should satisfy the laws
--
-- [Right identity] @f '.' 'id'  =  f@
-- [Left identity]  @'id' '.' f  =  f@
-- [Associativity]  @f '.' (g '.' h)  =  (f '.' g) '.' h@
--
class Category cat where
    -- | the identity morphism
    id :: cat a a

    -- | morphism composition
    (.) :: cat b c -> cat a b -> cat a c

{-# RULES
"identity/left" forall p .
                id . p = p
"identity/right"        forall p .
                p . id = p
"association"   forall p q r .
                (p . q) . r = p . (q . r)
 #-}

-- | @since 3.0
instance Category (->) where
    id = GHC.Base.id
    (.) = (GHC.Base..)

-- | @since 4.7.0.0
instance Category (:~:) where
  id          = Refl
  Refl . Refl = Refl

-- | @since 4.10.0.0
instance Category (:~~:) where
  id            = HRefl
  HRefl . HRefl = HRefl

-- | @since 4.7.0.0
instance Category Coercion where
  id = Coercion
  (.) Coercion = coerce

-- | Right-to-left composition
(<<<) :: Category cat => cat b c -> cat a b -> cat a c
(<<<) = (.)

-- | Left-to-right composition
(>>>) :: Category cat => cat a b -> cat b c -> cat a c
f >>> g = g . f