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 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 77 "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 103 "src/ehc/EHC/CompilePhase/Parsers.chs" #-} cpParseEH :: EHCCompileRunner m => HsName -> EHCompilePhaseT m () cpParseEH modNm = cpParseWithFPath astHandler'_EH defaultEHParseOpts Nothing modNm {-# LINE 126 "src/ehc/EHC/CompilePhase/Parsers.chs" #-} cpParseHs :: EHCCompileRunner m => Bool -> HsName -> EHCompilePhaseT m () cpParseHs litmode = cpParseWithFPath astHandler'_HS (defaultEHParseOpts {ehpoptsLitMode=litmode}) Nothing {-# LINE 136 "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 141 "src/ehc/EHC/CompilePhase/Parsers.chs" #-} cpParseCoreWithFPath :: EHCCompileRunner m => Maybe FPath -> HsName -> EHCompilePhaseT m () cpParseCoreWithFPath = cpParseWithFPath astHandler'_Core (defaultEHParseOpts) {-# LINE 146 "src/ehc/EHC/CompilePhase/Parsers.chs" #-} cpParseCoreRunWithFPath :: EHCCompileRunner m => Maybe FPath -> HsName -> EHCompilePhaseT m () cpParseCoreRunWithFPath = cpParseWithFPath astHandler'_CoreRun (defaultEHParseOpts) {-# LINE 155 "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 192 "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 205 "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 245 "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 251 "src/ehc/EHC/CompilePhase/Parsers.chs" #-} cpDecodeCoreRun :: EHCCompileRunner m => Maybe String -> HsName -> EHCompilePhaseT m () cpDecodeCoreRun suff = cpDecode suff ecuStoreCore {-# LINE 260 "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 274 "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) } {-# LINE 287 "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) }