uhc-light-1.1.10.0: src/UHC/Light/Compiler/EHC/ASTHandler/Instances.hs
{-# 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