Parsers.hs

module UHC.Light.Compiler.EHC.CompilePhase.Parsers
( cpDecode''
, 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 UHC.Util.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 UHC.Light.Compiler.EHC.BuildFunction.Run
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








{-# LINE 80 "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 modNm 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
      -- ; liftIO $ putStrLn $ "cpParseWithFPath: ehcOptBangPatterns=" ++ show (ehcOptBangPatterns opts)
      ; 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 (ehpoptsOkToStopAtErr popts) $ seterrs errs
          _ -> seterrs [strMsg $ "No parser for " ++ _asthdlrName astHdlr]
      }

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

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

{-# LINE 196 "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 209 "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 (ASTFileSuffOverride_Suff 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 264 "src/ehc/EHC/CompilePhase/Parsers.chs" #-}
cpGetPrevHI :: EHCCompileRunner m => HsName -> EHCompilePhaseT m AST_HI
cpGetPrevHI modNm
  = do { cpMsg modNm VerboseDebug "cpGetPrevHI"
{-
       ; cr <- get
       ; 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
-}
       ; bcall $ ASTFromFile (mkPrevFileSearchKeyWithName modNm) (AlwaysEq ASTFileTimeHandleHow_AbsenceIgnore) ASTType_HI (ASTFileContent_Binary, ASTFileUse_Cache) ASTFileTiming_Prev
       }

{-# LINE 281 "src/ehc/EHC/CompilePhase/Parsers.chs" #-}
cpGetPrevCore :: EHCCompileRunner m => HsName -> EHCompilePhaseT m AST_Core
cpGetPrevCore modNm
  = do { cpMsg modNm VerboseDebug "cpGetPrevCore"
{-
       ; cr <- get
       ; 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)
-}
       ; bcall $ ASTFromFile (mkPrevFileSearchKeyWithName modNm) (AlwaysEq ASTFileTimeHandleHow_AbsenceIgnore) ASTType_Core (ASTFileContent_Binary, ASTFileUse_Cache) ASTFileTiming_Prev
       }

{-# LINE 297 "src/ehc/EHC/CompilePhase/Parsers.chs" #-}
cpGetPrevCoreRun :: EHCCompileRunner m => HsName -> EHCompilePhaseT m AST_CoreRun
cpGetPrevCoreRun modNm
  = do { cpMsg modNm VerboseDebug "cpGetPrevCoreRun"
{-
       ; cr <- get
       ; let  ecu    = crCU modNm cr
       ; when (isJust (_ecuMbCoreRunTime ecu) && isNothing (_ecuMbCoreRun ecu))
              (cpDecodeCoreRun (Just Cfg.suffixDotlessBinaryCoreRun) modNm)
       ; fmap (fromJust . _ecuMbCoreRun) $ gets (crCU modNm)
-}
       ; bcall $ ASTFromFile (mkPrevFileSearchKeyWithName modNm) (AlwaysEq ASTFileTimeHandleHow_AbsenceIgnore) ASTType_CoreRun (ASTFileContent_Binary, ASTFileUse_Cache) ASTFileTiming_Prev
       }