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))