{-# LANGUAGE CPP #-}

-----------------------------------------------------------------------------
-- A Parser monad with access to the 'DynFlags'.
--
-- The 'P' monad  only has access to the subset of 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 CmmMonad (
    PD(..)
  , liftP
  ) where

import GhcPrelude

import Control.Monad
import qualified Control.Monad.Fail as MonadFail

import DynFlags
import Lexer

newtype PD a = PD { PD a -> DynFlags -> PState -> ParseResult a
unPD :: DynFlags -> PState -> ParseResult a }

instance Functor PD where
  fmap :: (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 :: a -> PD a
pure = a -> PD a
forall a. a -> PD a
returnPD
  <*> :: 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
  >>= :: 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
#if !MIN_VERSION_base(4,13,0)
  fail = MonadFail.fail
#endif

instance MonadFail.MonadFail PD where
  fail :: String -> PD a
fail = String -> PD a
forall a. String -> PD a
failPD

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

returnPD :: a -> PD a
returnPD :: 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 (m :: * -> *) a. Monad m => a -> m a
return

thenPD :: PD a -> (a -> PD b) -> PD b
(PD m :: DynFlags -> PState -> ParseResult a
m) thenPD :: PD a -> (a -> PD b) -> PD b
`thenPD` k :: a -> PD b
k = (DynFlags -> PState -> ParseResult b) -> PD b
forall a. (DynFlags -> PState -> ParseResult a) -> PD a
PD ((DynFlags -> PState -> ParseResult b) -> PD b)
-> (DynFlags -> PState -> ParseResult b) -> PD b
forall a b. (a -> b) -> a -> b
$ \d :: DynFlags
d s :: PState
s ->
        case DynFlags -> PState -> ParseResult a
m DynFlags
d PState
s of
                POk s1 :: PState
s1 a :: a
a         -> PD b -> DynFlags -> PState -> ParseResult b
forall a. PD a -> DynFlags -> PState -> ParseResult a
unPD (a -> PD b
k a
a) DynFlags
d PState
s1
                PFailed warnFn :: DynFlags -> Messages
warnFn span :: SrcSpan
span err :: MsgDoc
err -> (DynFlags -> Messages) -> SrcSpan -> MsgDoc -> ParseResult b
forall a.
(DynFlags -> Messages) -> SrcSpan -> MsgDoc -> ParseResult a
PFailed DynFlags -> Messages
warnFn SrcSpan
span MsgDoc
err

failPD :: String -> PD a
failPD :: String -> PD a
failPD = P a -> PD a
forall a. P a -> PD a
liftP (P a -> PD a) -> (String -> P a) -> String -> PD a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> P a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail

instance HasDynFlags PD where
   getDynFlags :: PD DynFlags
getDynFlags = (DynFlags -> PState -> ParseResult DynFlags) -> PD DynFlags
forall a. (DynFlags -> PState -> ParseResult a) -> PD a
PD ((DynFlags -> PState -> ParseResult DynFlags) -> PD DynFlags)
-> (DynFlags -> PState -> ParseResult DynFlags) -> PD DynFlags
forall a b. (a -> b) -> a -> b
$ \d :: DynFlags
d s :: PState
s -> PState -> DynFlags -> ParseResult DynFlags
forall a. PState -> a -> ParseResult a
POk PState
s DynFlags
d