--  C -> Haskell Compiler: Lexer for C Header Files
--
--  Author : Manuel M T Chakravarty, Duncan Coutts
--  Created: 12 Febuary 2007
--
--  Copyright (c) [1999..2004] Manuel M T Chakravarty
--  Copyright (c) 2005-2007 Duncan Coutts
--
--  This file is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2 of the License, or
--  (at your option) any later version.
--
--  This file is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
--- DESCRIPTION ---------------------------------------------------------------
--
--  Monad for the C lexer and parser
--
--- DOCU ----------------------------------------------------------------------
--
--  language: Haskell 98
--
--  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 Names 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.
--
--- TODO ----------------------------------------------------------------------
--
--
{-# LANGUAGE CPP #-}

module CParserMonad ( 
  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
  setLastToken,      -- :: CToken -> P ()
  ) where

import Position  (Position(..), Pos(posOf))
import Errors    (interr)
import UNames    (Name)
import Idents    (Ident, lexemeToIdent, identToLexeme)

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)

import CTokens (CToken)

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 -> String
curInput   :: !String,          -- the current input
        PState -> CToken
prevToken  ::  CToken,          -- the previous token
        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 MonadFail P where
  fail :: String -> P a
fail 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
>>= \Position
pos -> Position -> [String] -> P a
forall a. Position -> [String] -> P a
failP Position
pos [String
m]

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

execParser :: P a -> String -> Position -> [Ident] -> [Name]
           -> Either a ([String], Position)
execParser :: P a
-> String
-> Position
-> [Ident]
-> [Name]
-> Either a ([String], Position)
execParser (P PState -> ParseResult a
parser) String
input Position
pos [Ident]
builtins [Name]
names =
  case PState -> ParseResult a
parser PState
initialState of
    POk PState
_ a
result -> a -> Either a ([String], Position)
forall a b. a -> Either a b
Left a
result
    PFailed [String]
message Position
pos -> ([String], Position) -> Either a ([String], Position)
forall a b. b -> Either a b
Right ([String]
message, Position
pos)
  where initialState :: PState
initialState = PState :: Position
-> String -> CToken -> [Name] -> Set Ident -> [Set Ident] -> PState
PState {
          curPos :: Position
curPos = Position
pos,
          curInput :: String
curInput = String
input,
          prevToken :: CToken
prevToken = String -> CToken
forall a. String -> a
interr String
"CLexer.execParser: Touched undefined 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 = (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 :: 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 :: 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)} -> 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 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 :: 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 = ((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
tyidents} ->
                             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
tyidents} ())

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
tyidents} ->
                             -- 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
tyidents
                                                then Ident
ident Ident -> Set Ident -> Set Ident
forall a. Ord a => a -> Set a -> Set a
`Set.delete` Set Ident
tyidents
                                                else Set Ident
tyidents } ())

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
tyidents} ->
                             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
tyidents

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
tyidents,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
tyidentsSet 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. String -> a
interr String
"leaveScope: already in global scope"
                       (Set Ident
tyidents:[Set Ident]
ss') -> PState -> () -> ParseResult ()
forall a. PState -> a -> ParseResult a
POk PState
s{tyidents :: Set Ident
tyidents=Set Ident
tyidents, scopes :: [Set Ident]
scopes=[Set Ident]
ss'} ()

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

setInput :: String -> P ()
setInput :: String -> P ()
setInput String
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 :: String
curInput=String
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

setLastToken :: CToken -> P ()
setLastToken :: CToken -> P ()
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 :: CToken
prevToken=CToken
tok} ()