Common.hs

module UHC.Light.Compiler.EHC.Common
( module Data.Maybe, module Data.List, module Data.Char
, module System.IO
, module UHC.Util.CompileRun2, module UHC.Util.Pretty, module UHC.Util.FPath, module UHC.Util.Utils
, module UHC.Light.Compiler.Base.Common, module UHC.Light.Compiler.Base.HsName.Builtin, module UHC.Light.Compiler.Opts
, module UHC.Light.Compiler.Error, module UHC.Light.Compiler.Error.Pretty
, module UHC.Light.Compiler.Gam.Full
, HSState (..)
, EHState (..)
, CRState (..)
, CRRState (..)
, EHCompileUnitState (..)
, ecuStateFinalDestination
, ecuStateIsCore
, ecuStateIsCoreRun
, EHCompileUnitKind (..)
, ecuStateToKind
, FinalCompileHow (..)
, mkShellCmd, mkShellCmd', showShellCmd
, mkInOrOutputFPathDirFor
, mkInOrOutputFPathFor
, mkOutputFPath
, mkPerModuleOutputFPath
, mkPerExecOutputFPath
, hsstateIsLiteral
, hsstateShowLit
, hsstateNext
, CState (..), OState (..) )
where
import Data.List
import Data.Char
import Data.Maybe
import Control.Monad.State
import System.IO
import UHC.Util.CompileRun2
import UHC.Util.Pretty
import UHC.Util.FPath
import UHC.Util.Utils
import UHC.Light.Compiler.Base.Common
import UHC.Light.Compiler.Base.HsName.Builtin
import UHC.Light.Compiler.Opts
import UHC.Light.Compiler.Error
import UHC.Light.Compiler.Error.Pretty
import UHC.Light.Compiler.Gam.Full
import UHC.Light.Compiler.Opts.CommandLine
import UHC.Util.Time
import System.Directory




{-# LINE 35 "src/ehc/EHC/Common.chs" #-}
-- dummy, so module is not empty for initial variants, and exports will take effect

{-# LINE 45 "src/ehc/EHC/Common.chs" #-}
data HSState
  = HSStart                 -- starting from .hs
  | HSAllSem                -- done all semantics for .hs
  | HMOnlyMinimal           -- done minimal info only
  -- | HMStart                 -- starting from nothing, not using .hi info nor .hs file, just for linking etc
  | HSOnlyImports           -- done imports from .hs
  | HIStart                 -- starting from .hi
  | HIAllSem                -- done all semantics for .hi
  | HIOnlyImports           -- done imports from .hi
  | LHSStart                -- starting from .lhs
  | LHSOnlyImports          -- done imports from .lhs
  deriving (Show,Eq)

{-# LINE 66 "src/ehc/EHC/Common.chs" #-}
hsstateIsLiteral :: HSState -> Bool
hsstateIsLiteral LHSStart       = True
hsstateIsLiteral LHSOnlyImports = True
hsstateIsLiteral _              = False

{-# LINE 75 "src/ehc/EHC/Common.chs" #-}
hsstateShowLit :: HSState -> String
hsstateShowLit LHSStart       = "Literal"
hsstateShowLit LHSOnlyImports = "Literal"
hsstateShowLit _              = ""

{-# LINE 86 "src/ehc/EHC/Common.chs" #-}
hsstateNext :: HSState -> HSState
hsstateNext HSStart       = HSOnlyImports
hsstateNext HIStart       = HIOnlyImports
-- hsstateNext HMStart       = HMOnlyMinimal
hsstateNext LHSStart      = LHSOnlyImports
hsstateNext st            = st

{-# LINE 99 "src/ehc/EHC/Common.chs" #-}
data EHState
  = EHStart
  | EHAllSem
  deriving (Show,Eq)

{-# LINE 108 "src/ehc/EHC/Common.chs" #-}
-- | State for .c files
data CState
  = CStart
  | CAllSem
  deriving (Show,Eq)

-- | State for .o files
data OState
  = OStart
  | OAllSem
  deriving (Show,Eq)

{-# LINE 124 "src/ehc/EHC/Common.chs" #-}
data CRState
  = CRStartBinary
  | CRStartText
  | CROnlyImports
  | CRAllSem
  deriving (Show,Eq)

{-# LINE 133 "src/ehc/EHC/Common.chs" #-}
data CRRState
  = CRRStartBinary
  -- | CRRStartText
  | CRROnlyImports
  | CRRAllSem
  deriving (Show,Eq)

{-# LINE 144 "src/ehc/EHC/Common.chs" #-}
data EHCompileUnitState
  = ECUS_Unknown
  | ECUS_Haskell !HSState
  | ECUS_Eh      !EHState
  | ECUS_C       !CState
  | ECUS_O       !OState
  | ECUS_Core    !CRState
  | ECUS_CoreRun !CRRState
  | ECUS_Grin
  | ECUS_Fail
  deriving (Show,Eq)

{-# LINE 164 "src/ehc/EHC/Common.chs" #-}
-- | The final state
ecuStateFinalDestination :: (EHCompileUnitState -> EHCompileUnitState) -> EHCompileUnitState -> EHCompileUnitState
ecuStateFinalDestination postModf
  = postModf . n
  where n (ECUS_Haskell _) = ECUS_Haskell HSAllSem
        n (ECUS_Eh      _) = ECUS_Eh      EHAllSem
        n (ECUS_C       _) = ECUS_C       CAllSem
        n (ECUS_O       _) = ECUS_O       OAllSem
        n (ECUS_Core    _) = ECUS_Core    CRAllSem
        n (ECUS_CoreRun _) = ECUS_CoreRun CRRAllSem
        n _                = ECUS_Fail

{-# LINE 184 "src/ehc/EHC/Common.chs" #-}
-- | Is compilation from Core source
ecuStateIsCore :: EHCompileUnitState -> Bool
ecuStateIsCore st = case st of
  ECUS_Core _ -> True
  _           -> False

{-# LINE 194 "src/ehc/EHC/Common.chs" #-}
-- | Is compilation from CoreRun source
ecuStateIsCoreRun :: EHCompileUnitState -> Bool
ecuStateIsCoreRun st = case st of
  ECUS_CoreRun _ -> True
  _              -> False

{-# LINE 208 "src/ehc/EHC/Common.chs" #-}
data EHCompileUnitKind
  = EHCUKind_HS     -- Haskell: .hs .lhs .hi
  | EHCUKind_C      -- C: .c
  | EHCUKind_None   -- Nothing
  deriving Eq

{-# LINE 218 "src/ehc/EHC/Common.chs" #-}
ecuStateToKind :: EHCompileUnitState -> EHCompileUnitKind
ecuStateToKind s
  = case s of
      ECUS_Haskell _ -> EHCUKind_HS
      ECUS_C       _ -> EHCUKind_C
      _              -> EHCUKind_None

{-# LINE 233 "src/ehc/EHC/Common.chs" #-}
data FinalCompileHow
  = FinalCompile_Module
  | FinalCompile_Exec

{-# LINE 243 "src/ehc/EHC/Common.chs" #-}
mkShellCmd' :: [Cmd] -> FilePath -> CmdLineOpts -> (FilePath,[String])
mkShellCmd' forCmds cmdStr o = (cmdStr, showCmdLineOpts' forCmds o)

mkShellCmd :: [String] -> (FilePath,[String])
mkShellCmd (cmd:args) = (cmd,args)

showShellCmd :: (FilePath,[String]) -> String
showShellCmd (cmd,args) = concat $ intersperse " " $ [cmd] ++ args

{-# LINE 258 "src/ehc/EHC/Common.chs" #-}
mkInOrOutputFPathDirFor :: FPATH nm => InOrOutputFor -> EHCOpts -> nm -> FPath -> String -> (FPath,Maybe String)
mkInOrOutputFPathDirFor inoutputfor opts modNm fp suffix
  = (fpathSetSuff suffix fp', d)
  where (fp',d) = case inoutputfor of
                    OutputFor_Module   -> f ehcOptOutputDir
                    OutputFor_Pkg      -> f ehcOptOutputDir -- ehcOptOutputPkgLibDir
                    InputFrom_Loc l
                      | filelocIsPkg l -> f (const Nothing)
                      | otherwise      -> f ehcOptOutputDir
        f g     = case g opts of
                    Just d -> ( fpathPrependDir d'
                                $ fpathSetBase (fpathBase fp)	-- ensure possibly adapted name in filesys is used
                                $ mkFPath modNm					-- includes module hierarchy into filename
                              , Just d'
                              )
                           where d' = filePathUnPrefix d
                    _      -> (fp,Nothing)

{-# LINE 283 "src/ehc/EHC/Common.chs" #-}
mkInOrOutputFPathFor :: FPATH nm => InOrOutputFor -> EHCOpts -> nm -> FPath -> String -> FPath
mkInOrOutputFPathFor inoutputfor opts modNm fp suffix
  = fst $ mkInOrOutputFPathDirFor inoutputfor opts modNm fp suffix

{-# LINE 289 "src/ehc/EHC/Common.chs" #-}
mkOutputFPath :: FPATH nm => EHCOpts -> nm -> FPath -> String -> FPath
mkOutputFPath = mkInOrOutputFPathFor OutputFor_Module

{-# LINE 298 "src/ehc/EHC/Common.chs" #-}
-- | FPath for per module output
mkPerModuleOutputFPath :: EHCOpts -> Bool -> HsName -> FPath -> String -> FPath
mkPerModuleOutputFPath opts doSepBy_ modNm fp suffix
  = fpO modNm fp
  where fpO m f= case ehcOptPkgOpt opts of
                   Just _        -> nm_
                   _ | doSepBy_  -> nm_
                     | otherwise -> mkOutputFPath opts m f suffix
               where nm_ = mkOutputFPath opts (hsnMapQualified (const base) m) (fpathSetBase base f) suffix
                         where base = hsnShow "_" "_" m

{-# LINE 315 "src/ehc/EHC/Common.chs" #-}
-- | FPath for final executable, with possible suffix (and forcing flag, even on given exec)
mkPerExecOutputFPath :: EHCOpts -> HsName -> FPath -> Maybe (String, Bool) -> FPath
mkPerExecOutputFPath opts modNm fp mbSuffix
  = maybe id (\(s,force) -> if force then fpathSetSuff s else id) mbSuffix fpExec
  where fpExecBasedOnSrc = maybe (mkOutputFPath opts modNm fp "") (\(s,_) -> mkOutputFPath opts modNm fp s) mbSuffix
        fpExec = maybe fpExecBasedOnSrc id (ehcOptMbOutputFile opts)