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
, ASTType (..)
, ASTFileContent (..)
, ASTHandlerKey
, ASTFileUse (..)
, ASTSuffixKey
, ASTFileTiming (..)
, FileSuffInitState
, PrevSearchInfo
, FinalCompileHow (..)
, mkShellCmd, mkShellCmd', showShellCmd
, mkInOrOutputFPathDirFor
, mkInOrOutputFPathFor
, mkOutputFPath
, mkPerModuleOutputFPath
, mkPerExecOutputFPath
, hsstateIsLiteral
, hsstateShowLit
, hsstateNext
, CState (..), OState (..)
, prevSearchInfoAdaptedSearchPath )
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 GHC.Generics
import UHC.Light.Compiler.Gam.Full
import UHC.Light.Compiler.Opts.CommandLine
import qualified UHC.Util.RelMap as Rel
import UHC.Util.Time
import System.Directory




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

{-# LINE 50 "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 71 "src/ehc/EHC/Common.chs" #-}
hsstateIsLiteral :: HSState -> Bool
hsstateIsLiteral LHSStart       = True
hsstateIsLiteral LHSOnlyImports = True
hsstateIsLiteral _              = False

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

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

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

{-# LINE 113 "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 129 "src/ehc/EHC/Common.chs" #-}
data CRState
  = CRStartBinary
  | CRStartText
  | CROnlyImports
  | CRAllSem
  deriving (Show,Eq)

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

{-# LINE 149 "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 169 "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 189 "src/ehc/EHC/Common.chs" #-}
-- | Is compilation from Core source
ecuStateIsCore :: EHCompileUnitState -> Bool
ecuStateIsCore st = case st of
  ECUS_Core _ -> True
  _           -> False

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

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

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

{-# LINE 238 "src/ehc/EHC/Common.chs" #-}
-- | An 'Enum' of all types of ast we can deal with
data ASTType
  = ASTType_HS
  | ASTType_EH
  | ASTType_HI
  | ASTType_Core
  | ASTType_CoreRun
  | ASTType_C
  | ASTType_O
  | ASTType_Unknown
  deriving (Eq, Ord, Enum, Typeable, Generic, Bounded, Show)

instance Hashable ASTType

{-# LINE 271 "src/ehc/EHC/Common.chs" #-}
-- | File content variations of ast we can deal with (in principle)
data ASTFileContent
  = ASTFileContent_Text
  | ASTFileContent_LitText
  | ASTFileContent_Binary
  | ASTFileContent_Unknown
  deriving (Eq, Ord, Enum, Typeable, Generic, Bounded, Show)

instance Hashable ASTFileContent

{-# LINE 283 "src/ehc/EHC/Common.chs" #-}
-- | Combination of 'ASTType' and 'ASTFileContent' as key into map of handlers
type ASTHandlerKey = (ASTType, ASTFileContent)

{-# LINE 288 "src/ehc/EHC/Common.chs" #-}
-- | File usage variations of ast
data ASTFileUse
  = ASTFileUse_Cache		-- ^ internal use cache on file
  | ASTFileUse_Dump			-- ^ output: dumped, possibly usable as src later on
  | ASTFileUse_Target		-- ^ output: as target of compilation
  | ASTFileUse_Src			-- ^ input: src file
  | ASTFileUse_Unknown		-- ^ unknown
  deriving (Eq, Ord, Enum, Typeable, Generic, Bounded, Show)

instance Hashable ASTFileUse

{-# LINE 301 "src/ehc/EHC/Common.chs" #-}
-- | Key for allowed suffixes, multiples allowed to cater for different suffixes
type ASTSuffixKey = (ASTFileContent, ASTFileUse)

{-# LINE 306 "src/ehc/EHC/Common.chs" #-}
-- | File timing variations of ast
data ASTFileTiming
  = ASTFileTiming_Prev		-- ^ previously generated
  | ASTFileTiming_Current	-- ^ current one
  deriving (Eq, Ord, Enum, Typeable, Generic, Bounded, Show)

instance Hashable ASTFileTiming

{-# LINE 320 "src/ehc/EHC/Common.chs" #-}
-- | initial state/settings categorizing the kind of file/ast dealing with
type FileSuffInitState =
     ( EHCompileUnitState
     , ASTType
     , ASTFileContent
     , ASTFileUse
     )

{-# LINE 334 "src/ehc/EHC/Common.chs" #-}
type PrevSearchInfo = (HsName,(FPath,FileLoc))

{-# LINE 338 "src/ehc/EHC/Common.chs" #-}
-- | strip tail part corresponding to module name, and use it to search as well
prevSearchInfoAdaptedSearchPath :: Maybe PrevSearchInfo -> FileLocPath -> FileLocPath
prevSearchInfoAdaptedSearchPath (Just (prevNm,(prevFp,prevLoc))) searchPath
  = case (fpathMbDir (mkFPath prevNm), fpathMbDir prevFp, prevLoc) of
	  (_, _, p) | filelocIsPkg p
		-> p : searchPath
	  (Just n, Just p, _)
		-> mkDirFileLoc (filePathUnPrefix prefix) : searchPath
		where (prefix,_) = splitAt (length p - length n) p
	  _ -> searchPath
prevSearchInfoAdaptedSearchPath _ searchPath = searchPath

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

{-# LINE 366 "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 381 "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 406 "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 412 "src/ehc/EHC/Common.chs" #-}
mkOutputFPath :: FPATH nm => EHCOpts -> nm -> FPath -> String -> FPath
mkOutputFPath = mkInOrOutputFPathFor OutputFor_Module

{-# LINE 421 "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 438 "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)