{-# LANGUAGE GADTs, TemplateHaskell, KindSignatures #-} -- {-# LANGUAGE RecursiveDo #-} 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.CtxtRedOnly.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 {-# LINE 140 "src/ehc/EHC/BuildFunction/Run.chs" #-} -- | Execute a build function, possibly caching/memoizing a result bcall :: forall res m . (Typeable res, EHCCompileRunner m) => BFun' m res -> EHCompilePhaseT m res bcall bfun = do -- query cache bcache <- getl $ st ^* bstateCache mbCachedRes <- lkup bfun bcache case mbCachedRes of Just res -> do -- debug/trace cpTr TraceOn_BldFun ["cache " ++ show bfun] -- immediate result return res _ -> do -- debug/trace getl cstk >>= \stk -> cpTr TraceOn_BldFun $ [">>>>> " ++ show bfun] ++ map show stk -- prepare bstart bfun -- actual execution res <- case bfun of CRSI -> brefto bfun BRef_CRSI CRSIWithCompileOrderPl bglob compileOrder {- astplan@ -}(ASTBuildPlan {_astbplPipe=astpipe {-, _astbplChoice=choice -} }) -> 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) -- astpipe where mutRecL = filter ((> 1) . length) compileOrder -- Flow module info into global state flow1 modSearchKey@(PrevFileSearchKey {_pfsrchKey=FileSearchKey {_fsrchNm=modNm}}) astplan = do let allowFlow = bAllowFlowPl modNm astplan ASTSemFlowStage_BetweenModule -- From: cpFlowHsSem1 updHS <- maybe2M (allowFlow $ astpMbFromHSToEH True) (\pl -> do -- let pl = mkBuildPlan p choice 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 { -- From: cpFlowHsSem1 _crsiHSInh = hsInh { HSSem.idGam_Inh_AGItf = ig `gamUnion` HSSem.idGam_Inh_AGItf hsInh , HSSem.fixityGam_Inh_AGItf = fg `gamUnion` HSSem.fixityGam_Inh_AGItf hsInh } } -- From: cpFlowEHSem1 updEH <- maybe2M (allowFlow $ astpMbFromEH True) (\pl -> do -- let pl = mkBuildPlan p choice 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 = EHSem.gathDataGam_Syn_AGItf ehSem `gamUnion` EHSem.dataGam_Inh_AGItf 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 -- From: cpFlowEHSem1 ( ( crsiEHInh ^= ehInh' ) . ( crsiCEnv ^= cenv' ) ) $ crsi -- From: cpFlowCoreModSem 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) -- From: cpFlowCoreModSem updCoreRunSrc <- maybe2M (allowFlow $ astpMbCheckCoreRunToCoreRun True) (\pl -> do -- let p = _astbplPipe pl cpTrPP TraceOn_BldFlow ["ASTSemFlowStage_BetweenModule astpMbSrcCachedCoreRun" >#< modSearchKey, pp pl] bcall $ FoldCoreRunCheckPlMb bglob modSearchKey pl ) (return id) $ \_ (corerunChkSem,_) -> do -- modNm' <- bcall $ ActualModNm modNm return $ ((crsiCoreRunState ^* crcrsiNm2RefMp) ^$= \coreRunInh -> CoreRun2ChkSem.nm2refGath_Syn_AGItf corerunChkSem `CoreRun.nm2refUnion` coreRunInh) . ((crsiCoreRunState ^* crcrsiReqdModules) ^$= (++ [modNm])) let updCoreGrin = id -- From: cpFoldCore2CoreRun updCoreCoreRun <- maybe2M (allowFlow $ astpMbFromCoreToCoreRun True) (\pl -> do -- let pl = mkBuildPlan p choice 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] -- first recursively take care of all imports (_, imps) <- bcall $ ImportsOfNamePl bglob modSearchKey astplan cpTr TraceOn_BldImport ["CRSIOfNamePl " ++ show modSearchKey, "imps=" ++ show imps] bcall $ CRSIWithImpsPl bglob (mkPrevFileSearchKeyWithNameMbPrev modNm (_ecuMbPrevSearchInfo ecu)) imps astplan -- flow HS semantics forward into global state for current module, for a next stage in the pipeline -- From: cpFlowHsSem1 maybe2M (allowFlow $ astpMbFromHSToEH True) (\pl -> do -- let pl = mkBuildPlan p choice 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' } -- flow HS semantics forward into global state for current module, for a next stage in the pipeline -- From: cpFlowHsSem1 maybe2M (allowFlow $ astpMbFromHS True) (\pl -> do -- let pl = mkBuildPlan p choice 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 } } -- flow EH semantics forward into global state for current module, for a next stage in the pipeline -- From: cpFlowEHSem1 maybe2M (allowFlow $ astpMbFromEH True) (\pl -> do -- let pl = mkBuildPlan p choice 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 ) -- put back additional hidden exports 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 -- cpTrPP TraceOn_BldPlan ["ASTBuildPlanChoicePMb" >#< modSearchKey, "astpipe:" >#< astpipe] maybeM (bMkASTPMbChoice bglob modSearchKey astpipe) (return Nothing) (breturn . Just) EcuOf modNm -> brefto bfun $ BRef_ECU modNm -- does not typecheck... -- EcuMbOf modNm -> brefto' bfun $ BRef_ECU modNm {- EcuOfName modNm -> do -- For interaction with old build system, in case of already existing ecu and no dependency on file, take that one maybeM' (fmap fst $ bderef'' $ BRef_ECU modNm) (\_ -> bcall $ EcuOf modNm) $ bcall $ EcuOfNameAndPath (FileSearchKey modNm ASTFileNameOverride_AsIs) -} {- (mbEcu,_) <- bderef'' $ BRef_ECU modNm case mbEcu of Just ecu -> bcall $ EcuOf modNm _ -> bcall $ EcuOfNameAndPath (modNm, ASTFileNameOverride_AsIs) -} {- EcuOfNameAndPath mf -> do bcall $ EcuOfPrevNameAndPath (PrevFileSearchKey mf Nothing) -} 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 -- 20150904 TBD: sort this out, is hackish... Issue: be able to detect what commandline choice is and let that one override in buildplan choice construction 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 {-tm-} | (fp,(_,t,c,u {-,tm-})) <- fpsFound ] cpTrPP TraceOn_BldFPaths $ ["EcuOfPrevNameAndPath:" >#< modSearchKey, "on searchpath:" >#< vlist searchPath', "suffices:" >#< show fileSuffMpHs] ++ map ("found:" >#<) astAvailFiles bUpdECU modNm $ (ecuASTAvailFiles ^= astAvailFiles) . (ecuIsTopMod ^$= (isTopModule ||)) -- 20150915 TBD: this cannot be a plain set, not sure why but probably due to sideeffect and impl of bcall $ IsTopMod 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 {- ASTRefFromFileMb modSearchKey chkTimeStamp asttype skey tkey -> do eithAST <- bcall $ ASTRefFromFileEither modSearchKey False chkTimeStamp asttype skey tkey case eithAST of Left _ -> return Nothing Right res -> breturn $ Just 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 -- ref = -- :: BRef res -- ast case BRef_ASTFile modSearchKey asttype skey tkey of -- use case instead of let to be able to also access the AST type via tyvar 'ast' (@20150803 ghc 7.8.3: let does not allow scoped tyvars to be introduced in this way) (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' :: EHCompilePhaseT m res -- dflt' = undefFor modNmAsked 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 linkingStyle -> do ecu <- bcall $ EcuOfPrevNameAndPath modSearchKey opts <- bcall $ EHCOptsOf modSearchKey let fp = ecuSrcFilePath ecu pm <- liftIO $ getPermissions $ case mkOutputMbDir (if linkingStyle == LinkingStyle_Pkg then OutputFor_Pkg else OutputFor_Module) opts of Just d -> d _ -> maybe "." id $ fpathMbDir fp let res = writable pm -- liftIO $ putStrLn (fpathToStr fp ++ " writ " ++ show res) bUpdECU (ecuModNm ecu) $ ecuDirIsWritable ^= res breturn res CanCompile modSearchKey -> do ecu <- bcall $ EcuOfPrevNameAndPath modSearchKey opts <- bcall $ EHCOptsOf modSearchKey isWr <- bcall $ DirOfModIsWriteable modSearchKey (ehcOptLinkingStyle opts) mbTm <- bcall $ ModfTimeOfFile modSearchKey (ecu ^. ecuASTType) (ecu ^. ecuASTFileContent, ecu ^. ecuASTFileUse) ASTFileTiming_Current breturn $ isJust mbTm && isWr {- NeedsCompile modNm -> do -- From: crModNeedsCompile opts <- bcall $ EHCOptsOf modNm ecu <- bcall $ EcuOfName modNm return $ ecuIsMainMod ecu -- ecuIsTopMod ecu || not ( ehcOptCheckRecompile opts -- 20150817 TBD -- && ecuCanUseHIInsteadOfHS ecu -- && null newer ) -} 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 {- crModNeedsCompile :: HsName -> EHCompileRun -> Bool crModNeedsCompile modNm cr = ecuIsMainMod ecu -- ecuIsTopMod ecu || not ( ehcOptCheckRecompile opts && ecuCanUseHIInsteadOfHS ecu && null newer ) where ecu = crCU modNm cr (newer,_) = crPartitionNewerOlderImports modNm cr opts = _crStateInfo cr ^. crsiOpts crPartitionNewerOlderImports :: HsName -> EHCompileRun -> ([EHCompileUnit],[EHCompileUnit]) crPartitionNewerOlderImports modNm cr = partition isNewer $ map (flip crCU cr) $ ecuImpNmL ecu where ecu = crCU modNm cr t = panicJust "crPartitionNewerOlderImports1" $ _ecuMbHIInfoTime ecu isNewer ecu' | isJust mbt = t' `diffClockTimes` t > noTimeDiff | otherwise = False where t' = panicJust "crPartitionNewerOlderImports2" $ _ecuMbHIInfoTime ecu' mbt = _ecuMbHIInfoTime ecu' -- | Can HI be used instead of HS? -- This is purely based on HI being of the right version and HS not newer. -- The need for recompilation considers dependencies on imports as well. ecuCanUseHIInsteadOfHS :: EHCompileUnit -> Bool ecuCanUseHIInsteadOfHS ecu = ecuIsValidHIInfo ecu && not (ecuIsHSNewerThanHI ecu) ecuIsValidHIInfo :: EHCompileUnit -> Bool ecuIsValidHIInfo ecu = case _ecuMbPrevHIInfo ecu of Just i -> HI.hiiValidity i == HI.HIValidity_Ok _ -> False -- | Is HS newer? -- If no HS exists False is returned. ecuIsHSNewerThanHI :: EHCompileUnit -> Bool ecuIsHSNewerThanHI ecu = case (_ecuMbSrcTime ecu,_ecuMbHIInfoTime ecu) of (Just ths,Just thi) -> ths `diffClockTimes` thi > noTimeDiff (Nothing ,Just thi) -> False _ -> True -} 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 ) {- ModnameAndImports modSearchKey@(PrevFileSearchKey {_pfsrchKey=FileSearchKey {_fsrchNm=modNm}, _pfsrchMbCxtInfo=mbPrev}) asttype -> do maybeM' (bcall $ ModnameAndImportsPMb modSearchKey (ASTPipe_Src ASTFileUse_Src ASTFileTiming_Current asttype)) breturn $ do cpSetLimitErrsWhen 1 "bcall ModnameAndImports" [rngLift emptyRange Err_Str $ "Cannot extract module name and imports from " ++ show modNm ++ " (" ++ show asttype ++ ")" ] -- should not arrive at usage of this result return $ panic $ "BuildFunction.Run.bcall ModnameAndImports: " ++ show modNm ModnameAndImportsP modSearchKey@(PrevFileSearchKey {_pfsrchKey=FileSearchKey {_fsrchNm=modNm}, _pfsrchMbCxtInfo=mbPrev}) astpipe -> do maybeM' (bcall $ ModnameAndImportsPMb modSearchKey astpipe) breturn $ do return (modNm, Set.empty, Nothing, False) -} ModnameAndImportsPlMb modSearchKey@(PrevFileSearchKey {_pfsrchKey=FileSearchKey {_fsrchNm=modNm}, _pfsrchMbCxtInfo=mbPrev}) astplan -> do -- ecu <- bcall $ EcuOfPrevNameAndPath modSearchKey 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 ++ ")" ] -- should not arrive at usage of this result breturn $ panic $ "BuildFunction.Run.bcall ModnameAndImports: " ++ show modNm {- ModnameAndImportsPlMb modSearchKey@(PrevFileSearchKey {_pfsrchKey=FileSearchKey {_fsrchNm=modNm}, _pfsrchMbCxtInfo=mbPrev}) astplan@(ASTBuildPlan {_astbplPipe=astpipe}) -> do maybeM (bcall $ ASTBuildPlanChoicePMb modSearchKey astpipe) (return Nothing) $ \tmOfRes -> do maybeM (_tmofresDelayed tmOfRes) (return Nothing) $ \mp -> breturn $ Just (modNm, Map.keysSet mp, mbPrev, False) -} 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) -- reinvoke if CPP has not been invoked before || ehcOptCmdLineOptsDoneViaPragma opts2 -- or options have been set via pragma ) -- check whether the pragma has a cmdline option like effect && (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) ( -- (\v -> tr "FoldHIInfo.hiiExps" (pp v) v) $ HI.hiiExps hiInfo) (HI.hiiHiddenExps hiInfo) -- when hasMain (crSetAndCheckMain modNm) cpUpdSI (\crsi -> crsi {crsiModMp = Map.insert modNm mmi' mm}) -- this should be made explicit 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 -- _ecuIsTopMod ecu , 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 --- $ (\v -> tr "XX mmiInscps mmi" (pp v ) v) $ mmiInscps --- $ (\v -> tr "XX mmi" (pp v ) v) $ 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 -- TBD: should move elsewhere . ecuStoreHIDeclImpS ( -- (\v -> tr "YY" (pp $ Set.toList v) v) $ ecuSrcDeclImpNmS ecu) -- . ecuSetHasMain hasMain ) 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)) -- when hasMain (crSetAndCheckMain modNm) breturn $ Just ( hsSem -- , ecuSrcDeclImpNmS ecu , 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) $ -- void $ cpOutputSomeModule (^. ecuEH) astHandler'_EH ASTFileContent_Text "" Cfg.suffixDotlessOutputTextualEh modNm liftIO $ putPPFPath (mkOutputFPath opts modNm (ecuFilePath ecu) Cfg.suffixDotlessOutputTextualEh) (EHSem.pp_Syn_AGItf ehSem) 1000 isTopMod <- bcall $ IsTopMod modSearchKey when (isTopMod && EhOpt_DumpAST `elem` ehcOptEhOpts opts) $ liftIO $ putPPFPath (mkOutputFPath opts modNm (ecuFilePath ecu) Cfg.suffixDotlessOutputTextualEhAST) (EHSem.ppAST_Syn_AGItf ehSem) 1000 cpSetLimitErrsWhen 5 about errs breturn $ Just ehSem FPathPreprocessedWithCPP pkgKeyDirL modSearchKey@(PrevFileSearchKey {_pfsrchKey=FileSearchKey {_fsrchNm=modNm}}) -> do -- Just <$> cpPreprocessWithCPP pkgKeyDirL modNm -- cr <- get opts <- bcall $ EHCOptsOf modSearchKey ecu <- bcall $ EcuOf modNm let fp = ecuSrcFilePath ecu fpCPP = fpathSetSuff {- mkOutputFPath opts modNm fp -} (maybe "" (\s -> s ++ "-") (fpathMbSuff fp) ++ "cpp") fp -- fpCPP = fpathSetBase {- mkOutputFPath opts modNm fp -} (fpathBase 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 -- [ {- "traditional-cpp", -} {- "std=gnu99", -} "fno-show-column", "P" ] ++ [ cppOptI d | d <- gccInclDirs opts pkgKeyDirL ] ++ ehcOptCmdLineOpts opts ++ map (cppArg . fpathToStr) [ fp ] -- , fpCPP ] ) when (ehcOptVerbosity opts >= VerboseALot) $ do cpMsg modNm VerboseALot "CPP" -- liftIO $ putStrLn ("pkg db: " ++ show (ehcOptPkgDb opts)) -- liftIO $ putStrLn ("pkg srch filter: " ++ (show $ ehcOptPackageSearchFilter opts)) -- liftIO $ putStrLn ("exposed pkgs: " ++ show (pkgExposedPackages $ ehcOptPkgDb opts)) -- liftIO $ putStrLn ("pkgKeyDirL: " ++ show pkgKeyDirL) liftIO $ putStrLn $ showShellCmd preCPP -- when (ecuCanCompile ecu) 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) ] -- should not arrive at usage of this result 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 {- , _astbplChoice= Choice_No c -}}) -> 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 {- (Just $ length $ crsi ^. crsiCoreRunState ^. crcrsiReqdModules) -} (crsi ^. crsiCoreRunState ^. crcrsiNm2RefMp) core cpUpdSI $ (crsiCoreRunState ^* crcrsiReqdModules) ^$= (++ [modNm]) -- (++ [ecuModNm ecu]) -- between module flow part, TBD: corerun, nmref part -- cpUpdSI (\crsi -> crsi {crsiCore2RunInh = nm2ref'}) -- per module part bUpdECU modNm ( ecuStoreCore2CoreRunSem sem -- . ecuStoreCoreRun corerun ) breturn $ Just sem FoldCoreRunModPlMb modSearchKey@(PrevFileSearchKey {_pfsrchKey=FileSearchKey {_fsrchNm=modNm}}) (ASTBuildPlan {_astbplPipe= astpipe, _astbplChoice= Choice_Src astavail}) -> do -- ecu <- bcall $ EcuOfPrevNameAndPath modSearchKey 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 -- ecu <- bcall $ EcuOfPrevNameAndPath modSearchKey maybe2M (return $ (bIsAllowedFlowPl astplan $ astpMbCheckCoreRunToCoreRun False) >>= astplMbSubPlan) (\pl -> bcall $ ASTPlMb bglob modSearchKey pl) (return Nothing) $ \pl ASTResult {_astresAST=crr} -> do {- maybe2M (return $ astpMbCheckCoreRunToCoreRun False astpipe) -- 20150905 TBD: get rid of _ecuASTFileContent (\(p,_) -> bASTFromFileMb modSearchKey (AlwaysEq ASTFileTimeHandleHow_AbsenceIsError) (astpType p) (_ecuASTFileContent ecu, astpUse p) (astfileuseReadTiming $ astpUse p)) (return Nothing) $ \_ (crr,_) -> do -} crsi <- bcall $ CRSIOfNamePl bglob modSearchKey astplan let inh = CoreRun2ChkSem.Inh_AGItf { CoreRun2ChkSem.moduleNr_Inh_AGItf = Nothing -- Just $ length $ crsi ^. crsiCoreRunState ^. crcrsiReqdModules , CoreRun2ChkSem.nm2ref_Inh_AGItf = crsi ^. crsiCoreRunState ^. crcrsiNm2RefMp } crrSem = CoreRun2ChkSem.crmodCheck' inh crr -- debug -- ecu <- bcall $ EcuOf modNm -- cpOutputSomeModule (const $ CoreRun2ChkSem.crr_Syn_AGItf crrSem) astHandler'_CoreRun ASTFileContent_Text "-FoldCoreRunCheckPlMb" Cfg.suffixDotlessOutputTextualCoreRun (ecuModNm ecu) 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 -- finalize bend -- debug/trace getl cstk >>= \stk -> cpTr TraceOn_BldFun $ ["<<<<< " ++ show bfun] ++ map show stk -- the result return res where -- construct a reference to something and also yield corresponding result 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 -- lookup in cache 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 -- factored out: new module name extracted from src file newModNm :: PrevFileSearchKey -> HsName -> (EHCompileUnit -> EHCompileUnit) -> EHCompilePhaseT m (HsName, Maybe PrevSearchInfo) newModNm modSearchKey@(PrevFileSearchKey {_pfsrchKey=FileSearchKey {_fsrchNm=modNm}}) modNm' upd = do -- ecu <- bcall $ EcuOf modNm -- cpTr TraceOn_BldResult ["newModNm1 " ++ show modSearchKey ++ "mod=" ++ show modNm ++ " hasMain=" ++ show (ecuHasMain ecu)] 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 -- cpTr TraceOn_BldResult ["newModNm2 " ++ show modSearchKey ++ "mod=" ++ show modNmNew ++ " hasMain=" ++ show (ecuHasMain ecu)] let newPrev = Just (modNmNew, (ecuSrcFilePath ecu, ecuFileLocation ecu)) bUpdECU modNmNew $ ecuMbPrevSearchInfo ^= newPrev -- ecu <- bcall $ EcuOf modNm -- cpTr TraceOn_BldResult ["newModNm3 " ++ show modSearchKey ++ "modold=" ++ show modNm ++ " hasMain=" ++ show (ecuHasMain ecu)] return (modNmNew, newPrev) -- undefined result undefFor modNm = return $ panic $ "BuildFunction.Run.bcall (" ++ show bfun ++ ") undefined result related to " ++ show modNm {-# LINE 1363 "src/ehc/EHC/BuildFunction/Run.chs" #-} -- lens access st = crStateInfo ^* crsiBState cstk = st ^* bstateCallStack -- call init/finalization bstart :: (Typeable res, EHCCompileRunner m) => BFun' m res -> EHCompilePhaseT m () bstart bfun = cstk =$: (BFun bfun :) bend :: (EHCCompileRunner m) => EHCompilePhaseT m () bend = cstk =$: tail -- | memoize 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) -- memoize & return breturn :: (EHCCompileRunner m, Typeable res) => res -> EHCompilePhaseT m res breturn res = do bmemo (Identity res) return res {-# LINE 1405 "src/ehc/EHC/BuildFunction/Run.chs" #-} -- | Make a Choice what to build, resolve newer/older choice bMkASTPMbChoice :: forall m . (EHCCompileRunner m) => BuildGlobal -> PrevFileSearchKey -> ASTPipe -> TmOfResM m -- EHCompilePhaseT m (Maybe (TmOfRes m)) bMkASTPMbChoice bglob modSearchKey astpipe = do tmOf modSearchKey astpipe where -- cached variant bTmOf :: PrevFileSearchKey -> ASTPipe -> TmOfResM m bTmOf k p = bcall $ ASTBuildPlanChoicePMb bglob k p tmOf :: PrevFileSearchKey -> ASTPipe -> TmOfResM m -- source: time of src itself + imports tmOf modSearchKey p@(ASTPipe_Src {astpUse=u, {- astpTiming=tm, -} 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 = {- t == _ecuASTType ecu && -} 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)) -- choose first available 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 -- choose first available, only to be overridden with second if indicated 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 -- choose based on newest in combi with imports also indicating being newer 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'} {- -- cached: just time of cached file itself, if file is valid tmOf modSearchKey p@(ASTPipe_Src {astpUse=ASTFileUse_Cache, astpType=t}) = ifM' (bcall $ ASTFileIsValid modSearchKey t (ASTFileContent_Binary, ASTFileUse_Cache) ASTFileTiming_Prev) (return Nothing) $ do mbTm <- bcall $ ModfTimeOfFile modSearchKey t (ASTFileContent_Binary, ASTFileUse_Cache) ASTFileTiming_Prev case mbTm of Just (tm,fp) -> do cpTrPP TraceOn_BldPipe ["bMkASTPMbChoice ASTPipe_Src ASTFileUse_Cache ASTFileTiming_Prev:" >#< modSearchKey >#< tm, "file:" >#< fp, "pipe:" >#< p] return $ Just $ emptyTmOfRes {_tmofresDelayed= return Nothing, _tmofresTm= tm} _ -> return Nothing -} -- cache: time recursively computed, if file can be cached tmOf modSearchKey (ASTPipe_Cache {astpPipe=p}) = do opts <- bcall $ EHCOptsOf modSearchKey ifM' (bcall $ DirOfModIsWriteable modSearchKey (ehcOptLinkingStyle opts)) (return Nothing) $ updTmChoiceM Choice_No $ bTmOf modSearchKey p -- whole: time recursively computed, merged into 1 time for all 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 } -- derived: time recursively computed tmOf modSearchKey (ASTPipe_Derived {astpPipe=p}) = do cpTrPP TraceOn_BldPipe ["bMkASTPMbChoice ASTPipe_Derived:" >#< modSearchKey, "pipe:" >#< p] updTmChoiceM Choice_No $ bTmOf modSearchKey p -- transformation (also derived): time recursively computed tmOf modSearchKey (ASTPipe_Trf {astpPipe=p}) = updTmChoiceM Choice_No $ bTmOf modSearchKey p -- compound: maximum of all, ignoring possible absence of imports 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 } -- others, for now... 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 {-# LINE 1575 "src/ehc/EHC/BuildFunction/Run.chs" #-} -- | Build a AST result 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 {-# LINE 1590 "src/ehc/EHC/BuildFunction/Run.chs" #-} -- | Execute a Choice what to build, having resolved newer/older choice 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 -- let asttypeAsked = astpType astpipe -- the source file available to produce the asked AST, not necessarily used 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 -- (modNm, modSearchKey') <- bNmEtcFromAST modSearchKey astpipe let hii0 = HI.emptyHIInfo hii1 <- maybeM (bGetHsSemPlMb bglob modSearchKey astplan) (return hii0) $ \hsSem -> return $ hii0 { -- cpFlowHsSem1 HI.hiiFixityGam = HSSem.gathFixityGam_Syn_AGItf hsSem , HI.hiiHIDeclImpModS = ecuHIDeclImpNmS ecu -- TBD: sort out, should not be from hi } hii2 <- maybeM (bcall $ FoldEHPlMb bglob modSearchKey astplan) (return hii1) $ \ehSem -> return $ hii1 { -- cpFlowEHSem1 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.hiiLamMp = lm , HI.hiiMbOrphan = EHSem.mbOrphan_Syn_AGItf ehSem -- , HI.hiiHIUsedImpModS = usedImpS -- TBD: sort out } 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) >>= -- 20150818 TBD: factor below out 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) >>= -- 20150818 TBD: factor below out 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 -- Cache/write AST maybeM (bcall $ ASTPlMb bglob modSearchKey $ mkBuildPlan astpipe' c) dflt $ \res -> do -- TBD: write/output side effect return $ Just $ astresPipe ^= astpipe' $ res -- (ast, ref, astpipe') 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 -- ASTPipe_Derived ASTType_EH _ -> do ASTBuildPlan {_astbplPipe= p, _astbplChoice= Choice_No c} | isJust $ astpMbFromHSToEH True p -> do -- From: cpTranslateHs2EH maybeM (bGetHsSemPlMb bglob modSearchKey astplan) dflt (bRetAST modSearchKey astpipe . HSSem.eh_Syn_AGItf) -- ASTPipe_Derived ASTType_Core _ -> do ASTBuildPlan {_astbplPipe= p, _astbplChoice= Choice_No c} | isJust $ astpMbFromEHToCore True p -> do -- From: cpTranslateEH2Core opts <- bcall $ EHCOptsOf modSearchKey maybeM (bcall $ FoldEHPlMb bglob modSearchKey astplan) dflt (bRetAST modSearchKey astpipe . cmodTrfElimNonCodegenConstructs opts . EHSem.cmodule_Syn_AGItf) -- ASTPipe_Derived ASTType_CoreRun _ -> do ASTBuildPlan {_astbplPipe= p, _astbplChoice= Choice_No c} | isJust $ astpMbFromCoreToCoreRun True p -> do -- From: cpFoldCore2CoreRun maybeM (bcall $ FoldCore2CoreRunPlMb bglob modSearchKey astplan) dflt $ \sem -> do r <- bRetAST modSearchKey astpipe $ Core2CoreRunSem.crm_Syn_CodeAGItf sem -- debug -- ecu <- bcall $ EcuOf modNm -- cpOutputSomeModule (^. ecuCoreRun) astHandler'_CoreRun ASTFileContent_Text "-astpMbFromCoreToCoreRun" Cfg.suffixDotlessOutputTextualCoreRun (ecuModNm ecu) 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 -- debug -- ecu <- bcall $ EcuOf modNm -- cpOutputSomeModule (const crr) astHandler'_CoreRun ASTFileContent_Text "-astpMbCheckCoreRunToCoreRun" Cfg.suffixDotlessOutputTextualCoreRun (ecuModNm ecu) return r _ -> dflt cpTrPP TraceOn_BldPipe ["<<<<< bExecASTPMbChoice" >#< modSearchKey, "has res:" >#< show (isJust res), pp astplan] return res where dflt = return Nothing {-# LINE 1728 "src/ehc/EHC/BuildFunction/Run.chs" #-} 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 {-# LINE 1744 "src/ehc/EHC/BuildFunction/Run.chs" #-} -- | Get AST from file, maybe... -- Wrapper around bcalls. bASTFromFileEither :: forall res m . (Typeable res, EHCCompileRunner m) => PrevFileSearchKey --- ^ module name and possibly known path -> Bool --- ^ errors are returned instead of reported directly -> (AlwaysEq ASTFileTimeHandleHow) --- ^ how to deal with timestamp -> ASTType --- ^ content type -> ASTSuffixKey --- ^ suffix and content variation -> ASTFileTiming --- ^ timing (i.e. previous or current) -> 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 -- TBD: faulty... -- (ref :: BRef m res) <- bcall $ ASTRefFromFileMb modSearchKey chkTimeStamp asttype skey tkey 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 -- | Get AST from file, maybe... -- Wrapper around bcalls. bASTFromFileMb :: -- forall res m . (Typeable res, EHCCompileRunner m) => PrevFileSearchKey --- ^ module name and possibly known path -> (AlwaysEq ASTFileTimeHandleHow) --- ^ how to deal with timestamp -> ASTType --- ^ content type -> ASTSuffixKey --- ^ suffix and content variation -> ASTFileTiming --- ^ timing (i.e. previous or current) -> 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 {-# LINE 1803 "src/ehc/EHC/BuildFunction/Run.chs" #-} -- | Get possible Hs semantics bGetHsSemPlMb :: (EHCCompileRunner m) => BuildGlobal -> PrevFileSearchKey -> ASTBuildPlan -> EHCompilePhaseT m ( Maybe ( AST_HS_Sem_Check -- all semantics ) ) bGetHsSemPlMb bglob modSearchKey astplan = fmap (fmap extr) $ bcall $ FoldHsPlMb bglob modSearchKey astplan where extr (hsSem, _) = hsSem {-# LINE 1827 "src/ehc/EHC/BuildFunction/Run.chs" #-} -- | Dereference an indirection into compilation state, possibly with a result, and a setter 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 -- | Dereference an indirection into compilation state 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 -- | Dereference an indirection into compilation state 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 {-# LINE 1894 "src/ehc/EHC/BuildFunction/Run.chs" #-} type ASTFlowPred = ASTPipe -> Maybe (ASTPipe,ASTAlreadyFlowIntoCRSIFromToInfo) type ASTFlowPred' = Bool -> ASTFlowPred {-# LINE 1899 "src/ehc/EHC/BuildFunction/Run.chs" #-} -- | Is a particular flow of semantics allowed? bIsAllowedFlowPl'' :: ASTBuildPlan -> ASTFlowPred -> Maybe (ASTBuildPlan, (ASTPipe,ASTAlreadyFlowIntoCRSIFromToInfo)) bIsAllowedFlowPl'' astplan astpred = astplFind astpred astplan -- | Is a particular flow of semantics allowed? bIsAllowedFlowPl' :: ASTBuildPlan -> ASTFlowPred -> Maybe (ASTBuildPlan, ASTAlreadyFlowIntoCRSIFromToInfo) bIsAllowedFlowPl' astplan astpred = fmap (\(pl,(_,fl)) -> (pl,fl)) $ bIsAllowedFlowPl'' astplan astpred -- | Is a particular flow of semantics allowed? bIsAllowedFlowPl :: ASTBuildPlan -> ASTFlowPred -> Maybe ASTBuildPlan bIsAllowedFlowPl astplan astpred = fmap fst $ bIsAllowedFlowPl' astplan astpred -- | Check whether a particular flow of semantics is allowed, and mark it to have occurred 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 {-# LINE 1935 "src/ehc/EHC/BuildFunction/Run.chs" #-} astpMbFromHSToEH, 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} 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} {-# LINE 1942 "src/ehc/EHC/BuildFunction/Run.chs" #-} astpMbFromEHToCore :: ASTFlowPred' 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} {-# LINE 1952 "src/ehc/EHC/BuildFunction/Run.chs" #-} 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 {-# LINE 1967 "src/ehc/EHC/BuildFunction/Run.chs" #-} 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 {-# LINE 1982 "src/ehc/EHC/BuildFunction/Run.chs" #-} 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} {-# LINE 1987 "src/ehc/EHC/BuildFunction/Run.chs" #-} 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} {-# LINE 1996 "src/ehc/EHC/BuildFunction/Run.chs" #-} f1 <||> f2 = \a -> f1 a <|> f2 a f1 <|||> f2 = \a b -> f1 a b <|> f2 a b