{-# 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 Control.Applicative (Applicative(..))
import Control.Monad (liftM, ap)
#if MIN_VERSION_base(4,9,0)
import Control.Monad.Fail (MonadFail (..))
#endif
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 (msgs :: [String]
msgs,pos :: Position
pos)) = String -> ErrorInfo -> String
showErrorInfo "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 { P a -> PState -> ParseResult a
unP :: PState -> ParseResult a }

instance Functor P where
  fmap :: (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 :: a -> P a
pure = a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return
  <*> :: 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
  return :: a -> P a
return = a -> P a
forall a. a -> P a
returnP
  >>= :: 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 :: String -> P a
fail m :: String
m = P Position
getPos P Position -> (Position -> P a) -> P a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \pos :: 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 :: P a
-> InputStream
-> Position
-> [Ident]
-> [Name]
-> Either ParseError (a, [Name])
execParser (P parser :: PState -> ParseResult a
parser) input :: InputStream
input pos :: Position
pos builtins :: [Ident]
builtins names :: [Name]
names =
  case PState -> ParseResult a
parser PState
initialState of
    PFailed message :: [String]
message errpos :: Position
errpos -> ParseError -> Either ParseError (a, [Name])
forall a b. a -> Either a b
Left (([String], Position) -> ParseError
ParseError ([String]
message,Position
errpos))
    POk st :: PState
st result :: 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 = $WPState :: Position
-> InputStream
-> CToken
-> CToken
-> [Name]
-> Set Ident
-> [Set Ident]
-> PState
PState {
          curPos :: Position
curPos = Position
pos,
          curInput :: InputStream
curInput = InputStream
input,
          prevToken :: CToken
prevToken = String -> CToken
forall a. String -> a
internalErr "CLexer.execParser: Touched undefined token!",
          savedToken :: CToken
savedToken = String -> CToken
forall a. String -> a
internalErr "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 :: a -> P a
returnP a :: 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
$ \s :: 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 m :: PState -> ParseResult a
m) thenP :: P a -> (a -> P b) -> P b
`thenP` k :: 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
$ \s :: PState
s ->
        case PState -> ParseResult a
m PState
s of
                POk s' :: PState
s' a :: a
a        -> (P b -> PState -> ParseResult b
forall a. P a -> PState -> ParseResult a
unP (a -> P b
k a
a)) PState
s'
                PFailed err :: [String]
err pos :: Position
pos -> [String] -> Position -> ParseResult b
forall a. [String] -> Position -> ParseResult a
PFailed [String]
err Position
pos

failP :: Position -> [String] -> P a
failP :: Position -> [String] -> P a
failP pos :: Position
pos msg :: [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
$ \_ -> [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=(n :: Name
n:ns :: [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 :: [Name]
namesupply=[Name]
ns} Name
n

setPos :: Position -> P ()
setPos :: Position -> P ()
setPos pos :: 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
$ \s :: PState
s -> PState -> () -> ParseResult ()
forall a. PState -> a -> ParseResult a
POk PState
s{curPos :: Position
curPos=Position
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
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 :: Set Ident
tyidents = Ident
ident Ident -> Set Ident -> Set Ident
forall a. Ord a => a -> Set a -> Set a
`Set.insert` Set Ident
tyids} ())

shadowTypedef :: Ident -> P ()
shadowTypedef :: Ident -> P ()
shadowTypedef ident :: 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 :: Set Ident
tyidents = if Ident
ident Ident -> Set Ident -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Ident
tyids
                                                then Ident
ident Ident -> Set Ident -> Set Ident
forall a. Ord a => a -> Set a -> Set a
`Set.delete` Set Ident
tyids
                                                else Set Ident
tyids } ())

isTypeIdent :: Ident -> P Bool
isTypeIdent :: Ident -> P Bool
isTypeIdent ident :: 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 :: [Set Ident]
scopes=Set Ident
tyidsSet Ident -> [Set Ident] -> [Set Ident]
forall a. a -> [a] -> [a]
:[Set Ident]
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 "leaveScope: already in global scope"
                       (tyids :: Set Ident
tyids:ss' :: [Set Ident]
ss') -> PState -> () -> ParseResult ()
forall a. PState -> a -> ParseResult a
POk PState
s{tyidents :: Set Ident
tyidents=Set Ident
tyids, scopes :: [Set Ident]
scopes=[Set Ident]
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 i :: 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
$ \s :: PState
s -> PState -> () -> ParseResult ()
forall a. PState -> a -> ParseResult a
POk PState
s{curInput :: InputStream
curInput=InputStream
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 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
$ \s :: PState
s -> PState -> () -> ParseResult ()
forall a. PState -> a -> ParseResult a
POk PState
s{savedToken :: CToken
savedToken=(PState -> CToken
prevToken PState
s)} ()
setLastToken tok :: 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
$ \s :: PState
s -> PState -> () -> ParseResult ()
forall a. PState -> a -> ParseResult a
POk PState
s{prevToken :: CToken
prevToken=CToken
tok,savedToken :: CToken
savedToken=(PState -> CToken
prevToken PState
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
$ \s :: PState
s -> PState -> () -> ParseResult ()
forall a. PState -> a -> ParseResult a
POk PState
s{savedToken :: CToken
savedToken=(PState -> CToken
prevToken PState
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