module UHC.Light.Compiler.EHC.CompilePhase.Parsers ( cpParseOffside , cpParseEH , cpParseCoreWithFPath , cpParseOffsideStopAtErr , cpDecodeHIInfo , cpDecodeCore , cpGetPrevHI , cpGetPrevCore , 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.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 61 "src/ehc/EHC/CompilePhase/Parsers.chs" #-} -- | Generalization of parser invocation cpParseWithFPath :: PP msg => (ScanUtils.ScanOpts -> FilePath -> Handle -> IO inp) -- tokenize/scan file -> (parser -> inp -> (a,[msg])) -- parse tokens -> ([Err] -> EHCompilePhase 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 -> EHCompilePhase out cpParseWithFPath scan parse seterrs parser scanOpts store mbFp modNm = do { cr <- get ; (fn,fh) <- lift $ openFPath (maybe (ecuFilePath (crCU modNm cr)) id mbFp) ReadMode False ; tokens <- lift $ 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 :: OffsideParser [Token] Pair Token (Maybe Token) a -> ScanUtils.ScanOpts -> EcuUpdater a -> String -> Maybe FPath -> HsName -> EHCompilePhase () cpParseOffsideWithFPath parser scanOpts store description mbFp modNm = cpParseWithFPath offsideScanHandle parseOffsideToResMsgs (cpSetLimitErrsWhen 5 description) parser scanOpts store mbFp modNm {- = do { cr <- get ; (fn,fh) <- lift $ openFPath (maybe (ecuFilePath (crCU modNm cr)) id mbFp) ReadMode False ; tokens <- lift $ offsideScanHandle scanOpts fn fh -- ; lift $ 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 104 "src/ehc/EHC/CompilePhase/Parsers.chs" #-} cpParseOffside :: HSPrs.HSParser a -> ScanUtils.ScanOpts -> EcuUpdater a -> String -> HsName -> EHCompilePhase () cpParseOffside parser scanOpts store description modNm = cpParseOffsideWithFPath parser scanOpts store description Nothing modNm {-# LINE 135 "src/ehc/EHC/CompilePhase/Parsers.chs" #-} cpParseEH :: HsName -> EHCompilePhase () cpParseEH = cpParseOffside EHPrs.pAGItf (ehScanOpts defaultEHCOpts) ecuStoreEH "Parse (EH syntax) of module" {-# LINE 162 "src/ehc/EHC/CompilePhase/Parsers.chs" #-} cpParseHs :: Bool -> HsName -> EHCompilePhase () 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 174 "src/ehc/EHC/CompilePhase/Parsers.chs" #-} cpParseOffsideStopAtErr :: HSPrs.HSParser a -> ScanUtils.ScanOpts -> EcuUpdater a -> HsName -> EHCompilePhase () cpParseOffsideStopAtErr parser scanOpts store modNm = do { cr <- get ; (fn,fh) <- lift $ openFPath (ecuFilePath (crCU modNm cr)) ReadMode False ; tokens <- lift $ offsideScanHandle scanOpts fn fh ; let (res,_) = parseOffsideToResMsgsStopAtErr parser tokens ; cpUpdCU modNm (store res) } {-# LINE 194 "src/ehc/EHC/CompilePhase/Parsers.chs" #-} cpParseHsImport :: Bool -> HsName -> EHCompilePhase () cpParseHsImport litmode modNm = do { cr <- get ; let (_,opts) = crBaseInfo' cr ; cpParseOffsideStopAtErr (HSPrs.pAGItfImport opts) ((hsScanOpts opts) {ScanUtils.scoLitmode = litmode}) ecuStoreHS modNm } {-# LINE 203 "src/ehc/EHC/CompilePhase/Parsers.chs" #-} cpParseCoreWithFPath :: Maybe FPath -> HsName -> EHCompilePhase () cpParseCoreWithFPath mbFp modNm = do (_,opts) <- gets crBaseInfo' cpParseWithFPath scanHandle parseToResMsgs (cpSetLimitErrsWhen 5 "Parse Core") CorePrs.pCModule (coreScanOpts opts) ecuStoreCore mbFp modNm {- cpParseCore :: HsName -> EHCompilePhase () 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 248 "src/ehc/EHC/CompilePhase/Parsers.chs" #-} cpDecodeHIInfo :: HsName -> EHCompilePhase () 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 <- lift $ 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 { lift $ 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 294 "src/ehc/EHC/CompilePhase/Parsers.chs" #-} -- | Decode from serialized file and store result in the compileunit for the module modNm cpDecode :: Serialize x => Maybe String -> EcuUpdater x -> HsName -> EHCompilePhase () 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 312 "src/ehc/EHC/CompilePhase/Parsers.chs" #-} cpDecodeCore :: Maybe String -> HsName -> EHCompilePhase () cpDecodeCore suff = cpDecode suff ecuStoreCore {-# LINE 321 "src/ehc/EHC/CompilePhase/Parsers.chs" #-} cpGetPrevHI :: HsName -> EHCompilePhase () 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 334 "src/ehc/EHC/CompilePhase/Parsers.chs" #-} cpGetPrevCore :: HsName -> EHCompilePhase 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) }