module UHC.Light.Compiler.EHC.CompilePhase.Parsers ( cpParseOffside , cpParseEH , cpParseCoreWithFPath , cpParseOffsideStopAtErr , cpDecodeHIInfo , cpDecodeCore , cpDecodeCoreRun , cpGetPrevHI , cpGetPrevCore , cpGetPrevCoreRun , cpParseHs , cpParseHsImport ) where 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 Control.Monad.State import UHC.Light.Compiler.EHC.Common import UHC.Light.Compiler.EHC.CompileUnit import UHC.Light.Compiler.EHC.CompileRun 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 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 import Control.Exception as CE {-# LINE 64 "src/ehc/EHC/CompilePhase/Parsers.chs" #-} -- | Generalization of parser invocation cpParseWithFPath :: (EHCCompileRunner m, PP msg) => (ScanUtils.ScanOpts -> FilePath -> Handle -> IO inp) -- tokenize/scan file -> (parser -> inp -> (a,[msg])) -- parse tokens -> ([Err] -> EHCompilePhaseT m out) -- monadic output from errors -> parser -- the parser -> ScanUtils.ScanOpts -- options to the tokenizer/scanner -> EcuUpdater a -- updater of state -> Maybe FPath -- possibly overriding FilePath instead of default derived from state for this module name -> HsName -- module name -> EHCompilePhaseT m out cpParseWithFPath scan parse seterrs parser scanOpts store mbFp modNm = do { cr <- get ; (fn,fh) <- liftIO $ openFPath (maybe (ecuFilePath (crCU modNm cr)) id mbFp) ReadMode False ; tokens <- liftIO $ scan scanOpts fn fh ; let (res,msgs) = parse parser tokens errs = map (rngLift emptyRange mkPPErr) msgs ; cpUpdCU modNm (store res) ; seterrs errs } -- cpParseOffsideWithFPath :: HSPrs.HSParser a -> ScanUtils.ScanOpts -> EcuUpdater a -> String -> Maybe FPath -> HsName -> EHCompilePhase () -- `HSPrs.HSParser a' is a type synonym for `OffsideParser [Token] Pair Token (Maybe Token) a' but is not expanded as such... cpParseOffsideWithFPath :: EHCCompileRunner m => OffsideParser [Token] Pair Token (Maybe Token) a -> ScanUtils.ScanOpts -> EcuUpdater a -> String -> Maybe FPath -> HsName -> EHCompilePhaseT m () cpParseOffsideWithFPath parser scanOpts store description mbFp modNm = cpParseWithFPath offsideScanHandle parseOffsideToResMsgs (cpSetLimitErrsWhen 5 description) parser scanOpts store mbFp modNm {- = do { cr <- get ; (fn,fh) <- liftIO $ openFPath (maybe (ecuFilePath (crCU modNm cr)) id mbFp) ReadMode False ; tokens <- liftIO $ offsideScanHandle scanOpts fn fh -- ; liftIO $ putStrLn $ show tokens -- does not work, no Show instance ; let (res,msgs) = parseOffsideToResMsgs parser tokens errs = map (rngLift emptyRange mkPPErr) msgs ; cpUpdCU modNm (store res) ; cpSetLimitErrsWhen 5 description errs } -} {-# LINE 107 "src/ehc/EHC/CompilePhase/Parsers.chs" #-} cpParseOffside :: EHCCompileRunner m => HSPrs.HSParser a -> ScanUtils.ScanOpts -> EcuUpdater a -> String -> HsName -> EHCompilePhaseT m () cpParseOffside parser scanOpts store description modNm = cpParseOffsideWithFPath parser scanOpts store description Nothing modNm {-# LINE 138 "src/ehc/EHC/CompilePhase/Parsers.chs" #-} cpParseEH :: EHCCompileRunner m => HsName -> EHCompilePhaseT m () cpParseEH = cpParseOffside EHPrs.pAGItf (ehScanOpts defaultEHCOpts) ecuStoreEH "Parse (EH syntax) of module" {-# LINE 165 "src/ehc/EHC/CompilePhase/Parsers.chs" #-} cpParseHs :: EHCCompileRunner m => Bool -> HsName -> EHCompilePhaseT m () cpParseHs litmode modNm = do { cr <- get ; let (ecu,_,opts,_) = crBaseInfo modNm cr ; cpParseOffsideWithFPath (HSPrs.pAGItf opts) ((hsScanOpts opts) {ScanUtils.scoLitmode = litmode}) ecuStoreHS ("Parse (" ++ (if litmode then "Literate " else "") ++ "Haskell syntax) of module") Nothing modNm } {-# LINE 177 "src/ehc/EHC/CompilePhase/Parsers.chs" #-} cpParseOffsideStopAtErr :: EHCCompileRunner m => HSPrs.HSParser a -> ScanUtils.ScanOpts -> EcuUpdater a -> HsName -> EHCompilePhaseT m () cpParseOffsideStopAtErr parser scanOpts store modNm = do { cr <- get ; (fn,fh) <- liftIO $ openFPath (ecuFilePath (crCU modNm cr)) ReadMode False ; tokens <- liftIO $ offsideScanHandle scanOpts fn fh ; let (res,_) = parseOffsideToResMsgsStopAtErr parser tokens ; cpUpdCU modNm (store res) } {-# LINE 197 "src/ehc/EHC/CompilePhase/Parsers.chs" #-} cpParseHsImport :: EHCCompileRunner m => Bool -> HsName -> EHCompilePhaseT m () cpParseHsImport litmode modNm = do { cr <- get ; let (_,opts) = crBaseInfo' cr ; cpParseOffsideStopAtErr (HSPrs.pAGItfImport opts) ((hsScanOpts opts) {ScanUtils.scoLitmode = litmode}) ecuStoreHS modNm } {-# LINE 206 "src/ehc/EHC/CompilePhase/Parsers.chs" #-} cpParseCoreWithFPath :: EHCCompileRunner m => Maybe FPath -> HsName -> EHCompilePhaseT m () cpParseCoreWithFPath mbFp modNm = do (_,opts) <- gets crBaseInfo' cpParseWithFPath scanHandle parseToResMsgs (cpSetLimitErrsWhen 5 "Parse Core") CorePrs.pCModule (coreScanOpts opts) ecuStoreCore mbFp modNm {- cpParseCore :: EHCCompileRunner m => HsName -> EHCompilePhaseT m () cpParseCore modNm = do { cr <- get ; let (ecu,_,opts,fp) = crBaseInfo modNm cr fpC = fpathSetSuff Cfg.suffixDotlessInputOutputTextualCore fp ; cpMsg' modNm VerboseALot "Parsing" Nothing fpC ; errs <- cpParsePlainToErrs CorePrs.pCModule (coreScanOpts opts) ecuStoreCore fpC modNm ; when (ehcDebugStopAtCoreError opts) (cpSetLimitErrsWhen 5 "Parse Core (of previous compile) of module" errs) ; return () } -} {-# LINE 251 "src/ehc/EHC/CompilePhase/Parsers.chs" #-} cpDecodeHIInfo :: EHCCompileRunner m => HsName -> EHCompilePhaseT m () cpDecodeHIInfo modNm = do { cr <- get ; let (ecu,_,opts,fp) = crBaseInfo modNm cr -- if outputdir is specified, use that location to possibly read hi from. fpH = mkInOrOutputFPathFor (InputFrom_Loc $ ecuFileLocation ecu) opts modNm fp "hi" ; cpMsg' modNm VerboseALot "Decoding" Nothing fpH ; hiinfo <- liftIO $ CE.catch (do { i <- getSGetFile (fpathToStr fpH) (HI.sgetHIInfo opts) -- getSerializeFile (fpathToStr fpH) -- Bin.getBinaryFPath fpH ; return i }) (\(_ :: SomeException) -> return $ HI.emptyHIInfo {HI.hiiValidity = HI.HIValidity_Absent}) ; when (ehcOptVerbosity opts > VerboseALot) (do { liftIO $ putPPLn (pp hiinfo) }) ; let canCompile = crModCanCompile modNm cr ; 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 297 "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" Nothing fpC ; x <- liftIO $ getSerializeFile (fpathToStr fpC) ; cpUpdCU modNm (store x) } {-# LINE 315 "src/ehc/EHC/CompilePhase/Parsers.chs" #-} cpDecodeCore :: EHCCompileRunner m => Maybe String -> HsName -> EHCompilePhaseT m () cpDecodeCore suff = cpDecode suff ecuStoreCore {-# LINE 320 "src/ehc/EHC/CompilePhase/Parsers.chs" #-} cpDecodeCoreRun :: EHCCompileRunner m => Maybe String -> HsName -> EHCompilePhaseT m () cpDecodeCoreRun suff = cpDecode suff ecuStoreCore {-# LINE 329 "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) } {-# LINE 342 "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) -- (cpParseCore modNm) ; fmap (fromJust . ecuMbCore) $ gets (crCU modNm) } {-# LINE 355 "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) }