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.EHC.ASTPipeline , module UHC.Light.Compiler.Gam.Full , HSState (..) , EHState (..) , CRState (..) , CRRState (..) , EHCompileUnitState (..) , ecuStateFinalDestination , ecuStateIsCore , ecuStateIsCoreRun , EHCompileUnitKind (..) , ecuStateToKind , ASTFileNameOverride (..), astFileNameOverrideMbFPath , ASTFileSuffOverride (..) , ASTFileTimeHandleHow (..) , FileSuffInitState , PrevSearchInfo , FileSearchKey (..) , PrevFileSearchKey (..), updPrevFileSearchKeyWithName, mkPrevFileSearchKeyWithName, mkPrevFileSearchKeyWithNameMbPrev, mkPrevFileSearchKeyWithNamePrev , FinalCompileHow (..) , mkShellCmd, mkShellCmd', showShellCmd , mkInOrOutputFPathDirFor , mkInOrOutputFPathFor , mkOutputFPath , mkPerModuleOutputFPath , mkPerExecOutputFPath , hsstateIsLiteral , hsstateShowLit , hsstateNext , GetMeta (..), allGetMeta , CState (..), OState (..) , prevSearchInfoAdaptedSearchPath , mkOutputMbDir ) 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.EHC.ASTPipeline 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 43 "src/ehc/EHC/Common.chs" #-} -- dummy, so module is not empty for initial variants, and exports will take effect {-# LINE 53 "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 74 "src/ehc/EHC/Common.chs" #-} hsstateIsLiteral :: HSState -> Bool hsstateIsLiteral LHSStart = True hsstateIsLiteral LHSOnlyImports = True hsstateIsLiteral _ = False {-# LINE 83 "src/ehc/EHC/Common.chs" #-} hsstateShowLit :: HSState -> String hsstateShowLit LHSStart = "Literal" hsstateShowLit LHSOnlyImports = "Literal" hsstateShowLit _ = "" {-# LINE 94 "src/ehc/EHC/Common.chs" #-} hsstateNext :: HSState -> HSState hsstateNext HSStart = HSOnlyImports hsstateNext HIStart = HIOnlyImports -- hsstateNext HMStart = HMOnlyMinimal hsstateNext LHSStart = LHSOnlyImports hsstateNext st = st {-# LINE 107 "src/ehc/EHC/Common.chs" #-} data EHState = EHStart | EHAllSem deriving (Show,Eq) {-# LINE 116 "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 132 "src/ehc/EHC/Common.chs" #-} data CRState = CRStartBinary | CRStartText | CROnlyImports | CRAllSem deriving (Show,Eq) {-# LINE 141 "src/ehc/EHC/Common.chs" #-} data CRRState = CRRStartBinary | CRRStartText | CRROnlyImports | CRRAllSem deriving (Show,Eq) {-# LINE 152 "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 172 "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 192 "src/ehc/EHC/Common.chs" #-} -- | Is compilation from Core source ecuStateIsCore :: EHCompileUnitState -> Bool ecuStateIsCore st = case st of ECUS_Core _ -> True _ -> False {-# LINE 202 "src/ehc/EHC/Common.chs" #-} -- | Is compilation from CoreRun source ecuStateIsCoreRun :: EHCompileUnitState -> Bool ecuStateIsCoreRun st = case st of ECUS_CoreRun _ -> True _ -> False {-# LINE 216 "src/ehc/EHC/Common.chs" #-} data EHCompileUnitKind = EHCUKind_HS -- Haskell: .hs .lhs .hi | EHCUKind_C -- C: .c | EHCUKind_None -- Nothing deriving Eq {-# LINE 226 "src/ehc/EHC/Common.chs" #-} ecuStateToKind :: EHCompileUnitState -> EHCompileUnitKind ecuStateToKind s = case s of ECUS_Haskell _ -> EHCUKind_HS ECUS_C _ -> EHCUKind_C _ -> EHCUKind_None {-# LINE 241 "src/ehc/EHC/Common.chs" #-} -- | Overriding an automatically chosen name (based on module name) data ASTFileNameOverride = ASTFileNameOverride_AsIs -- ^ fully as is | ASTFileNameOverride_FPath FPath -- ^ with FPath as replacement | ASTFileNameOverride_FPathAsTop FPath -- ^ with FPath as top level module path deriving (Eq, Ord, Typeable, Generic) instance Show ASTFileNameOverride where show (ASTFileNameOverride_AsIs ) = "AsIs" show (ASTFileNameOverride_FPath fp) = fpathToStr fp ++ "(Overr)" show (ASTFileNameOverride_FPathAsTop fp) = fpathToStr fp ++ "(^Overr)" instance PP ASTFileNameOverride where pp = pp . show instance Hashable ASTFileNameOverride -- | Possibly extract FPath astFileNameOverrideMbFPath :: ASTFileNameOverride -> Maybe (FPath,Bool) astFileNameOverrideMbFPath (ASTFileNameOverride_FPath fp) = Just (fp,False) astFileNameOverrideMbFPath (ASTFileNameOverride_FPathAsTop fp) = Just (fp,True) astFileNameOverrideMbFPath _ = Nothing {-# LINE 266 "src/ehc/EHC/Common.chs" #-} -- | Overriding an automatically chosen name (based on module name) data ASTFileSuffOverride = ASTFileSuffOverride_AsIs -- ^ fully as is | ASTFileSuffOverride_Suff ASTSuffixKey -- ^ with suff from key as replacement deriving (Eq, Ord, Typeable, Generic, Show) instance Hashable ASTFileSuffOverride {-# LINE 280 "src/ehc/EHC/Common.chs" #-} -- | How to handle possibly previously timing info of file data ASTFileTimeHandleHow = ASTFileTimeHandleHow_Ignore -- ^ just don't do anything with it | ASTFileTimeHandleHow_AbsenceIsError -- ^ if not there, file is not there, error | ASTFileTimeHandleHow_AbsenceIgnore -- ^ if not there, file is not there, ignore deriving (Eq, Ord, Typeable, Generic, Show) instance Hashable ASTFileTimeHandleHow {-# LINE 295 "src/ehc/EHC/Common.chs" #-} -- | initial state/settings categorizing the kind of file/ast dealing with type FileSuffInitState = ( EHCompileUnitState , ASTType , ASTFileContent , ASTFileUse ) {-# LINE 309 "src/ehc/EHC/Common.chs" #-} -- | Info returned from first module/import analysis required for imports done from that module type PrevSearchInfo = (HsName,(FPath,FileLoc)) {-# LINE 314 "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 328 "src/ehc/EHC/Common.chs" #-} -- | Search key for a file to be compiled data FileSearchKey = FileSearchKey { _fsrchNm :: HsName -- ^ module name , _fsrchOverr :: ASTFileNameOverride -- ^ possibly an alternate/overriding file path } deriving (Eq, Ord, Typeable, Generic) instance Hashable FileSearchKey {- instance Eq FileSearchKey where k1 == k2 | where mbfp1@(~(Just fp)) = astFileNameOverrideMbFPath $ _fsrchOverr k1 -} instance Show FileSearchKey where show (FileSearchKey n ov) = case ov of ASTFileNameOverride_AsIs -> show n _ -> show ov instance PP FileSearchKey where pp = pp . show {-# LINE 355 "src/ehc/EHC/Common.chs" #-} -- | Full search key for a file to be compiled, possibly including (previous search) context in which search is done data PrevFileSearchKey = PrevFileSearchKey { _pfsrchKey :: FileSearchKey -- ^ module and possible file name info , _pfsrchMbCxtInfo :: Maybe PrevSearchInfo -- ^ previous search context } deriving (Eq, Ord, Typeable, Generic) instance Hashable PrevFileSearchKey instance Show PrevFileSearchKey where show (PrevFileSearchKey k mc) = show k ++ maybe "" (\c -> "(" ++ show c ++ ")") mc instance PP PrevFileSearchKey where pp = pp . show updPrevFileSearchKeyWithName :: HsName -> PrevFileSearchKey -> PrevFileSearchKey updPrevFileSearchKeyWithName n (PrevFileSearchKey (FileSearchKey _ f) p) = PrevFileSearchKey (FileSearchKey n f) p mkPrevFileSearchKeyWithName :: HsName -> PrevFileSearchKey mkPrevFileSearchKeyWithName n = mkPrevFileSearchKeyWithNameMbPrev n Nothing mkPrevFileSearchKeyWithNameMbPrev :: HsName -> Maybe PrevSearchInfo -> PrevFileSearchKey mkPrevFileSearchKeyWithNameMbPrev n mp = PrevFileSearchKey (FileSearchKey n ASTFileNameOverride_AsIs) mp mkPrevFileSearchKeyWithNamePrev :: HsName -> PrevSearchInfo -> PrevFileSearchKey mkPrevFileSearchKeyWithNamePrev n p = mkPrevFileSearchKeyWithNameMbPrev n (Just p) {-# LINE 393 "src/ehc/EHC/Common.chs" #-} data FinalCompileHow = FinalCompile_Module | FinalCompile_Exec {-# LINE 403 "src/ehc/EHC/Common.chs" #-} data GetMeta = GetMeta_Src | GetMeta_HI | GetMeta_Core | GetMeta_CoreRun | GetMeta_Dir deriving (Eq,Ord) allGetMeta = [ GetMeta_Src , GetMeta_HI , GetMeta_Core , GetMeta_CoreRun , GetMeta_Dir ] {-# LINE 436 "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 451 "src/ehc/EHC/Common.chs" #-} -- | Get the output dir mkOutputMbDir :: InOrOutputFor -> EHCOpts -> Maybe String mkOutputMbDir inoutputfor opts = case inoutputfor of OutputFor_Module -> f ehcOptOutputDir OutputFor_Pkg -> f ehcOptOutputDir -- ehcOptOutputPkgLibDir InputFrom_Loc l | filelocIsPkg l -> f (const Nothing) | otherwise -> f ehcOptOutputDir where f g = fmap filePathUnPrefix $ g opts {-# LINE 464 "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) = maybe (fp, Nothing) (\(fp,d) -> (fp, Just d)) $ do d <- mkOutputMbDir inoutputfor opts return ( fpathPrependDir d $ fpathSetBase (fpathBase fp) -- ensure possibly adapted name in filesys is used $ mkFPath modNm -- includes module hierarchy into filename , d ) {- = (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 499 "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 505 "src/ehc/EHC/Common.chs" #-} mkOutputFPath :: FPATH nm => EHCOpts -> nm -> FPath -> String -> FPath mkOutputFPath = mkInOrOutputFPathFor OutputFor_Module {-# LINE 514 "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 531 "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)