uhc-light-1.1.9.4: src/UHC/Light/Compiler/EHC/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.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)