-- |
-- Module      :  Language.C.Parser.Monad
-- Copyright   :  (c) 2006-2011 Harvard University
--                (c) 2011-2013 Geoffrey Mainland
-- License     :  BSD-style
-- Maintainer  :  mainland@drexel.edu

{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}

module Language.C.Parser.Monad (
    P,
    runP,
    evalP,

    PState,
    emptyPState,

    getInput,
    setInput,
    pushLexState,
    popLexState,
    getLexState,
    pushbackToken,
    getPushbackToken,
    getCurToken,
    setCurToken,

    addTypedef,
    addClassdef,
    addVariable,
    isTypedef,
    isClassdef,

    pushScope,
    popScope,

    c99Exts,
    c11Exts,
    gccExts,
    blocksExts,
    cudaExts,
    openCLExts,
    objcExts,

    useExts,
    antiquotationExts,
    useC99Exts,
    useC11Exts,
    useGccExts,
    useBlocksExts,
    useCUDAExts,
    useOpenCLExts,
    useObjCExts,

    LexerException(..),
    ParserException(..),
    quoteTok,
    failAt,
    lexerError,
    unexpectedEOF,
    emptyCharacterLiteral,
    illegalCharacterLiteral,
    illegalNumericalLiteral,
    parserError,
    unclosed,
    expected,
    expectedAt,

    AlexInput(..),
    alexGetChar,
    alexGetByte,
    alexInputPrevChar,
    alexLoc,
    nextChar,
    peekChar,
    maybePeekChar,
    skipChar,

    AlexPredicate,
    allowAnti,
    ifExtension
  ) where

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative (Applicative(..))
#endif /* !MIN_VERSION_base(4,8,0) */
import Control.Monad.Exception
import Control.Monad.State
import Data.Bits
import qualified Data.ByteString.Char8 as B
import Data.ByteString.Internal (c2w)
import Data.List (foldl')
import Data.Loc
#if !(MIN_VERSION_base(4,9,0))
import Data.Monoid (Monoid(..), (<>))
#endif /* !(MIN_VERSION_base(4,9,0)) */
#if MIN_VERSION_base(4,9,0) && !(MIN_VERSION_base(4,11,0))
import Data.Semigroup (Semigroup(..))
#endif
import qualified Data.Set as Set
import Data.Typeable (Typeable)
import Data.Word
import Text.PrettyPrint.Mainland
import Text.PrettyPrint.Mainland.Class

import Language.C.Parser.Tokens
import Language.C.Syntax

data PState = PState
    { PState -> AlexInput
input      :: !AlexInput
    , PState -> Maybe (L Token)
pbToken    :: !(Maybe (L Token))
    , PState -> L Token
curToken   :: L Token
    , PState -> [Int]
lexState   :: ![Int]
    , PState -> ExtensionsInt
extensions :: !ExtensionsInt
    , PState -> Set String
typedefs   :: !(Set.Set String)
    , PState -> Set String
classdefs  :: !(Set.Set String)
    , PState -> [(Set String, Set String)]
scopes     :: [(Set.Set String, Set.Set String)]
    }

emptyPState :: [Extensions]
            -> [String]
            -> B.ByteString
            -> Maybe Pos
            -> PState
emptyPState :: [Extensions] -> [String] -> ByteString -> Maybe Pos -> PState
emptyPState [Extensions]
exts [String]
typnames ByteString
buf Maybe Pos
pos = PState
    { input :: AlexInput
input       = AlexInput
inp
    , pbToken :: Maybe (L Token)
pbToken     = Maybe (L Token)
forall a. Maybe a
Nothing
    , curToken :: L Token
curToken    = String -> L Token
forall a. HasCallStack => String -> a
error String
"no token"
    , lexState :: [Int]
lexState    = [Int
0]
    , extensions :: ExtensionsInt
extensions  = (ExtensionsInt -> Int -> ExtensionsInt)
-> ExtensionsInt -> [Int] -> ExtensionsInt
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ExtensionsInt -> Int -> ExtensionsInt
forall a. Bits a => a -> Int -> a
setBit ExtensionsInt
0 ((Extensions -> Int) -> [Extensions] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Extensions -> Int
forall a. Enum a => a -> Int
fromEnum [Extensions]
exts)
    , typedefs :: Set String
typedefs    = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList [String]
typnames
    , classdefs :: Set String
classdefs   = Set String
forall a. Set a
Set.empty
    , scopes :: [(Set String, Set String)]
scopes      = []
    }
  where
    inp :: AlexInput
    inp :: AlexInput
inp = AlexInput
          { alexPos :: Maybe Pos
alexPos      = Maybe Pos
pos
          , alexPrevChar :: Char
alexPrevChar = Char
'\n'
          , alexInput :: ByteString
alexInput    = ByteString
buf
          , alexOff :: Int
alexOff      = Int
0
          }

newtype P a = P { forall a. P a -> PState -> Either SomeException (a, PState)
runP :: PState -> Either SomeException (a, PState) }

instance Functor P where
    fmap :: forall a b. (a -> b) -> P a -> P b
fmap a -> b
f P a
mx = (PState -> Either SomeException (b, PState)) -> P b
forall a. (PState -> Either SomeException (a, PState)) -> P a
P ((PState -> Either SomeException (b, PState)) -> P b)
-> (PState -> Either SomeException (b, PState)) -> P b
forall a b. (a -> b) -> a -> b
$ \PState
s -> case P a -> PState -> Either SomeException (a, PState)
forall a. P a -> PState -> Either SomeException (a, PState)
runP P a
mx PState
s of
                            Left SomeException
e         -> SomeException -> Either SomeException (b, PState)
forall a b. a -> Either a b
Left SomeException
e
                            Right (a
x, PState
s')  -> (b, PState) -> Either SomeException (b, PState)
forall a b. b -> Either a b
Right (a -> b
f a
x, PState
s')

instance Applicative P where
    pure :: forall a. a -> P a
pure a
x = (PState -> Either SomeException (a, PState)) -> P a
forall a. (PState -> Either SomeException (a, PState)) -> P a
P ((PState -> Either SomeException (a, PState)) -> P a)
-> (PState -> Either SomeException (a, PState)) -> P a
forall a b. (a -> b) -> a -> b
$ \PState
s -> (a, PState) -> Either SomeException (a, PState)
forall a b. b -> Either a b
Right (a
x, PState
s)

    P (a -> b)
mf <*> :: forall a b. P (a -> b) -> P a -> P b
<*> P a
mx = (PState -> Either SomeException (b, PState)) -> P b
forall a. (PState -> Either SomeException (a, PState)) -> P a
P ((PState -> Either SomeException (b, PState)) -> P b)
-> (PState -> Either SomeException (b, PState)) -> P b
forall a b. (a -> b) -> a -> b
$ \PState
s -> case P (a -> b) -> PState -> Either SomeException (a -> b, PState)
forall a. P a -> PState -> Either SomeException (a, PState)
runP P (a -> b)
mf PState
s of
                            Left SomeException
e         -> SomeException -> Either SomeException (b, PState)
forall a b. a -> Either a b
Left SomeException
e
                            Right (a -> b
f, PState
s')  -> P b -> PState -> Either SomeException (b, PState)
forall a. P a -> PState -> Either SomeException (a, PState)
runP ((a -> b) -> P a -> P b
forall a b. (a -> b) -> P a -> P b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f P a
mx) PState
s'

instance Monad P where
    P a
m >>= :: forall a b. P a -> (a -> P b) -> P b
>>= a -> P b
k = (PState -> Either SomeException (b, PState)) -> P b
forall a. (PState -> Either SomeException (a, PState)) -> P a
P ((PState -> Either SomeException (b, PState)) -> P b)
-> (PState -> Either SomeException (b, PState)) -> P b
forall a b. (a -> b) -> a -> b
$ \PState
s -> case P a -> PState -> Either SomeException (a, PState)
forall a. P a -> PState -> Either SomeException (a, PState)
runP P a
m PState
s of
                          Left SomeException
e         -> SomeException -> Either SomeException (b, PState)
forall a b. a -> Either a b
Left SomeException
e
                          Right (a
a, PState
s')  -> P b -> PState -> Either SomeException (b, PState)
forall a. P a -> PState -> Either SomeException (a, PState)
runP (a -> P b
k a
a) PState
s'

    return :: forall a. a -> P a
return = a -> P a
forall a. a -> P a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

#if MIN_VERSION_base(4,13,0)
instance MonadFail P where
#endif
    fail :: forall a. String -> P a
fail String
msg = do
        AlexInput
inp <- P AlexInput
getInput
        ParserException -> P a
forall e a. Exception e => e -> P a
forall (m :: * -> *) e a.
(MonadException m, Exception e) =>
e -> m a
throw (ParserException -> P a) -> ParserException -> P a
forall a b. (a -> b) -> a -> b
$ Loc -> Doc -> ParserException
ParserException (AlexInput -> AlexInput -> Loc
alexLoc AlexInput
inp AlexInput
inp) (String -> Doc
text String
msg)

instance MonadState PState P where
    get :: P PState
get    = (PState -> Either SomeException (PState, PState)) -> P PState
forall a. (PState -> Either SomeException (a, PState)) -> P a
P ((PState -> Either SomeException (PState, PState)) -> P PState)
-> (PState -> Either SomeException (PState, PState)) -> P PState
forall a b. (a -> b) -> a -> b
$ \PState
s -> (PState, PState) -> Either SomeException (PState, PState)
forall a b. b -> Either a b
Right (PState
s, PState
s)
    put :: PState -> P ()
put PState
s  = (PState -> Either SomeException ((), PState)) -> P ()
forall a. (PState -> Either SomeException (a, PState)) -> P a
P ((PState -> Either SomeException ((), PState)) -> P ())
-> (PState -> Either SomeException ((), PState)) -> P ()
forall a b. (a -> b) -> a -> b
$ \PState
_ -> ((), PState) -> Either SomeException ((), PState)
forall a b. b -> Either a b
Right ((), PState
s)

instance MonadException P where
    throw :: forall e a. Exception e => e -> P a
throw e
e = (PState -> Either SomeException (a, PState)) -> P a
forall a. (PState -> Either SomeException (a, PState)) -> P a
P ((PState -> Either SomeException (a, PState)) -> P a)
-> (PState -> Either SomeException (a, PState)) -> P a
forall a b. (a -> b) -> a -> b
$ \PState
_ -> SomeException -> Either SomeException (a, PState)
forall a b. a -> Either a b
Left (e -> SomeException
forall e. Exception e => e -> SomeException
toException e
e)

    P a
m catch :: forall e a. Exception e => P a -> (e -> P a) -> P a
`catch` e -> P a
h = (PState -> Either SomeException (a, PState)) -> P a
forall a. (PState -> Either SomeException (a, PState)) -> P a
P ((PState -> Either SomeException (a, PState)) -> P a)
-> (PState -> Either SomeException (a, PState)) -> P a
forall a b. (a -> b) -> a -> b
$ \PState
s ->
        case P a -> PState -> Either SomeException (a, PState)
forall a. P a -> PState -> Either SomeException (a, PState)
runP P a
m PState
s of
          Left SomeException
e ->
              case SomeException -> Maybe e
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
                Just e
e'  -> P a -> PState -> Either SomeException (a, PState)
forall a. P a -> PState -> Either SomeException (a, PState)
runP (e -> P a
h e
e') PState
s
                Maybe e
Nothing  -> SomeException -> Either SomeException (a, PState)
forall a b. a -> Either a b
Left SomeException
e
          Right (a
a, PState
s')  -> (a, PState) -> Either SomeException (a, PState)
forall a b. b -> Either a b
Right (a
a, PState
s')

evalP :: P a -> PState -> Either SomeException a
evalP :: forall a. P a -> PState -> Either SomeException a
evalP P a
comp PState
st =
    case P a -> PState -> Either SomeException (a, PState)
forall a. P a -> PState -> Either SomeException (a, PState)
runP P a
comp PState
st of
      Left SomeException
e        -> SomeException -> Either SomeException a
forall a b. a -> Either a b
Left SomeException
e
      Right (a
a, PState
_)  -> a -> Either SomeException a
forall a b. b -> Either a b
Right a
a

getInput  :: P AlexInput
getInput :: P AlexInput
getInput = (PState -> AlexInput) -> P AlexInput
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PState -> AlexInput
input

setInput  :: AlexInput -> P ()
setInput :: AlexInput -> P ()
setInput AlexInput
inp = (PState -> PState) -> P ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((PState -> PState) -> P ()) -> (PState -> PState) -> P ()
forall a b. (a -> b) -> a -> b
$ \PState
s ->
    PState
s { input = inp }

pushLexState :: Int -> P ()
pushLexState :: Int -> P ()
pushLexState Int
ls = (PState -> PState) -> P ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((PState -> PState) -> P ()) -> (PState -> PState) -> P ()
forall a b. (a -> b) -> a -> b
$ \PState
s ->
    PState
s { lexState = ls : lexState s }

popLexState :: P Int
popLexState :: P Int
popLexState = do
    Int
ls <- P Int
getLexState
    (PState -> PState) -> P ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((PState -> PState) -> P ()) -> (PState -> PState) -> P ()
forall a b. (a -> b) -> a -> b
$ \PState
s ->
        PState
s { lexState = tail (lexState s) }
    Int -> P Int
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
ls

getLexState :: P Int
getLexState :: P Int
getLexState = (PState -> Int) -> P Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ([Int] -> Int
forall a. HasCallStack => [a] -> a
head ([Int] -> Int) -> (PState -> [Int]) -> PState -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PState -> [Int]
lexState)

pushbackToken :: L Token -> P ()
pushbackToken :: L Token -> P ()
pushbackToken L Token
tok = do
    Maybe (L Token)
maybe_tok <- (PState -> Maybe (L Token)) -> P (Maybe (L Token))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PState -> Maybe (L Token)
pbToken
    case Maybe (L Token)
maybe_tok of
      Maybe (L Token)
Nothing -> (PState -> PState) -> P ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((PState -> PState) -> P ()) -> (PState -> PState) -> P ()
forall a b. (a -> b) -> a -> b
$ \PState
s -> PState
s { pbToken = Just tok }
      Just L Token
_  -> String -> P ()
forall a. String -> P a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"More than one token pushed back."

getPushbackToken :: P (Maybe (L Token))
getPushbackToken :: P (Maybe (L Token))
getPushbackToken = do
    Maybe (L Token)
tok <- (PState -> Maybe (L Token)) -> P (Maybe (L Token))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PState -> Maybe (L Token)
pbToken
    (PState -> PState) -> P ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((PState -> PState) -> P ()) -> (PState -> PState) -> P ()
forall a b. (a -> b) -> a -> b
$ \PState
s -> PState
s { pbToken = Nothing }
    Maybe (L Token) -> P (Maybe (L Token))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (L Token)
tok

getCurToken :: P (