{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Language.C.Syntax.ParserMonad
-- Copyright   :  (c) [1999..2004] Manuel M T Chakravarty
--                (c) 2005-2007 Duncan Coutts
-- License     :  BSD-style
-- Maintainer  :  benedikt.huber@gmail.com
-- Portability :  portable
--
-- Monad for the C lexer and parser
--
--  This monad has to be usable with Alex and Happy. Some things in it are
--  dictated by that, eg having to be able to remember the last token.
--
--  The monad also provides a unique name supply (via the Name module)
--
--  For parsing C we have to maintain a set of identifiers that we know to be
--  typedef'ed type identifiers. We also must deal correctly with scope so we
--  keep a list of sets of identifiers so we can save the outer scope when we
--  enter an inner scope.
module Language.C.Parser.ParserMonad (
  P,
  execParser,
  failP,
  getNewName,        -- :: P Name
  addTypedef,        -- :: Ident -> P ()
  shadowTypedef,     -- :: Ident -> P ()
  isTypeIdent,       -- :: Ident -> P Bool
  enterScope,        -- :: P ()
  leaveScope,        -- :: P ()
  setPos,            -- :: Position -> P ()
  getPos,            -- :: P Position
  getInput,          -- :: P String
  setInput,          -- :: String -> P ()
  getLastToken,      -- :: P CToken
  getSavedToken,     -- :: P CToken
  setLastToken,      -- :: CToken -> P ()
  handleEofToken,    -- :: P ()
  getCurrentPosition,-- :: P Position
  ParseError(..),
  ) where
import Language.C.Data.Error (internalErr, showErrorInfo,ErrorInfo(..),ErrorLevel(..))
import Language.C.Data.Position  (Position(..))
import Language.C.Data.InputStream
import Language.C.Data.Name    (Name)
import Language.C.Data.Ident    (Ident)
import Language.C.Parser.Tokens (CToken(CTokEof))

import Prelude hiding (Applicative(..), MonadFail(..))
import Control.Applicative (Applicative(..))
import Control.Monad (liftM, ap)
import Control.Monad.Fail (MonadFail (..))
import Data.Set  (Set)
import qualified Data.Set as Set (fromList, insert, member, delete)

newtype ParseError = ParseError ([String],Position)
instance Show ParseError where
    show :: ParseError -> String
show (ParseError ([String]
msgs,Position
pos)) = String -> ErrorInfo -> String
showErrorInfo String
"Syntax Error !" (ErrorLevel -> Position -> [String] -> ErrorInfo
ErrorInfo ErrorLevel
LevelError Position
pos [String]
msgs)


data ParseResult a
  = POk !PState a
  | PFailed [String] Position   -- The error message and position

data PState = PState {
        PState -> Position
curPos     :: !Position,        -- position at current input location
        PState -> InputStream
curInput   :: !InputStream,      -- the current input
        PState -> CToken
prevToken  ::  CToken,          -- the previous token
        PState -> CToken
savedToken ::  CToken,          -- and the token before that
        PState -> [Name]
namesupply :: ![Name],          -- the name unique supply
        PState -> Set Ident
tyidents   :: !(Set Ident),     -- the set of typedef'ed identifiers
        PState -> [Set Ident]
scopes     :: ![Set Ident]      -- the tyident sets for outer scopes
     }

newtype P a = P { forall a. P a -> PState -> ParseResult a
unP :: PState -> ParseResult a }

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

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

instance Monad P where
  >>= :: forall a b. P a -> (a -> P b) -> P b
(>>=) = P a -> (a -> P b) -> P b
forall a b. P a -> (a -> P b) -> P b
thenP
#if !MIN_VERSION_base(4,13,0)
  fail m = getPos >>= \pos -> failP pos [m]
#endif

#if MIN_VERSION_base(4,9,0)
instance MonadFail P where
  fail :: forall a. String -> P a
fail String
m = P Position
getPos P Position -> (Position -> P a) -> P a
forall a b. P a -> (a -> P b) -> P b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Position
pos -> Position -> [String] -> P a
forall a. Position -> [String] -> P a
failP Position
pos [String
m]
#endif

-- | execute the given parser on the supplied input stream.
--   returns 'ParseError' if the parser failed, and a pair of
--   result and remaining name supply otherwise
--
-- Synopsis: @execParser parser inputStream initialPos predefinedTypedefs uniqNameSupply@
execParser :: P a -> InputStream -> Position -> [Ident] -> [Name]
           -> Either ParseError (a,[Name])
execParser :: forall a.
P a
-> InputStream
-> Position
-> [Ident]
-> [Name]
-> Either ParseError (a, [Name])
execParser (P PState -> ParseResult a
parser) InputStream
input Position
pos [Ident]
builtins [Name]
names =
  case PState -> ParseResult a
parser PState
initialState of
    PFailed [String]
message Position
errpos -> ParseError -> Either ParseError (a, [Name])
forall a b. a -> Either a b
Left (([String], Position) -> ParseError
ParseError ([String]
message,Position
errpos))
    POk PState
st a
result -> (a, [Name]) -> Either ParseError (a, [Name])
forall a b. b -> Either a b
Right (a
result, PState -> [Name]
namesupply PState
st)
  where initialState :: PState
initialState = PState {
          curPos :: Position
curPos = Position
pos,
          curInput :: InputStream
curInput = InputStream
input,
          prevToken :: CToken
prevToken = String -> CToken
forall a. String -> a
internalErr String
"CLexer.execParser: Touched undefined token!",
          savedToken :: CToken
savedToken = String -> CToken
forall a. String -> a
internalErr String
"CLexer.execParser: Touched undefined token (safed token)!",
          namesupply :: [Name]
namesupply = [Name]
names,
          tyidents :: Set Ident
tyidents = [Ident] -> Set Ident
forall a. Ord a => [a] -> Set a
Set.fromList [Ident]
builtins,
          scopes :: [Set Ident]
scopes   = []
        }

{-# INLINE returnP #-}
returnP :: a -> P a
returnP :: forall a. a -> P a
returnP a
a = (PState -> ParseResult a) -> P a
forall a. (PState -> ParseResult a) -> P a
P ((PState -> ParseResult a) -> P a)
-> (PState -> ParseResult a) -> P a
forall a b. (a -> b) -> a -> b
$ \PState
s -> PState -> a -> ParseResult a
forall a. PState -> a -> ParseResult a
POk PState
s a
a

{-# INLINE thenP #-}
thenP :: P a -> (a -> P b) -> P b
(P PState -> ParseResult a
m) thenP :: forall a b. P a -> (a -> P b) -> P b
`thenP` a -> P b
k = (PState -> ParseResult b) -> P b
forall a. (PState -> ParseResult a) -> P a
P ((PState -> ParseResult b) -> P b)
-> (PState -> ParseResult b) -> P b
forall a b. (a -> b) -> a -> b
$ \PState
s ->
        case PState -> ParseResult a
m PState
s of
                POk PState
s' a
a        -> (P b -> PState -> ParseResult b
forall a. P a -> PState -> ParseResult a
unP (a -> P b
k a
a)) PState
s'
                PFailed [String]
err Position
pos -> [String] -> Position -> ParseResult b
forall a. [String] -> Position -> ParseResult a
PFailed [String]
err Position
pos

failP :: Position -> [String] -> P a
failP :: forall a. Position -> [String] -> P a
failP Position
pos [String]
msg = (PState -> ParseResult a) -> P a
forall a. (PState -> ParseResult a) -> P a
P ((PState -> ParseResult a) -> P a)
-> (PState -> ParseResult a) -> P a
forall a b. (a -> b) -> a -> b
$ \PState
_ -> [String] -> Position -> ParseResult a
forall a. [String] -> Position -> ParseResult a
PFailed [String]
msg Position
pos

getNewName :: P Name
getNewName :: P Name
getNewName = (PState -> ParseResult Name) -> P Name
forall a. (PState -> ParseResult a) -> P a
P ((PState -> ParseResult Name) -> P Name)
-> (PState -> ParseResult Name) -> P Name
forall a b. (a -> b) -> a -> b
$ \s :: PState
s@PState{namesupply :: PState -> [Name]
namesupply=(Name
n:[Name]
ns)} -> Name
n Name -> ParseResult Name -> ParseResult Name
forall a b. a -> b -> b
`seq` PState -> Name -> ParseResult Name
forall a. PState -> a -> ParseResult a
POk PState
s{namesupply=ns} Name
n

setPos :: Position -> P ()
setPos :: Position -> P ()
setPos Position
pos = (PState -> ParseResult ()) -> P ()
forall a. (PState -> ParseResult a) -> P a
P ((PState -> ParseResult ()) -> P ())
-> (PState -> ParseResult ()) -> P ()
forall a b. (a -> b) -> a -> b
$ \PState
s -> PState -> () -> ParseResult ()
forall a. PState -> a -> ParseResult a
POk PState
s{curPos=pos} ()

getPos :: P Position
getPos :: P Position
getPos = (PState -> ParseResult Position) -> P Position
forall a. (PState -> ParseResult a) -> P a
P ((PState -> ParseResult Position) -> P Position)
-> (PState -> ParseResult Position) -> P Position
forall a b. (a -> b) -> a -> b
$ \s :: PState
s@PState{curPos :: PState -> Position
curPos=Position
pos} -> PState -> Position -> ParseResult Position
forall a. PState -> a -> ParseResult a
POk PState
s Position
pos

addTypedef :: Ident -> P ()
addTypedef :: Ident -> P ()
addTypedef Ident
ident = ((PState -> ParseResult ()) -> P ()
forall a. (PState -> ParseResult a) -> P a
P ((PState -> ParseResult ()) -> P ())
-> (PState -> ParseResult ()) -> P ()
forall a b. (a -> b) -> a -> b
$ \s :: PState
s@PState{tyidents :: PState -> Set Ident
tyidents=Set Ident
tyids} ->
                             PState -> () -> ParseResult ()
forall a. PState -> a -> ParseResult a
POk PState
s{tyidents = ident `Set.insert` tyids} ())

shadowTypedef :: Ident -> P ()
shadowTypedef :: Ident -> P ()
shadowTypedef Ident
ident = ((PState -> ParseResult ()) -> P ()
forall a. (PState -> ParseResult a) -> P a
P ((PState -> ParseResult ()) -> P ())
-> (PState -> ParseResult ()) -> P ()
forall a b. (a -> b) -> a -> b
$ \s :: PState
s@PState{tyidents :: PState -> Set Ident
tyidents=Set Ident
tyids} ->
                             -- optimisation: mostly the ident will not be in
                             -- the tyident set so do a member lookup to avoid
                             --  churn induced by calling delete
                             PState -> () -> ParseResult ()
forall a. PState -> a -> ParseResult a
POk PState
s{tyidents = if ident `Set.member` tyids
                                                then ident `Set.delete` tyids
                                                else tyids } ())

isTypeIdent :: Ident -> P Bool
isTypeIdent :: Ident -> P Bool
isTypeIdent Ident
ident = (PState -> ParseResult Bool) -> P Bool
forall a. (PState -> ParseResult a) -> P a
P ((PState -> ParseResult Bool) -> P Bool)
-> (PState -> ParseResult Bool) -> P Bool
forall a b. (a -> b) -> a -> b
$ \s :: PState
s@PState{tyidents :: PState -> Set Ident
tyidents=Set Ident
tyids} ->
                             PState -> Bool -> ParseResult Bool
forall a. PState -> a -> ParseResult a
POk PState
s (Bool -> ParseResult Bool) -> Bool -> ParseResult Bool
forall a b. (a -> b) -> a -> b
$! Ident -> Set Ident -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Ident
ident Set Ident
tyids

enterScope :: P ()
enterScope :: P ()
enterScope = (PState -> ParseResult ()) -> P ()
forall a. (PState -> ParseResult a) -> P a
P ((PState -> ParseResult ()) -> P ())
-> (PState -> ParseResult ()) -> P ()
forall a b. (a -> b) -> a -> b
$ \s :: PState
s@PState{tyidents :: PState -> Set Ident
tyidents=Set Ident
tyids,scopes :: PState -> [Set Ident]
scopes=[Set Ident]
ss} ->
                     PState -> () -> ParseResult ()
forall a. PState -> a -> ParseResult a
POk PState
s{scopes=tyids:ss} ()

leaveScope :: P ()
leaveScope :: P ()
leaveScope = (PState -> ParseResult ()) -> P ()
forall a. (PState -> ParseResult a) -> P a
P ((PState -> ParseResult ()) -> P ())
-> (PState -> ParseResult ()) -> P ()
forall a b. (a -> b) -> a -> b
$ \s :: PState
s@PState{scopes :: PState -> [Set Ident]
scopes=[Set Ident]
ss} ->
                     case [Set Ident]
ss of
                       []          -> String -> ParseResult ()
forall a. HasCallStack => String -> a
error String
"leaveScope: already in global scope"
                       (Set Ident
tyids:[Set Ident]
ss') -> PState -> () -> ParseResult ()
forall a. PState -> a -> ParseResult a
POk PState
s{tyidents=tyids, scopes=ss'} ()

getInput :: P InputStream
getInput :: P InputStream
getInput = (PState -> ParseResult InputStream) -> P InputStream
forall a. (PState -> ParseResult a) -> P a
P ((PState -> ParseResult InputStream) -> P InputStream)
-> (PState -> ParseResult InputStream) -> P InputStream
forall a b. (a -> b) -> a -> b
$ \s :: PState
s@PState{curInput :: PState -> InputStream
curInput=InputStream
i} -> PState -> InputStream -> ParseResult InputStream
forall a. PState -> a -> ParseResult a
POk PState
s InputStream
i

setInput :: InputStream -> P ()
setInput :: InputStream -> P ()
setInput InputStream
i = (PState -> ParseResult ()) -> P ()
forall a. (PState -> ParseResult a) -> P a
P ((PState -> ParseResult ()) -> P ())
-> (PState -> ParseResult ()) -> P ()
forall a b. (a -> b) -> a -> b
$ \PState
s -> PState -> () -> ParseResult ()
forall a. PState -> a -> ParseResult a
POk PState
s{curInput=i} ()

getLastToken :: P CToken
getLastToken :: P CToken
getLastToken = (PState -> ParseResult CToken) -> P CToken
forall a. (PState -> ParseResult a) -> P a
P ((PState -> ParseResult CToken) -> P CToken)
-> (PState -> ParseResult CToken) -> P CToken
forall a b. (a -> b) -> a -> b
$ \s :: PState
s@PState{prevToken :: PState -> CToken
prevToken=CToken
tok} -> PState -> CToken -> ParseResult CToken
forall a. PState -> a -> ParseResult a
POk PState
s CToken
tok

getSavedToken :: P CToken
getSavedToken :: P CToken
getSavedToken = (PState -> ParseResult CToken) -> P CToken
forall a. (PState -> ParseResult a) -> P a
P ((PState -> ParseResult CToken) -> P CToken)
-> (PState -> ParseResult CToken) -> P CToken
forall a b. (a -> b) -> a -> b
$ \s :: PState
s@PState{savedToken :: PState -> CToken
savedToken=CToken
tok} -> PState -> CToken -> ParseResult CToken
forall a. PState -> a -> ParseResult a
POk PState
s CToken
tok

-- | @setLastToken modifyCache tok@
setLastToken :: CToken -> P ()
setLastToken :: CToken -> P ()
setLastToken CToken
CTokEof = (PState -> ParseResult ()) -> P ()
forall a. (PState -> ParseResult a) -> P a
P ((PState -> ParseResult ()) -> P ())
-> (PState -> ParseResult ()) -> P ()
forall a b. (a -> b) -> a -> b
$ \PState
s -> PState -> () -> ParseResult ()
forall a. PState -> a -> ParseResult a
POk PState
s{savedToken=(prevToken s)} ()
setLastToken CToken
tok      = (PState -> ParseResult ()) -> P ()
forall a. (PState -> ParseResult a) -> P a
P ((PState -> ParseResult ()) -> P ())
-> (PState -> ParseResult ()) -> P ()
forall a b. (a -> b) -> a -> b
$ \PState
s -> PState -> () -> ParseResult ()
forall a. PState -> a -> ParseResult a
POk PState
s{prevToken=tok,savedToken=(prevToken s)} ()

-- | handle an End-Of-File token (changes savedToken)
handleEofToken :: P ()
handleEofToken :: P ()
handleEofToken = (PState -> ParseResult ()) -> P ()
forall a. (PState -> ParseResult a) -> P a
P ((PState -> ParseResult ()) -> P ())
-> (PState -> ParseResult ()) -> P ()
forall a b. (a -> b) -> a -> b
$ \PState
s -> PState -> () -> ParseResult ()
forall a. PState -> a -> ParseResult a
POk PState
s{savedToken=(prevToken s)} ()

getCurrentPosition :: P Position
getCurrentPosition :: P Position
getCurrentPosition = (PState -> ParseResult Position) -> P Position
forall a. (PState -> ParseResult a) -> P a
P ((PState -> ParseResult Position) -> P Position)
-> (PState -> ParseResult Position) -> P Position
forall a b. (a -> b) -> a -> b
$ \s :: PState
s@PState{curPos :: PState -> Position
curPos=Position
pos} -> PState -> Position -> ParseResult Position
forall a. PState -> a -> ParseResult a
POk PState
s Position
pos