module UHC.Light.Compiler.EHC.CompilePhase.Parsers ( cpDecode'' , 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 UHC.Util.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 {-# LINE 80 "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 modNm 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 -- ; liftIO $ putStrLn $ "cpParseWithFPath: ehcOptBangPatterns=" ++ show (ehcOptBangPatterns opts) ; 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 (ehpoptsOkToStopAtErr popts) $ seterrs errs _ -> seterrs [strMsg $ "No parser for " ++ _asthdlrName astHdlr] } {-# 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 {ehpoptsOkToStopAtErr=True, ehpoptsLitMode=litmode, ehpoptsForImport=True}) Nothing {-# 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 (ASTFileSuffOverride_Suff 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 264 "src/ehc/EHC/CompilePhase/Parsers.chs" #-} cpGetPrevHI :: EHCCompileRunner m => HsName -> EHCompilePhaseT m AST_HI cpGetPrevHI modNm = do { cpMsg modNm VerboseDebug "cpGetPrevHI" {- ; cr <- get ; 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 -} ; bcall $ ASTFromFile (mkPrevFileSearchKeyWithName modNm) (AlwaysEq ASTFileTimeHandleHow_AbsenceIgnore) ASTType_HI (ASTFileContent_Binary, ASTFileUse_Cache) ASTFileTiming_Prev } {-# LINE 281 "src/ehc/EHC/CompilePhase/Parsers.chs" #-} cpGetPrevCore :: EHCCompileRunner m => HsName -> EHCompilePhaseT m AST_Core cpGetPrevCore modNm = do { cpMsg modNm VerboseDebug "cpGetPrevCore" {- ; cr <- get ; 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 (mkPrevFileSearchKeyWithName modNm) (AlwaysEq ASTFileTimeHandleHow_AbsenceIgnore) ASTType_Core (ASTFileContent_Binary, ASTFileUse_Cache) ASTFileTiming_Prev } {-# LINE 297 "src/ehc/EHC/CompilePhase/Parsers.chs" #-} cpGetPrevCoreRun :: EHCCompileRunner m => HsName -> EHCompilePhaseT m AST_CoreRun cpGetPrevCoreRun modNm = do { cpMsg modNm VerboseDebug "cpGetPrevCoreRun" {- ; cr <- get ; let ecu = crCU modNm cr ; when (isJust (_ecuMbCoreRunTime ecu) && isNothing (_ecuMbCoreRun ecu)) (cpDecodeCoreRun (Just Cfg.suffixDotlessBinaryCoreRun) modNm) ; fmap (fromJust . _ecuMbCoreRun) $ gets (crCU modNm) -} ; bcall $ ASTFromFile (mkPrevFileSearchKeyWithName modNm) (AlwaysEq ASTFileTimeHandleHow_AbsenceIgnore) ASTType_CoreRun (ASTFileContent_Binary, ASTFileUse_Cache) ASTFileTiming_Prev }