Re: Building on Windows: the saga continues

module Main (main) where

import Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet
import Data.List
import System.IO

main :: IO ()
main = do
    hSetBuffering stdout NoBuffering
    hSetBuffering stderr NoBuffering
    let dflags0 = DynFlags {
                      ways = [],
                      settings = Settings {
                          sTargetPlatform = Platform {
                              platformOS = OSMinGW32
                          }
                      }
                  }
        ((), dflags1) = runCmdLine processArgs dflags0
    putStrLn "A"
    print $ ways dflags1
    putStrLn "B"

data GeneralFlag
   = Opt_PIC
   | Opt_SccProfilingOn
   | Opt_Static

   deriving (Eq, Show, Enum)

data Language = Haskell98 | Haskell2010
   deriving Enum

data ExtensionFlag
   = Opt_ParallelArrays
   deriving Enum

data DynFlags = DynFlags {
  settings              :: Settings,
  extensions            :: [OnOff ExtensionFlag],
  extensionFlags        :: IntSet,
  ways                  :: [Way],
  buildTag              :: String,
  rtsBuildTag           :: String,
  packageFlags          :: [PackageFlag],
  generalFlags          :: IntSet,
  language              :: Maybe Language,
  ghcMode               :: (),
  ghcLink               :: (),
  hscTarget             :: (),
  hscOutName            :: (),
  extCoreName           :: (),
  verbosity             :: (),
  optLevel              :: (),
  simplPhases           :: (),
  maxSimplIterations    :: (),
  shouldDumpSimplPhase  :: (),
  ruleCheck             :: (),
  strictnessBefore      :: (),
  simplTickFactor       :: (),
  specConstrThreshold   :: (),
  specConstrCount       :: (),
  liberateCaseThreshold :: (),
  floatLamArgs          :: (),
  historySize           :: (),
  cmdlineHcIncludes     :: (),
  importPaths           :: (),
  mainFunIs             :: (),
  ctxtStkDepth          :: (),
  splitInfo             :: (),
  objectDir             :: (),
  dylibInstallName      :: (),
  hiDir                 :: (),
  stubDir               :: (),
  dumpDir               :: (),
  objectSuf             :: (),
  hcSuf                 :: (),
  hiSuf                 :: (),
  canGenerateDynamicToo :: (),
  dynObjectSuf          :: (),
  dynHiSuf              :: (),
  outputFile            :: (),
  outputHi              :: (),
  dynLibLoader          :: (),
  dumpPrefixForce       :: (),
  includePaths          :: (),
  libraryPaths          :: (),
  frameworkPaths        :: (),
  cmdlineFrameworks     :: (),
  rtsOpts               :: (),
  rtsOptsEnabled        :: (),
  hpcDir                :: (),
  depMakefile           :: (),
  depIncludePkgDeps     :: (),
  depSuffixes           :: (),
  extraPkgConfs         :: (),
  filesToClean          :: (),
  dirsToClean           :: (),
  filesToNotIntermelean :: (),
  generatedDumps        :: (),
  dumpFlags             :: (),
  warningFlags          :: (),
  safeHaskell           :: (),
  thOnLoc               :: (),
  newDerivOnLoc         :: (),
  pkgTrustOnLoc         :: (),
  warnSafeOnLoc         :: (),
  warnUnsafeOnLoc       :: (),
  ufCreationThreshold   :: (),
  ufUseThreshold        :: (),
  ufFunAppDiscount      :: (),
  ufDictDiscount        :: (),
  ufKeenessFactor       :: (),
  ufDearOp              :: (),
  maxWorkerArgs         :: (),
  ghciHistSize          :: (),
  haddockOptions        :: (),
  ghciScripts           :: (),
  pprUserLength         :: (),
  pprCols               :: (),
  traceLevel            :: (),
  profAuto              :: (),
  interactivePrint      :: (),
  llvmVersion           :: (),
  nextWrapperNum        :: ()
 }

data Settings = Settings {
  sTargetPlatform        :: Platform
 }

targetPlatform :: DynFlags -> Platform
targetPlatform dflags = sTargetPlatform (settings dflags)

data PackageFlag
  = ExposePackage   String

data Way
  = WayThreaded
  | WayDebug
  | WayProf
  | WayEventLog
  | WayPar
  | WayGran
  | WayNDP
  | WayDyn
  deriving (Show, Eq, Ord)

wayGeneralFlags :: Platform -> Way -> [GeneralFlag]
wayGeneralFlags _ WayThreaded = []
wayGeneralFlags _ WayDebug = []
wayGeneralFlags platform WayDyn =
        case platformOS platform of
            OSMinGW32 -> [Opt_PIC]
            OSDarwin  -> [Opt_PIC]
            OSLinux   -> [Opt_PIC]
            _         -> []
wayGeneralFlags _ WayProf     = [Opt_SccProfilingOn]
wayGeneralFlags _ WayEventLog = []
wayGeneralFlags _ WayPar      = []
wayGeneralFlags _ WayGran     = []
wayGeneralFlags _ WayNDP      = []

wayExtras :: Platform -> Way -> DynFlags -> DynFlags
wayExtras _ WayThreaded dflags = dflags
wayExtras _ WayDebug    dflags = dflags
wayExtras _ WayDyn      dflags = dflags
wayExtras _ WayProf     dflags = dflags
wayExtras _ WayEventLog dflags = dflags
wayExtras _ WayPar      dflags = exposePackage' "concurrent" dflags
wayExtras _ WayGran     dflags = exposePackage' "concurrent" dflags
wayExtras _ WayNDP      dflags = setExtensionFlag' Opt_ParallelArrays dflags

data OnOff a = On a

flattenExtensionFlags :: Maybe Language -> [OnOff ExtensionFlag] -> IntSet
flattenExtensionFlags ml = foldr f defaultExtensionFlags
    where f (On flag)  flags = IntSet.insert (fromEnum flag) flags
          defaultExtensionFlags = IntSet.fromList (map fromEnum (languageExtensions ml))

languageExtensions :: Maybe Language -> [ExtensionFlag]
languageExtensions Nothing = []
languageExtensions (Just Haskell98) = []
languageExtensions (Just Haskell2010) = []

gopt_set :: DynFlags -> GeneralFlag -> DynFlags
gopt_set dfs f = dfs{ generalFlags = IntSet.insert (fromEnum f) (generalFlags dfs) }

gopt_unset :: DynFlags -> GeneralFlag -> DynFlags
gopt_unset dfs f = dfs{ generalFlags = IntSet.delete (fromEnum f) (generalFlags dfs) }

xopt_set :: DynFlags -> ExtensionFlag -> DynFlags
xopt_set dfs f
    = let onoffs = On f : extensions dfs
      in dfs { extensions = onoffs,
               extensionFlags = flattenExtensionFlags (language dfs) onoffs }

flagsAll :: [Flag (CmdLineP DynFlags)]
flagsAll = [
    Flag "-prof"           (NoArg (addWay WayProf))
  , Flag "-dynamic"        (NoArg (do unSetGeneralFlag Opt_Static
                                      addWay WayDyn))
 ]

type DynP = EwM (CmdLineP DynFlags)

upd :: (DynFlags -> DynFlags) -> DynP ()
upd f = liftEwM (do dflags <- getCmdLineState
                    putCmdLineState $ f dflags)

addWay :: Way -> DynP ()
addWay w = upd (addWay' w)

addWay' :: Way -> DynFlags -> DynFlags
addWay' w dflags0 = let platform = targetPlatform dflags0
                        dflags1 = dflags0 { ways = w : ways dflags0 }
                        dflags2 = wayExtras platform w dflags1
                        dflags3 = foldr setGeneralFlag' dflags2 (wayGeneralFlags platform w)
                    in dflags3

unSetGeneralFlag :: GeneralFlag -> DynP ()
unSetGeneralFlag f = upd (unSetGeneralFlag' f)

setGeneralFlag' :: GeneralFlag -> DynFlags -> DynFlags
setGeneralFlag' f dflags = gopt_set dflags f
unSetGeneralFlag' :: GeneralFlag -> DynFlags -> DynFlags
unSetGeneralFlag' f dflags = gopt_unset dflags f


setExtensionFlag' :: ExtensionFlag -> DynFlags -> DynFlags
setExtensionFlag' f dflags = xopt_set dflags f

exposePackage' :: String -> DynFlags -> DynFlags
exposePackage' p dflags
    = dflags { packageFlags = ExposePackage p : packageFlags dflags }

data Platform
        = Platform {
              platformOS                       :: OS
          }
        deriving (Read, Show, Eq)

data OS
        = OSUnknown
        | OSLinux
        | OSDarwin
        | OSSolaris2
        | OSMinGW32
        | OSFreeBSD
        | OSDragonFly
        | OSOpenBSD
        | OSNetBSD
        | OSKFreeBSD
        | OSHaiku
        | OSOsf3
        deriving (Read, Show, Eq)

data Flag m = Flag
    {   flagName    :: String,   -- Flag, without the leading "-"
        flagOptKind :: OptKind m -- What to do if we see it
    }

data OptKind m                             -- Suppose the flag is -f
    = NoArg     (EwM m ())                 -- -f all by itself

newtype EwM m a = EwM { unEwM :: String -> m a }

instance Monad m => Monad (EwM m) where
    (EwM f) >>= k = EwM (\l -> do r <- f l
                                  unEwM (k r) l)
    return v = EwM (\_ -> return v)

setArg :: Monad m => String -> EwM m () -> EwM m ()
setArg l (EwM f) = EwM (\_ -> f l)

liftEwM :: Monad m => m a -> EwM m a
liftEwM action = EwM (\_ -> do { r <- action; return r })


newtype CmdLineP s a = CmdLineP { runCmdLine :: s -> (a, s) }

instance Monad (CmdLineP s) where
    m >>= k = CmdLineP $ \s ->
                  let (a, s') = runCmdLine m s
                  in runCmdLine (k a) s'

    return a = CmdLineP $ \s -> (a, s)

getCmdLineState :: CmdLineP s s
getCmdLineState   = CmdLineP $ \s -> (s,s)
putCmdLineState :: s -> CmdLineP s ()
putCmdLineState s = CmdLineP $ \_ -> ((),s)


processArgs :: CmdLineP DynFlags ()
processArgs = unEwM process (error "processArgs: no arg yet")
  where
    process =
        case findArg flagsAll "-dynamic" of
            Just (NoArg _) -> setArg "-dynamic" $ do unSetGeneralFlag Opt_Static
                                                     addWay WayDyn
            Nothing -> return ()

findArg :: [Flag m] -> String -> Maybe (OptKind m)
findArg spec arg =
    case
           [ optKind
           | flag <- spec,
             let optKind  = flagOptKind flag,
             Just _ <- [stripPrefix (flagName flag) arg] ]
    of
        []      -> Nothing
        (one:_) -> Just one