diff options
Diffstat (limited to 'compiler/GHC/Cmm/Parser/Monad.hs')
-rw-r--r-- | compiler/GHC/Cmm/Parser/Monad.hs | 84 |
1 files changed, 84 insertions, 0 deletions
diff --git a/compiler/GHC/Cmm/Parser/Monad.hs b/compiler/GHC/Cmm/Parser/Monad.hs new file mode 100644 index 0000000000..cbe89248c8 --- /dev/null +++ b/compiler/GHC/Cmm/Parser/Monad.hs @@ -0,0 +1,84 @@ +----------------------------------------------------------------------------- +-- A Parser monad with access to the 'DynFlags'. +-- +-- The 'P' monad only has access to the subset of 'DynFlags' +-- required for parsing Haskell. + +-- The parser for C-- requires access to a lot more of the 'DynFlags', +-- so 'PD' provides access to 'DynFlags' via a 'HasDynFlags' instance. +----------------------------------------------------------------------------- +module GHC.Cmm.Parser.Monad ( + PD(..) + , liftP + , failMsgPD + , getProfile + , getPlatform + , getPtrOpts + , getHomeUnitId + ) where + +import GHC.Prelude + +import GHC.Platform +import GHC.Platform.Profile +import GHC.Cmm.Info + +import Control.Monad + +import GHC.Driver.Session +import GHC.Parser.Lexer +import GHC.Parser.Errors +import GHC.Types.SrcLoc +import GHC.Unit.Types +import GHC.Unit.Home + +newtype PD a = PD { unPD :: DynFlags -> PState -> ParseResult a } + +instance Functor PD where + fmap = liftM + +instance Applicative PD where + pure = returnPD + (<*>) = ap + +instance Monad PD where + (>>=) = thenPD + +liftP :: P a -> PD a +liftP (P f) = PD $ \_ s -> f s + +failMsgPD :: (SrcSpan -> Error) -> PD a +failMsgPD = liftP . failMsgP + +returnPD :: a -> PD a +returnPD = liftP . return + +thenPD :: PD a -> (a -> PD b) -> PD b +(PD m) `thenPD` k = PD $ \d s -> + case m d s of + POk s1 a -> unPD (k a) d s1 + PFailed s1 -> PFailed s1 + +instance HasDynFlags PD where + getDynFlags = PD $ \d s -> POk s d + +getProfile :: PD Profile +getProfile = targetProfile <$> getDynFlags + +getPlatform :: PD Platform +getPlatform = profilePlatform <$> getProfile + +getPtrOpts :: PD PtrOpts +getPtrOpts = do + dflags <- getDynFlags + profile <- getProfile + pure $ PtrOpts + { po_profile = profile + , po_align_check = gopt Opt_AlignmentSanitisation dflags + } + +-- | Return the UnitId of the home-unit. This is used to create labels. +getHomeUnitId :: PD UnitId +getHomeUnitId = do + dflags <- getDynFlags + pure (homeUnitId (mkHomeUnitFromFlags dflags)) |