module UHC.Light.Compiler.EHC.CompilePhase.Parsers ( cpParseEH , cpParseCoreWithFPath , cpParseCoreRunWithFPath , cpDecode'' , cpDecodeCore , cpDecodeCoreRun , cpGetPrevHI , cpGetPrevCore , cpGetPrevCoreRun , cpParseHs , cpParseHsImport ) where import UHC.Light.Compiler.Base.ParseUtils import UU.Parsing import UU.Parsing.Offside import qualified UHC.Util.ScanUtils as ScanUtils import UHC.Light.Compiler.Scanner.Common import UHC.Util.ParseUtils import UHC.Util.Lens import Control.Monad.Error import Control.Monad.State import qualified Data.Map as Map import UHC.Light.Compiler.EHC.Common import UHC.Light.Compiler.EHC.CompileUnit import UHC.Light.Compiler.EHC.CompileRun import UHC.Light.Compiler.EHC.ASTHandler.Instances import UHC.Light.Compiler.EHC.BuildFunction.Run import qualified UHC.Light.Compiler.EH as EH import qualified UHC.Light.Compiler.EH.Parser as EHPrs import qualified UHC.Light.Compiler.HS as HS import qualified UHC.Light.Compiler.HS.Parser as HSPrs import qualified UHC.Light.Compiler.Core as Core import qualified UHC.Light.Compiler.Core.Parser as CorePrs import qualified UHC.Light.Compiler.CoreRun as CoreRun import Control.Exception as CE import qualified UHC.Light.Compiler.HI as HI import qualified UHC.Util.Binary as Bin import UHC.Util.Serialize import qualified UHC.Light.Compiler.Config as Cfg import qualified UHC.Light.Compiler.SourceCodeSig as Sig {-# LINE 81 "src/ehc/EHC/CompilePhase/Parsers.chs" #-} -- | Generalization of parser invocation cpParseWithFPath :: ( EHCCompileRunner m ) => ASTHandler' a -> EHParseOpts -> Maybe FPath -- possibly overriding FilePath instead of default derived from state for this module name -> HsName -- module name -> EHCompilePhaseT m () cpParseWithFPath astHdlr popts mbFp modNm = do { cr <- get ; let (_,opts) = crBaseInfo' cr sopts = _asthdlrParseScanOpts astHdlr opts popts description = "Parse (" ++ (if ScanUtils.scoLitmode sopts then "Literate " else "") ++ _asthdlrName astHdlr ++ " syntax) of module `" ++ show modNm ++ "`" seterrs = cpSetLimitErrsWhen 5 description ; case _asthdlrParser astHdlr opts popts of Just (ASTParser p) -> do (res,errs) <- parseWithFPath sopts popts p (maybe (ecuFilePath (crCU modNm cr)) id mbFp) cpUpdCU modNm (_asthdlrEcuStore astHdlr res) unless (ehpoptsStopAtErr popts) $ seterrs errs _ -> seterrs [strMsg $ "No parser for " ++ _asthdlrName astHdlr] } {-# LINE 107 "src/ehc/EHC/CompilePhase/Parsers.chs" #-} cpParseEH :: EHCCompileRunner m => HsName -> EHCompilePhaseT m () cpParseEH modNm = cpParseWithFPath astHandler'_EH defaultEHParseOpts Nothing modNm {-# LINE 130 "src/ehc/EHC/CompilePhase/Parsers.chs" #-} cpParseHs :: EHCCompileRunner m => Bool -> HsName -> EHCompilePhaseT m () cpParseHs litmode = cpParseWithFPath astHandler'_HS (defaultEHParseOpts {ehpoptsLitMode=litmode}) Nothing {-# LINE 140 "src/ehc/EHC/CompilePhase/Parsers.chs" #-} cpParseHsImport :: EHCCompileRunner m => Bool -> HsName -> EHCompilePhaseT m () cpParseHsImport litmode = cpParseWithFPath astHandler'_HS (defaultEHParseOpts {ehpoptsStopAtErr=True, ehpoptsLitMode=litmode, ehpoptsForImport=True}) Nothing {-# LINE 145 "src/ehc/EHC/CompilePhase/Parsers.chs" #-} cpParseCoreWithFPath :: EHCCompileRunner m => Maybe FPath -> HsName -> EHCompilePhaseT m () cpParseCoreWithFPath = cpParseWithFPath astHandler'_Core (defaultEHParseOpts) {-# LINE 150 "src/ehc/EHC/CompilePhase/Parsers.chs" #-} cpParseCoreRunWithFPath :: EHCCompileRunner m => Maybe FPath -> HsName -> EHCompilePhaseT m () cpParseCoreRunWithFPath = cpParseWithFPath astHandler'_CoreRun (defaultEHParseOpts) {-# LINE 159 "src/ehc/EHC/CompilePhase/Parsers.chs" #-} cpDecodeHIInfo :: EHCCompileRunner m => HsName -> EHCompilePhaseT m () cpDecodeHIInfo modNm = do { cr <- get ; let (ecu,_,opts,fp) = crBaseInfo modNm cr fpH = asthdlrMkInputFPath astHandler'_HI opts ecu (ASTFileContent_Binary, ASTFileUse_Cache) modNm fp ; cpMsg' modNm VerboseALot "Decoding" Nothing fpH ; hiinfo <- liftIO $ CE.catch (getSGetFile (fpathToStr fpH) (HI.sgetHIInfo opts)) (\(_ :: SomeException) -> return $ HI.emptyHIInfo {HI.hiiValidity = HI.HIValidity_Absent}) ; when (ehcOptVerbosity opts > VerboseALot) (do { liftIO $ putPPLn (pp hiinfo) }) ; let canCompile = ecuCanCompile ecu ; case HI.hiiValidity hiinfo of HI.HIValidity_WrongMagic | not canCompile -> cpSetLimitErrsWhen 1 "Read HI" [rngLift emptyRange Err_WrongMagic (show modNm) (fpathToStr fpH) ] HI.HIValidity_Inconsistent | not canCompile -> cpSetLimitErrsWhen 1 "Read HI (of previous compile) of module" [rngLift emptyRange Err_InconsistentHI (show modNm) (fpathToStr fpH) [Sig.timestamp, Cfg.installVariant opts, show $ ehcOptTarget opts, show $ ehcOptTargetFlavor opts] [HI.hiiSrcTimeStamp hiinfo , HI.hiiCompiler hiinfo , show $ HI.hiiTarget hiinfo, show $ HI.hiiTargetFlavor hiinfo] ] _ -> cpUpdCU modNm (ecuStorePrevHIInfo {-- $ HI.hiiPostCheckValidity opts -} hiinfo) } {-# LINE 196 "src/ehc/EHC/CompilePhase/Parsers.chs" #-} -- | Decode from serialized file and store result in the compileunit for the module modNm cpDecode :: (EHCCompileRunner m, Serialize x) => Maybe String -> EcuUpdater x -> HsName -> EHCompilePhaseT m () cpDecode mbSuff store modNm = do { cr <- get ; let (ecu,_,opts,fp) = crBaseInfo modNm cr fpC = maybe id fpathSetSuff mbSuff fp ; cpMsg' modNm VerboseALot ("Decoding (" ++ show mbSuff ++ ")") Nothing fpC ; x <- liftIO $ getSerializeFile (fpathToStr fpC) ; cpUpdCU modNm (store x) } {-# LINE 209 "src/ehc/EHC/CompilePhase/Parsers.chs" #-} -- | Decode from serialized file and store result in the compileunit for the module modNm, return True if decoding could be done cpDecode'' :: EHCCompileRunner m => ASTHandler' ast -> ASTSuffixKey -> ASTFileTiming -> HsName -> EHCompilePhaseT m Bool cpDecode'' astHdlr skey tkey modNm = do { cr <- get ; let (ecu,_,opts,fp) = crBaseInfo modNm cr mbi@(~(Just info)) = astsuffixLookup skey $ _asthdlrSuffixRel astHdlr mbl@(~(Just lens)) = Map.lookup tkey $ _astsuffinfoASTLensMp info -- fpC = fpathSetSuff (_astsuffinfoSuff info) fp fpC = asthdlrMkInputFPath astHdlr opts ecu skey modNm fp ; if isJust mbi && isJust mbl then do cpMsg' modNm VerboseALot "Decoding" Nothing fpC mbx@(~(Just x)) <- liftIO $ _asthdlrGetSerializeFileIO astHdlr opts fpC if isJust mbx then do let errs = _asthdlrPostInputCheck astHdlr opts ecu modNm fpC x if null errs then do cpUpdCU modNm (lens ^= Just x) return True else do cpSetLimitErrsWhen 1 ("Decode " ++ _asthdlrName astHdlr) errs return False else return False else return False } -- | Decode from serialized file and store result in the compileunit for the module modNm cpDecode' :: EHCCompileRunner m => ASTHandler' ast -> ASTSuffixKey -> ASTFileTiming -> HsName -> EHCompilePhaseT m () cpDecode' astHdlr skey tkey modNm = do okDecode <- cpDecode'' astHdlr skey tkey modNm unless okDecode $ cpSetLimitErrsWhen 1 ("Decode " ++ _asthdlrName astHdlr) [strMsg $ "No decoder/lens for " ++ _asthdlrName astHdlr ++ " (" ++ show skey ++ "/" ++ show tkey ++ ")"] {-# LINE 249 "src/ehc/EHC/CompilePhase/Parsers.chs" #-} cpDecodeCore :: EHCCompileRunner m => Maybe String -> HsName -> EHCompilePhaseT m () -- cpDecodeCore = cpDecode' astHdlr skey timing cpDecodeCore suff = cpDecode suff ecuStoreCore {-# LINE 255 "src/ehc/EHC/CompilePhase/Parsers.chs" #-} cpDecodeCoreRun :: EHCCompileRunner m => Maybe String -> HsName -> EHCompilePhaseT m () cpDecodeCoreRun suff = cpDecode suff ecuStoreCore {-# LINE 264 "src/ehc/EHC/CompilePhase/Parsers.chs" #-} cpGetPrevHI :: EHCCompileRunner m => HsName -> EHCompilePhaseT m () cpGetPrevHI modNm = do { cr <- get ; cpMsg modNm VerboseDebug "cpGetPrevHI" ; let ecu = crCU modNm cr -- ; when (isJust (ecuMbHITime ecu)) -- (cpParseHI modNm) ; when (isJust (_ecuMbHIInfoTime ecu)) $ -- cpDecodeHIInfo modNm cpDecode' astHandler'_HI (ASTFileContent_Binary, ASTFileUse_Cache) ASTFileTiming_Prev modNm } {-# LINE 278 "src/ehc/EHC/CompilePhase/Parsers.chs" #-} cpGetPrevCore :: EHCCompileRunner m => HsName -> EHCompilePhaseT m Core.CModule cpGetPrevCore modNm = do { cr <- get ; cpMsg modNm VerboseDebug "cpGetPrevCore" -- ; let ecu = crCU modNm cr -- ; when (isJust (_ecuMbCoreTime ecu) && isNothing (_ecuMbCore ecu)) $ -- cpDecodeCore (Just Cfg.suffixDotlessBinaryCore) modNm -- cpDecode' astHandler'_Core (ASTFileContent_Binary, ASTFileUse_Cache) ASTFileTiming_Prev modNm -- ; fmap (fromJust . _ecuMbCore) $ gets (crCU modNm) ; bcall $ ASTFromFile (modNm,Nothing) ASTType_Core (ASTFileContent_Binary, ASTFileUse_Cache) ASTFileTiming_Prev } {-# LINE 292 "src/ehc/EHC/CompilePhase/Parsers.chs" #-} cpGetPrevCoreRun :: EHCCompileRunner m => HsName -> EHCompilePhaseT m CoreRun.Mod cpGetPrevCoreRun modNm = do { cr <- get ; cpMsg modNm VerboseDebug "cpGetPrevCoreRun" ; let ecu = crCU modNm cr ; when (isJust (_ecuMbCoreRunTime ecu) && isNothing (_ecuMbCoreRun ecu)) (cpDecodeCoreRun (Just Cfg.suffixDotlessBinaryCoreRun) modNm) ; fmap (fromJust . _ecuMbCoreRun) $ gets (crCU modNm) }