Parsers.hs

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