{-# LANGUAGE PackageImports #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-missing-fields #-}
module GHC.Util (
baseDynFlags
, parsePragmasIntoDynFlags
, parseFileGhcLib
, ParseResult (..)
, pprErrMsgBagWithLoc
, getMessages
, SDoc
, Located
, readExtension
, isAtom, addParen, paren, isApp, isOpApp, isAnyApp, isDot, isSection, isDotApp
) where
import "ghc-lib-parser" HsSyn
import "ghc-lib-parser" BasicTypes
import "ghc-lib-parser" RdrName
import "ghc-lib-parser" DynFlags
import "ghc-lib-parser" Platform
import "ghc-lib-parser" Fingerprint
import "ghc-lib-parser" Config
import "ghc-lib-parser" Lexer
import "ghc-lib-parser" Parser
import "ghc-lib-parser" SrcLoc
import "ghc-lib-parser" FastString
import "ghc-lib-parser" StringBuffer
import "ghc-lib-parser" ErrUtils
import "ghc-lib-parser" Outputable
import "ghc-lib-parser" GHC.LanguageExtensions.Type
import "ghc-lib-parser" Panic
import "ghc-lib-parser" HscTypes
import "ghc-lib-parser" HeaderInfo
import Data.List
import System.FilePath
import Language.Preprocessor.Unlit
import qualified Data.Map.Strict as Map
fakeSettings :: Settings
fakeSettings = Settings
{ sTargetPlatform=platform
, sPlatformConstants=platformConstants
, sProjectVersion=cProjectVersion
, sProgramName="ghc"
, sOpt_P_fingerprint=fingerprint0
}
where
platform =
Platform{platformWordSize=8
, platformOS=OSUnknown
, platformUnregisterised=True}
platformConstants =
PlatformConstants{pc_DYNAMIC_BY_DEFAULT=False,pc_WORD_SIZE=8}
fakeLlvmConfig :: (LlvmTargets, LlvmPasses)
fakeLlvmConfig = ([], [])
badExtensions :: [Extension]
badExtensions =
[
AlternativeLayoutRule
, AlternativeLayoutRuleTransitional
, Arrows
, TransformListComp
, UnboxedTuples
, UnboxedSums
, QuasiQuotes
, RecursiveDo
]
enabledExtensions :: [Extension]
enabledExtensions = filter (`notElem` badExtensions) enumerateExtensions
baseDynFlags :: DynFlags
baseDynFlags = foldl' xopt_set
(defaultDynFlags fakeSettings fakeLlvmConfig) enabledExtensions
parsePragmasIntoDynFlags :: DynFlags
-> ([Extension], [Extension])
-> FilePath
-> String
-> IO (Either String DynFlags)
parsePragmasIntoDynFlags flags (enable, disable) filepath str =
catchErrors $ do
let opts = getOptions flags (stringToStringBuffer str) filepath
(flags, _, _) <- parseDynamicFilePragma flags opts
let flags' = foldl' xopt_set flags enable
let flags'' = foldl' xopt_unset flags' disable
return $ Right flags''
where
catchErrors :: IO (Either String DynFlags) -> IO (Either String DynFlags)
catchErrors act = handleGhcException reportErr
(handleSourceError reportErr act)
reportErr e = return $ Left (show e)
parseFileGhcLib ::
FilePath -> String -> DynFlags -> ParseResult (Located (HsModule GhcPs))
parseFileGhcLib filename str flags =
Lexer.unP Parser.parseModule parseState
where
location = mkRealSrcLoc (mkFastString filename) 1 1
buffer = stringToStringBuffer $
if takeExtension filename /= ".lhs" then str else unlit filename str
parseState = mkPState flags buffer location
isAtom :: (p ~ GhcPass pass) => HsExpr p -> Bool
isAtom x = case x of
HsVar {} -> True
HsUnboundVar {} -> True
HsRecFld {} -> True
HsOverLabel {} -> True
HsIPVar {} -> True
HsPar {} -> True
SectionL {} -> True
SectionR {} -> True
ExplicitTuple {} -> True
ExplicitSum {} -> True
ExplicitList {} -> True
RecordCon {} -> True
RecordUpd {} -> True
ArithSeq {} -> True
HsBracket {} -> True
HsRnBracketOut {} -> True
HsTcBracketOut {} -> True
HsSpliceE {} -> True
HsLit _ x | not $ isNegativeLit x -> True
HsOverLit _ x | not $ isNegativeOverLit x -> True
_ -> False
where
isNegativeLit (HsInt _ i) = il_neg i
isNegativeLit (HsRat _ f _) = fl_neg f
isNegativeLit (HsFloatPrim _ f) = fl_neg f
isNegativeLit (HsDoublePrim _ f) = fl_neg f
isNegativeLit (HsIntPrim _ x) = x < 0
isNegativeLit (HsInt64Prim _ x) = x < 0
isNegativeLit (HsInteger _ x _) = x < 0
isNegativeLit _ = False
isNegativeOverLit OverLit {ol_val=HsIntegral i} = il_neg i
isNegativeOverLit OverLit {ol_val=HsFractional f} = fl_neg f
isNegativeOverLit _ = False
addParen :: (p ~ GhcPass pass) => HsExpr p -> HsExpr p
addParen e = HsPar noExt (noLoc e)
paren :: (p ~ GhcPass pass) => HsExpr GhcPs -> HsExpr GhcPs
paren x
| isAtom x = x
| otherwise = addParen x
isApp :: (p ~ GhcPass pass) => HsExpr p -> Bool
isApp x = case x of
HsApp {} -> True
_ -> False
isOpApp :: (p ~ GhcPass pass) => HsExpr p -> Bool
isOpApp x = case x of
OpApp {} -> True
_ -> False
isAnyApp :: (p ~ GhcPass pass) => HsExpr p -> Bool
isAnyApp x = isApp x || isOpApp x
isDot :: HsExpr GhcPs -> Bool
isDot x
| HsVar _ (L _ ident) <- x
, ident == mkVarUnqual (fsLit ".") = True
| otherwise = False
isSection :: (p ~ GhcPass pass) => HsExpr p -> Bool
isSection x = case x of
SectionL {} -> True
SectionR {} -> True
_ -> False
isDotApp :: HsExpr GhcPs -> Bool
isDotApp (OpApp _ _ (L _ op) _) = isDot op
isDotApp _ = False
enumerateExtensions :: [Extension]
enumerateExtensions = [Cpp .. StarIsType]
readExtension :: String -> Maybe Extension
readExtension x = Map.lookup x exts
where exts = Map.fromList [(show x, x) | x <- [Cpp .. StarIsType]]