{-# LANGUAGE RecordWildCards #-} module UHC.Light.Compiler.EHC.ASTHandler.Instances ( module UHC.Light.Compiler.EHC.ASTHandler , astHandler'_HS , astHandler'_EH , astHandler'_Core , astHandler'_CoreRun , allASThandlerMp , asthandlerLookup , asthandlerLookup' , asthandlerLookupM' , astHandler'_HI ) where import UHC.Light.Compiler.EHC.Common import UHC.Light.Compiler.EHC.CompileUnit import UHC.Light.Compiler.EHC.CompileRun.Base import qualified UHC.Light.Compiler.Config as Cfg import UHC.Light.Compiler.EHC.ASTHandler import qualified Data.Map as Map import qualified Data.IntMap as IMap import Data.Maybe import qualified UHC.Util.RelMap as Rel import Data.Typeable import UHC.Light.Compiler.Base.ParseUtils import UHC.Light.Compiler.EHC.ASTTypes import UHC.Light.Compiler.Core.Trf.EraseExtractTysigCore import qualified UHC.Light.Compiler.EH.Main as EHSem import qualified UHC.Light.Compiler.HS.MainAG as HSSem import UHC.Light.Compiler.CoreRun as CoreRun import UHC.Light.Compiler.Core.ToCoreRun import UHC.Light.Compiler.CoreRun.Pretty import UHC.Light.Compiler.Core as Core import UHC.Light.Compiler.Core.Pretty import UHC.Light.Compiler.Core.PrettyTrace 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 qualified UHC.Light.Compiler.EH.Parser as EHPrs import qualified UHC.Light.Compiler.HS.Parser as HSPrs import qualified UHC.Light.Compiler.Core.Parser as CorePrs import qualified UHC.Light.Compiler.CoreRun.Parser as CoreRunPrs import Control.Exception as CE import qualified UHC.Util.Binary as Bin import UHC.Util.Serialize import UHC.Light.Compiler.Module.ImportExport import UHC.Light.Compiler.CodeGen.ImportUsedModules import UHC.Util.Time import System.Directory import qualified UHC.Light.Compiler.HI as HI import qualified UHC.Light.Compiler.Config as Cfg import qualified UHC.Light.Compiler.SourceCodeSig as Sig {-# LINE 135 "src/ehc/EHC/ASTHandler/Instances.chs" #-} astHandler'_HS :: ASTHandler' AST_HS astHandler'_HS = mk emptyASTHandler' where mk (hdlr@(ASTHandler' {..})) = emptyASTHandler' -- ASTHandler' { _asthdlrName = "Haskell" , _asthdlrASTLens = Just ecuMbHS {- , _asthdlrSuffixRel = mkASTSuffixRel [ ( (ASTFileContent_Text , ASTFileUse_Src), ("hs", ecuMbHS, tmlens) ) , ( (ASTFileContent_LitText, ASTFileUse_Src), ("lhs", ecuMbHS, tmlens) ) ] -} , _asthdlrSuffixRel = mkASTSuffixRel' [ ( (ASTFileContent_Text , ASTFileUse_Src) , ("hs" , [ (ASTFileTiming_Current, ecuMbHS) ] , [ (ASTFileTiming_Current, ecuMbSrcTime) ] , id ) ) , ( (ASTFileContent_Text , ASTFileUse_SrcImport) , ("hs" , [ (ASTFileTiming_Current, ecuMbHS) ] , [ (ASTFileTiming_Current, ecuMbSrcTime) ] , \o -> o {ehpoptsOkToStopAtErr=True, ehpoptsForImport=True} ) ) , ( (ASTFileContent_LitText , ASTFileUse_Src) , ("lhs" , [ (ASTFileTiming_Current, ecuMbHS) ] , [ (ASTFileTiming_Current, ecuMbSrcTime) ] , \o -> o {ehpoptsLitMode=True} ) ) , ( (ASTFileContent_LitText , ASTFileUse_SrcImport) , ("lhs" , [ (ASTFileTiming_Current, ecuMbHS) ] , [ (ASTFileTiming_Current, ecuMbSrcTime) ] , \o -> o {ehpoptsLitMode=True, ehpoptsOkToStopAtErr=True, ehpoptsForImport=True} ) ) ] , _asthdlrEcuStore = ecuStoreHS , _asthdlrParseScanOpts = \opts _ -> hsScanOpts opts , _asthdlrParser = \opts popts -> Just $ ASTParser $ if ehpoptsForImport popts then HSPrs.pAGItfImport opts else HSPrs.pAGItf opts {- -- the rest, avoid record update (http://hackage.haskell.org/trac/ghc/ticket/2595, http://breaks.for.alienz.org/blog/2011/10/21/record-update-for-insufficiently-polymorphic-field/) , _asthdlrMkOutputFPath = _asthdlrMkOutputFPath , _asthdlrSuffixMp = _asthdlrSuffixMp , _asthdlrInput = _asthdlrInput -} } {- tmlens = Just ecuMbSrcTime -} {-# LINE 242 "src/ehc/EHC/ASTHandler/Instances.chs" #-} astHandler'_EH :: ASTHandler' AST_EH astHandler'_EH = mk emptyASTHandler' where mk (hdlr@(ASTHandler' {..})) = emptyASTHandler' -- ASTHandler' { _asthdlrName = "EH" , _asthdlrASTLens = Just ecuMbEH , _asthdlrSuffixRel = mkASTSuffixRel [ ( (ASTFileContent_Text , ASTFileUse_Src), ("eh", ecuMbEH, Nothing) ) ] , _asthdlrEcuStore = ecuStoreEH , _asthdlrParseScanOpts = \opts _ -> ehScanOpts opts , _asthdlrParser = \_ _ -> Just $ ASTParser EHPrs.pAGItf , _asthdlrPretty = \_ ecu _ -> fmap EHSem.pp_Syn_AGItf $ _ecuMbEHSem ecu {- -- the rest, avoid record update (http://hackage.haskell.org/trac/ghc/ticket/2595, http://breaks.for.alienz.org/blog/2011/10/21/record-update-for-insufficiently-polymorphic-field/) , _asthdlrMkOutputFPath = _asthdlrMkOutputFPath , _asthdlrSuffixMp = _asthdlrSuffixMp , _asthdlrInput = _asthdlrInput -} } {-# LINE 270 "src/ehc/EHC/ASTHandler/Instances.chs" #-} astHandler'_HI :: ASTHandler' AST_HI astHandler'_HI = mk emptyASTHandler' where mk (hdlr@(ASTHandler' {..})) = emptyASTHandler' -- ASTHandler' { _asthdlrName = "HI" , _asthdlrASTLens = Just ecuMbHIInfo , _asthdlrSuffixRel = mkASTSuffixRel' [ ( (ASTFileContent_Binary , ASTFileUse_Cache) , ("hi" , [ (ASTFileTiming_Current, ecuMbHIInfo) , (ASTFileTiming_Prev, ecuMbPrevHIInfo) ] , [ (ASTFileTiming_Prev, ecuMbHIInfoTime) ] , id ) ) ] , _asthdlrMkInputFPath = \opts ecu modNm fp suff -> -- if outputdir is specified, use that location to possibly read hi from. mkInOrOutputFPathFor (InputFrom_Loc $ ecuFileLocation ecu) opts modNm fp suff , _asthdlrEcuStore = ecuStoreHIInfo , _asthdlrPutSerializeFileIO= default_asthdlrPutSerializeFileIO , _asthdlrGetSerializeFileIO= \opts fp -> fmap Just $ CE.catch (getSGetFile (fpathToStr fp) (HI.sgetHIInfo opts)) (\(_ :: SomeException) -> return $ HI.emptyHIInfo {HI.hiiValidity = HI.HIValidity_Absent}) , _asthdlrPostInputCheck = \opts ecu modNm fp hiinfo -> case HI.hiiValidity hiinfo of HI.HIValidity_Ok -> [] HI.HIValidity_WrongMagic | not (ecuCanCompile ecu) -> [rngLift emptyRange Err_WrongMagic (show modNm) (fpathToStr fp) ] HI.HIValidity_Inconsistent | not (ecuCanCompile ecu) -> [rngLift emptyRange Err_InconsistentHI (show modNm) (fpathToStr fp) [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] ] _ -> [] , _asthdlrASTIsValid = \hiinfo -> HI.hiiValidity hiinfo == HI.HIValidity_Ok } {-# LINE 325 "src/ehc/EHC/ASTHandler/Instances.chs" #-} astHandler'_Core :: ASTHandler' AST_Core astHandler'_Core = mk emptyASTHandler' where mk (hdlr@(ASTHandler' {..})) = emptyASTHandler' -- ASTHandler' { _asthdlrName = "Core" , _asthdlrASTLens = Just ecuMbCore , _asthdlrSuffixRel = mkASTSuffixRel [ ( (ASTFileContent_Binary , ASTFileUse_Target) , (Cfg.suffixDotlessBinaryCore, ecuMbCore, Nothing) ) , ( (ASTFileContent_Text , ASTFileUse_Src) , (Cfg.suffixDotlessOutputTextualCore, ecuMbCore, Nothing) ) , ( (ASTFileContent_Text , ASTFileUse_Dump) , (Cfg.suffixDotlessOutputTextualCore, ecuMbCore, Nothing) ) , ( (ASTFileContent_ASTText , ASTFileUse_Dump) , (Cfg.suffixDotlessOutputTextualCoreAST, ecuMbCore, Nothing) ) , ( (ASTFileContent_Binary , ASTFileUse_Src) , (Cfg.suffixDotlessInputOutputBinaryCore, ecuMbCore, Nothing) ) , ( (ASTFileContent_Binary , ASTFileUse_Dump) , (Cfg.suffixDotlessInputOutputBinaryCore, ecuMbCore, Nothing) ) ] `Rel.union` mkASTSuffixRel' [ ( (ASTFileContent_Binary , ASTFileUse_Cache) , (Cfg.suffixDotlessBinaryCore , [ (ASTFileTiming_Current, ecuMbCore) , (ASTFileTiming_Prev, ecuMbCore) ] , [ (ASTFileTiming_Prev, ecuMbCoreTime) ] , id ) ) ] , _asthdlrEcuStore = ecuStoreCore , _asthdlrParseScanOpts = \opts _ -> coreScanOpts opts , _asthdlrParser = \opts _ -> Just $ ASTParser (CorePrs.pCModule opts :: EHPrsAna AST_Core) , _asthdlrPretty = \opts _ ast -> Just $ ppCModule (opts {- ehcOptCoreOpts = coreOpts ++ ehcOptCoreOpts opts -}) $ cmodTrfEraseTyCore opts ast , _asthdlrPrettyTrace = \opts _ ast -> Just $ ppASTCModule opts ast , _asthdlrPutSerializeFileIO= default_asthdlrPutSerializeFileIO , _asthdlrGetSerializeFileIO= default_asthdlrGetSerializeFileIO -- the rest, avoid record update (http://hackage.haskell.org/trac/ghc/ticket/2595, http://breaks.for.alienz.org/blog/2011/10/21/record-update-for-insufficiently-polymorphic-field/) -- , _asthdlrParseParse = _asthdlrParseParse -- , _asthdlrParseScan = _asthdlrParseScan -- , _asthdlrParser = _asthdlrParser {- , _asthdlrMkOutputFPath = _asthdlrMkOutputFPath , _asthdlrSuffixMp = _asthdlrSuffixMp , _asthdlrInput = _asthdlrInput -} } {-# LINE 384 "src/ehc/EHC/ASTHandler/Instances.chs" #-} astHandler'_CoreRun :: ASTHandler' AST_CoreRun astHandler'_CoreRun = mk emptyASTHandler' where mk (hdlr@(ASTHandler' {..})) = emptyASTHandler' -- ASTHandler' { _asthdlrName = "CoreRun" , _asthdlrASTLens = Just ecuMbCoreRun , _asthdlrSuffixRel = mkASTSuffixRel [ ( (ASTFileContent_Binary , ASTFileUse_Target) , (Cfg.suffixDotlessBinaryCoreRun, ecuMbCoreRun, Nothing) ) , ( (ASTFileContent_Text , ASTFileUse_Src) , (Cfg.suffixDotlessOutputTextualCoreRun, ecuMbCoreRun, Nothing) ) , ( (ASTFileContent_Text , ASTFileUse_Dump) , (Cfg.suffixDotlessOutputTextualCoreRun, ecuMbCoreRun, Nothing) ) , ( (ASTFileContent_Binary , ASTFileUse_Src) , (Cfg.suffixDotlessInputOutputBinaryCoreRun, ecuMbCoreRun, Nothing) ) , ( (ASTFileContent_Binary , ASTFileUse_Dump) , (Cfg.suffixDotlessInputOutputBinaryCoreRun, ecuMbCoreRun, Nothing) ) ] `Rel.union` mkASTSuffixRel' [ ( (ASTFileContent_Binary , ASTFileUse_Cache) , (Cfg.suffixDotlessBinaryCoreRun , [ (ASTFileTiming_Current, ecuMbCoreRun) , (ASTFileTiming_Prev, ecuMbCoreRun) ] , [ (ASTFileTiming_Prev, ecuMbCoreRunTime) ] , id ) ) ] , _asthdlrEcuStore = ecuStoreCoreRun , _asthdlrParseScanOpts = \opts _ -> corerunScanOpts , _asthdlrParser = \opts _ -> Just $ ASTParser (CoreRunPrs.pMod opts :: EHPrsAna AST_CoreRun) , _asthdlrPretty = \opts _ ast -> Just $ ppMod' opts ast , _asthdlrPutSerializeFileIO= default_asthdlrPutSerializeFileIO , _asthdlrGetSerializeFileIO= default_asthdlrGetSerializeFileIO -- the rest, avoid record update (http://hackage.haskell.org/trac/ghc/ticket/2595, http://breaks.for.alienz.org/blog/2011/10/21/record-update-for-insufficiently-polymorphic-field/) -- , _asthdlrParseParse = _asthdlrParseParse -- , _asthdlrParseScan = _asthdlrParseScan -- , _asthdlrParser = _asthdlrParser {- , _asthdlrMkOutputFPath = _asthdlrMkOutputFPath , _asthdlrSuffixMp = _asthdlrSuffixMp , _asthdlrInput = _asthdlrInput -} } {-# LINE 524 "src/ehc/EHC/ASTHandler/Instances.chs" #-} -- | Global mapping from ASTType to ast handler allASThandlerMp :: ASTHandlerMp allASThandlerMp = Map.fromList [ ( ASTType_HS , ASTHandler astHandler'_HS ) , ( ASTType_EH , ASTHandler astHandler'_EH ) , ( ASTType_HI , ASTHandler astHandler'_HI ) , ( ASTType_Core , ASTHandler astHandler'_Core ) , ( ASTType_CoreRun , ASTHandler astHandler'_CoreRun ) ] {-# LINE 551 "src/ehc/EHC/ASTHandler/Instances.chs" #-} -- | Lookup ast handler, forcing a particular ast type asthandlerLookup :: Typeable ast => ASTType -> Maybe (ASTHandler' ast) asthandlerLookup t = case Map.lookup t allASThandlerMp of Just (ASTHandler h) -> cast h _ -> Nothing {-# LINE 559 "src/ehc/EHC/ASTHandler/Instances.chs" #-} -- | Lookup ast handler, allowing arbitrary type by hiding the type asthandlerLookup' :: ASTType -> (forall ast . Typeable ast => ASTHandler' ast -> Maybe x) -> Maybe x asthandlerLookup' t f = case Map.lookup t allASThandlerMp of Just (ASTHandler h) -> f h _ -> Nothing {-# LINE 567 "src/ehc/EHC/ASTHandler/Instances.chs" #-} -- | Lookup ast handler, allowing arbitrary type by hiding the type, monadically asthandlerLookupM' :: Monad m => ASTType -> (forall ast . Typeable ast => ASTHandler' ast -> m (Maybe x)) -> m (Maybe x) asthandlerLookupM' t f = case Map.lookup t allASThandlerMp of Just (ASTHandler h) -> f h _ -> return Nothing {-# LINE 579 "src/ehc/EHC/ASTHandler/Instances.chs" #-} default_asthdlrGetSerializeFileIO :: Serialize ast => EHCOpts -> FPath -> IO (Maybe ast) default_asthdlrGetSerializeFileIO _ fp = fmap Just $ getSerializeFile (fpathToStr fp) default_asthdlrPutSerializeFileIO :: Serialize ast => FilePath -> ast -> IO Bool default_asthdlrPutSerializeFileIO fn ast = putSerializeFile fn ast >> return True