-----------------------------------------------------------------------------
-- 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
  , getPDConfig
  , getProfile
  , getPlatform
  , getHomeUnitId
  , PDConfig(..)
  ) where

import GHC.Prelude

import GHC.Cmm.Parser.Config

import GHC.Platform
import GHC.Platform.Profile

import Control.Monad

import GHC.Parser.Lexer
import GHC.Parser.Errors.Types
import GHC.Types.Error ( MsgEnvelope )
import GHC.Types.SrcLoc
import GHC.Unit.Types
import GHC.Unit.Home

newtype PD a = PD { forall a. PD a -> PDConfig -> HomeUnit -> PState -> ParseResult a
unPD :: PDConfig -> HomeUnit -> PState -> ParseResult a }

instance Functor PD where
  fmap :: forall a b. (a -> b) -> PD a -> PD b
fmap = (a -> b) -> PD a -> PD b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Applicative PD where
  pure :: forall a. a -> PD a
pure = a -> PD a
forall a. a -> PD a
returnPD
  <*> :: forall a b. PD (a -> b) -> PD a -> PD b
(<*>) = PD (a -> b) -> PD a -> PD b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad PD where
  >>= :: forall a b. PD a -> (a -> PD b) -> PD b
(>>=) = PD a -> (a -> PD b) -> PD b
forall a b. PD a -> (a -> PD b) -> PD b
thenPD

liftP :: P a -> PD a
liftP :: forall a. P a -> PD a
liftP (P PState -> ParseResult a
f) = (PDConfig -> HomeUnit -> PState -> ParseResult a) -> PD a
forall a. (PDConfig -> HomeUnit -> PState -> ParseResult a) -> PD a
PD ((PDConfig -> HomeUnit -> PState -> ParseResult a) -> PD a)
-> (PDConfig -> HomeUnit -> PState -> ParseResult a) -> PD a
forall a b. (a -> b) -> a -> b
$ \PDConfig
_ HomeUnit
_ PState
s -> PState -> ParseResult a
f PState
s

failMsgPD :: (SrcSpan -> MsgEnvelope PsMessage) -> PD a
failMsgPD :: forall a. (SrcSpan -> MsgEnvelope PsMessage) -> PD a
failMsgPD = P a -> PD a
forall a. P a -> PD a
liftP (P a -> PD a)
-> ((SrcSpan -> MsgEnvelope PsMessage) -> P a)
-> (SrcSpan -> MsgEnvelope PsMessage)
-> PD a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SrcSpan -> MsgEnvelope PsMessage) -> P a
forall a. (SrcSpan -> MsgEnvelope PsMessage) -> P a
failMsgP

returnPD :: a -> PD a
returnPD :: forall a. a -> PD a
returnPD = P a -> PD a
forall a. P a -> PD a
liftP (P a -> PD a) -> (a -> P a) -> a -> PD a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> P a
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return

thenPD :: PD a -> (a -> PD b) -> PD b
(PD PDConfig -> HomeUnit -> PState -> ParseResult a
m) thenPD :: forall a b. PD a -> (a -> PD b) -> PD b
`thenPD` a -> PD b
k = (PDConfig -> HomeUnit -> PState -> ParseResult b) -> PD b
forall a. (PDConfig -> HomeUnit -> PState -> ParseResult a) -> PD a
PD ((PDConfig -> HomeUnit -> PState -> ParseResult b) -> PD b)
-> (PDConfig -> HomeUnit -> PState -> ParseResult b) -> PD b
forall a b. (a -> b) -> a -> b
$ \PDConfig
d HomeUnit
hu PState
s ->
        case PDConfig -> HomeUnit -> PState -> ParseResult a
m PDConfig
d HomeUnit
hu PState
s of
                POk PState
s1 a
a   -> PD b -> PDConfig -> HomeUnit -> PState -> ParseResult b
forall a. PD a -> PDConfig -> HomeUnit -> PState -> ParseResult a
unPD (a -> PD b
k a
a) PDConfig
d HomeUnit
hu PState
s1
                PFailed PState
s1 -> PState -> ParseResult b
forall a. PState -> ParseResult a
PFailed PState
s1

getPDConfig :: PD PDConfig
getPDConfig :: PD PDConfig
getPDConfig = (PDConfig -> HomeUnit -> PState -> ParseResult PDConfig)
-> PD PDConfig
forall a. (PDConfig -> HomeUnit -> PState -> ParseResult a) -> PD a
PD ((PDConfig -> HomeUnit -> PState -> ParseResult PDConfig)
 -> PD PDConfig)
-> (PDConfig -> HomeUnit -> PState -> ParseResult PDConfig)
-> PD PDConfig
forall a b. (a -> b) -> a -> b
$ \PDConfig
pdc HomeUnit
_ PState
s -> PState -> PDConfig -> ParseResult PDConfig
forall a. PState -> a -> ParseResult a
POk PState
s PDConfig
pdc

getProfile :: PD Profile
getProfile :: PD Profile
getProfile = (PDConfig -> HomeUnit -> PState -> ParseResult Profile)
-> PD Profile
forall a. (PDConfig -> HomeUnit -> PState -> ParseResult a) -> PD a
PD ((PDConfig -> HomeUnit -> PState -> ParseResult Profile)
 -> PD Profile)
-> (PDConfig -> HomeUnit -> PState -> ParseResult Profile)
-> PD Profile
forall a b. (a -> b) -> a -> b
$ \PDConfig
pdc HomeUnit
_ PState
s -> PState -> Profile -> ParseResult Profile
forall a. PState -> a -> ParseResult a
POk PState
s (PDConfig -> Profile
pdProfile PDConfig
pdc)

getPlatform :: PD Platform
getPlatform :: PD Platform
getPlatform = Profile -> Platform
profilePlatform (Profile -> Platform) -> PD Profile -> PD Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PD Profile
getProfile

-- | Return the UnitId of the home-unit. This is used to create labels.
getHomeUnitId :: PD UnitId
getHomeUnitId :: PD UnitId
getHomeUnitId = (PDConfig -> HomeUnit -> PState -> ParseResult UnitId) -> PD UnitId
forall a. (PDConfig -> HomeUnit -> PState -> ParseResult a) -> PD a
PD ((PDConfig -> HomeUnit -> PState -> ParseResult UnitId)
 -> PD UnitId)
-> (PDConfig -> HomeUnit -> PState -> ParseResult UnitId)
-> PD UnitId
forall a b. (a -> b) -> a -> b
$ \PDConfig
_ HomeUnit
hu PState
s -> PState -> UnitId -> ParseResult UnitId
forall a. PState -> a -> ParseResult a
POk PState
s (HomeUnit -> UnitId
forall u. GenHomeUnit u -> UnitId
homeUnitId HomeUnit
hu)