Parsers.hs

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)
       }