Parsers.hs

module UHC.Light.Compiler.EHC.CompilePhase.Parsers
( cpParseEH
, cpParseCoreWithFPath
, cpParseCoreRunWithFPath
, cpDecode''
, cpDecodeCore
, cpDecodeCoreRun
, 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 Control.Monad.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 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
import qualified UHC.Light.Compiler.Config as Cfg
import qualified UHC.Light.Compiler.SourceCodeSig as Sig








{-# LINE 77 "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' 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
      ; 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 (ehpoptsStopAtErr popts) $ seterrs errs
          _ -> seterrs [strMsg $ "No parser for " ++ _asthdlrName astHdlr]
      }

{-# LINE 103 "src/ehc/EHC/CompilePhase/Parsers.chs" #-}
cpParseEH :: EHCCompileRunner m => HsName -> EHCompilePhaseT m ()
cpParseEH modNm
  = cpParseWithFPath astHandler'_EH defaultEHParseOpts Nothing modNm

{-# LINE 126 "src/ehc/EHC/CompilePhase/Parsers.chs" #-}
cpParseHs :: EHCCompileRunner m => Bool -> HsName -> EHCompilePhaseT m ()
cpParseHs litmode = cpParseWithFPath astHandler'_HS (defaultEHParseOpts {ehpoptsLitMode=litmode}) Nothing

{-# LINE 136 "src/ehc/EHC/CompilePhase/Parsers.chs" #-}
cpParseHsImport :: EHCCompileRunner m => Bool -> HsName -> EHCompilePhaseT m ()
cpParseHsImport litmode = cpParseWithFPath astHandler'_HS (defaultEHParseOpts {ehpoptsStopAtErr=True, ehpoptsLitMode=litmode, ehpoptsForImport=True}) Nothing

{-# LINE 141 "src/ehc/EHC/CompilePhase/Parsers.chs" #-}
cpParseCoreWithFPath :: EHCCompileRunner m => Maybe FPath -> HsName -> EHCompilePhaseT m ()
cpParseCoreWithFPath = cpParseWithFPath astHandler'_Core (defaultEHParseOpts)

{-# LINE 146 "src/ehc/EHC/CompilePhase/Parsers.chs" #-}
cpParseCoreRunWithFPath :: EHCCompileRunner m => Maybe FPath -> HsName -> EHCompilePhaseT m ()
cpParseCoreRunWithFPath = cpParseWithFPath astHandler'_CoreRun (defaultEHParseOpts)

{-# LINE 155 "src/ehc/EHC/CompilePhase/Parsers.chs" #-}
cpDecodeHIInfo :: EHCCompileRunner m => HsName -> EHCompilePhaseT m ()
cpDecodeHIInfo modNm
  = do { cr <- get
       ; let  (ecu,_,opts,fp) = crBaseInfo modNm cr
              fpH     = asthdlrMkInputFPath astHandler'_HI opts ecu (ASTFileContent_Binary, ASTFileUse_Cache) modNm fp
       ; cpMsg' modNm VerboseALot "Decoding" Nothing fpH
       ; hiinfo <- liftIO $
           CE.catch (getSGetFile (fpathToStr fpH) (HI.sgetHIInfo opts))
                    (\(_ :: SomeException) -> return $ HI.emptyHIInfo {HI.hiiValidity = HI.HIValidity_Absent})
       ; when (ehcOptVerbosity opts > VerboseALot)
              (do { liftIO $ putPPLn (pp hiinfo)
                  })
       ; let canCompile = ecuCanCompile ecu
       ; 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 192 "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 205 "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 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 245 "src/ehc/EHC/CompilePhase/Parsers.chs" #-}
cpDecodeCore :: EHCCompileRunner m => Maybe String -> HsName -> EHCompilePhaseT m ()
-- cpDecodeCore = cpDecode' astHdlr skey timing
cpDecodeCore suff = cpDecode suff ecuStoreCore

{-# LINE 251 "src/ehc/EHC/CompilePhase/Parsers.chs" #-}
cpDecodeCoreRun :: EHCCompileRunner m => Maybe String -> HsName -> EHCompilePhaseT m ()
cpDecodeCoreRun suff = cpDecode suff ecuStoreCore

{-# LINE 260 "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
              cpDecode' astHandler'_HI (ASTFileContent_Binary, ASTFileUse_Cache) ASTFileTiming_Prev modNm
       }

{-# LINE 274 "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
              cpDecode' astHandler'_Core (ASTFileContent_Binary, ASTFileUse_Cache) ASTFileTiming_Prev modNm
       ; fmap (fromJust . _ecuMbCore) $ gets (crCU modNm)
       }

{-# LINE 287 "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)
       }