module UHC.Light.Compiler.EHC.BuildFunction.Run
( module UHC.Light.Compiler.EHC.BuildFunction
, bcall )
where
import UHC.Light.Compiler.EHC.BuildFunction
import UHC.Light.Compiler.EHC.Common
import UHC.Light.Compiler.EHC.CompileRun.Base
import UHC.Light.Compiler.EHC.CompileUnit
import UHC.Light.Compiler.EHC.FileSuffMp
import UHC.Light.Compiler.EHC.CompilePhase.CompileC
import UHC.Light.Compiler.EHC.CompilePhase.Output
import UHC.Light.Compiler.Base.ParseUtils
import UHC.Util.ScanUtils as ScanUtils
import UHC.Light.Compiler.EHC.ASTHandler
import UHC.Light.Compiler.EHC.ASTHandler.Instances
import qualified UHC.Light.Compiler.Config as Cfg
import UHC.Light.Compiler.Opts.CommandLine
import UHC.Light.Compiler.Base.Optimize
import UHC.Light.Compiler.CodeGen.RefGenerator
import UHC.Util.Lens
import Data.Typeable
import Data.Maybe
import Data.List
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified UHC.Util.FastSeq as Seq
import Control.Applicative
import Control.Monad.State
import UHC.Util.Error
import UHC.Light.Compiler.Base.Trace
import qualified UHC.Light.Compiler.EH as EH
import qualified UHC.Light.Compiler.EH.Main as EHSem
import qualified UHC.Light.Compiler.HS as HS
import qualified UHC.Light.Compiler.HS.MainAG as HSSem
import qualified UHC.Light.Compiler.Core as Core
import qualified UHC.Light.Compiler.Core.ToGrin as Core2GrSem
import qualified UHC.Light.Compiler.Core.ToCoreRun as Core2CoreRunSem
import UHC.Light.Compiler.Core.Trf.ElimNonCodegenConstructs
import qualified UHC.Light.Compiler.CoreRun as CoreRun
import UHC.Light.Compiler.LamInfo
import qualified UHC.Util.Rel as Rel
import UHC.Util.Time
import System.Directory
import UHC.Light.Compiler.Module.ImportExport
import qualified UHC.Light.Compiler.HS.ModImpExp as HSSemMod
import UHC.Light.Compiler.CodeGen.ModuleImportExportImpl
import UHC.Light.Compiler.CHR.Solve (chrStoreUnion)
import qualified UHC.Light.Compiler.Core.Check as Core2ChkSem
import qualified UHC.Light.Compiler.CoreRun.Check as CoreRun2ChkSem
import qualified UHC.Light.Compiler.CoreRun.ModImpExp as CoreRunSemMod
import qualified UHC.Light.Compiler.HI as HI
import UHC.Light.Compiler.EHC.CompilePhase.Module(cpUpdHiddenExports)
import UHC.Light.Compiler.Base.PackageDatabase
import UHC.Light.Compiler.Base.Pragma
bcall :: forall res m . (Typeable res, EHCCompileRunner m) => BFun' m res -> EHCompilePhaseT m res
bcall bfun = do
bcache <- getl $ st ^* bstateCache
mbCachedRes <- lkup bfun bcache
case mbCachedRes of
Just res -> do
cpTr TraceOn_BldFun ["cache " ++ show bfun]
return res
_ -> do
getl cstk >>= \stk -> cpTr TraceOn_BldFun $ [">>>>> " ++ show bfun] ++ map show stk
bstart bfun
res <- case bfun of
CRSI -> brefto bfun BRef_CRSI
CRSIWithCompileOrderPl bglob compileOrder (ASTBuildPlan {_astbplPipe=astpipe }) -> do
cpTrPP TraceOn_BldImport $ ["CRSIWithCompileOrderPl pipe:" >#< astpipe] ++ map pp compileOrder
case compileOrder of
_ | length mutRecL > 0 -> cpSetLimitErrs 1 "compilation run" [rngLift emptyRange Err_MutRecModules mutRecL]
| otherwise -> forM_ compileOrder $ \[modNm] -> do
bLiftASTPipeToASTBuildPlan bglob (return ()) (\k p -> flow1 k p) (mkPrevFileSearchKeyWithName modNm) (_bglobPipe bglob)
where mutRecL = filter ((> 1) . length) compileOrder
flow1 modSearchKey@(PrevFileSearchKey {_pfsrchKey=FileSearchKey {_fsrchNm=modNm}}) astplan = do
let allowFlow = bAllowFlowPl modNm astplan ASTSemFlowStage_BetweenModule
updHS <- maybe2M
(allowFlow $ astpMbFromHSToEH True)
(\pl -> do
cpTrPP TraceOn_BldFlow ["ASTSemFlowStage_BetweenModule astpMbFromHSToEH" >#< modSearchKey, pp pl]
bGetHsSemPlMb bglob modSearchKey pl
) (return id) $ \_ (hsSem) -> do
return $ \crsi ->
let hsInh = crsi ^. crsiHSInh
ig = HSSem.gathIdGam_Syn_AGItf hsSem
fg = HSSem.gathFixityGam_Syn_AGItf hsSem
in crsi
{
_crsiHSInh = hsInh
{ HSSem.idGam_Inh_AGItf = ig `gamUnion` HSSem.idGam_Inh_AGItf hsInh
, HSSem.fixityGam_Inh_AGItf = fg `gamUnion` HSSem.fixityGam_Inh_AGItf hsInh
}
}
updEH <- maybe2M
(allowFlow $ astpMbFromEH True)
(\pl -> do
cpTrPP TraceOn_BldFlow ["ASTSemFlowStage_BetweenModule astpMbFromEH" >#< modSearchKey, pp pl]
bcall $ FoldEHPlMb bglob modSearchKey pl
) (return id) $ \_ ehSem -> do
return $ \crsi ->
let opts = crsi ^. crsiOpts
ehInh = crsi ^. crsiEHInh
cenv = crsi ^. crsiCEnv
cenv' = cenvDataGam ^$= (EHSem.gathDataGam_Syn_AGItf ehSem `gamUnion`) $ cenv
ehInh' = ehInh
{
EHSem.dataGam_Inh_AGItf = cenv' ^. cenvDataGam
, EHSem.valGam_Inh_AGItf = EHSem.gathValGam_Syn_AGItf ehSem `gamUnion` EHSem.valGam_Inh_AGItf ehInh
, EHSem.tyGam_Inh_AGItf = EHSem.gathTyGam_Syn_AGItf ehSem `gamUnion` EHSem.tyGam_Inh_AGItf ehInh
, EHSem.tyKiGam_Inh_AGItf = EHSem.gathTyKiGam_Syn_AGItf ehSem `gamUnion` EHSem.tyKiGam_Inh_AGItf ehInh
, EHSem.polGam_Inh_AGItf = EHSem.gathPolGam_Syn_AGItf ehSem `gamUnion` EHSem.polGam_Inh_AGItf ehInh
, EHSem.kiGam_Inh_AGItf = EHSem.gathKiGam_Syn_AGItf ehSem `gamUnion` EHSem.kiGam_Inh_AGItf ehInh
, EHSem.clGam_Inh_AGItf = EHSem.gathClGam_Syn_AGItf ehSem `gamUnion` EHSem.clGam_Inh_AGItf ehInh
, EHSem.clDfGam_Inh_AGItf = EHSem.gathClDfGam_Syn_AGItf ehSem `gamUnion` EHSem.clDfGam_Inh_AGItf ehInh
, EHSem.chrStore_Inh_AGItf = EHSem.gathChrStore_Syn_AGItf ehSem `chrStoreUnion` EHSem.chrStore_Inh_AGItf ehInh
}
in
( ( crsiEHInh ^= ehInh' )
. ( crsiCEnv ^= cenv' )
) $ crsi
updCoreSrc <- maybe2M
(allowFlow $ astpMbSrcCachedCore True)
(\pl -> do
let p = _astbplPipe pl
cpTrPP TraceOn_BldFlow ["ASTSemFlowStage_BetweenModule astpMbSrcCachedCore" >#< modSearchKey, pp p]
bcall $ FoldCoreModPlMb modSearchKey pl
) (return id) $ \_ (coreChkSem, _, _, _, _, _) -> do
return $ (crsiCEnv ^* cenvDataGam) ^$= (`gamUnion` Core2ChkSem.gathDataGam_Syn_CodeAGItf coreChkSem)
updCoreRunSrc <- maybe2M
(allowFlow $ astpMbCheckCoreRunToCoreRun True)
(\pl -> do
cpTrPP TraceOn_BldFlow ["ASTSemFlowStage_BetweenModule astpMbSrcCachedCoreRun" >#< modSearchKey, pp pl]
bcall $ FoldCoreRunCheckPlMb bglob modSearchKey pl
) (return id) $ \_ (corerunChkSem,_) -> do
return $ ((crsiCoreRunState ^* crcrsiNm2RefMp) ^$= \coreRunInh -> CoreRun2ChkSem.nm2refGath_Syn_AGItf corerunChkSem `CoreRun.nm2refUnion` coreRunInh)
. ((crsiCoreRunState ^* crcrsiReqdModules) ^$= (++ [modNm]))
let updCoreGrin = id
updCoreCoreRun <- maybe2M
(allowFlow $ astpMbFromCoreToCoreRun True)
(\pl -> do
cpTrPP TraceOn_BldFlow ["ASTSemFlowStage_BetweenModule astpMbFromCoreToCoreRun" >#< modSearchKey, pp pl]
bcall $ FoldCore2CoreRunPlMb bglob modSearchKey pl
) (return id) $ \_ core2corerunSem -> do
return $ (crsiCoreRunState ^* crcrsiNm2RefMp) ^$= \core2RunInh ->
Core2CoreRunSem.nm2refGath_Syn_CodeAGItf core2corerunSem `CoreRun.nm2refUnion` core2RunInh
cpUpdSI $ updCoreRunSrc . updCoreCoreRun . updCoreSrc . updCoreGrin . updEH . updHS
brefto bfun BRef_CRSI
CRSIWithImpsPl bglob (PrevFileSearchKey {_pfsrchKey=FileSearchKey {_fsrchNm=modNm}, _pfsrchMbCxtInfo=mbPrev}) imps astplan@(ASTBuildPlan {_astbplPipe=astpipe}) -> do
impsmp <- bcall $ ImportsRecursiveWithImpsP bglob mbPrev imps astpipe
let compileOrder = scc [ (n, Set.toList i) | (n,i) <- Map.toList impsmp ]
cpTr TraceOn_BldSccImports $ [show modNm ++ " " ++ show imps] ++ [show compileOrder]
bcall $ CRSIWithCompileOrderPl bglob compileOrder astplan
brefto bfun BRef_CRSI
CRSIOfNameP bglob modSearchKey astpipe -> do
bLiftASTPipeToASTBuildPlan bglob (brefto bfun BRef_CRSI) (\k p -> bcall $ CRSIOfNamePl bglob k p) modSearchKey astpipe
CRSIOfNamePl bglob modSearchKey@(PrevFileSearchKey {_pfsrchKey=FileSearchKey {_fsrchNm=modNm}}) astplan@(ASTBuildPlan {_astbplPipe=astpipe, _astbplChoice=choice}) -> do
let allowFlow = bAllowFlowPl modNm astplan ASTSemFlowStage_PerModule
ecu <- bcall $ EcuOfPrevNameAndPath modSearchKey
cpTrPP TraceOn_BldPipe [pp "CRSIOfNamePl", pp astplan]
(_, imps) <- bcall $ ImportsOfNamePl bglob modSearchKey astplan
cpTr TraceOn_BldImport ["CRSIOfNamePl " ++ show modSearchKey, "imps=" ++ show imps]
bcall $ CRSIWithImpsPl bglob (mkPrevFileSearchKeyWithNameMbPrev modNm (_ecuMbPrevSearchInfo ecu)) imps astplan
maybe2M (allowFlow $ astpMbFromHSToEH True)
(\pl -> do
cpTrPP TraceOn_BldFlow ["ASTSemFlowStage_PerModule astpMbFromHSToEH" >#< modSearchKey, pp pl]
bGetHsSemPlMb bglob modSearchKey pl
) (return ()) $ \_ hsSem -> do
cpUpdSI $ \crsi ->
let ehInh = crsi ^. crsiEHInh
ig = HSSem.gathIdGam_Syn_AGItf hsSem
ehInh' = ehInh
{ EHSem.idQualGam_Inh_AGItf = idGam2QualGam ig `gamUnion` EHSem.idQualGam_Inh_AGItf ehInh
}
in crsi
{ _crsiEHInh = ehInh'
}
maybe2M (allowFlow $ astpMbFromHS True)
(\pl -> do
cpTrPP TraceOn_BldFlow ["ASTSemFlowStage_PerModule astpMbFromHS" >#< modSearchKey, pp pl]
bGetHsSemPlMb bglob modSearchKey pl
) (return ()) $ \_ hsSem -> do
cpUpdSI $ \crsi ->
let ehInh = crsi ^. crsiEHInh
opts = crsi ^. crsiOpts
mk = if ehcOptUseAssumePrelude opts
then \_ n -> n
else \k n -> idQualGamReplacement (EHSem.idQualGam_Inh_AGItf ehInh) k (hsnQualified n)
in crsi
{ _crsiOpts = opts
{ ehcOptBuiltinNames = mkEHBuiltinNames mk
}
}
maybe2M (allowFlow $ astpMbFromEH True)
(\pl -> do
cpTrPP TraceOn_BldFlow ["ASTSemFlowStage_PerModule astpMbFromEH" >#< modSearchKey, pp pl]
bcall $ FoldEHPlMb bglob modSearchKey pl
) (return ()) $ \_ ehSem -> do
crsi <- bcall CRSI
let mmi = panicJust "cpFlowEHSem1.crsiModMp" $ Map.lookup modNm $ crsiModMp crsi
mentrelFilterMp
= mentrelFilterMpUnions [ EHSem.gathMentrelFilterMp_Syn_AGItf ehSem, mentrelToFilterMp' False [modNm] (mmiExps mmi) ]
usedImpS = mentrelFilterMpModuleNames mentrelFilterMp
bUpdECU modNm ( ecuStoreHIUsedImpS usedImpS
. ecuStoreUsedNames mentrelFilterMp
)
cpUpdHiddenExports modNm $ Seq.toList $ EHSem.gathHiddenExports_Syn_AGItf ehSem
brefto bfun BRef_CRSI
ExposedPackages -> brefto bfun BRef_ExposedPackages
EHCOptsOf modSearchKey@(PrevFileSearchKey {_pfsrchKey=FileSearchKey {_fsrchNm=modNm}}) -> brefto bfun $ BRef_EHCOpts modNm
ImportsOfNamePl bglob modSearchKey@(PrevFileSearchKey {_pfsrchKey=FileSearchKey {_fsrchNm=modNm}}) astplan@(ASTBuildPlan {_astbplPipe=astpipe}) -> do
let dflt = return (modNm, Set.empty)
maybeM (bcall $ ASTBuildPlanChoicePMb bglob modSearchKey astpipe) dflt $ \tmOfRes -> do
maybeM (_tmofresDelayed tmOfRes) dflt $ \TmOfDelayedRes {_tmofdresModNm=nm, _tmofdresImpMp=mp} -> do
cpTr TraceOn_BldImport ["ImportsOfNamePl " ++ show modSearchKey, "actual modNm=" ++ show nm, "impNmS=" ++ show (Map.keysSet mp)]
breturn (nm, Map.keysSet mp)
ImportsRecursiveWithImpsP bglob mbPrev imps astpipe -> do
recimps <- fmap Map.unions $ forM (Set.toList imps) $ \imp -> do
let modSearchKey = mkPrevFileSearchKeyWithNameMbPrev imp mbPrev
(nm', imps', recimps') <- bcall $ ImportsRecursiveOfNameP bglob modSearchKey astpipe
return $ Map.insert nm' imps' recimps'
breturn recimps
ImportsRecursiveOfNameP bglob modSearchKey@(PrevFileSearchKey {_pfsrchKey=FileSearchKey {_fsrchNm=modNm}}) astpipe -> do
ecu <- bcall $ EcuOfPrevNameAndPath modSearchKey
(nm, imps) <- bLiftASTPipeToASTBuildPlan bglob (return (modNm, Set.empty))
(\k p -> bcall $ ImportsOfNamePl bglob k p)
modSearchKey astpipe
recimps <- bcall $ ImportsRecursiveWithImpsP bglob (_ecuMbPrevSearchInfo ecu) imps astpipe
breturn (nm, imps, recimps)
ActualModNm modSearchKey -> (fmap ecuModNm $ bcall $ EcuOfPrevNameAndPath modSearchKey) >>= breturn
BuildPlanPMb bglob modSearchKey astpipe ->
maybeM (bcall $ ASTBuildPlanChoicePMb bglob modSearchKey astpipe) (return Nothing) $ \tmr -> do
let pl = mkBuildPlan astpipe $ _tmofresChoice tmr
cpTrPP TraceOn_BldPlan ["BuildPlanPMb" >#< modSearchKey, pp pl]
breturn $ Just pl
ASTBuildPlanChoicePMb bglob modSearchKey astpipe -> do
maybeM (bMkASTPMbChoice bglob modSearchKey astpipe) (return Nothing) (breturn . Just)
EcuOf modNm -> brefto bfun $ BRef_ECU modNm
EcuOfPrevNameAndPath modSearchKey@(PrevFileSearchKey {_pfsrchKey=FileSearchKey {_fsrchNm=modNm, _fsrchOverr=overrFp}, _pfsrchMbCxtInfo=mbPrev}) -> do
opts <- bcall $ EHCOptsOf modSearchKey
let (mbFp,isTopModule) = case overrFp of
ASTFileNameOverride_AsIs -> (Nothing, False)
ASTFileNameOverride_FPath fp -> (Just fp, False)
ASTFileNameOverride_FPathAsTop fp -> (Just fp, True )
searchPath = ehcOptImportFileLocPath opts
adaptFileSuffMp = if isTopModule then (fileSuffMpHsNoSuff ++) else id
searchPath' = prevSearchInfoAdaptedSearchPath mbPrev searchPath
fileSuffMpHs <- fmap (map tup123to12 . adaptFileSuffMp) $ getl $ crStateInfo ^* crsiFileSuffMp
cpTr TraceOn_BldSearchPaths ["FPathSearchForFile: " ++ show modNm, "sp1=" ++ show searchPath, "sp2=" ++ show searchPath', "prev=" ++ show mbPrev]
fpsFound <- cpFindFilesForFPathInLocations
(fileLocSearch opts)
tup1234to13 False fileSuffMpHs searchPath' (Just modNm) mbFp
let astAvailFiles = [ ASTAvailableFile fp t c u | (fp,(_,t,c,u )) <- fpsFound ]
cpTrPP TraceOn_BldFPaths $ ["EcuOfPrevNameAndPath:" >#< modSearchKey, "on searchpath:" >#< vlist searchPath', "suffices:" >#< show fileSuffMpHs] ++ map ("found:" >#<) astAvailFiles
bUpdECU modNm $
(ecuASTAvailFiles ^= astAvailFiles)
. (ecuIsTopMod ^$= (isTopModule ||))
bmemo $ (BRef_ECU modNm :: BRef m res)
fmap (panicJust "EcuOfPrevNameAndPath") $ bLookupECU modNm
FPathSearchForFile suff fn -> do
let fp = mkTopLevelFPath suff fn
modNm = mkHNm $ fpathBase fp
cpTr TraceOn_BldFPaths ["FPathSearchForFile: " ++ show modNm ++ ", " ++ fpathToStr fp]
breturn (modNm, fp)
FPathForAST modSearchKey@(PrevFileSearchKey {_pfsrchKey=FileSearchKey {_fsrchNm=modNmAsked, _fsrchOverr=overr}}) asttype skey tkey -> do
res@(fp, suffoverr, ecu) <- case overr of
ASTFileNameOverride_FPath fp -> (bcall $ EcuOf modNmAsked) >>= \ecu -> return (fp, ASTFileSuffOverride_AsIs, ecu)
_ -> (bcall $ EcuOfPrevNameAndPath modSearchKey) >>= \ecu -> return (ecuSrcFilePath ecu, ASTFileSuffOverride_Suff skey, ecu)
breturn res
ASTFromFile modSearchKey@(PrevFileSearchKey {_pfsrchKey=FileSearchKey {_fsrchNm=modNm}}) chkTimeStamp asttype skey tkey -> do
maybeM (bASTFromFileMb modSearchKey chkTimeStamp asttype skey tkey) (undefFor modNm) $ \(res,_) -> breturn res
ASTRefFromFileEither modSearchKey@(PrevFileSearchKey {_pfsrchKey=FileSearchKey {_fsrchNm=modNmAsked, _fsrchOverr=overr}}) yieldErr (AlwaysEq chkTimeStamp) asttype skey@(astfcont,_) tkey -> do
(fp, suffoverr, ecu) <- bcall $ FPathForAST modSearchKey asttype skey tkey
let modNm = ecuModNm ecu
case BRef_ASTFile modSearchKey asttype skey tkey of
(ref :: BRef m ast) -> do
mbtm <- fmap (fmap fst) $ bcall $ ModfTimeOfFile modSearchKey asttype skey tkey
opts <- bcall $ EHCOptsOf modSearchKey
let (mbhdlr :: Maybe (ASTHandler' ast)) = asthandlerLookup asttype
mkfp hdlr = asthdlrMkInputFPath hdlr opts ecu suffoverr modNm fp
(mbRes :: Maybe ast, mbset) <- bderef'' ref
case (mbRes, mbset, mbhdlr) of
(Just ast, _, _) -> ret ref ast
(_, Just set, Just (astHdlr :: ASTHandler' ast)) | chkTimeStamp == ASTFileTimeHandleHow_Ignore || isJust mbtm -> case astfcont of
ASTFileContent_Binary -> do
cpMsg' modNm VerboseALot "Decoding" Nothing fpC
cpTr TraceOn_BldFPaths ["ASTFromFile ASTFileContent_Binary: " ++ show modNm ++ ", fp=" ++ fpathToStr fp ++ " -> fpC=" ++ fpathToStr fpC]
mbx@(~(Just x)) <- liftIO $ _asthdlrGetSerializeFileIO astHdlr opts fpC
if isJust mbx
then do
cpTr TraceOn_BldResult ["ASTFromFile Deserialize ok: " ++ show modNm]
let errs = _asthdlrPostInputCheck astHdlr opts ecu modNm fpC x
if null errs
then do
cpTr TraceOn_BldRef ["ASTFromFile ASTFileContent_Binary: " ++ show modNm ++ ", ref=" ++ show ref]
cpMsg' modNm VerboseDebug "Decoded" Nothing fpC
setret ref x
else do
cpTr TraceOn_BldResult ["ASTFromFile ASTFileContent_Binary postcheck errors: " ++ show modNm]
err'' ("Decode AST check " ++ _asthdlrName astHdlr) errs
else err "decoder"
fc | fc `elem` [ASTFileContent_Text, ASTFileContent_LitText] -> do
cpMsg' modNm VerboseALot "Parsing" Nothing fpC
let
popts = _astsuffinfoUpdParseOpts info defaultEHParseOpts
sopts = _asthdlrParseScanOpts astHdlr opts popts
description = "Parse (" ++ (if ScanUtils.scoLitmode sopts then "Literate " else "") ++ _asthdlrName astHdlr ++ " syntax) of module `" ++ show modNm ++ "`"
seterrs es = err'' description es
cpTr TraceOn_BldFPaths ["ASTFromFile " ++ show fc ++ ": " ++ show modNm ++ ", fp=" ++ fpathToStr fp ++ " -> fpC=" ++ fpathToStr fpC ++ "(fp == fpC: " ++ show (fp == fpC) ++ ") ehpoptsOkToStopAtErr=" ++ show (ehpoptsOkToStopAtErr popts) ]
case _asthdlrParser astHdlr opts popts of
Just (ASTParser p) -> do
(ast,errs) <- parseWithFPath sopts popts p fpC
if null errs || ehpoptsOkToStopAtErr popts
then do
cpMsg' modNm VerboseDebug "Parsed" Nothing fpC
setret ref ast
else seterrs errs
_ -> do
seterrs [strMsg $ "No parser for " ++ _asthdlrName astHdlr]
fc -> err $ "ast content handler " ++ show fc
where mbi@(~(Just info)) = astsuffixLookup skey $ _asthdlrSuffixRel astHdlr
mbl@(~(Just lens)) = Map.lookup tkey $ _astsuffinfoASTLensMp info
fpC = mkfp astHdlr
err = err' fpC (_asthdlrName astHdlr)
setret ref ast = set ast >> ret ref ast
_ | isNothing mbhdlr -> err1 "ast handler"
| isNothing mbset -> err2 mbhdlr "ast setter"
| chkTimeStamp == ASTFileTimeHandleHow_AbsenceIsError && isNothing mbtm
-> err2 mbhdlr "file time info (probably non existent)"
| otherwise -> dflt'
where err1 = err' fp (show asttype)
err2 (Just h) = err' (mkfp h) (_asthdlrName h)
where
dflt' = return $ Left ("",[])
err' fp k m = err'' ("Decode " ++ k ++ " for file " ++ fpathToStr fp) [strMsg $ "No " ++ m ++ " for " ++ k ++ " (" ++ show skey ++ "/" ++ show tkey ++ ")"]
err'' | yieldErr = \desc es -> return $ Left (desc,es)
| otherwise = \desc es -> cpSetLimitErrsWhen 5 desc es >> dflt'
ret ref ast = let r = Right ref in bmemo' r >> return r
ASTP bglob modSearchKey@(PrevFileSearchKey {_pfsrchKey=FileSearchKey {_fsrchNm=modNm}}) astpipe -> do
maybeM (bcall $ ASTPMb bglob modSearchKey astpipe) (undefFor modNm) $ \(ASTResult {_astresAST=res}) -> breturn res
ASTPlMb bglob modSearchKey astplan -> do
bExecASTPMbChoice bglob modSearchKey astplan
ASTPMb bglob modSearchKey astpipe -> do
bLiftASTPipeToASTBuildPlan bglob (return Nothing) (\k p -> bcall $ ASTPlMb bglob k p) modSearchKey astpipe
ModfTimeOfFile modSearchKey@(PrevFileSearchKey {_pfsrchKey=FileSearchKey {_fsrchNm=modNm}}) asttype skey tkey -> do
(fp, suffoverr, ecu) <- bcall $ FPathForAST modSearchKey asttype skey tkey
opts <- bcall $ EHCOptsOf modSearchKey
case (asthandlerLookup' asttype $ \hdlr -> do
suffinfo <- astsuffixLookup skey $ _asthdlrSuffixRel hdlr
let mblens = Map.lookup tkey $ _astsuffinfoModfTimeMp suffinfo
return (mblens, asthdlrMkInputFPath hdlr opts ecu suffoverr modNm fp)
) of
Just (mblens, fp) -> do
r <- tm opts ecu (maybe (const id) (\lens -> (lens ^=) . Just) mblens) fp
cpTr TraceOn_BldTimes ["ModfTimeOfFile " ++ show modSearchKey, "asttype: " ++ show asttype ++ ", skey: " ++ show skey ++ ", tkey: " ++ show tkey, "fp: " ++ fpathToStr fp, "mb time: " ++ show r]
return r
_ ->
return Nothing
where
tm opts ecu store fp = do
let n = fpathToStr fp
nExists <- liftIO $ doesFileExist n
when (ehcOptVerbosity opts >= VerboseDebug) $ liftIO $ putStrLn ("meta info of: " ++ show (ecuModNm ecu) ++ ", file: " ++ n ++ ", exists: " ++ show nExists)
if nExists
then do
t <- liftIO $ fpathGetModificationTime fp
when (ehcOptVerbosity opts >= VerboseDebug) $ liftIO $ putStrLn ("time stamp of: " ++ show (ecuModNm ecu) ++ ", time: " ++ show t)
bUpdECU modNm $ store t
breturn $ Just (t, fp)
else
return Nothing
ASTFileIsValid modSearchKey asttype skey tkey -> do
mbValid <- asthandlerLookupM' asttype $ \hdlr -> do
eith <- bASTFromFileEither modSearchKey False (AlwaysEq ASTFileTimeHandleHow_AbsenceIgnore) asttype skey tkey
case eith of
Left _ -> return Nothing
Right (ast, _, _) -> return $ Just $ _asthdlrASTIsValid hdlr ast
maybe (return False) breturn mbValid
DirOfModIsWriteable modSearchKey -> do
ecu <- bcall $ EcuOfPrevNameAndPath modSearchKey
let fp = ecuSrcFilePath ecu
pm <- liftIO $ getPermissions (maybe "." id $ fpathMbDir fp)
let res = writable pm
bUpdECU (ecuModNm ecu) $ ecuDirIsWritable ^= res
breturn res
CanCompile modSearchKey -> do
ecu <- bcall $ EcuOfPrevNameAndPath modSearchKey
isWr <- bcall $ DirOfModIsWriteable modSearchKey
mbTm <- bcall $ ModfTimeOfFile modSearchKey (ecu ^. ecuASTType) (ecu ^. ecuASTFileContent, ecu ^. ecuASTFileUse) ASTFileTiming_Current
breturn $ isJust mbTm && isWr
ASTFileIsNewerThan (modSearchKey1, asttype1, skey1, tkey1) (modSearchKey2, asttype2, skey2, tkey2) -> do
mbTm1 <- bcall $ ModfTimeOfFile modSearchKey1 asttype1 skey1 tkey1
mbTm2 <- bcall $ ModfTimeOfFile modSearchKey2 asttype2 skey2 tkey2
case (mbTm1, mbTm2) of
(Just (t1,_), Just (t2,_)) -> breturn $ Just $ t1 `diffClockTimes` t2 > noTimeDiff
_ -> return Nothing
IsTopMod modSearchKey -> do
ecu <- bcall $ EcuOfPrevNameAndPath modSearchKey
breturn $ _ecuIsTopMod ecu
HasMain bglob modSearchKey astpipe -> do
let dflt = return False
maybeM (bcall $ ASTBuildPlanChoicePMb bglob modSearchKey astpipe) dflt $ \tmofres -> do
if _tmofresHasMain tmofres
then breturn True
else do
maybeM (_tmofresDelayed tmofres) dflt (breturn . _tmofdresHasMain)
FoldHsMod modSearchKey@(PrevFileSearchKey {_pfsrchKey=FileSearchKey {_fsrchNm=modNm, _fsrchOverr=overr}, _pfsrchMbCxtInfo=mbPrev}) mbPkgKeyDirLForCPP@(~(Just pkgKeyDirL)) -> do
let doCPP = isJust mbPkgKeyDirLForCPP
overr' <-
if doCPP
then fmap ASTFileNameOverride_FPath $ bcall $ FPathPreprocessedWithCPP pkgKeyDirL modSearchKey
else
return ASTFileNameOverride_AsIs
let modSearchKey' = PrevFileSearchKey (FileSearchKey modNm overr') mbPrev
ecu <- bcall $ EcuOfPrevNameAndPath modSearchKey'
let modNm' = ecuModNm ecu
modSearchKey'' = PrevFileSearchKey (FileSearchKey modNm' overr') mbPrev
hs <- bcall $ ASTFromFile modSearchKey'' (AlwaysEq ASTFileTimeHandleHow_AbsenceIsError) ASTType_HS (_ecuASTFileContent ecu, ASTFileUse_SrcImport) ASTFileTiming_Current
crsi <- bcall $ CRSI
opts <- bcall $ EHCOptsOf modSearchKey
let inh = crsiHSModInh crsi
hsSemMod = HSSemMod.wrap_AGItf (HSSemMod.sem_AGItf hs)
(inh { HSSemMod.gUniq_Inh_AGItf = crsi ^. crsiHereUID
, HSSemMod.moduleNm_Inh_AGItf = modNm'
})
hasMain= HSSemMod.mainValExists_Syn_AGItf hsSemMod
pragmas = HSSemMod.fileHeaderPragmas_Syn_AGItf hsSemMod
(ecuOpts,modifiedOpts)
= ehcOptUpdateWithPragmas pragmas opts
bUpdECU modNm' ( ecuStoreHSSemMod hsSemMod
. ecuSetHasMain hasMain
. ecuStorePragmas pragmas
. (if modifiedOpts then ecuStoreOpts ecuOpts else id)
)
breturn
( hsSemMod
, hasMain
, pragmas
, if modifiedOpts then Just ecuOpts else Nothing
)
ModnameAndImportsPlMb modSearchKey@(PrevFileSearchKey {_pfsrchKey=FileSearchKey {_fsrchNm=modNm}, _pfsrchMbCxtInfo=mbPrev}) astplan -> do
let astpipe = _astbplPipe astplan
asttype = astpType astpipe
case asttype of
ASTType_HS -> fmap Just $ bcall $ HsModnameAndImports modSearchKey
ASTType_EH -> return $ Just (modNm, Set.empty, mbPrev, False)
ASTType_HI -> do
(_, impNmS, _, hasMain) <- bcall $ FoldHIInfo modSearchKey
breturn $ Just (modNm, impNmS, mbPrev, hasMain)
ASTType_Core -> do
maybeM (bcall $ FoldCoreModPlMb modSearchKey astplan) (return Nothing) $ \(_, modNm', impNmS, _, hasMain, newPrev) -> do
cpTr TraceOn_BldImport ["ModnameAndImportsPlMb FoldCoreModPlMb " ++ show modSearchKey, "astplan=" ++ show astplan, "impNmS=" ++ show impNmS]
breturn $ Just (modNm', impNmS, newPrev, hasMain)
ASTType_CoreRun -> do
maybeM (bcall $ FoldCoreRunModPlMb modSearchKey astplan) (return Nothing) $ \(_, modNm', impNmS, _, hasMain, newPrev) -> do
cpTr TraceOn_BldImport ["ModnameAndImportsPlMb FoldCoreRunModPlMb " ++ show modSearchKey, "astplan=" ++ show astplan, "impNmS=" ++ show impNmS]
breturn $ Just (modNm', impNmS, newPrev, hasMain)
_ -> do
cpSetLimitErrsWhen 1 "Imports" [rngLift emptyRange Err_Str $ "Cannot extract module name and imports from " ++ show modNm ++ " (" ++ show asttype ++ ")" ]
breturn $ panic $ "BuildFunction.Run.bcall ModnameAndImports: " ++ show modNm
HsModnameAndImports modSearchKey@(PrevFileSearchKey {_pfsrchKey=FileSearchKey {_fsrchNm=modNm}}) -> do
opts <- bcall $ EHCOptsOf modSearchKey
pkgKeyDirL <- bcall ExposedPackages
let doCPP = ehcOptCPP opts
mkMbPkgKeyDirL doCPP = if doCPP then Just pkgKeyDirL else Nothing
mbPkgKeyDirL = mkMbPkgKeyDirL doCPP
cpStepUID
resFold1@( _, hasMain
, pragmas, mbOpts
) <- bcall $ FoldHsMod modSearchKey mbPkgKeyDirL
let opts2 = maybe opts id mbOpts
resFold2@( hsSemMod, _, _, _ ) <-
if ( not (ehcOptCPP opts2)
|| ehcOptCmdLineOptsDoneViaPragma opts2
)
&& (not $ null $ filter pragmaInvolvesCmdLine $ Set.toList pragmas)
then do
let doCPP2 = doCPP || Set.member Pragma_CPP pragmas
bcall $ FoldHsMod modSearchKey $ mkMbPkgKeyDirL doCPP2
else return resFold1
let modNm' = HSSemMod.realModuleNm_Syn_AGItf hsSemMod
impNmS = HSSemMod.modImpNmS_Syn_AGItf hsSemMod
(modNmNew, newPrev) <- newModNm modSearchKey modNm' $ ecuStoreSrcDeclImpS impNmS
return (modNmNew, impNmS, newPrev, hasMain)
FoldHIInfo modSearchKey@(PrevFileSearchKey {_pfsrchKey=FileSearchKey {_fsrchNm=modNm}}) -> do
hiInfo <- bcall $ ASTFromFile modSearchKey (AlwaysEq ASTFileTimeHandleHow_AbsenceIgnore) ASTType_HI (ASTFileContent_Binary, ASTFileUse_Cache) ASTFileTiming_Prev
opts <- bcall $ EHCOptsOf modSearchKey
crsi <- bcall $ CRSI
let hasMain= HI.hiiHasMain hiInfo
mm = crsiModMp crsi
mmi = Map.findWithDefault emptyModMpInfo modNm mm
mmi' = mkModMpInfo modNm
(mmiInscps mmi)
(
HI.hiiExps hiInfo)
(HI.hiiHiddenExps hiInfo)
cpUpdSI (\crsi -> crsi {crsiModMp = Map.insert modNm mmi' mm})
bUpdECU modNm ( ecuStoreHIDeclImpS (HI.hiiHIDeclImpModS hiInfo)
. ecuStoreHIUsedImpS (HI.hiiHIUsedImpModS hiInfo)
. ecuSetHasMain hasMain
)
when (ehcOptVerbosity opts >= VerboseDebug)
(liftIO $ putStrLn
(show modNm
++ ": hi imps, decl=" ++ show (HI.hiiHIDeclImpModS hiInfo)
++ ", used=" ++ show (HI.hiiHIUsedImpModS hiInfo)
) )
breturn
( hiInfo
, HI.hiiHIDeclImpModS hiInfo
, HI.hiiHIUsedImpModS hiInfo
, hasMain
)
ImportNameInfo modSearchKey@(PrevFileSearchKey {_pfsrchKey=FileSearchKey {_fsrchNm=modNm}}) optimScope -> do
ecu <- bcall $ EcuOfPrevNameAndPath modSearchKey
let isWholeProg = optimScope > OptimizationScope_PerModule
impNmL | isWholeProg = []
| otherwise = ecuImpNmL ecu
return impNmL
ImportExportImpl modSearchKey@(PrevFileSearchKey {_pfsrchKey=FileSearchKey {_fsrchNm=modNm}}) optimScope -> do
ecu <- bcall $ EcuOfPrevNameAndPath modSearchKey
opts <- bcall $ EHCOptsOf modSearchKey
crsi <- bcall $ CRSI
impNmL <- bcall $ ImportNameInfo modSearchKey optimScope
let isWholeProg = optimScope > OptimizationScope_PerModule
expNmFldMp | ecuIsMainMod ecu = Map.empty
| otherwise = crsiExpNmOffMp modNm crsi
modOffMp | isWholeProg = Map.filterWithKey (\n _ -> n == modNm) $ crsiModOffMp crsi
| otherwise = crsiModOffMp crsi
return $ emptyModuleImportExportImpl
{ mieimplUsedModNmL = if ecuIsMainMod ecu then [ m | (m,_) <- sortOnLazy snd $ Map.toList $ Map.map fst modOffMp ] else []
, mieimplHsName2FldMpMp = Map.fromList
[ (n,(o,mp))
| (n,o) <- refGen 0 1 impNmL
, let (_,mp) = panicJust ("cpGenModuleImportExportImpl: " ++ show n) (Map.lookup n (crsiModOffMp crsi))
]
, mieimplHsName2FldMp = expNmFldMp
}
FoldHsPMb bglob modSearchKey astpipe -> do
bLiftASTPipeToASTBuildPlan bglob (return Nothing) (\k p -> bcall $ FoldHsPlMb bglob k p) modSearchKey astpipe
FoldHsPlMb bglob modSearchKey@(PrevFileSearchKey {_pfsrchKey=FileSearchKey {_fsrchNm=modNm}}) astplan@(ASTBuildPlan {_astbplPipe=astpipe, _astbplChoice= Choice_No c}) -> do
cpTrPP TraceOn_BldFold $ ["FoldHsPMb" >#< modNm, pp astplan]
maybe2M (return $ bIsAllowedFlowPl astplan $ astpMbFromHSToEH False)
(\pl -> bcall $ ASTPlMb bglob modSearchKey pl) (return Nothing) $ \_ (ASTResult {_astresAST=hs}) -> do
cpTr TraceOn_BldFold $ ["FoldHsPMb ok"]
ecu <- bcall $ EcuOfPrevNameAndPath modSearchKey
opts <- bcall $ EHCOptsOf modSearchKey
crsi <- bcall $ CRSIOfNamePl bglob modSearchKey astplan
isTopMod <- bcall $ IsTopMod modSearchKey
let inh = crsi ^. crsiHSInh
hsSem = HSSem.wrap_AGItf (HSSem.sem_AGItf hs)
(inh { HSSem.opts_Inh_AGItf = opts
, HSSem.gUniq_Inh_AGItf = crsi ^. crsiHereUID
, HSSem.moduleNm_Inh_AGItf = modNm
, HSSem.isTopMod_Inh_AGItf = isTopMod
, HSSem.modInScope_Inh_AGItf = inscps
, HSSem.modEntToOrig_Inh_AGItf = exps
, HSSem.topInstanceNmL_Inh_AGItf = modInstNmL (ecuMod ecu)
})
where mmi = panicJust "FoldHs.crsiModMp" $ Map.lookup modNm $ crsiModMp crsi
inscps = Rel.toDomMap
$ mmiInscps
$ mmi
exps = Rel.toRngMap $ Rel.restrictRng (\o -> let mq = hsnQualifier (ioccNm o) in isJust mq && fromJust mq /= modNm)
$ Rel.mapRng mentIdOcc $ mmiExps mmi
hasMain= HSSem.mainValExists_Syn_AGItf hsSem
let trpp = HSSem.trpp_Syn_AGItf hsSem
when (not $ trppIsEmpty trpp) $ trPPOnIO trpp
cpSetLimitErrsWhen 5 "Dependency/name analysis" $ Seq.toList $ HSSem.errSq_Syn_AGItf hsSem
bUpdECU modNm ( ecuStoreHSSem hsSem
. ecuStoreHIDeclImpS (
ecuSrcDeclImpNmS ecu)
)
when (ehcOptEmitHS opts)
(liftIO $ putPPFPath (mkOutputFPath opts modNm (ecuFilePath ecu) "hs2") (HSSem.pp_Syn_AGItf hsSem) 1000)
when (ehcOptShowHS opts)
(liftIO $ putWidthPPLn 120 (HSSem.pp_Syn_AGItf hsSem))
when (ehcOptVerbosity opts >= VerboseDebug)
(liftIO $ putStrLn (show modNm ++ " hasMain=" ++ show hasMain))
breturn $ Just
( hsSem
, hasMain
)
FoldEHPMb bglob modSearchKey astpipe -> do
bLiftASTPipeToASTBuildPlan bglob (return Nothing) (\k p -> bcall $ FoldEHPlMb bglob k p) modSearchKey astpipe
FoldEHPlMb bglob modSearchKey@(PrevFileSearchKey {_pfsrchKey=FileSearchKey {_fsrchNm=modNm}}) astplan@(ASTBuildPlan {_astbplPipe=astpipe, _astbplChoice= Choice_No c}) -> do
maybe2M (return $ astpMbFromEH False astpipe)
(\(p,_) -> bcall $ ASTPlMb bglob modSearchKey $ mkBuildPlan p c) (return Nothing) $ \_ (ASTResult {_astresAST=eh}) -> do
ecu <- bcall $ EcuOfPrevNameAndPath modSearchKey
opts <- bcall $ EHCOptsOf modSearchKey
crsi <- bcall $ CRSIOfNamePl bglob modSearchKey astplan
mieimpl <- bcall $ ImportExportImpl modSearchKey (ehcOptOptimizationScope opts)
let mbEH = _ecuMbEH ecu
ehSem = EHSem.wrap_AGItf (EHSem.sem_AGItf eh)
((crsi ^. crsiEHInh)
{ EHSem.moduleNm_Inh_AGItf = ecuModNm ecu
, EHSem.gUniq_Inh_AGItf = crsi ^. crsiHereUID
, EHSem.opts_Inh_AGItf = opts
, EHSem.importUsedModules_Inh_AGItf = ecuImportUsedModules ecu
, EHSem.moduleImportExportImpl_Inh_AGItf = mieimpl
, EHSem.isMainMod_Inh_AGItf = ecuIsMainMod ecu
})
about = "EH analyses: Type checking"
errs = Seq.toList $ EHSem.allErrSq_Syn_AGItf ehSem
bUpdECU modNm $! ecuStoreEHSem $! ehSem
let trpp = EHSem.trpp_Syn_AGItf ehSem
when (not $ trppIsEmpty trpp) $ trPPOnIO trpp
when (ehcOptEmitEH opts)
(liftIO $ putPPFPath (mkOutputFPath opts modNm (ecuFilePath ecu) "eh2") (EHSem.pp_Syn_AGItf ehSem) 1000)
when (ehcOptShowEH opts)
(liftIO $ putWidthPPLn 120 (EHSem.pp_Syn_AGItf ehSem))
when (EhOpt_Dump `elem` ehcOptEhOpts opts) $
liftIO $ putPPFPath (mkOutputFPath opts modNm (ecuFilePath ecu) Cfg.suffixDotlessOutputTextualEh) (EHSem.pp_Syn_AGItf ehSem) 1000
isTopMod <- bcall $ IsTopMod modSearchKey
cpSetLimitErrsWhen 5 about errs
breturn $ Just ehSem
FPathPreprocessedWithCPP pkgKeyDirL modSearchKey@(PrevFileSearchKey {_pfsrchKey=FileSearchKey {_fsrchNm=modNm}}) -> do
opts <- bcall $ EHCOptsOf modSearchKey
ecu <- bcall $ EcuOf modNm
let fp = ecuSrcFilePath ecu
fpCPP = fpathSetSuff (maybe "" (\s -> s ++ "-") (fpathMbSuff fp) ++ "cpp") fp
shellCmdCpp = Cfg.shellCmdOverride opts Cfg.shellCmdCpp PgmExec_CPP
shellCmdCppOpts = execOptsPlain $ Map.findWithDefault [] shellCmdCpp $ ehcOptExecOptsMp opts
preCPP = mkShellCmd' [Cmd_CPP,Cmd_CPP_Preprocessing] shellCmdCpp
( Cfg.cppOpts ++ gccDefs opts ["CPP"]
++ map cppOptF shellCmdCppOpts
++ [ cppOptI d | d <- gccInclDirs opts pkgKeyDirL ]
++ ehcOptCmdLineOpts opts
++ map (cppArg . fpathToStr) [ fp ]
)
when (ehcOptVerbosity opts >= VerboseALot) $ do
cpMsg modNm VerboseALot "CPP"
liftIO $ putStrLn $ showShellCmd preCPP
ifM (bcall $ CanCompile modSearchKey)
(do liftIO $ fpathEnsureExists fpCPP
cpSystem' (Just $ fpathToStr fpCPP) preCPP
cpRegisterFilesToRm [fpCPP]
bUpdECU modNm (ecuStoreCppFilePath fpCPP)
breturn fpCPP
)
(do cpSetLimitErrsWhen 1 "CPP" [rngLift emptyRange Err_CannotCreateFile (show modNm) (fpathToStr fpCPP) ]
breturn $ panic $ "BuildFunction.Run.bcall FPathPreprocessedWithCPP: " ++ fpathToStr fpCPP
)
FoldCoreModPlMb modSearchKey@(PrevFileSearchKey {_pfsrchKey=FileSearchKey {_fsrchNm=modNm}}) (ASTBuildPlan {_astbplPipe= astpipe, _astbplChoice= Choice_Src astavail}) -> do
ecu <- bcall $ EcuOfPrevNameAndPath modSearchKey
maybe2M (return $ astpMbSrcCachedCore True astpipe)
(\(p,_) -> bASTFromFileMb modSearchKey (AlwaysEq ASTFileTimeHandleHow_AbsenceIsError) (astpType p) (_astavailfContent astavail, astpUse p) (astfileuseReadTiming $ astpUse p))
(return Nothing) $
\_ (core,_) -> do
opts <- bcall $ EHCOptsOf modSearchKey
let inh = Core2ChkSem.Inh_CodeAGItf
{ Core2ChkSem.opts_Inh_CodeAGItf = opts
, Core2ChkSem.moduleNm_Inh_CodeAGItf = modNm
}
coreSem = Core2ChkSem.cmodCheck' inh core
hasMain = Core2ChkSem.hasMain_Syn_CodeAGItf coreSem
modNm' = Core2ChkSem.realModuleNm_Syn_CodeAGItf coreSem
impNmS = Set.fromList $ Core2ChkSem.impModNmL_Syn_CodeAGItf coreSem
mod = Core2ChkSem.mod_Syn_CodeAGItf coreSem
cpTr TraceOn_BldResult ["FoldCoreModPlMb " ++ show modSearchKey ++ " hasMain=" ++ show hasMain]
(modNmNew, newPrev) <- newModNm modSearchKey modNm' $
( ecuStoreCoreSemMod coreSem
. ecuSetHasMain hasMain
. ecuStoreMod mod
. ecuStoreSrcDeclImpS impNmS
)
breturn $ Just
( coreSem
, modNmNew
, impNmS
, mod
, hasMain
, newPrev
)
FoldCore2CoreRunPlMb bglob modSearchKey@(PrevFileSearchKey {_pfsrchKey=FileSearchKey {_fsrchNm=modNm}}) astplan@(ASTBuildPlan {_astbplPipe=astpipe }) -> do
maybe2M (return $ (bIsAllowedFlowPl astplan $ astpMbFromCoreToCoreRun False) >>= astplMbSubPlan)
(\pl -> bcall $ ASTPlMb bglob modSearchKey pl) (return Nothing) $ \pl ASTResult {_astresAST=core} -> do
opts <- bcall $ EHCOptsOf modSearchKey
crsi <- bcall $ CRSIOfNamePl bglob modSearchKey astplan
hasMain <- bcall $ HasMain bglob modSearchKey $ _astbplPipe pl
cpTr TraceOn_BldResult ["FoldCore2CoreRunPlMb " ++ show modSearchKey ++ " subpipe=" ++ show (_astbplPipe pl) ++ " hasMain=" ++ show hasMain]
let sem = Core2CoreRunSem.cmod2CoreRun'' opts hasMain Nothing (crsi ^. crsiCoreRunState ^. crcrsiNm2RefMp) core
cpUpdSI $ (crsiCoreRunState ^* crcrsiReqdModules) ^$= (++ [modNm])
bUpdECU modNm ( ecuStoreCore2CoreRunSem sem
)
breturn $ Just sem
FoldCoreRunModPlMb modSearchKey@(PrevFileSearchKey {_pfsrchKey=FileSearchKey {_fsrchNm=modNm}}) (ASTBuildPlan {_astbplPipe= astpipe, _astbplChoice= Choice_Src astavail}) -> do
maybe2M (return $ astpMbSrcCachedCoreRun True astpipe)
(\(p,_) -> bASTFromFileMb modSearchKey (AlwaysEq ASTFileTimeHandleHow_AbsenceIsError) (astpType p) (_astavailfContent astavail, astpUse p) (astfileuseReadTiming $ astpUse p))
(return Nothing) $
\_ (crr,_) -> do
let inh = CoreRunSemMod.Inh_AGItf
{ CoreRunSemMod.moduleNm_Inh_AGItf = modNm
}
crrSem = CoreRunSemMod.crmodImpExp' inh crr
hasMain = CoreRunSemMod.hasMain_Syn_AGItf crrSem
modNm' = CoreRunSemMod.realModuleNm_Syn_AGItf crrSem
impNmS = Set.fromList $ CoreRunSemMod.impModNmL_Syn_AGItf crrSem
mod = CoreRunSemMod.mod_Syn_AGItf crrSem
cpTr TraceOn_BldResult ["FoldCoreRunModPlMb " ++ show modSearchKey, "hasMain=" ++ show hasMain, "impNmS=" ++ show impNmS]
(modNmNew, newPrev) <- newModNm modSearchKey modNm' $
( (ecuCoreRunSemMod ^= crrSem)
. ecuSetHasMain hasMain
. ecuStoreMod mod
. ecuStoreSrcDeclImpS impNmS
)
breturn $ Just
( crrSem
, modNmNew
, impNmS
, mod
, hasMain
, newPrev
)
FoldCoreRunCheckPlMb bglob modSearchKey@(PrevFileSearchKey {_pfsrchKey=FileSearchKey {_fsrchNm=modNm}}) astplan@(ASTBuildPlan {_astbplPipe=astpipe}) -> do
maybe2M (return $ (bIsAllowedFlowPl astplan $ astpMbCheckCoreRunToCoreRun False) >>= astplMbSubPlan)
(\pl -> bcall $ ASTPlMb bglob modSearchKey pl) (return Nothing) $ \pl ASTResult {_astresAST=crr} -> do
crsi <- bcall $ CRSIOfNamePl bglob modSearchKey astplan
let inh = CoreRun2ChkSem.Inh_AGItf
{ CoreRun2ChkSem.moduleNr_Inh_AGItf = Nothing
, CoreRun2ChkSem.nm2ref_Inh_AGItf = crsi ^. crsiCoreRunState ^. crcrsiNm2RefMp
}
crrSem = CoreRun2ChkSem.crmodCheck' inh crr
bUpdECU modNm $
( (ecuCoreRunSemChk ^= crrSem)
. (ecuCoreRun ^= CoreRun2ChkSem.crr_Syn_AGItf crrSem)
)
breturn $ Just
( crrSem
, CoreRun2ChkSem.crr_Syn_AGItf crrSem
)
_ -> panic $ "BuildFunction.Run.bcall: not implemented: " ++ show bfun
bend
getl cstk >>= \stk -> cpTr TraceOn_BldFun $ ["<<<<< " ++ show bfun] ++ map show stk
return res
where
brefto' :: BFun' m res -> BRef m res -> EHCompilePhaseT m (Maybe res)
brefto' bfun ref = bmemo ref >> bderef' ref
brefto :: BFun' m res -> BRef m res -> EHCompilePhaseT m res
brefto bfun ref = fmap (panicJust $ "BuildFunction.Run.bcall.brefto " ++ show bfun) $ brefto' bfun ref
lkup :: Typeable m => BFun' m res -> BCache m -> EHCompilePhaseT m (Maybe res)
lkup bfun bcache =
case bcacheLookup bfun bcache of
Just (res :: Identity res) -> return $ Just $ runIdentity res
_ -> case bcacheLookup bfun bcache of
Just (ref :: BRef m res) -> bderef' ref
_ -> return Nothing
newModNm :: PrevFileSearchKey -> HsName -> (EHCompileUnit -> EHCompileUnit) -> EHCompilePhaseT m (HsName, Maybe PrevSearchInfo)
newModNm modSearchKey@(PrevFileSearchKey {_pfsrchKey=FileSearchKey {_fsrchNm=modNm}}) modNm' upd = do
modNmNew <- ifM (bcall $ IsTopMod modSearchKey)
(do
cpUpdCUWithKey modNm (\_ ecu -> (modNm', upd $ cuUpdKey modNm' ecu))
when (modNm /= modNm') $ do
crStateInfo ^* crsiBState ^* bstateCache ^* bcacheModNmForward =$: Map.insert modNm modNm'
cpTr TraceOn_BldRef ["newModNm rename: " ++ show modNm ++ " -> " ++ show modNm']
return modNm'
)
(do
bUpdECU modNm upd
return modNm
)
ecu <- bcall $ EcuOf modNmNew
let newPrev = Just (modNmNew, (ecuSrcFilePath ecu, ecuFileLocation ecu))
bUpdECU modNmNew $ ecuMbPrevSearchInfo ^= newPrev
return (modNmNew, newPrev)
undefFor modNm = return $ panic $ "BuildFunction.Run.bcall (" ++ show bfun ++ ") undefined result related to " ++ show modNm
st = crStateInfo ^* crsiBState
cstk = st ^* bstateCallStack
bstart :: (Typeable res, EHCCompileRunner m) => BFun' m res -> EHCompilePhaseT m ()
bstart bfun = cstk =$: (BFun bfun :)
bend :: (EHCCompileRunner m) => EHCompilePhaseT m ()
bend = cstk =$: tail
bmemo :: (EHCCompileRunner m, Typeable f, Typeable res) => f res -> EHCompilePhaseT m ()
bmemo res = do
(BFun bfun : _) <- getl $ st ^* bstateCallStack
case cast bfun of
Just bfun -> do
cpTr TraceOn_BldFun $ ["memo " ++ show bfun]
st ^* bstateCache =$: bcacheInsert bfun res
_ -> panic $ "BuildFunction.Run.bcall.bmemo: " ++ show bfun
bmemo' :: (EHCCompileRunner m, Typeable res) => res -> EHCompilePhaseT m ()
bmemo' res = do
(BFun bfun : _) <- getl $ st ^* bstateCallStack
case cast bfun of
Just bfun -> do
cpTr TraceOn_BldFun $ ["memo " ++ show bfun]
st ^* bstateCache =$: bcacheInsert bfun (Identity res)
_ -> panic $ "BuildFunction.Run.bcall.bmemo': " ++ show bfun ++ ", " ++ show (typeOf bfun) ++ ", " ++ show (typeOf res)
breturn :: (EHCCompileRunner m, Typeable res) => res -> EHCompilePhaseT m res
breturn res = do
bmemo (Identity res)
return res
bMkASTPMbChoice :: forall m . (EHCCompileRunner m) => BuildGlobal -> PrevFileSearchKey -> ASTPipe -> TmOfResM m
bMkASTPMbChoice bglob modSearchKey astpipe = do
tmOf modSearchKey astpipe
where
bTmOf :: PrevFileSearchKey -> ASTPipe -> TmOfResM m
bTmOf k p = bcall $ ASTBuildPlanChoicePMb bglob k p
tmOf :: PrevFileSearchKey -> ASTPipe -> TmOfResM m
tmOf modSearchKey p@(ASTPipe_Src {astpUse=u, astpType=t}) = do
let overrMbFp@(~(Just (overrFp,overr)))
= astFileNameOverrideMbFPath $ _fsrchOverr $ _pfsrchKey modSearchKey
isOverr = isJust overrMbFp && overr
ecu <- bcall $ EcuOfPrevNameAndPath modSearchKey
case ecuLookupAvailASTFile t u (if isOverr then isOkSuff (fpathSuff overrFp) t else const True) ecu of
Just av -> do
let tm = astfileuseReadTiming u
choice = Choice_Src av
astplan = mkBuildPlan p choice
mbTm <- bcall $ ModfTimeOfFile modSearchKey t (_astavailfContent av, u) tm
cpTrPP TraceOn_BldResult ["bMkASTPMbChoice ASTPipe_Src:" >#< modSearchKey, "pipe:" >#< p, "mbTm=" >|< mbTm]
case mbTm of
Just (tm,fp) -> do
cpTrPP TraceOn_BldPipe ["bMkASTPMbChoice ASTPipe_Src:" >#< modSearchKey >#< tm, "file:" >#< fp, "pipe:" >#< p, "asked type:" >#< t, "cmdln type:" >#< _ecuASTType ecu, "isOverr:" >#< isOverr, "avail:" >#< av]
return $ Just $ emptyTmOfRes
{ _tmofresChoice = choice
, _tmofresIsOverr = isOverr
, _tmofresDelayed = do
cpTr TraceOn_BldImport ["bMkASTPMbChoice ASTPipe_Src _tmofresDelayed (1) " ++ show modSearchKey, " =" ++ show p]
maybeM (bcall $ ModnameAndImportsPlMb modSearchKey astplan) (return Nothing) $ \(nm, imps, _, hasMain) -> do
imptms <- forM (Set.toList imps) $ \n -> bTmOf (mkPrevFileSearchKeyWithName n) (_bglobPipe bglob) >>= \mbt -> return (n, fmap _tmofresTm mbt)
cpTrPP TraceOn_BldImport $ ["bMkASTPMbChoice ASTPipe_Src _tmofresDelayed (2)" >#< show modSearchKey, "recurse on glob astpipe=" >|< _bglobPipe bglob] ++ [n >#< t | (n,t) <- imptms]
if all (isJust . snd) imptms
then return $ Just $ emptyTmOfDelayedRes
{ _tmofdresModNm = nm
, _tmofdresHasMain = hasMain
, _tmofdresImpMp = Map.fromList [(n,t) | (n, Just t) <- imptms]
}
else return Nothing
, _tmofresTm = tm
}
_ -> return Nothing
_ -> return Nothing
where
isOkSuff :: String -> ASTType -> ASTSuffixKey -> Bool
isOkSuff suff t sk = fromMaybe False $ asthandlerLookup' t $ \hdlr -> (astsuffixLookupSuff sk $ _asthdlrSuffixRel hdlr) >>= (return . (== suff))
tmOf modSearchKey p@(ASTPipe_Choose {astpHow=ASTPipeHowChoice_Avail, astpPipe1=p1, astpPipe2=p2}) =
maybeM' (bTmOf modSearchKey p1) (return . Just . updTmChoice Choice_L) $
updTmChoiceM Choice_R $ bTmOf modSearchKey p2
tmOf modSearchKey p@(ASTPipe_Choose {astpHow=ASTPipeHowChoice_Overr, astpPipe1=p1, astpPipe2=p2}) = do
mbTm1 <- bTmOf modSearchKey p1
case mbTm1 of
Just tm1@(TmOfRes {_tmofresIsOverr=True}) -> return $ Just $ updTmChoice Choice_L tm1
_ -> do
mbTm2 <- bTmOf modSearchKey p2
case (mbTm1, mbTm2) of
(_ , Just tm2@(TmOfRes {_tmofresIsOverr=True})) -> return $ Just $ updTmChoice Choice_R tm2
(Nothing, _ ) -> return $ fmap (updTmChoice Choice_R) mbTm2
(_ , _ ) -> return $ fmap (updTmChoice Choice_L) mbTm1
tmOf modSearchKey p@(ASTPipe_Choose {astpHow=ASTPipeHowChoice_Newer, astpPipe1=p1, astpPipe2=p2}) =
tmChoose modSearchKey (return Nothing) (bTmOf modSearchKey p1) (bTmOf modSearchKey p2) (ret "1" p1 Choice_L) (ret "2" p2 Choice_R)
where ret msg _ ch res@(TmOfRes {_tmofresChoice=choice,_tmofresTm=tm}) = do
let choice' = ch choice
cpTrPP TraceOn_BldPipe ["bMkASTPMbChoice ASTPipe_FirstNewestAvailable:" >#< msg >#< tm, "choice:" >#< show choice', "pipe:" >#< p]
return $ Just $ res {_tmofresChoice=choice'}
tmOf modSearchKey (ASTPipe_Cache {astpPipe=p}) = do
ifM' (bcall $ DirOfModIsWriteable modSearchKey) (return Nothing) $ updTmChoiceM Choice_No $ bTmOf modSearchKey p
tmOf modSearchKey (ASTPipe_Whole {astpPipe=p}) = do
maybeM (bTmOf modSearchKey p) (return Nothing) $ \tmr@(TmOfRes {_tmofresDelayed=mimps,_tmofresChoice=choice,_tmofresTm=tm}) -> do
maybeM mimps (return Nothing) $ \tmdr@(TmOfDelayedRes {_tmofdresImpMp=imps}) -> do
return $ Just $ tmr
{ _tmofresDelayed= return $ Just $ tmdr {_tmofdresImpMp= Map.empty}
, _tmofresChoice= Choice_No choice
, _tmofresTm= maximum $ tm : Map.elems imps
}
tmOf modSearchKey (ASTPipe_Derived {astpPipe=p}) = do
cpTrPP TraceOn_BldPipe ["bMkASTPMbChoice ASTPipe_Derived:" >#< modSearchKey, "pipe:" >#< p]
updTmChoiceM Choice_No $ bTmOf modSearchKey p
tmOf modSearchKey (ASTPipe_Trf {astpPipe=p}) = updTmChoiceM Choice_No $ bTmOf modSearchKey p
tmOf modSearchKey (ASTPipe_Compound {astpPipes=ps}) = do
tms <- mapM (bTmOf modSearchKey) ps
if null tms || not (all isJust tms)
then return Nothing
else do
let subs = map (panicJust $ "bMkASTPMbChoice: " ++ show modSearchKey) tms
(mtsimps, cs, ts, os, ms) = unzip5 [ (s,c,t,o,m) | TmOfRes {_tmofresDelayed=s, _tmofresChoice=c, _tmofresTm=t, _tmofresIsOverr=o, _tmofresHasMain=m} <- subs ]
(tsimpsSeen, mtsimpsMbFound) <- if or ms
then return ([], Just mtsimps)
else do (seen,mb) <- breakM (maybe False _tmofdresHasMain) mtsimps
return (seen, fmap snd mb)
let hasMain = isJust mtsimpsMbFound
return $ Just $ emptyTmOfRes
{ _tmofresChoice = Choices cs
, _tmofresIsOverr = or os
, _tmofresDelayed = do
tmdress@(~(tmdres:_)) <- fmap catMaybes $ maybe (return tsimpsSeen) (fmap (tsimpsSeen++) . sequence) mtsimpsMbFound
let (~(nm:_),tsimps) = unzip [ (n,i) | TmOfDelayedRes {_tmofdresModNm=n, _tmofdresImpMp=i} <- tmdress ]
return $ if null tsimps then Nothing else Just $ tmdres {_tmofdresHasMain= hasMain, _tmofdresImpMp= Map.unions tsimps}
, _tmofresTm = maximum ts
, _tmofresHasMain = hasMain
}
tmOf _ _ = return Nothing
tmChoose :: EHCCompileRunner m => PrevFileSearchKey -> EHCompilePhaseT m x -> TmOfResM m -> TmOfResM m -> (TmOfRes m -> EHCompilePhaseT m x) -> (TmOfRes m -> EHCompilePhaseT m x) -> EHCompilePhaseT m x
tmChoose modSearchKey adflt tm1 tm2 a1 a2 = tm1 >>= \mbtm1 -> tm2 >>= \mbtm2 -> case (mbtm1, mbtm2) of
(Just t1 , Nothing ) -> a1 t1
(Nothing , Just t2 ) -> a2 t2
(Just t1@(TmOfRes {_tmofresTm=tm1})
, Just t2@(TmOfRes {_tmofresDelayed=mti2, _tmofresTm=tm2})
) -> do
(mxtm2, ti2) <- mti2 >>= (return . maybe (tm2, Map.empty) (\TmOfDelayedRes{_tmofdresImpMp=ti2} -> (maximum $ tm2 : Map.elems ti2, ti2)))
cpTrPP TraceOn_BldPipe ["tmChoose stamps" >#< modSearchKey, "tm1" >#< tm1, "mxtm2" >#< mxtm2, "tm2" >#< (tm2 >-< indent 2 (vlist $ Map.toList ti2))]
if tm1 `diffClockTimes` mxtm2 > noTimeDiff then a1 t1 else a2 t2
_ -> adflt
bRetAST :: forall m ast1 ast2 . (Typeable ast1, Typeable ast2, EHCCompileRunner m) => PrevFileSearchKey -> ASTPipe -> ast1 -> EHCompilePhaseT m (Maybe (ASTResult m ast2))
bRetAST modSearchKey astpipe ast1 = do
case cast ast1 of
Just ast2 -> do
(_, mbset) <- bderef'' ref
case mbset of
Just set -> set ast2 >> mkASTResult ast2 ref astpipe >>= (return . Just)
_ -> return Nothing
where ref :: BRef m ast2
ref = BRef_AST modSearchKey (astpType astpipe)
_ -> return Nothing
bExecASTPMbChoice :: (Typeable ast, EHCCompileRunner m) => BuildGlobal -> PrevFileSearchKey -> ASTBuildPlan -> EHCompilePhaseT m (Maybe (ASTResult m ast))
bExecASTPMbChoice bglob modSearchKey@(PrevFileSearchKey {_pfsrchKey=FileSearchKey {_fsrchNm=modNm}}) astplan@(ASTBuildPlan {_astbplPipe=astpipe, _astbplChoice=choice}) = do
ecu <- bcall $ EcuOfPrevNameAndPath modSearchKey
cpTrPP TraceOn_BldPipe [">>>>> bExecASTPMbChoice" >#< modSearchKey, pp astplan]
res <- case astplan of
ASTBuildPlan {_astbplPipe= ASTPipe_Derived ASTType_HI astpipe', _astbplChoice= Choice_No c} -> do
let hii0 = HI.emptyHIInfo
hii1 <- maybeM (bGetHsSemPlMb bglob modSearchKey astplan) (return hii0) $ \hsSem -> return $ hii0
{
HI.hiiFixityGam = HSSem.gathFixityGam_Syn_AGItf hsSem
, HI.hiiHIDeclImpModS = ecuHIDeclImpNmS ecu
}
hii2 <- maybeM (bcall $ FoldEHPlMb bglob modSearchKey astplan) (return hii1) $ \ehSem -> return $ hii1
{
HI.hiiDataGam = EHSem.gathDataGam_Syn_AGItf ehSem
, HI.hiiValGam = EHSem.gathValGam_Syn_AGItf ehSem
, HI.hiiTyGam = EHSem.gathTyGam_Syn_AGItf ehSem
, HI.hiiTyKiGam = EHSem.gathTyKiGam_Syn_AGItf ehSem
, HI.hiiPolGam = EHSem.gathPolGam_Syn_AGItf ehSem
, HI.hiiClGam = EHSem.gathClGam_Syn_AGItf ehSem
, HI.hiiClDfGam = EHSem.gathClDfGam_Syn_AGItf ehSem
, HI.hiiCHRStore = EHSem.gathChrStore_Syn_AGItf ehSem
, HI.hiiMbOrphan = EHSem.mbOrphan_Syn_AGItf ehSem
}
let hii3 = hii2
bRetAST modSearchKey astpipe hii2
ASTBuildPlan {_astbplPipe= ASTPipe_Src ASTFileUse_Src _ asttypeAsked, _astbplChoice= Choice_Src av}
-> do
bASTFromFileEither modSearchKey False (AlwaysEq ASTFileTimeHandleHow_AbsenceIsError) asttypeAsked (_astavailfContent av, _astavailfUse av) (astfileuseReadTiming $ _astavailfUse av) >>=
either (\_ -> return Nothing)
(\(a,r,t) -> fmap Just $ mkASTResult' a r astpipe (Just t))
ASTBuildPlan {_astbplPipe= ASTPipe_Src ASTFileUse_Cache _ asttypeAsked, _astbplChoice= Choice_Src av} -> do
bASTFromFileEither modSearchKey True (AlwaysEq ASTFileTimeHandleHow_AbsenceIgnore) asttypeAsked (_astavailfContent av, _astavailfUse av) (astfileuseReadTiming $ _astavailfUse av) >>=
either (\_ -> return Nothing)
(\(a,r,t) -> fmap Just $ mkASTResult' a r astpipe (Just t))
ASTBuildPlan {_astbplPipe= ASTPipe_Cache asttypeAsked astpipe', _astbplChoice= Choice_No c} -> do
maybeM (bcall $ ASTPlMb bglob modSearchKey $ mkBuildPlan astpipe' c) dflt $ \res -> do
return $ Just $ astresPipe ^= astpipe' $ res
ASTBuildPlan {_astbplPipe= ASTPipe_Choose {astpPipe1=p}, _astbplChoice= Choice_L c} -> do
bcall $ ASTPlMb bglob modSearchKey $ mkBuildPlan p c
ASTBuildPlan {_astbplPipe= ASTPipe_Choose {astpPipe2=p}, _astbplChoice= Choice_R c} -> do
bcall $ ASTPlMb bglob modSearchKey $ mkBuildPlan p c
ASTBuildPlan {_astbplPipe= p, _astbplChoice= Choice_No c}
| isJust $ astpMbFromHSToEH True p -> do
maybeM (bGetHsSemPlMb bglob modSearchKey astplan) dflt
(bRetAST modSearchKey astpipe . HSSem.eh_Syn_AGItf)
ASTBuildPlan {_astbplPipe= p, _astbplChoice= Choice_No c}
| isJust $ astpMbFromEHToCore True p -> do
opts <- bcall $ EHCOptsOf modSearchKey
maybeM (bcall $ FoldEHPlMb bglob modSearchKey astplan) dflt
(bRetAST modSearchKey astpipe . cmodTrfElimNonCodegenConstructs opts . EHSem.cmodule_Syn_AGItf)
ASTBuildPlan {_astbplPipe= p, _astbplChoice= Choice_No c}
| isJust $ astpMbFromCoreToCoreRun True p -> do
maybeM (bcall $ FoldCore2CoreRunPlMb bglob modSearchKey astplan) dflt $ \sem -> do
r <- bRetAST modSearchKey astpipe $ Core2CoreRunSem.crm_Syn_CodeAGItf sem
return r
ASTBuildPlan {_astbplPipe= p, _astbplChoice= Choice_No c}
| isJust $ astpMbCheckCoreRunToCoreRun True p -> do
maybeM (bcall $ FoldCoreRunCheckPlMb bglob modSearchKey astplan) dflt $ \(_,crr) -> do
r <- bRetAST modSearchKey astpipe crr
return r
_ -> dflt
cpTrPP TraceOn_BldPipe ["<<<<< bExecASTPMbChoice" >#< modSearchKey, "has res:" >#< show (isJust res), pp astplan]
return res
where
dflt = return Nothing
bLiftASTPipeToASTBuildPlan
:: (EHCCompileRunner m)
=> BuildGlobal
-> EHCompilePhaseT m res
-> (PrevFileSearchKey -> ASTBuildPlan -> EHCompilePhaseT m res)
-> (PrevFileSearchKey -> ASTPipe -> EHCompilePhaseT m res)
bLiftASTPipeToASTBuildPlan bglob dflt f modSearchKey astpipe = do
maybeM (bcall $ BuildPlanPMb bglob modSearchKey astpipe) dflt $ \astplan ->
f modSearchKey astplan
bASTFromFileEither
:: forall res m .
(Typeable res, EHCCompileRunner m)
=> PrevFileSearchKey
-> Bool
-> (AlwaysEq ASTFileTimeHandleHow)
-> ASTType
-> ASTSuffixKey
-> ASTFileTiming
-> EHCompilePhaseT m
( Either
( String, [Err] )
( res
, BRef m res
, ClockTime
)
)
bASTFromFileEither modSearchKey yieldErr chkTimeStamp asttype skey tkey = do
let dflt = Left ("",[])
mbtm@(~(Just (tm,_))) <- bcall $ ModfTimeOfFile modSearchKey asttype skey tkey
if isJust mbtm
then do
eithref <- bcall $ ASTRefFromFileEither modSearchKey yieldErr chkTimeStamp asttype skey tkey
case eithref of
Right ref -> fmap (maybe dflt (\ast -> Right (ast, ref, tm))) $ bderef' ref
Left e -> return $ Left e
else return dflt
bASTFromFileMb
::
(Typeable res, EHCCompileRunner m)
=> PrevFileSearchKey
-> (AlwaysEq ASTFileTimeHandleHow)
-> ASTType
-> ASTSuffixKey
-> ASTFileTiming
-> EHCompilePhaseT m (Maybe (res, BRef m res))
bASTFromFileMb modSearchKey chkTimeStamp asttype skey tkey =
fmap (either (const Nothing) (Just . tup123to12)) $ bASTFromFileEither modSearchKey False chkTimeStamp asttype skey tkey
bGetHsSemPlMb
:: (EHCCompileRunner m)
=> BuildGlobal
-> PrevFileSearchKey
-> ASTBuildPlan
-> EHCompilePhaseT m
( Maybe
( AST_HS_Sem_Check
) )
bGetHsSemPlMb bglob modSearchKey astplan = fmap (fmap extr) $ bcall $ FoldHsPlMb bglob modSearchKey astplan
where
extr (hsSem, _) = hsSem
bderef'' :: forall res m . (Typeable res, EHCCompileRunner m) => BRef m res -> EHCompilePhaseT m (Maybe res, Maybe (res -> EHCompilePhaseT m ()))
bderef'' bref = do
cr <- get
let st = cr ^. crStateInfo
opts = st ^. crsiOpts
res@(r1,r2) <- case bref of
BRef_CRSI -> return (Just $ cr ^. crStateInfo, Nothing)
BRef_ExposedPackages -> return (Just $ pkgExposedPackages $ ehcOptPkgDb opts, Nothing)
BRef_ECU modNm -> do
mbecu <- bLookupECU modNm
return (mbecu, Just $ \ecu -> bUpdECU modNm (const ecu))
BRef_EHCOpts modNm -> do
mbecu <- bLookupECU modNm
let o = maybe opts id $ mbecu >>= ecuMbOpts
return (Just o, Nothing)
BRef_AST modSearchKey@(PrevFileSearchKey {_pfsrchKey=FileSearchKey {_fsrchNm=modNm}}) asttype -> case asthandlerLookup asttype of
Just (hdlr :: ASTHandler' res) ->
case _asthdlrASTLens hdlr of
Just l -> do
ecu <- bcall $ EcuOfPrevNameAndPath modSearchKey
return (ecu ^. l, Just $ \ast -> bUpdECU modNm $ l ^= Just ast)
_ -> dflt
_ -> dflt
where dflt = return (Nothing, Nothing)
BRef_ASTFile modSearchKey@(PrevFileSearchKey {_pfsrchKey=FileSearchKey {_fsrchNm=modNm}}) asttype skey tkey -> case asthandlerLookup asttype of
Just (hdlr :: ASTHandler' res) -> case astsuffixLookup skey $ _asthdlrSuffixRel hdlr of
Just suffinfo -> case Map.lookup tkey $ _astsuffinfoASTLensMp suffinfo of
Just l -> do
ecu <- bcall $ EcuOfPrevNameAndPath modSearchKey
return (ecu ^. l, Just $ \ast -> bUpdECU modNm $ l ^= Just ast)
_ -> dflt
_ -> dflt
_ -> dflt
where dflt = return (Nothing, Nothing)
cpTr TraceOn_BldRef ["bderef'': ok?=" ++ show (isJust r1) ++ "," ++ show (isJust r2) ++ ", ref=" ++ show bref]
return res
bderef' :: forall res m . (Typeable res, EHCCompileRunner m) => BRef m res -> EHCompilePhaseT m (Maybe res)
bderef' bref = do
cpTr TraceOn_BldRef $ ["bderef' " ++ show bref]
fmap fst $ bderef'' bref
bderef :: forall res m . (Typeable res, EHCCompileRunner m) => BRef m res -> EHCompilePhaseT m res
bderef bref = do
fmap (panicJust $ "BuildFunction.Run.bderef " ++ show bref) $ bderef' bref
type ASTFlowPred = ASTPipe -> Maybe (ASTPipe,ASTAlreadyFlowIntoCRSIFromToInfo)
type ASTFlowPred' = Bool -> ASTFlowPred
bIsAllowedFlowPl'' :: ASTBuildPlan -> ASTFlowPred -> Maybe (ASTBuildPlan, (ASTPipe,ASTAlreadyFlowIntoCRSIFromToInfo))
bIsAllowedFlowPl'' astplan astpred = astplFind astpred astplan
bIsAllowedFlowPl' :: ASTBuildPlan -> ASTFlowPred -> Maybe (ASTBuildPlan, ASTAlreadyFlowIntoCRSIFromToInfo)
bIsAllowedFlowPl' astplan astpred = fmap (\(pl,(_,fl)) -> (pl,fl)) $ bIsAllowedFlowPl'' astplan astpred
bIsAllowedFlowPl :: ASTBuildPlan -> ASTFlowPred -> Maybe ASTBuildPlan
bIsAllowedFlowPl astplan astpred = fmap fst $ bIsAllowedFlowPl' astplan astpred
bAllowFlowPl
:: (EHCCompileRunner m)
=> HsName
-> ASTBuildPlan
-> ASTSemFlowStage
-> ASTFlowPred
-> EHCompilePhaseT m (Maybe ASTBuildPlan)
bAllowFlowPl modNm astplan flowstage astpred = do
ecu <- bcall (EcuOf modNm)
let fnd@(~(Just (astplanFnd,flowFnd)))
= bIsAllowedFlowPl' astplan astpred
asttype = astpType $ _astbplPipe astplanFnd
key = (flowstage, Just flowFnd)
nyf = not $ ecuHasAlreadyFlowedWith asttype key ecu
cpTrPP TraceOn_BldFlow ["bAllowFlowPl" >#< modNm >#< flowstage, "astplan:" >#< astplan, "pred:" >#< fnd]
if isJust fnd && nyf
then do
bUpdAlreadyFlowIntoCRSIWith modNm asttype key
return $ Just astplanFnd
else return Nothing
astpMbFromHSToEH, astpMbFromEHToCore, astpMbFromHS, astpMbFromEH :: ASTFlowPred'
astpMbFromHSToEH top p = case p of {ASTPipe_Derived ASTType_EH p' | astpType p' == ASTType_HS -> Just (if' top p p', (Just ASTType_EH, ASTType_HS)); _ -> Nothing}
astpMbFromEHToCore top p = case p of {ASTPipe_Derived ASTType_Core p' | astpType p' == ASTType_EH -> Just (if' top p p', (Just ASTType_Core, ASTType_EH)); _ -> Nothing}
astpMbFromHS top p = case p of {ASTPipe_Derived _ p' | astpType p' == ASTType_HS -> Just (if' top p p', (Nothing, ASTType_HS)); _ -> Nothing}
astpMbFromEH top p = case p of {ASTPipe_Derived _ p' | astpType p' == ASTType_EH -> Just (if' top p p', (Nothing, ASTType_EH)); _ -> Nothing}
astpMbSrcCore, astpMbCachedCore, astpMbSrcCachedCore :: ASTFlowPred'
astpMbSrcCore top p = case p of
ASTPipe_Src ASTFileUse_Src _ ASTType_Core
-> Just (if' top p p, (Nothing, ASTType_Core))
_ -> Nothing
astpMbCachedCore top p = case p of
ASTPipe_Src ASTFileUse_Cache _ ASTType_Core
-> Just (if' top p p, (Nothing, ASTType_Core))
_ -> Nothing
astpMbSrcCachedCore = astpMbSrcCore <|||> astpMbCachedCore
astpMbSrcCoreRun, astpMbCachedCoreRun, astpMbSrcCachedCoreRun :: ASTFlowPred'
astpMbSrcCoreRun top p = case p of
ASTPipe_Src ASTFileUse_Src _ ASTType_CoreRun
-> Just (if' top p p, (Nothing, ASTType_CoreRun))
_ -> Nothing
astpMbCachedCoreRun top p = case p of
ASTPipe_Src ASTFileUse_Cache _ ASTType_CoreRun
-> Just (if' top p p, (Nothing, ASTType_CoreRun))
_ -> Nothing
astpMbSrcCachedCoreRun = astpMbSrcCoreRun <|||> astpMbCachedCoreRun
astpMbFromCoreToCoreRun :: ASTFlowPred'
astpMbFromCoreToCoreRun top p = case p of {ASTPipe_Derived ASTType_CoreRun p' | astpType p' == ASTType_Core -> Just (if' top p p', (Just ASTType_CoreRun, ASTType_Core)); _ -> Nothing}
astpMbCheckCoreRunToCoreRun :: ASTFlowPred'
astpMbCheckCoreRunToCoreRun top p = case p of {ASTPipe_Trf ASTType_CoreRun ASTTrf_Check p' | astpType p' == ASTType_CoreRun -> Just (if' top p p', (Just ASTType_CoreRun, ASTType_CoreRun)); _ -> Nothing}
f1 <||> f2 = \a -> f1 a <|> f2 a
f1 <|||> f2 = \a b -> f1 a b <|> f2 a b