{-# LANGUAGE NoImplicitPrelude #-} module Language.Haskell.Brittany.Internal.ParseExact ( parseModule , parseModuleFromString ) where import Language.Haskell.Brittany.Internal.Prelude import qualified Control.Monad import qualified Control.Monad.Trans.Except as Except import qualified GHC hiding ( parseModule ) import qualified GHC.ByteOrder import qualified GHC.Data.Bag import qualified GHC.Data.StringBuffer import qualified GHC.Driver.Session import qualified GHC.Parser.Header import qualified GHC.Platform import qualified GHC.Settings import qualified GHC.Types.SrcLoc import qualified GHC.Utils.Error import qualified GHC.Utils.Fingerprint import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint import qualified System.IO -- TODO why are redirecting to parseModuleFromString here? parseModule :: [String] -> System.IO.FilePath -> (GHC.DynFlags -> IO (Either String a)) -> IO (Either String (GHC.ParsedSource, a)) parseModule args fp dynCheck = do str <- System.IO.readFile fp parseModuleFromString args fp dynCheck str -- | Parses a Haskell module. Although this nominally requires IO, it is -- morally pure. It should have no observable effects. parseModuleFromString :: [String] -> System.IO.FilePath -> (GHC.DynFlags -> IO (Either String a)) -> String -> IO (Either String (GHC.ParsedSource, a)) parseModuleFromString arguments1 filePath checkDynFlags string = Except.runExceptT $ do let dynFlags1 = GHC.Driver.Session.gopt_set -- It feels like this should be either @Sf_Ignore@ or @Sf_None@, but both -- of those modes have trouble parsing safe imports (@import safe ...@). -- Neither passing in @"-XUnsafe"@ as a command line argument nor having -- @{-# LANGUAGE Unsafe #-}@ in the source file seem to help. initialDynFlags { GHC.Driver.Session.safeHaskell = GHC.Sf_Unsafe } GHC.Driver.Session.Opt_KeepRawTokenStream (dynFlags2, leftovers1, _) <- GHC.Driver.Session.parseDynamicFlagsCmdLine dynFlags1 $ fmap GHC.Types.SrcLoc.noLoc arguments1 handleLeftovers leftovers1 let stringBuffer = GHC.Data.StringBuffer.stringToStringBuffer string arguments2 = GHC.Parser.Header.getOptions dynFlags2 stringBuffer filePath (dynFlags3, leftovers2, _) <- GHC.Driver.Session.parseDynamicFilePragma dynFlags2 arguments2 handleLeftovers leftovers2 dynFlagsResult <- Except.ExceptT $ checkDynFlags dynFlags3 let parseResult = ExactPrint.parseModuleFromStringInternal dynFlags3 filePath string case parseResult of Left errorMessages -> handleErrorMessages errorMessages -- Right parsedMod -> case ExactPrint.makeDeltaAst' parsedMod of -- res -> pure (res, dynFlagsResult) -- Right (L l (GHC.HsModule ann lay name xprt imp decls depr hdr)) -> -- case ExactPrint.runTransform (ExactPrint.balanceCommentsList decls) of -- (decls', _, _) -> -- pure -- ( L l (GHC.HsModule ann lay name xprt imp decls' depr hdr) -- , dynFlagsResult -- ) Right res -> pure (res, dynFlagsResult) handleLeftovers :: Monad m => [GHC.Types.SrcLoc.Located String] -> Except.ExceptT String m () handleLeftovers leftovers = Control.Monad.unless (null leftovers) . Except.throwE $ "leftovers: " <> show (fmap GHC.Types.SrcLoc.unLoc leftovers) handleErrorMessages :: Monad m => GHC.Utils.Error.ErrorMessages -> Except.ExceptT String m a handleErrorMessages = Except.throwE . mappend "errorMessages: " . show . GHC.Data.Bag.bagToList initialDynFlags :: GHC.Driver.Session.DynFlags initialDynFlags = GHC.Driver.Session.defaultDynFlags initialSettings initialLlvmConfig initialSettings :: GHC.Driver.Session.Settings initialSettings = GHC.Driver.Session.Settings { GHC.Driver.Session.sGhcNameVersion = initialGhcNameVersion , GHC.Driver.Session.sFileSettings = initialFileSettings , GHC.Driver.Session.sTargetPlatform = initialTargetPlatform , GHC.Driver.Session.sToolSettings = initialToolSettings , GHC.Driver.Session.sPlatformMisc = initialPlatformMisc , GHC.Driver.Session.sRawSettings = [] } initialFileSettings :: GHC.Driver.Session.FileSettings initialFileSettings = GHC.Driver.Session.FileSettings { GHC.Driver.Session.fileSettings_ghciUsagePath = "" , GHC.Driver.Session.fileSettings_ghcUsagePath = "" , GHC.Driver.Session.fileSettings_globalPackageDatabase = "" , GHC.Driver.Session.fileSettings_tmpDir = "" , GHC.Driver.Session.fileSettings_toolDir = Nothing , GHC.Driver.Session.fileSettings_topDir = "" } initialGhcNameVersion :: GHC.Driver.Session.GhcNameVersion initialGhcNameVersion = GHC.Driver.Session.GhcNameVersion { GHC.Driver.Session.ghcNameVersion_programName = "" , GHC.Driver.Session.ghcNameVersion_projectVersion = "" } initialPlatformMisc :: GHC.Driver.Session.PlatformMisc initialPlatformMisc = GHC.Driver.Session.PlatformMisc { GHC.Driver.Session.platformMisc_ghcRTSWays = "" , GHC.Driver.Session.platformMisc_ghcRtsWithLibdw = False , GHC.Driver.Session.platformMisc_ghcWithInterpreter = False , GHC.Driver.Session.platformMisc_ghcWithSMP = False , GHC.Driver.Session.platformMisc_libFFI = False , GHC.Driver.Session.platformMisc_llvmTarget = "" , GHC.Driver.Session.platformMisc_targetPlatformString = "" } initialLlvmConfig :: GHC.Driver.Session.LlvmConfig initialLlvmConfig = GHC.Driver.Session.LlvmConfig { GHC.Driver.Session.llvmPasses = [] , GHC.Driver.Session.llvmTargets = [] } _initialPlatformConstants :: GHC.Platform.PlatformConstants _initialPlatformConstants = GHC.Platform.PlatformConstants { GHC.Platform.pc_AP_STACK_SPLIM = 0 , GHC.Platform.pc_BITMAP_BITS_SHIFT = 0 , GHC.Platform.pc_BLOCK_SIZE = 0 , GHC.Platform.pc_BLOCKS_PER_MBLOCK = 0 , GHC.Platform.pc_CINT_SIZE = 0 , GHC.Platform.pc_CLONG_LONG_SIZE = 0 , GHC.Platform.pc_CLONG_SIZE = 0 , GHC.Platform.pc_CONTROL_GROUP_CONST_291 = 0 , GHC.Platform.pc_ILDV_CREATE_MASK = 0 , GHC.Platform.pc_ILDV_STATE_CREATE = 0 , GHC.Platform.pc_ILDV_STATE_USE = 0 , GHC.Platform.pc_LDV_SHIFT = 0 , GHC.Platform.pc_MAX_CHARLIKE = 0 , GHC.Platform.pc_MAX_Double_REG = 0 , GHC.Platform.pc_MAX_Float_REG = 0 , GHC.Platform.pc_MAX_INTLIKE = 0 , GHC.Platform.pc_MAX_Long_REG = 0 , GHC.Platform.pc_MAX_Real_Double_REG = 0 , GHC.Platform.pc_MAX_Real_Float_REG = 0 , GHC.Platform.pc_MAX_Real_Long_REG = 0 , GHC.Platform.pc_MAX_Real_Vanilla_REG = 0 , GHC.Platform.pc_MAX_Real_XMM_REG = 0 , GHC.Platform.pc_MAX_SPEC_AP_SIZE = 0 , GHC.Platform.pc_MAX_SPEC_SELECTEE_SIZE = 0 , GHC.Platform.pc_MAX_Vanilla_REG = 0 , GHC.Platform.pc_MAX_XMM_REG = 0 , GHC.Platform.pc_MIN_CHARLIKE = 0 , GHC.Platform.pc_MIN_INTLIKE = 0 , GHC.Platform.pc_MIN_PAYLOAD_SIZE = 0 , GHC.Platform.pc_MUT_ARR_PTRS_CARD_BITS = 0 , GHC.Platform.pc_OFFSET_bdescr_blocks = 0 , GHC.Platform.pc_OFFSET_bdescr_flags = 0 , GHC.Platform.pc_OFFSET_bdescr_free = 0 , GHC.Platform.pc_OFFSET_bdescr_start = 0 , GHC.Platform.pc_OFFSET_Capability_r = 0 , GHC.Platform.pc_OFFSET_CostCentreStack_mem_alloc = 0 , GHC.Platform.pc_OFFSET_CostCentreStack_scc_count = 0 , GHC.Platform.pc_OFFSET_StgArrBytes_bytes = 0 , GHC.Platform.pc_OFFSET_stgEagerBlackholeInfo = 0 , GHC.Platform.pc_OFFSET_StgEntCounter_allocd = 0 , GHC.Platform.pc_OFFSET_StgEntCounter_allocs = 0 , GHC.Platform.pc_OFFSET_StgEntCounter_entry_count = 0 , GHC.Platform.pc_OFFSET_StgEntCounter_link = 0 , GHC.Platform.pc_OFFSET_StgEntCounter_registeredp = 0 , GHC.Platform.pc_OFFSET_StgFunInfoExtraFwd_arity = 0 , GHC.Platform.pc_OFFSET_StgFunInfoExtraRev_arity = 0 , GHC.Platform.pc_OFFSET_stgGCEnter1 = 0 , GHC.Platform.pc_OFFSET_stgGCFun = 0 , GHC.Platform.pc_OFFSET_StgHeader_ccs = 0 , GHC.Platform.pc_OFFSET_StgHeader_ldvw = 0 , GHC.Platform.pc_OFFSET_StgMutArrPtrs_ptrs = 0 , GHC.Platform.pc_OFFSET_StgMutArrPtrs_size = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rCCCS = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rCurrentNursery = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rCurrentTSO = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rD1 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rD2 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rD3 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rD4 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rD5 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rD6 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rF1 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rF2 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rF3 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rF4 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rF5 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rF6 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rHp = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rHpAlloc = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rHpLim = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rL1 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rR1 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rR10 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rR2 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rR3 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rR4 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rR5 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rR6 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rR7 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rR8 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rR9 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rSp = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rSpLim = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rXMM1 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rXMM2 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rXMM3 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rXMM4 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rXMM5 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rXMM6 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rYMM1 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rYMM2 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rYMM3 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rYMM4 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rYMM5 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rYMM6 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rZMM1 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rZMM2 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rZMM3 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rZMM4 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rZMM5 = 0 , GHC.Platform.pc_OFFSET_StgRegTable_rZMM6 = 0 , GHC.Platform.pc_OFFSET_StgSmallMutArrPtrs_ptrs = 0 , GHC.Platform.pc_OFFSET_StgStack_sp = 0 , GHC.Platform.pc_OFFSET_StgStack_stack = 0 , GHC.Platform.pc_OFFSET_StgTSO_alloc_limit = 0 , GHC.Platform.pc_OFFSET_StgTSO_cccs = 0 , GHC.Platform.pc_OFFSET_StgTSO_stackobj = 0 , GHC.Platform.pc_OFFSET_StgUpdateFrame_updatee = 0 , GHC.Platform.pc_PROF_HDR_SIZE = 0 , GHC.Platform.pc_REP_CostCentreStack_mem_alloc = 0 , GHC.Platform.pc_REP_CostCentreStack_scc_count = 0 , GHC.Platform.pc_REP_StgEntCounter_allocd = 0 , GHC.Platform.pc_REP_StgEntCounter_allocs = 0 , GHC.Platform.pc_REP_StgFunInfoExtraFwd_arity = 0 , GHC.Platform.pc_REP_StgFunInfoExtraRev_arity = 0 , GHC.Platform.pc_RESERVED_C_STACK_BYTES = 0 , GHC.Platform.pc_RESERVED_STACK_WORDS = 0 , GHC.Platform.pc_SIZEOF_CostCentreStack = 0 , GHC.Platform.pc_SIZEOF_StgArrBytes_NoHdr = 0 , GHC.Platform.pc_SIZEOF_StgFunInfoExtraRev = 0 , GHC.Platform.pc_SIZEOF_StgMutArrPtrs_NoHdr = 0 , GHC.Platform.pc_SIZEOF_StgSmallMutArrPtrs_NoHdr = 0 , GHC.Platform.pc_SIZEOF_StgSMPThunkHeader = 0 , GHC.Platform.pc_SIZEOF_StgUpdateFrame_NoHdr = 0 , GHC.Platform.pc_STD_HDR_SIZE = 0 , GHC.Platform.pc_TAG_BITS = 0 , GHC.Platform.pc_TICKY_BIN_COUNT = 0 , GHC.Platform.pc_WORD_SIZE = 0 } -- initialPlatformMini :: GHC.Settings.PlatformMini -- initialPlatformMini = GHC.Settings.PlatformMini -- { GHC.Settings.platformMini_arch = GHC.Platform.ArchX86_64 -- , GHC.Settings.platformMini_os = GHC.Platform.OSLinux -- } initialTargetPlatform :: GHC.Settings.Platform initialTargetPlatform = GHC.Settings.Platform { GHC.Settings.platformArchOS = initialArchOS , GHC.Settings.platformByteOrder = GHC.ByteOrder.LittleEndian , GHC.Settings.platformHasGnuNonexecStack = False , GHC.Settings.platformHasIdentDirective = False , GHC.Settings.platformHasSubsectionsViaSymbols = False , GHC.Settings.platformIsCrossCompiling = False , GHC.Settings.platformLeadingUnderscore = False -- , GHC.Settings.platformMini = initialPlatformMini , GHC.Settings.platformTablesNextToCode = False , GHC.Settings.platformUnregisterised = False , GHC.Settings.platformWordSize = GHC.Platform.PW8 , GHC.Settings.platform_constants = Nothing } initialArchOS :: GHC.Platform.ArchOS initialArchOS = GHC.Platform.ArchOS { GHC.Platform.archOS_arch = GHC.Platform.ArchUnknown -- why do we need to specify these? , GHC.Platform.archOS_OS = GHC.Platform.OSUnknown -- why do we need to specify these? } initialToolSettings :: GHC.Settings.ToolSettings initialToolSettings = GHC.Settings.ToolSettings { GHC.Settings.toolSettings_ccSupportsNoPie = False , GHC.Settings.toolSettings_extraGccViaCFlags = [] , GHC.Settings.toolSettings_ldIsGnuLd = False , GHC.Settings.toolSettings_ldSupportsBuildId = False , GHC.Settings.toolSettings_ldSupportsCompactUnwind = False , GHC.Settings.toolSettings_ldSupportsFilelist = False , GHC.Settings.toolSettings_opt_a = [] , GHC.Settings.toolSettings_opt_c = [] , GHC.Settings.toolSettings_opt_cxx = [] , GHC.Settings.toolSettings_opt_F = [] , GHC.Settings.toolSettings_opt_i = [] , GHC.Settings.toolSettings_opt_l = [] , GHC.Settings.toolSettings_opt_L = [] , GHC.Settings.toolSettings_opt_lc = [] , GHC.Settings.toolSettings_opt_lcc = [] , GHC.Settings.toolSettings_opt_lm = [] , GHC.Settings.toolSettings_opt_lo = [] , GHC.Settings.toolSettings_opt_P = [] , GHC.Settings.toolSettings_opt_P_fingerprint = GHC.Utils.Fingerprint.fingerprint0 , GHC.Settings.toolSettings_opt_windres = [] , GHC.Settings.toolSettings_pgm_a = ("", []) , GHC.Settings.toolSettings_pgm_ar = "" , GHC.Settings.toolSettings_pgm_c = "" , GHC.Settings.toolSettings_pgm_dll = ("", []) , GHC.Settings.toolSettings_pgm_F = "" , GHC.Settings.toolSettings_pgm_i = "" , GHC.Settings.toolSettings_pgm_install_name_tool = "" , GHC.Settings.toolSettings_pgm_l = ("", []) , GHC.Settings.toolSettings_pgm_L = "" , GHC.Settings.toolSettings_pgm_lc = ("", []) , GHC.Settings.toolSettings_pgm_lcc = ("", []) , GHC.Settings.toolSettings_pgm_libtool = "" , GHC.Settings.toolSettings_pgm_lm = ("", []) , GHC.Settings.toolSettings_pgm_lo = ("", []) , GHC.Settings.toolSettings_pgm_otool = "" , GHC.Settings.toolSettings_pgm_P = ("", []) , GHC.Settings.toolSettings_pgm_ranlib = "" , GHC.Settings.toolSettings_pgm_T = "" , GHC.Settings.toolSettings_pgm_windres = "" }